diff -Nru sbcl-2.0.6/base-target-features.lisp-expr sbcl-2.1.1/base-target-features.lisp-expr --- sbcl-2.0.6/base-target-features.lisp-expr 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/base-target-features.lisp-expr 2021-01-30 11:22:38.000000000 +0000 @@ -51,12 +51,6 @@ ;; our dialect :sbcl - ;; Douglas Thomas Crosher's conservative generational GC (the only one - ;; we currently support for X86). - ;; :gencgc used to be here; CSR moved it into - ;; local-target-features.lisp-expr via make-config.sh, as alpha, - ;; sparc and ppc ports don't currently support it. -- CSR, 2002-02-21 - ;; ;; features present in this particular build ;; @@ -214,12 +208,6 @@ ;; ; :sb-futex - ;; On some operating systems the FS segment register (used for SBCL's - ;; thread local storage) is not reliably preserved in signal - ;; handlers, so we need to restore its value from the pthread thread - ;; local storage. - ; :restore-fs-segment-register-from-tls - ;; 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 @@ -307,7 +295,7 @@ ;; 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 SIGPIPE, except to wake up syscalls.) + ;; (Replaces use of SIGURG, except to wake up syscalls.) ; :sb-thruption ;; When compiling with safepoints and thruptions, the TIMER facility @@ -358,16 +346,12 @@ ;; any Intel 386 or better, or compatibles like the AMD K6 or K7 ;; :x86-64 ;; any x86-64 CPU running in 64-bit mode - ;; :alpha - ;; DEC/Compaq Alpha CPU ;; :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 - ;; :hppa - ;; any PA-RISC CPU ;; :mips ;; any MIPS CPU (in little-endian mode with :little-endian) ;; :arm @@ -422,6 +406,5 @@ ;; :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. - ;; :hpux = We're intended to run under HP-UX 11.11 or later ;; :win32 = We're intended to under some version of Microsoft Windows. ) diff -Nru sbcl-2.0.6/build-order.lisp-expr sbcl-2.1.1/build-order.lisp-expr --- sbcl-2.0.6/build-order.lisp-expr 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/build-order.lisp-expr 2021-01-30 11:22:38.000000000 +0000 @@ -172,8 +172,10 @@ ("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/early-alieneval" :c-headers) ; for funs and vars needed at build and run time + ("src/code/alieneval" :c-headers) ("src/code/target-error" :not-host) ;; "src/code/toplevel.lisp" is the first to need this. It's generated @@ -193,14 +195,12 @@ ("src/code/target-alieneval" :not-host) ("src/code/target-c-call" :not-host) - ("src/code/target-allocate" :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/compiler/generic/pinned-objects" :not-host) ("src/code/list" :not-host) ("src/code/seq" :not-host) ; "code/seq" should come after "code/list". @@ -213,12 +213,13 @@ ("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) - #+hpux ("src/code/hpux-os" :not-host) #+bsd ("src/code/bsd-os" :not-host) #+linux ("src/code/linux-os" :not-host) #+haiku ("src/code/haiku-os" :not-host) @@ -230,15 +231,17 @@ ("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/late-cas" :not-host) ("src/code/fd-stream" :not-host) ("src/code/stream" :not-host) ("src/code/early-format") @@ -251,7 +254,6 @@ ("src/code/query" :not-host) ("src/code/sort" :not-host) - ("src/code/time" :not-host) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; compiler (and a few miscellaneous files whose dependencies make it @@ -296,8 +298,6 @@ ("src/compiler/vmdef" :c-headers) ("src/code/defmacro" :c-headers) - ("src/code/destructuring-bind" :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) @@ -310,17 +310,14 @@ ;; 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") - #+hppa ("src/code/hppa-vm") + #+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") - #+alpha ("src/code/alpha-vm") - #+mips ("src/code/mips-vm") - #+arm ("src/code/arm-vm") - #+arm64 ("src/code/arm64-vm") - #+riscv ("src/code/riscv-vm") + #+(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, @@ -356,11 +353,6 @@ ("src/compiler/generic/primtype" :c-headers) - ;; for DEFSTRUCT ALIEN-TYPE, needed by host-type.lisp - ("src/code/host-alieneval") - - ;; can't be done until definition of e.g. DEFINE-ALIEN-TYPE-CLASS in - ;; host-alieneval.lisp ("src/code/host-c-call") ;; SB-XC:DEFTYPE is needed in order to compile late-type @@ -388,7 +380,7 @@ ("src/code/class-init" :c-headers) - ;; The DEFSTRUCT machinery needs SB-XC:SUBTYPEP, defined in + ;; 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" @@ -417,8 +409,8 @@ ("src/code/random") ("src/code/hash-table" :c-headers) ("src/code/readtable") - ("src/code/pathname") - ("src/code/host-pprint") ; defines QUEUED-OP needed by 'pprint' + ("src/code/pathname" :not-host) + ("src/code/host-pprint") ("src/compiler/fndb") ("src/compiler/generic/vm-fndb") @@ -431,7 +423,7 @@ ("src/code/load") - #+linkage-table ("src/code/linkage-table" :not-host) + ("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) @@ -448,7 +440,6 @@ ("src/compiler/target-dump" :not-host) ; needs stuff from compiler/dump.lisp ("src/compiler/ir1report") ; for COMPILER-ERROR-CONTEXT - ("src/code/target-pathname" :not-host) ; needs "code/pathname" ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp ("src/compiler/xref") ("src/compiler/target-main" :not-host) @@ -462,6 +453,7 @@ :ignore-failure-p)) ("src/compiler/ir1util") ("src/compiler/callable-args") + ("src/compiler/locall") ("src/compiler/ir1opt") ("src/compiler/loop") @@ -475,7 +467,7 @@ ("src/compiler/sxhash") ("src/code/quantifiers") ("src/compiler/bitops-derive-type") - ("src/compiler/locall") + ("src/compiler/dfo") ("src/compiler/dce") ("src/compiler/checkgen") @@ -612,6 +604,7 @@ ("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" @@ -622,6 +615,7 @@ ("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 @@ -768,6 +762,7 @@ "src/pcl/fsc" "src/pcl/methods" "src/pcl/fixup" + "src/pcl/call-next-method" "src/pcl/defcombin" "src/pcl/ctypes" "src/pcl/env" diff -Nru sbcl-2.0.6/.cirrus.yml sbcl-2.1.1/.cirrus.yml --- sbcl-2.0.6/.cirrus.yml 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/.cirrus.yml 2021-01-30 11:22:38.000000000 +0000 @@ -2,8 +2,9 @@ freebsd_instance: matrix: - image_family: freebsd-12-1 image_family: freebsd-11-3-snap + image_family: freebsd-12-1-snap + # image_family: freebsd-13-0-snap cpu: 1 memory: 1G diff -Nru sbcl-2.0.6/contrib/asdf-module.mk sbcl-2.1.1/contrib/asdf-module.mk --- sbcl-2.0.6/contrib/asdf-module.mk 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/asdf-module.mk 2021-01-30 11:22:38.000000000 +0000 @@ -30,6 +30,7 @@ $(FASL):: $(SBCL) --eval '(setf (sb-ext:readtable-base-char-preference *readtable*) :both)' \ + --eval '(declaim (muffle-conditions compiler-note))' \ --load ../asdf-stub.lisp \ --eval '(asdf::build-asdf-contrib "$(SYSTEM)")' diff -Nru sbcl-2.0.6/contrib/asdf-stub.lisp sbcl-2.1.1/contrib/asdf-stub.lisp --- sbcl-2.0.6/contrib/asdf-stub.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/asdf-stub.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -66,6 +66,8 @@ (format o "(provide :~A)~%~{(require ~(~S~))~%~}" name dependencies)) (compile-file module-setup.lisp :output-file module-setup.fasl) (operate 'compile-bundle-op system) + (let ((s (find-symbol "DUMP/RESTORE-INTERESTING-TYPES" "SB-C"))) + (when s (funcall s 'write))) (concatenate-files input-fasls module.fasl))) (defun test-asdf-contrib (system) diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/constants-gethostbyname.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/constants-gethostbyname.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/constants-gethostbyname.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/constants-gethostbyname.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -7,12 +7,12 @@ (addr (* t)) (len int) (af int))) - (:integer NETDB-INTERNAL #+hpux "h_NETDB_INTERNAL" #-hpux "NETDB_INTERNAL" "See errno.") - (:integer NETDB-SUCCESS #+hpux "h_NETDB_SUCCESS" #-hpux "NETDB_SUCCESS" "No problem.") + (:integer NETDB-INTERNAL "NETDB_INTERNAL" "See errno.") + (:integer NETDB-SUCCESS "NETDB_SUCCESS" "No problem.") (:integer HOST-NOT-FOUND "HOST_NOT_FOUND" "Authoritative Answer Host not found.") (:integer TRY-AGAIN "TRY_AGAIN" "Non-Authoritative Host not found, or SERVERFAIL.") (:integer NO-RECOVERY "NO_RECOVERY" "Non recoverable errors, FORMERR, REFUSED, NOTIMP.") (:integer NO-DATA "NO_DATA" "Valid name, no data record of requested type.") (:integer NO-ADDRESS "NO_ADDRESS" "No address, look for MX record.") - #-(or hpux sunos) + #-sunos (:function h-strerror ("hstrerror" c-string (errno int)))) diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/constants-unix.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/constants-unix.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/constants-unix.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/constants-unix.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1,8 +1,8 @@ ("sys/socket.h" "errno.h" "fcntl.h") ((:integer af-local - #+(or sunos solaris hpux) "AF_UNIX" - #-(or sunos solaris hpux) "AF_LOCAL" + #+(or sunos solaris) "AF_UNIX" + #-(or sunos solaris) "AF_LOCAL" "Local to host (pipes and file-domain).") (:integer ifnamsiz "IFNAMSIZ") diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/inet4.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/inet4.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/inet4.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/inet4.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -92,7 +92,7 @@ sockaddr)) (defmethod free-sockaddr-for ((socket inet-socket) sockaddr) - (sockint::free-sockaddr-in sockaddr)) + (sb-alien:free-alien sockaddr)) (defmethod size-of-sockaddr ((socket inet-socket)) sockint::size-of-sockaddr-in) diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/inet6.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/inet6.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/inet6.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/inet6.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -100,7 +100,7 @@ sockaddr)) (defmethod free-sockaddr-for ((socket inet6-socket) sockaddr) - (sockint::free-sockaddr-in6 sockaddr)) + (sb-alien:free-alien sockaddr)) (defmethod size-of-sockaddr ((socket inet6-socket)) sockint::size-of-sockaddr-in6) diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/inet.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/inet.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/inet.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/inet.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -134,7 +134,7 @@ (go :error) (return-from getprotobyname (protoent-to-values ent)))))) #+sb-thread - (sb-thread::with-system-mutex (**getprotoby-lock**) + (sb-int:with-system-mutex (**getprotoby-lock**) (get-it)) #-sb-thread (get-it)) diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/local.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/local.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/local.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/local.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -25,7 +25,7 @@ (values sockaddr sockint::size-of-sockaddr-un))) (defmethod free-sockaddr-for ((socket local-socket) sockaddr) - (sockint::free-sockaddr-un sockaddr)) + (sb-alien:free-alien sockaddr)) (defmethod size-of-sockaddr ((socket local-socket)) sockint::size-of-sockaddr-un) @@ -80,7 +80,7 @@ (values sockaddr sockint::size-of-sockaddr-un-abstract)))))) (defmethod free-sockaddr-for ((socket local-abstract-socket) sockaddr) - (sockint::free-sockaddr-un-abstract sockaddr)) + (sb-alien:free-alien sockaddr)) (defmethod size-of-sockaddr ((socket local-abstract-socket)) sockint::size-of-sockaddr-un-abstract) diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/name-service.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/name-service.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/name-service.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/name-service.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -68,14 +68,14 @@ "Returns a HOST-ENT instance for HOST-NAME or signals a NAME-SERVICE-ERROR. HOST-NAME may also be an IP address in dotted quad notation or some other weird stuff - see gethostbyname(3) for the details." - (sb-thread::with-system-mutex (**gethostby-lock** :allow-with-interrupts t) + (sb-int:with-system-mutex (**gethostby-lock** :allow-with-interrupts t) (make-host-ent (sockint::gethostbyname host-name)))) (defun get-host-by-address (address) "Returns a HOST-ENT instance for ADDRESS, which should be a vector of (integer 0 255), or signals a NAME-SERVICE-ERROR. See gethostbyaddr(3) for details." - (sb-thread::with-system-mutex (**gethostby-lock** :allow-with-interrupts t) + (sb-int:with-system-mutex (**gethostby-lock** :allow-with-interrupts t) (sockint::with-in-addr packed-addr () (let ((addr-vector (coerce address 'vector))) (loop for i from 0 below (length addr-vector) @@ -148,7 +148,7 @@ elements in case of an IPv6 address, or signals a NAME-SERVICE-ERROR. See gethostbyaddr(3) for details." (declare (optimize speed)) - (multiple-value-bind (sockaddr sockaddr-free sockaddr-size address-family) + (multiple-value-bind (sockaddr sockaddr-size address-family) (etypecase address ((vector (unsigned-byte 8) 4) (let ((sockaddr (sb-alien:make-alien sockint::sockaddr-in))) @@ -157,7 +157,7 @@ (dotimes (i (length address)) (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i) (aref address i))) - (values sockaddr #'sockint::free-sockaddr-in + (values sockaddr (sb-alien:alien-size sockint::sockaddr-in :bytes) sockint::af-inet))) #-win32 @@ -167,7 +167,7 @@ (dotimes (i (length address)) (setf (sb-alien:deref (sockint::sockaddr-in6-addr sockaddr) i) (aref address i))) - (values sockaddr #'sockint::free-sockaddr-in6 + (values sockaddr (sb-alien:alien-size sockint::sockaddr-in6 :bytes) sockint::af-inet6)))) (unwind-protect @@ -186,7 +186,7 @@ :type address-family :aliases nil :addresses (list address)))) - (funcall sockaddr-free sockaddr))))) + (sb-alien:free-alien sockaddr))))) ;;; Error handling diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/sockets.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/sockets.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/sockets.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/sockets.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -177,8 +177,8 @@ ((or (eql element-type 'character) (eql element-type 'base-char)) (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i))) (t (sb-alien:deref (sb-alien:deref copy-buffer) i))))) - (apply #'values buffer len (multiple-value-list - (bits-of-sockaddr socket sockaddr)))) + (multiple-value-call #'values buffer len + (bits-of-sockaddr socket sockaddr))) (:interrupted nil))) (sb-alien:free-alien copy-buffer)))))) diff -Nru sbcl-2.0.6/contrib/sb-bsd-sockets/tests.lisp sbcl-2.1.1/contrib/sb-bsd-sockets/tests.lisp --- sbcl-2.0.6/contrib/sb-bsd-sockets/tests.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-bsd-sockets/tests.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -350,6 +350,34 @@ (network-unreachable-error () 'network-unreachable)) t) +#+(and ipv4-support sb-thread) +(deftest sockopt-close-wait-listen-eof + (let ((listen-sock (make-instance 'inet-socket :type :stream :protocol :tcp)) + (client-sock (make-instance 'inet-socket :type :stream :protocol :tcp)) + server-sock + port) + (unwind-protect + (progn + (socket-bind listen-sock #(127 0 0 1) 0) + (setf port (nth-value 1 (socket-name listen-sock))) + (socket-listen listen-sock 1) + + (let ((client-connect-thread + (sb-thread:make-thread + (lambda () + (socket-connect client-sock #(127 0 0 1) port) + (socket-close client-sock))))) + (setf server-sock (socket-accept listen-sock))) + + ;; Wait for input. This should return when we get EOF + ;; from the client. It should /not/ hang. + (sb-sys:wait-until-fd-usable (socket-file-descriptor server-sock) :input) + (listen (socket-make-stream server-sock :input t))) + (socket-close listen-sock) + (socket-close client-sock) + (and server-sock (socket-close server-sock)))) + nil) + #+ipv4-support (deftest socket-open-p-true.1 (socket-open-p (make-instance 'inet-socket :type :stream :protocol :tcp)) diff -Nru sbcl-2.0.6/contrib/sb-cltl2/tests.lisp sbcl-2.1.1/contrib/sb-cltl2/tests.lisp --- sbcl-2.0.6/contrib/sb-cltl2/tests.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-cltl2/tests.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -136,6 +136,16 @@ (equalp (frob (+ x x)) '(+ y y)))) t) +;; MULTIPLE-VALUE-BIND and -SETQ and were failing to macroexpand-all +;; because the walker treated them both as special operators. +(deftest macroexpand-all.mvb + (let ((form '(multiple-value-bind (a b) (something) (use-them a b)))) + (not (equalp form (macroexpand-all form nil)))) + t) +(deftest macroexpand-all.mvs + (let ((form '(multiple-value-setq (a b) (something)))) + (not (equalp form (macroexpand-all form nil)))) + t) ;;;; DECLARATION-INFORMATION (defmacro dinfo (thing &environment env) diff -Nru sbcl-2.0.6/contrib/sb-concurrency/tests/test-frlock.lisp sbcl-2.1.1/contrib/sb-concurrency/tests/test-frlock.lisp --- sbcl-2.0.6/contrib/sb-concurrency/tests/test-frlock.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-concurrency/tests/test-frlock.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -19,8 +19,8 @@ ;; XXX something like clock_getres(CLOCK_REALTIME, ...) would be better (defvar *minimum-sleep* - #+(or openbsd sunos) 0.01 - #-(or openbsd sunos) 0.0001) + #+(or openbsd netbsd sunos) 0.01 + #-(or openbsd netbsd sunos) 0.0001) (defun test-frlocks (&key (reader-count (min (* 12 *cpus*) 200)) (read-count 1000000) diff -Nru sbcl-2.0.6/contrib/sb-concurrency/tests/test-gate.lisp sbcl-2.1.1/contrib/sb-concurrency/tests/test-gate.lisp --- sbcl-2.0.6/contrib/sb-concurrency/tests/test-gate.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-concurrency/tests/test-gate.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -36,6 +36,23 @@ :arguments i))) (int-gate (make-gate))) (sleep 1) + ;; Considering that OPEN-GATE = CONDITION-BROADCAST, this action of INTERRUPT-THREAD + ;; with an (OPEN-GATE) call would be expressly forbidden if condition vars were + ;; implemented by native (pthread) primitives. Generally speaking the pthread intrinsics + ;; provide better mutex fairness, and I very much doubt we could use our condition + ;; vars with pthread mutexes. + ;; + ;; Debian docs say: "ASYNC-SIGNAL SAFETY + ;; The condition functions are not async-signal safe, and should not be called from a + ;; signal handler. In particular, calling pthread_cond_signal or pthread_cond_broadcast + ;; from a signal handler may deadlock the calling thread." + ;; https://manpages.debian.org/testing/glibc-doc/pthread_cond_broadcast.3.en.html + ;; + ;; OpenGroup calls out cond_signal but does not say cond_broadcast isn't safe. + ;; I suspect that it means that they both are not safe since they share a doc page: + ;; "It is not safe to use the pthread_cond_signal() function in a signal handler + ;; that is invoked asynchronously." + ;; https://pubs.opengroup.org/onlinepubs/007904975/functions/pthread_cond_broadcast.html (interrupt-thread (car threads) (lambda () (unwind-protect (when (gate-open-p gate) diff -Nru sbcl-2.0.6/contrib/sb-concurrency/tests/test-utils.lisp sbcl-2.1.1/contrib/sb-concurrency/tests/test-utils.lisp --- sbcl-2.0.6/contrib/sb-concurrency/tests/test-utils.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-concurrency/tests/test-utils.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -10,6 +10,7 @@ ;;;; files for more information. (in-package :sb-concurrency-test) +(declaim (sb-ext:muffle-conditions sb-ext:compiler-note)) #+sb-thread (progn diff -Nru sbcl-2.0.6/contrib/sb-executable/sb-executable.lisp sbcl-2.1.1/contrib/sb-executable/sb-executable.lisp --- sbcl-2.0.6/contrib/sb-executable/sb-executable.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-executable/sb-executable.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -60,7 +60,7 @@ (out-name (namestring (translate-logical-pathname output-file))) (prot (elt (multiple-value-list (sb-unix:unix-stat out-name)) 3))) (if prot - (sb-unix::void-syscall ("chmod" c-string int) + (sb-unix:void-syscall ("chmod" c-string int) out-name (logior prot (if (logand prot #o400) #o100) diff -Nru sbcl-2.0.6/contrib/sb-gmp/gmp.lisp sbcl-2.1.1/contrib/sb-gmp/gmp.lisp --- sbcl-2.0.6/contrib/sb-gmp/gmp.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-gmp/gmp.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -934,14 +934,15 @@ (defun gmp-intexp (base power) (declare (inline mpz-mul-2exp mpz-pow)) - (check-type power (integer #.(1+ most-negative-fixnum) #.most-positive-fixnum)) (cond ((or (and (integerp base) (< (abs power) 1000) (< (blength base) 4)) + (member base '(0 1 -1)) *gmp-disabled*) (orig-intexp base power)) (t + (check-type power (integer #.(1+ most-negative-fixnum) #.most-positive-fixnum)) (cond ((minusp power) (/ (the integer (gmp-intexp base (- power))))) ((eql base 2) diff -Nru sbcl-2.0.6/contrib/sb-gmp/tests.lisp sbcl-2.1.1/contrib/sb-gmp/tests.lisp --- sbcl-2.0.6/contrib/sb-gmp/tests.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-gmp/tests.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -196,6 +196,10 @@ 'mpz-pow -15546163094340153687 11)) +(deftest intexp-1 + (sb-gmp::gmp-intexp 1 (ash 1 127)) + 1) + (deftest remove-1 (multiple-value-list (mpz-remove 28 2)) (7 2)) diff -Nru sbcl-2.0.6/contrib/sb-grovel/foreign-glue.lisp sbcl-2.1.1/contrib/sb-grovel/foreign-glue.lisp --- sbcl-2.0.6/contrib/sb-grovel/foreign-glue.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-grovel/foreign-glue.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -356,7 +356,7 @@ (defmacro define-c-struct (name size &rest elements) (multiple-value-bind (struct-elements accessors) (let* ((root (make-instance 'struct :name name :children nil :offset 0))) - (loop for e in (sort elements #'< :key #'fourth) + (loop for e in (sort (copy-list elements) #'< :key #'fourth) do (insert-element root (apply 'mk-val e)) finally (return root)) (setf (children root) @@ -370,7 +370,6 @@ object c-object index) (let ((with (intern (format nil "WITH-~A" name))) (allocate (intern (format nil "ALLOCATE-~A" name))) - (free (intern (format nil "FREE-~A" name))) (size-of (intern (format nil "SIZE-OF-~A" name)))) `(progn (sb-alien:define-alien-type ,@(first struct-elements)) @@ -390,7 +389,7 @@ ,(second ,pair))) ,field-values)) ,@,body) - (,',free ,,var))))) + (sb-alien:free-alien ,,var))))) (defconstant ,size-of ,size) (defun ,allocate () (let* ((,object (sb-alien:make-alien ,name)) @@ -403,9 +402,7 @@ ;; optimizations might be possible. (dotimes (,index ,size) (setf (deref ,c-object ,index) 0)) - ,object)) - (defun ,free (,object) - (sb-alien:free-alien ,object))))))) + ,object))))))) ;; FIXME: Nothing in SBCL uses this, but kept it around in case there ;; are third-party sb-grovel clients. It should go away eventually, diff -Nru sbcl-2.0.6/contrib/sb-introspect/test-driver.lisp sbcl-2.1.1/contrib/sb-introspect/test-driver.lisp --- sbcl-2.0.6/contrib/sb-introspect/test-driver.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-introspect/test-driver.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -565,7 +565,9 @@ (type-equal (function-type #'f) (if (expect-wild-return-type-p #'f) '(function (symbol) *) - '(function (symbol) (values simple-string &optional))))) + '(function (symbol) (values #+sb-unicode simple-string + #-sb-unicode simple-base-string + &optional))))) t) ;; Closures @@ -761,24 +763,25 @@ ;;; ASDF. I can't even. (compile 'sb-introspect:map-root) -(defun count-pointees (x simple &aux (n 0)) - (sb-introspect:map-root (lambda (obj) - (declare (ignore obj)) - (incf n)) - x - :simple simple) - n) +(defun list-pointees (x simple) + (sb-int:collect ((result)) + (sb-introspect:map-root (lambda (obj) (result obj)) + x :simple simple) + (result))) +(defun count-pointees (x simple) + (length (list-pointees x simple))) ;;; A closure points to its underlying function, all closed-over values, ;;; and possibly the closure's name. -;;; #'SB-INT:CONSTANTLY-T is a nameless closure over 1 value -(deftest map-root-closure-un (count-pointees #'SB-INT:CONSTANTLY-T nil) 2) -;;; (SYMBOL-FUNCTION 'AND) is a named closure over 1 value +(deftest map-root-closure-unnamed + (count-pointees (funcall (compile nil `(lambda (x) (lambda () x))) t) nil) + 2) +;;; (SYMBOL-FUNCTION 'AND) is a named closure over 1 value. +;;; The closed-over value is AND, and the name of the closure is (:MACRO AND). (deftest map-root-closure-named (count-pointees (symbol-function 'and) nil) 3) -;;; GFs point to their layout, implementation, slots, -;;; and a hash-code, except that 64-bit headers can store the hash code -;;; in the slot vector's high header bytes. +;;; GFs point to their layout, implementation function, and slot vector. +;;; There's also a hash-code which is stored is one of two different ways. ;;; However, in either case we expect only 3 referenced objects, ;;; because due to a strange design choice in MAP-ROOT, ;;; it does not invoke the funarg on fixnums (or characters). diff -Nru sbcl-2.0.6/contrib/sb-posix/interface.lisp sbcl-2.1.1/contrib/sb-posix/interface.lisp --- sbcl-2.0.6/contrib/sb-posix/interface.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-posix/interface.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -340,24 +340,36 @@ "Forks the current process, returning 0 in the new process and the PID of the child process in the parent. Forking while multiple threads are running is not supported." - (tagbody - (let () - #+sb-thread - (sb-impl::finalizer-thread-stop) - (sb-thread::with-all-threads-lock - (when (let ((avltree sb-thread::*all-threads*)) - (or (sb-thread::avlnode-left avltree) - (sb-thread::avlnode-right avltree))) - (go :error)) - (let ((pid (posix-fork))) - #+darwin - (when (= pid 0) - (darwin-reinit)) - #+sb-thread - (setf sb-impl::*finalizer-thread* t) - (return-from fork pid)))) - :error - (error "Cannot fork with multiple threads running."))) + ;; It would be easy enough to to allow fork in multithreaded code - we'd need the new + ;; process to set *ALL-THREADS* to contain only one thread, and unmap other threads' + ;; stack to avoid a memory leak. The tricky part would be adhering the the POSIX caveats. + ;; Linux: + ;; After a fork() in a multithreaded program, the child can safely call only async-signal-safe + ;; functions (see signal-safety(7)) until such time as it calls execve(2). + ;; FreeBSD: + ;; If the process has more than one thread, locks and other resources held by the other + ;; threads are not released and therefore only async-signal-safe functions are guaranteed + ;; to work in the child process until a call to execve(2) or a similar function. + ;; macOS: + ;; To be totally safe you should restrict yourself to only executing async-signal safe + ;; operations until such time as one of the exec functions is called. + #+sb-thread + (when (cdr (sb-int:with-system-mutex (sb-thread::*make-thread-lock*) + (sb-impl::finalizer-thread-stop) + ;; Dead threads aren't pruned from *ALL-THREADS* until the Pthread join. + ;; Do that now so that the forked process has only the main thread + ;; in *ALL-THREADS* and nothing in *JOINABLE-THREADS*. + (sb-thread::join-pthread-joinables #'identity) + ;; Threads are added to ALL-THREADS before they have an OS thread, + ;; 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) + (error "Cannot fork with multiple threads running.")) + (let ((pid (posix-fork))) + #+darwin (when (= pid 0) (darwin-reinit)) + #+sb-thread (sb-impl::finalizer-thread-start) + pid)) (export 'fork :sb-posix) (define-call "getpgid" pid-t minusp (pid pid-t)) @@ -504,11 +516,9 @@ (define-call "mlockall" int minusp (flags int)) (define-call "munlockall" int minusp) -#-win32 -(define-call "getpagesize" int minusp) -#+win32 -;;; KLUDGE: This could be taken from GetSystemInfo -(export (defun getpagesize () 4096)) +(export 'getpagesize) +(declaim (inline getpagesize)) +(defun getpagesize () (extern-alien "os_reported_page_size" (unsigned 32))) ;;; passwd database ;; The docstrings are copied from the descriptions in SUSv3, @@ -801,7 +811,8 @@ (if (minusp value) (syscall-error 'utimes) value))) - (let ((fun (extern-alien "sb_utimes" (function int (c-string :not-null t) + (let ((fun (extern-alien #-netbsd "utimes" #+netbsd "sb_utimes" + (function int (c-string :not-null t) (* (array alien-timeval 2))))) (name (filename filename))) (if (not (and access-time modification-time)) diff -Nru sbcl-2.0.6/contrib/sb-posix/posix-tests.lisp sbcl-2.1.1/contrib/sb-posix/posix-tests.lisp --- sbcl-2.0.6/contrib/sb-posix/posix-tests.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-posix/posix-tests.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -423,7 +423,6 @@ (ignore-errors (sb-posix:unlink name)))) nil) -#-hpux ; fix: cant handle c-vargs (deftest open.error.1 (handler-case (sb-posix:open *test-directory* sb-posix::o-wronly) (sb-posix:syscall-error (c) @@ -442,7 +441,7 @@ sb-posix::o-nonblock)) t) -#-(or hpux win32 netbsd) ; fix: cant handle c-vargs +#-(or win32 netbsd) ; fix: cant handle c-vargs (deftest fcntl.flock.1 (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (let ((flock (make-instance 'sb-posix:flock @@ -666,21 +665,24 @@ t) #-(or (and darwin x86) win32) -(deftest utimes.1 - (let ((file (merge-pathnames #p"utimes.1" *test-directory*)) - (atime (random (1- (expt 2 31)))) - (mtime (random (1- (expt 2 31))))) - (with-open-file (stream file - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (princ "Hello, utimes" stream)) - (sb-posix:utime file atime mtime) - (let* ((stat (sb-posix:stat file))) - (delete-file file) - (list (= (sb-posix:stat-atime stat) atime) - (= (sb-posix:stat-mtime stat) mtime)))) - (t t)) +(macrolet ((test (name posix-fun) + `(deftest ,name + (let ((file (merge-pathnames #p"utimes.1" *test-directory*)) + (atime (random (1- (expt 2 31)))) + (mtime (random (1- (expt 2 31))))) + (with-open-file (stream file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (princ "Hello, utimes" stream)) + (,posix-fun file atime mtime) + (let* ((stat (sb-posix:stat file))) + (delete-file file) + (list (= (sb-posix:stat-atime stat) atime) + (= (sb-posix:stat-mtime stat) mtime)))) + (t t)))) + (test utime.1 sb-posix:utime) + (test utimes.1 sb-posix:utimes)) ;; readlink tests. #-win32 @@ -697,7 +699,6 @@ ;; Same thing, but with a very long link target (which doesn't have ;; to exist). This tests the array adjustment in the wrapper, ;; provided that the target's length is long enough. - #-hpux ; arg2 to readlink is 80, and arg0 is larger than that (deftest readlink.2 (let ((target-pathname (make-pathname :name (make-string 255 :initial-element #\a) @@ -836,9 +837,8 @@ (delete-file temp)))) t "mkstemp-1") -;#-(or win32 sunos hpux) ;;;; mkdtemp is unimplemented on at least Solaris 10 -#-(or win32 hpux sunos) +#-(or win32 sunos) ;;; But it is implemented on OpenSolaris 2008.11 (deftest mkdtemp.1 (let ((pathname diff -Nru sbcl-2.0.6/contrib/sb-rotate-byte/compiler.lisp sbcl-2.1.1/contrib/sb-rotate-byte/compiler.lisp --- sbcl-2.0.6/contrib/sb-rotate-byte/compiler.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-rotate-byte/compiler.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -18,21 +18,24 @@ (macrolet (;; see src/compiler/srctran.lisp (with-byte-specifier ((size-var pos-var spec) &body body) - (once-only ((spec `(macroexpand ,spec)) + (once-only ((spec `(handler-case (macroexpand ,spec) + (error () + (return (values nil t))))) (temp '(gensym))) - `(if (and (consp ,spec) - (eq (car ,spec) 'byte) - (= (length ,spec) 3)) - (let ((,size-var (second ,spec)) - (,pos-var (third ,spec))) - ,@body) - (let ((,size-var `(byte-size ,,temp)) - (,pos-var `(byte-position ,,temp))) - `(let ((,,temp ,,spec)) - ,,@body)))))) + `(if (and (consp ,spec) + (eq (car ,spec) 'byte) + (= (length ,spec) 3)) + (let ((,size-var (second ,spec)) + (,pos-var (third ,spec))) + ,@body) + (let ((,size-var `(byte-size ,,temp)) + (,pos-var `(byte-position ,,temp))) + `(let ((,,temp ,,spec)) + ,,@body)))))) (define-source-transform rotate-byte (count spec num) - (with-byte-specifier (size pos spec) - `(%rotate-byte ,count ,size ,pos ,num)))) + (block nil + (with-byte-specifier (size pos spec) + `(%rotate-byte ,count ,size ,pos ,num))))) (defoptimizer (%rotate-byte derive-type) ((count size posn num)) ;; FIXME: this looks fairly unwieldy. I'm sure it can be made @@ -42,7 +45,7 @@ (if (numeric-type-p size) (let ((size-high (numeric-type-high size)) (num-type (sb-c::lvar-type num))) - (if (and size-high + (if (and (typep size-high '(integer 1)) num-type (<= size-high sb-vm:n-word-bits) (csubtypep num-type diff -Nru sbcl-2.0.6/contrib/sb-simple-streams/classes.lisp sbcl-2.1.1/contrib/sb-simple-streams/classes.lisp --- sbcl-2.0.6/contrib/sb-simple-streams/classes.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-simple-streams/classes.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -118,6 +118,8 @@ (pending :initform nil :type list) (handler :initform nil :type (or null sb-impl::handler)))) +(setq sb-pcl::*simple-stream-root-classoid* (sb-kernel:find-classoid 'simple-stream)) + (def-stream-class single-channel-simple-stream (simple-stream) (;; the "dirty" flag -- if this is > 0, write out buffer contents ;; before changing position; see flush-buffer diff -Nru sbcl-2.0.6/contrib/sb-simple-streams/impl.lisp sbcl-2.1.1/contrib/sb-simple-streams/impl.lisp --- sbcl-2.0.6/contrib/sb-simple-streams/impl.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-simple-streams/impl.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -56,7 +56,7 @@ (defmethod close ((stream simple-stream) &key abort) (device-close stream abort)) -(defun %file-position (stream position) +(defun sb-impl::s-%file-position (stream position) (declare (type simple-stream stream) (type (or (integer 0 *) (member nil :start :end)) position)) (with-stream-class (simple-stream stream) @@ -107,7 +107,7 @@ nil))) posn)))) -(defun %file-length (stream) +(defun sb-impl::s-%file-length (stream) (declare (type simple-stream stream)) (%check stream :open) (device-file-length stream)) @@ -138,7 +138,7 @@ nil)) -(defun %file-string-length (stream object) +(defun sb-impl::s-%file-string-length (stream object) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) @@ -160,19 +160,18 @@ count))) -(defun %read-line (stream eof-error-p eof-value recursive-p) +(defun sb-impl::s-%read-line (stream eof-error-p eof-value) (declare (optimize (speed 3) (space 1) (safety 0) (debug 0)) - (type simple-stream stream) - (ignore recursive-p)) + (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) - (return-from %read-line + (return-from sb-impl::s-%read-line (sb-impl::eof-or-lose stream eof-error-p eof-value))) ;; for interactive streams, finish output first to force prompt (when (and (any-stream-instance-flags stream :output) (any-stream-instance-flags stream :interactive)) - (%finish-output stream)) + (sb-impl::s-%finish-output stream)) (let* ((encap (sm melded-stream stream)) ; encapsulating stream (cbuf (make-string 80)) ; current buffer (bufs (list cbuf)) ; list of buffers @@ -227,23 +226,22 @@ (setf (cdr tail) (cons cbuf nil)) (setf tail (cdr tail)))))))) -(defun %read-char (stream eof-error-p eof-value recursive-p blocking-p) - (declare (type simple-stream stream) - (ignore recursive-p)) +(defun sb-impl::s-%read-char (stream eof-error-p eof-value blocking-p) + (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) - (return-from %read-char + (return-from sb-impl::s-%read-char (sb-impl::eof-or-lose stream eof-error-p eof-value))) ;; for interactive streams, finish output first to force prompt (when (and (any-stream-instance-flags stream :output) (any-stream-instance-flags stream :interactive)) - (%finish-output stream)) + (sb-impl::s-%finish-output stream)) (funcall-stm-handler j-read-char (sm melded-stream stream) eof-error-p eof-value blocking-p))) -(defun %unread-char (stream character) +(defun sb-impl::s-%unread-char (stream character) (declare (type simple-stream stream) (ignore character)) (with-stream-class (simple-stream stream) (%check stream :input) @@ -255,13 +253,12 @@ (setf (sm last-char-read-size stream) 0))))) -(defun %peek-char (stream peek-type eof-error-p eof-value recursive-p) - (declare (type simple-stream stream) - (ignore recursive-p)) +(defun sb-impl::s-%peek-char (stream peek-type eof-error-p eof-value) + (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) - (return-from %peek-char + (return-from sb-impl::s-%peek-char (sb-impl::eof-or-lose stream eof-error-p eof-value))) (let* ((encap (sm melded-stream stream)) (char (funcall-stm-handler j-read-char encap @@ -319,7 +316,7 @@ (device-clear-input stream buffer-only)) -(defun %read-byte (stream eof-error-p eof-value) +(defun sb-impl::s-%read-byte (stream eof-error-p eof-value) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :input) @@ -345,14 +342,14 @@ (sm encapsulated-char-read-size stream) 0))))))))) -(defun %write-char (stream character) +(defun sb-impl::s-%write-char (stream character) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) (funcall-stm-handler-2 j-write-char character (sm melded-stream stream)))) -(defun %fresh-line (stream) +(defun sb-impl::s-%fresh-line (stream) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) @@ -361,7 +358,7 @@ t))) -(defun %write-string (stream string start end) +(defun sb-impl::s-%write-string (stream string start end) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) @@ -369,14 +366,14 @@ start end))) -(defun %line-length (stream) +(defun sb-impl::s-%line-length (stream) (declare (type simple-stream stream)) (%check stream :output) ;; implement me nil) -(defun %finish-output (stream) +(defun sb-impl::s-%finish-output (stream) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) @@ -401,7 +398,7 @@ nil) -(defun %force-output (stream) +(defun sb-impl::s-%force-output (stream) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) @@ -422,7 +419,7 @@ nil) -(defun %clear-output (stream) +(defun sb-impl::%clear-output (stream) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) @@ -443,7 +440,7 @@ (device-clear-output stream))) -(defun %write-byte (stream integer) +(defun sb-impl::s-%write-byte (stream integer) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) @@ -510,7 +507,7 @@ ;; extend to work on other sequences: repeated read-byte ))) -(defun %write-sequence (stream seq start end) +(defun sb-impl::s-%write-sequence (stream seq start end) (declare (type simple-stream stream) (type sequence seq) (type sb-int:index start end)) @@ -565,46 +562,6 @@ )) seq) - -(defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8)) - (declare (type (sb-kernel:simple-unboxed-array (*)) vector) - (type stream stream)) - ;; START and END are octet offsets, not vector indices! [Except for strings] - ;; Return value is index of next octet to be read into (i.e., start+count) - (etypecase stream - (simple-stream - (with-stream-class (simple-stream stream) - (cond ((stringp vector) - (let* ((start (or start 0)) - (end (or end (length vector))) - (encap (sm melded-stream stream)) - (char (funcall-stm-handler j-read-char encap nil nil t))) - (when char - (setf (schar vector start) char) - (incf start) - (+ start (funcall-stm-handler j-read-chars encap vector nil - start end nil))))) - ((any-stream-instance-flags stream :string) - (error "Can't READ-BYTE on string streams.")) - (t - (do* ((encap (sm melded-stream stream)) - (index (or start 0) (1+ index)) - (end (or end (* (length vector) (vector-elt-width vector)))) - (endian-swap (endian-swap-value vector endian-swap)) - (flag t nil)) - ((>= index end) index) - (let ((byte (read-byte-internal encap nil nil flag))) - (unless byte - (return index)) - (setf (bref vector (logxor index endian-swap)) byte))))))) - ((or ansi-stream fundamental-stream) - (unless (typep vector '(or string - (simple-array (signed-byte 8) (*)) - (simple-array (unsigned-byte 8) (*)))) - (error "Wrong vector type for read-vector on stream not of type simple-stream.")) - (read-sequence vector stream :start (or start 0) :end end)))) - - ;;; ;;; USER-LEVEL FUNCTIONS ;;; @@ -621,54 +578,20 @@ (defmethod stream-element-type ((stream simple-stream)) '(unsigned-byte 8)) -(defun interactive-stream-p (stream) - "Return true if Stream does I/O on a terminal or other interactive device." - (etypecase stream - (simple-stream +(defmethod interactive-stream-p ((stream simple-stream)) (%check stream :open) (any-stream-instance-flags stream :interactive)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p)) - (fundamental-stream - nil))) -(defun (setf interactive-stream-p) (flag stream) - (typecase stream - (simple-stream +(defmethod (setf interactive-stream-p) (flag (stream simple-stream)) (%check stream :open) (if flag (add-stream-instance-flags stream :interactive) (remove-stream-instance-flags stream :interactive))) - (t - (error 'simple-type-error - :datum stream - :expected-type 'simple-stream - :format-control "Can't set interactive flag on ~S." - :format-arguments (list stream))))) - -(defun file-string-length (stream object) - (declare (type (or string character) object) (type stream stream)) - "Return the delta in STREAM's FILE-POSITION that would be caused by writing - OBJECT to STREAM. Non-trivial only in implementations that support - international character sets." - (typecase stream - (simple-stream (%file-string-length stream object)) - (t - (etypecase object - (character 1) - (string (length object)))))) - -(defun stream-external-format (stream) - "Returns Stream's external-format." - (etypecase stream - (simple-stream + +(defun sb-impl::s-%stream-external-format (stream) (with-stream-class (simple-stream) (%check stream :open) (sm external-format stream))) - (ansi-stream - :default) - (fundamental-stream - :default))) (defun open (filename &rest options &key (direction :input) @@ -725,58 +648,7 @@ (symbol (find-class class t)) (class class))))))) - -;; These are not normally inlined. -;; READ-CHAR is 1K of code, etc. This was probably either a brute-force -;; way to optimize IN-SYNONYM-OF and/or optimize for known sub-hierarchy -;; at compile-time, but how likely is that to help? -(declaim (inline read-byte read-char read-char-no-hang unread-char)) - -(defun read-byte (stream &optional (eof-error-p t) eof-value) - "Returns the next byte of the Stream." - (declare (sb-int:explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (etypecase stream - (simple-stream - (let ((byte (%read-byte stream eof-error-p eof-value))) - (if (eq byte eof-value) - byte - (the integer byte)))) - (ansi-stream - (sb-impl::ansi-stream-read-byte stream eof-error-p eof-value nil)) - (fundamental-stream - (let ((byte (sb-gray:stream-read-byte stream))) - (if (eq byte :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - (the integer byte))))))) - -(defun read-char (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) - "Inputs a character from Stream and returns it." - (declare (sb-int:explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (etypecase stream - (simple-stream - (let ((char (%read-char stream eof-error-p eof-value recursive-p t))) - (if (eq char eof-value) - char - (the character char)))) - (ansi-stream - (sb-impl::ansi-stream-read-char stream eof-error-p eof-value - recursive-p)) - (fundamental-stream - (let ((char (sb-gray:stream-read-char stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - (the character char))))))) - -(defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) - "Returns the next character from the Stream if one is availible, or nil." - (declare (sb-int:explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (etypecase stream - (simple-stream +(defun sb-impl::s-%read-char-no-hang (stream eof-error-p eof-value) (%check stream :input) (let ((char (with-stream-class (simple-stream) @@ -784,72 +656,6 @@ (if (or (eq char eof-value) (not char)) char (the character char)))) - (ansi-stream - (sb-impl::ansi-stream-read-char-no-hang stream eof-error-p eof-value - recursive-p)) - (fundamental-stream - (let ((char (sb-gray:stream-read-char-no-hang stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - (the (or character null) char))))))) - -(defun unread-char (character &optional (stream *standard-input*)) - "Puts the Character back on the front of the input Stream." - (declare (sb-int:explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%unread-char stream character)) - (ansi-stream - (sb-impl::ansi-stream-unread-char character stream)) - (fundamental-stream - (sb-gray:stream-unread-char stream character)))) - nil) - -(declaim (notinline read-byte read-char read-char-no-hang unread-char)) - -(defun peek-char (&optional (peek-type nil) (stream *standard-input*) - (eof-error-p t) eof-value recursive-p) - "Peeks at the next character in the input Stream. See manual for details." - (declare (sb-int:explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (etypecase stream - (simple-stream - (let ((char - (%peek-char stream peek-type eof-error-p eof-value recursive-p))) - (if (eq char eof-value) - char - (the character char)))) - ;; FIXME: Broken on ECHO-STREAM (cf internal implementation?) -- - ;; CSR, 2004-01-19 - (ansi-stream - (sb-impl::ansi-stream-peek-char peek-type stream eof-error-p eof-value - recursive-p)) - (fundamental-stream - ;; This seems to duplicate all the code of GENERALIZED-PEEKING-MECHANISM - (cond ((characterp peek-type) - (do ((char (sb-gray:stream-read-char stream) - (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (char= char peek-type)) - (cond ((eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value)) - (t - (sb-gray:stream-unread-char stream char) - char))))) - ((eq peek-type t) - (do ((char (sb-gray:stream-read-char stream) - (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (not (sb-impl::whitespace[2]p char))) - (cond ((eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value)) - (t - (sb-gray:stream-unread-char stream char) - char))))) - (t - (let ((char (sb-gray:stream-peek-char stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - (the character char))))))))) (defun listen (&optional (stream *standard-input*) (width 1)) "Returns T if WIDTH octets are available on STREAM. If WIDTH is @@ -867,25 +673,6 @@ (fundamental-stream (sb-gray:stream-listen stream))))) - -(defun read-line (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) - "Returns a line of text read from the Stream as a string, discarding the - newline character." - (declare (sb-int:explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%read-line stream eof-error-p eof-value recursive-p)) - (ansi-stream - (sb-impl::ansi-stream-read-line stream eof-error-p eof-value - recursive-p)) - (fundamental-stream - (multiple-value-bind (string eof) (sb-gray:stream-read-line stream) - (if (and eof (zerop (length string))) - (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t) - (values string eof))))))) - (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill) "Destructively modify SEQ by reading elements from STREAM. SEQ is bounded by START and END. SEQ is destructively modified by @@ -917,198 +704,22 @@ (sb-gray:stream-clear-input stream)))) nil) -(defun write-byte (integer stream) - "Outputs an octet to the Stream." - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%write-byte stream integer)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-bout stream) stream integer)) - (fundamental-stream - (sb-gray:stream-write-byte stream integer)))) - integer) - -(defun write-char (character &optional (stream *standard-output*)) - "Outputs the Character to the Stream." - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%write-char stream character)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-out stream) stream character)) - (fundamental-stream - (sb-gray:stream-write-char stream character)))) - character) - -(defun write-string (string &optional (stream *standard-output*) - &key (start 0) (end nil)) - "Outputs the String to the given Stream." - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream)) - (end (sb-impl::%check-vector-sequence-bounds string start end))) - (etypecase stream - (simple-stream - (%write-string stream string start end) - string) - (ansi-stream - (sb-impl::ansi-stream-write-string string stream start end)) - (fundamental-stream - (sb-gray:stream-write-string stream string start end))))) - -(defun write-line (string &optional (stream *standard-output*) - &key (start 0) end) - (declare (type string string)) - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream)) - (end (sb-impl::%check-vector-sequence-bounds string start end))) - (etypecase stream - (simple-stream +(defun sb-impl::s-%write-line (stream string start end) + (declare (type simple-stream stream)) (%check stream :output) (with-stream-class (simple-stream stream) (funcall-stm-handler-2 j-write-chars string stream start end) (funcall-stm-handler-2 j-write-char #\Newline stream))) - (ansi-stream - (sb-impl::ansi-stream-write-string string stream start end) - (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)) - (fundamental-stream - (sb-gray:stream-write-string stream string start end) - (sb-gray:stream-terpri stream)))) - string) - -(defun write-sequence (seq stream &key (start 0) (end nil)) - "Write the elements of SEQ bounded by START and END to STREAM." - (let ((stream (out-stream-from-designator stream)) - (end (or end (length seq)))) - (etypecase stream - (simple-stream - (%write-sequence stream seq start end)) - (ansi-stream - (sb-impl::ansi-stream-write-sequence seq stream start end)) - (fundamental-stream - (sb-gray:stream-write-sequence stream seq start end))))) -(defun terpri (&optional (stream *standard-output*)) - "Outputs a new line to the Stream." - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream +(defun sb-impl::s-%terpri (stream) (%check stream :output) (with-stream-class (simple-stream stream) (funcall-stm-handler-2 j-write-char #\Newline stream))) - (ansi-stream - (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)) - (fundamental-stream - (sb-gray:stream-terpri stream)))) - nil) - -(defun fresh-line (&optional (stream *standard-output*)) - "Outputs a new line to the Stream if it is not positioned at the beginning of - a line. Returns T if it output a new line, nil otherwise." - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%fresh-line stream)) - (ansi-stream - (sb-impl::ansi-stream-fresh-line stream)) - (fundamental-stream - (sb-gray:stream-fresh-line stream))))) -(defun finish-output (&optional (stream *standard-output*)) - "Attempts to ensure that all output sent to the Stream has reached its - destination, and only then returns." - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%finish-output stream)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output)) - (fundamental-stream - (sb-gray:stream-finish-output stream)))) - nil) - -(defun force-output (&optional (stream *standard-output*)) - "Attempts to force any buffered output to be sent." - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%force-output stream)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output)) - (fundamental-stream - (sb-gray:stream-force-output stream)))) - nil) - -(defun clear-output (&optional (stream *standard-output*)) - "Clears the given output Stream." - (declare (sb-int:explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%clear-output stream)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output)) - (fundamental-stream - (sb-gray:stream-clear-output stream)))) - nil) - - -(defun file-position (stream &optional position) - "With one argument returns the current position within the file - File-Stream is open to. If the second argument is supplied, then - this becomes the new file position. The second argument may also - be :start or :end for the start and end of the file, respectively." - (declare (type (or sb-int:index (member nil :start :end)) position)) - (etypecase stream - (simple-stream - (%file-position stream position)) - (ansi-stream - (sb-kernel:ansi-stream-file-position stream position)))) - -(defun file-length (stream) - "This function returns the length of the file that File-Stream is open to." - (etypecase stream - (simple-stream - (%file-length stream)) - (ansi-stream - (sb-impl::stream-file-stream-or-lose stream) - (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))) - -(defun charpos (&optional (stream *standard-output*)) - "Returns the number of characters on the current line of output of the given - Stream, or Nil if that information is not availible." - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream +(defun sb-impl::s-%charpos (stream) (with-stream-class (simple-stream stream) (%check stream :open) (sm charpos stream))) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos)) - (fundamental-stream - (sb-gray:stream-line-column stream))))) - -(defun line-length (&optional (stream *standard-output*)) - "Returns the number of characters in a line of output of the given - Stream, or Nil if that information is not availible." - (let ((stream (out-stream-from-designator stream))) - (etypecase stream - (simple-stream - (%check stream :output) - ;; TODO (sat 2003-04-02): a way to specify a line length would - ;; be good, I suppose. Returning nil here means - ;; sb-pretty::default-line-length is used. - nil) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length)) - (fundamental-stream - (sb-gray:stream-line-length stream))))) (defun wait-for-input-available (stream &optional timeout) "Waits for input to become available on the Stream and returns T. If @@ -1133,19 +744,9 @@ (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout)))))) ;; Make PATHNAME and NAMESTRING work -(defun sb-int:file-name (stream &optional new-name) - (typecase stream - (file-simple-stream +(defun sb-impl::s-%file-name (stream new-name) (with-stream-class (file-simple-stream stream) (cond (new-name (%file-rename stream new-name)) (t (%file-name stream))))) - (sb-sys:fd-stream - (cond (new-name - (setf (sb-impl::fd-stream-pathname stream) new-name) - (setf (sb-impl::fd-stream-file stream) - (%file-namestring new-name)) - t) - (t - (sb-impl::fd-stream-pathname stream)))))) diff -Nru sbcl-2.0.6/contrib/sb-simple-streams/internal.lisp sbcl-2.1.1/contrib/sb-simple-streams/internal.lisp --- sbcl-2.0.6/contrib/sb-simple-streams/internal.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-simple-streams/internal.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -249,6 +249,7 @@ (pos -1) (count 0) (state nil)) + (declare (ignorable count)) (flet ((input () (aref octets (incf ptr))) (unput (n) diff -Nru sbcl-2.0.6/contrib/sb-simple-streams/package.lisp sbcl-2.1.1/contrib/sb-simple-streams/package.lisp --- sbcl-2.0.6/contrib/sb-simple-streams/package.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-simple-streams/package.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -14,7 +14,7 @@ (:import-from #:sb-impl #:in-stream-from-designator #:out-stream-from-designator) ;; FIXME: Using deffoo! or equivalent might be nicer. - (:implement #:common-lisp #:sb-kernel #:sb-int) + (:implement #:common-lisp #:sb-impl) (:export ;; Stream classes #:STREAM #:SIMPLE-STREAM diff -Nru sbcl-2.0.6/contrib/sb-simple-streams/sb-simple-streams.asd sbcl-2.1.1/contrib/sb-simple-streams/sb-simple-streams.asd --- sbcl-2.0.6/contrib/sb-simple-streams/sb-simple-streams.asd 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-simple-streams/sb-simple-streams.asd 2021-01-30 11:22:38.000000000 +0000 @@ -32,3 +32,7 @@ #+sb-building-contrib :pathname #+sb-building-contrib #p"SYS:CONTRIB;SB-SIMPLE-STREAMS;" :components ((:file "simple-stream-tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system "sb-simple-streams/tests")))) + (or (funcall (intern "DO-TESTS" (find-package "SB-RT"))) + (error "test-op failed"))) diff -Nru sbcl-2.0.6/contrib/sb-simple-streams/simple-stream-tests.lisp sbcl-2.1.1/contrib/sb-simple-streams/simple-stream-tests.lisp --- sbcl-2.0.6/contrib/sb-simple-streams/simple-stream-tests.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-simple-streams/simple-stream-tests.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -60,6 +60,7 @@ (progn ,@body)) ,(when delete-afterwards `(ignore-errors (delete-file ,file)))))) +#+nil ; fails (deftest non-existent-class (handler-case (with-test-file (s *test-file* :class 'non-existent-stream) @@ -84,6 +85,7 @@ :direction :output :if-exists :overwrite :if-does-not-exist :create)) + (fresh-line s) (string= (write-string *dumb-string* s) *dumb-string*)) (delete-file *test-file*)) t) @@ -501,6 +503,7 @@ (read-char s))) #\A) +#+nil ; fails (deftest synonym-stream-6 ;; WRITE-STRING (with-sc-test-stream (*synonym*) @@ -542,8 +545,8 @@ (deftest synonym-stream-11 ;; STREAM-ELEMENT-TYPE (via STREAM-MISC-DISPATCH) (with-sc-test-stream (*synonym*) - (eql (stream-element-type (make-synonym-stream '*synonym*)) - (stream-element-type *synonym*))) + (equal (stream-element-type (make-synonym-stream '*synonym*)) + (stream-element-type *synonym*))) T) (deftest synonym-stream-12 @@ -603,6 +606,7 @@ (read-char synonym)) #\A) +#+nil ; fails (deftest broadcast-stream-6 ;; WRITE-STRING (with-sc-test-stream (synonym) @@ -705,6 +709,7 @@ (read-char synonym)) #\A) +#+nil ; fails (deftest two-way-stream-6 ;; WRITE-STRING (with-sc-test-stream (synonym) @@ -889,8 +894,8 @@ (deftest concatenated-stream-11 ;; STREAM-ELEMENT-TYPE (via STREAM-MISC-DISPATCH) (with-sc-test-stream (*synonym*) - (eql (stream-element-type (make-concatenated-stream *synonym*)) - (stream-element-type *synonym*))) + (equal (stream-element-type (make-concatenated-stream *synonym*)) + (stream-element-type *synonym*))) T) (deftest concatenated-stream-12 @@ -949,6 +954,7 @@ ;; launchpad bug #491087 +#+nil ; fails (deftest lp491087 (labels ((read-big-int (stream) (let ((b (make-array 1 :element-type '(signed-byte 32) diff -Nru sbcl-2.0.6/contrib/sb-simple-streams/strategy.lisp sbcl-2.1.1/contrib/sb-simple-streams/strategy.lisp --- sbcl-2.0.6/contrib/sb-simple-streams/strategy.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-simple-streams/strategy.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -109,6 +109,7 @@ (buffpos (sm buffpos stream)) (cnt 0) (char nil)) + (declare (ignorable cnt)) (unwind-protect (flet ((input () (when (>= buffpos (sm buffer-ptr stream)) diff -Nru sbcl-2.0.6/contrib/sb-sprof/graph.lisp sbcl-2.1.1/contrib/sb-sprof/graph.lisp --- sbcl-2.0.6/contrib/sb-sprof/graph.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-sprof/graph.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -266,8 +266,7 @@ (multiple-value-bind (start end) (code-bounds info) (values - (%make-node :name (or (sb-disassem::find-assembler-routine start) - (format nil "~a" info)) + (%make-node :name (format nil "~a" info) :debug-info info :start-pc-or-offset start :end-pc-or-offset end) @@ -277,12 +276,11 @@ (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info)) (start-offset (sb-c::compiled-debug-fun-start-pc cdf)) (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf)) - (component (sb-di::compiled-debug-fun-component info)) - (start-pc (code-start component))) + (component (sb-di::compiled-debug-fun-component info))) ;; Call graphs are mostly useless unless we somehow ;; distinguish a gazillion different (LAMBDA ())'s. (when (equal name '(lambda ())) - (setf name (format nil "Unknown component: #x~x" start-pc))) + (setf name (format nil "~a in ~a" name component))) (values (%make-node :name (clean-name name) :debug-info info :start-pc-or-offset start-offset @@ -291,6 +289,9 @@ (sb-di::debug-fun (%make-node :name (clean-name (sb-di::debug-fun-name info)) :debug-info info)) + (symbol + (%make-node :name (string info) + :debug-info sb-fasl:*assembler-routines*)) (t (%make-node :name (coerce info 'string) :debug-info info))))) @@ -338,8 +339,8 @@ (let ((elsewhere-count 0)) (with-lookup-tables () (map-traces - (lambda (thread time trace) - (declare (ignore thread time)) + (lambda (thread trace) + (declare (ignore thread)) (let ((visited-nodes '()) (depth 0) (caller nil)) diff -Nru sbcl-2.0.6/contrib/sb-sprof/interface.lisp sbcl-2.1.1/contrib/sb-sprof/interface.lisp --- sbcl-2.0.6/contrib/sb-sprof/interface.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-sprof/interface.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -70,7 +70,7 @@ If specified, call REPORT with :TYPE at the end. :RESET - It true, call RESET at the beginning. + If true, call RESET at the beginning. :THREADS Form that evaluates to the list threads to profile, or :ALL to indicate @@ -127,8 +127,6 @@ (stop-profiling))) ,@(when report-p `((report :type ,report)))))) -(defvar *timer* nil) - #-win32 (defun start-profiling (&key (max-samples *max-samples*) (mode *sampling-mode*) @@ -185,8 +183,7 @@ (truncate sample-interval) (values secs (truncate (* rest 1000000)))) (setf *sampling* sampling - *samples* (make-samples :start-time (get-internal-real-time) - :max-depth max-depth + *samples* (make-samples :max-depth max-depth :max-samples max-samples :sample-interval sample-interval :alloc-interval alloc-interval @@ -194,39 +191,57 @@ (enable-call-counting) (setf *profiled-threads* threads) (sb-sys:enable-interrupt sb-unix:sigprof - #'sigprof-handler - :synchronous t) - (ecase mode + #'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. - (sb-thread::with-all-threads-lock + ;; 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. - (dolist (thread (profiled-threads)) - (sb-thread::%set-symbol-value-in-thread 'sb-vm::*alloc-signal* thread alloc-signal))) + (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 - (let ((setup (sb-thread:make-semaphore :name "Timer thread setup semaphore"))) - (setf *timer-thread* - (sb-thread:make-thread (lambda () - (sb-thread:wait-on-semaphore setup) - (loop while (eq sb-thread:*current-thread* *timer-thread*) - do (sleep 1.0))) - :name "SB-SPROF wallclock timer thread")) - (sb-thread:signal-semaphore setup)) + (sb-thread::start-thread + (setf *timer* (sb-thread::%make-thread "SPROF timer" nil (sb-thread:make-semaphore))) + (lambda () + (loop (unless *timer* (return)) + (sleep sample-interval) + (map-threads + (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 - (setf *timer-thread* nil) - (setf *timer* (make-timer #'thread-distribution-handler :name "SB-PROF wallclock timer" - :thread *timer-thread*)) - (schedule-timer *timer* sample-interval :repeat-interval sample-interval))) + (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)) @@ -246,14 +261,16 @@ (:cpu (unix-setitimer :profile 0 0 0 0)) (:time - (unschedule-timer *timer*) - (setf *timer* nil - *timer-thread* nil))) + (let ((timer *timer*)) + ;; after this assignment, the timer thread will raise the + ;; profiling signal at most once more, and then stop. + (setf *timer* nil) + #-sb-thread (unschedule-timer timer) + #+sb-thread (sb-thread:join-thread timer)))) (disable-call-counting) (setf *profiling* nil *sampling* nil - *profiled-threads* nil) - (setf (samples-end-time *samples*) (get-internal-real-time)))) + *profiled-threads* nil))) (values)) (defun reset () diff -Nru sbcl-2.0.6/contrib/sb-sprof/record.lisp sbcl-2.1.1/contrib/sb-sprof/record.lisp --- sbcl-2.0.6/contrib/sb-sprof/record.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-sprof/record.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -14,29 +14,27 @@ ;;; 0 code-component-ish ;;; 1 an offset relative to the start of the code-component or an ;;; absolute address -(defconstant +elements-per-sample+ 2) +(defconstant +elements-per-pc-loc+ 2) ;;; 0 the trace start marker (trace-start . END-INDEX) ;;; 1 the current thread, an SB-THREAD:THREAD instance -;;; 2 the current internal real time -(defconstant +elements-per-trace-start+ 3) +(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 samples we'll be + ;; 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 sample takes two cells in the vector - +elements-per-sample+))) + ;; 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 start-time - mode sample-interval alloc-interval + 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 @@ -60,9 +58,6 @@ (sampled-threads nil :type list) ;; Metadata - (start-time (sb-int:missing-arg) :type sb-kernel:internal-time :read-only t) - (end-time nil :type (or null sb-kernel:internal-time)) - (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) @@ -78,7 +73,7 @@ approximately ~:D sample~:P), doubling the ~ size~%" (samples-trace-count samples) - (truncate (samples-index samples) +elements-per-sample+))) + (truncate (samples-index samples) +elements-per-pc-loc+))) (declaim (inline ensure-samples-vector)) (defun ensure-samples-vector (samples) @@ -89,7 +84,7 @@ ;; 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-sample+ + (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) @@ -103,8 +98,7 @@ (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* - (aref vector (+ index 2)) (get-internal-real-time)) + (aref vector (+ index 1)) sb-thread:*current-thread*) (setf (samples-index samples) (+ index +elements-per-trace-start+) (samples-trace-start samples) trace-start)))) @@ -118,56 +112,46 @@ ;; adjacent cells. (setf (aref vector index) info (aref vector (1+ index)) pc-or-offset) - (setf (samples-index samples) (+ index +elements-per-sample+)))) + (setf (samples-index samples) (+ index +elements-per-pc-loc+)))) ;;; Trace and sample and access functions (defun map-traces (function samples) "Call FUNCTION on each trace in SAMPLES -The lambda list of FUNCTION has to be compatible to - - (thread time trace) +The signature of FUNCTION must be compatible with (thread trace). -. FUNCTION is called once for each trace such that THREAD is the -SB-THREAD:TREAD instance that was sampled to produce TRACE, TIME is -the internal real time at which TRACE was produced and TRACE is an -opaque object whose only purpose is being used as the second argument -to MAP-TRACE-SAMPLES. +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. EXPERIMENTAL: Interface subject to change." (let ((function (sb-kernel:%coerce-callable-to-fun function)) (vector (samples-vector samples)) - (index (samples-index samples)) - (start-time (samples-start-time samples))) + (index (samples-index samples))) (when (plusp index) (sb-int:aver (typep (aref vector 0) '(cons (eql trace-start) index))) (loop for start = 0 then end while (< start index) for end = (cdr (aref vector start)) for thread = (aref vector (+ start 1)) - for time = (/ (- (aref vector (+ start 2)) start-time) - internal-time-units-per-second) do (let ((trace (list vector start end))) - (funcall function thread time trace)))))) + (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 lambda list of FUNCTION has to be compatible to - - (info pc-or-offset) - -. - -TRACE is an object as received by a function passed to MAP-TRACES. +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." (let ((function (sb-kernel:%coerce-callable-to-fun function))) (destructuring-bind (samples start end) trace - (loop for i from (- end +elements-per-sample+) + (loop for i from (- end +elements-per-pc-loc+) downto (+ start +elements-per-trace-start+ -1) - by +elements-per-sample+ + by +elements-per-pc-loc+ for info = (aref samples i) for pc-or-offset = (aref samples (1+ i)) do (funcall function info pc-or-offset))))) @@ -176,17 +160,13 @@ (defun map-all-samples (function &optional (samples *samples*)) "Call FUNCTION on each sample in SAMPLES. -The lambda list of FUNCTION has to be compatible to - - (info pc-or-offset) - -. +The signature of FUNCTION must be compatible with (info pc-or-offset). SAMPLES is usually the value of *SAMPLES* after a profiling run. EXPERIMENTAL: Interface subject to change." - (sb-int:dx-flet ((do-trace (thread time trace) - (declare (ignore thread time)) + (sb-int:dx-flet ((do-trace (thread trace) + (declare (ignore thread)) (map-trace-samples function trace))) (map-traces #'do-trace samples))) @@ -200,7 +180,7 @@ (etypecase info ;; Assembly routines or foreign functions don't move around, so ;; we've stored a raw PC - ((or null sb-kernel:code-component string) + ((or null sb-kernel:code-component string symbol) pc-or-offset) ;; Lisp functions might move, so we've stored a offset from the ;; start of the code component. @@ -221,18 +201,9 @@ (defvar *show-progress* nil) -(defvar *old-sampling* nil) - ;; Call count encapsulation information (defvar *encapsulations* (make-hash-table :test 'equal)) -(defun turn-off-sampling () - (setq *old-sampling* *sampling*) - (setq *sampling* nil)) - -(defun turn-on-sampling () - (setq *sampling* *old-sampling*)) - (defun show-progress (format-string &rest args) (when *show-progress* (apply #'format t format-string args) @@ -257,14 +228,17 @@ (defun debug-info (pc) (declare (type system-area-pointer pc) (muffle-conditions compiler-note)) - (let ((code (sb-di::code-header-from-pc pc))) + (let ((code (sb-di::code-header-from-pc pc)) + (pc-int (sap-int pc))) (cond ((not code) (let ((name (sap-foreign-symbol pc))) (if name (values (format nil "foreign function ~a" name) - (sap-int pc) - :foreign) - (values nil (sap-int pc) :foreign)))) + pc-int :foreign) + (values nil pc-int :foreign)))) + ((eq code sb-fasl:*assembler-routines*) + (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)) @@ -277,15 +251,15 @@ (di (unless (typep (sb-kernel:%code-debug-info code) 'sb-c::compiled-debug-info) (return-from debug-info - (values code (sap-int pc))))) - (pc-offset (- (sap-int pc) + (values code pc-int nil)))) + (pc-offset (- pc-int (- (sb-kernel:get-lisp-obj-address code) sb-vm:other-pointer-lowtag) code-header-len)) (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 (sap-int pc) nil)) + (values code pc-int nil)) (df ;; The code component might be moved by the GC. Store ;; a PC offset, and reconstruct the data in @@ -305,56 +279,21 @@ (defvar *profiled-threads* nil) (declaim (type (or list (member :all)) *profiled-threads*)) -;;; Thread which runs the wallclock timers, if any. -(defvar *timer-thread* nil) - -(defun profiled-threads () - (let ((profiled-threads *profiled-threads*)) - (remove *timer-thread* - (if (eq :all profiled-threads) - (sb-thread:list-all-threads) - 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*)) - (or (and (eq :all profiled-threads) - (not (eq *timer-thread* thread))) - (member thread profiled-threads :test #'eq)))) + (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. - (defvar *profiler-lock* (sb-thread:make-mutex :name "Statistical Profiler")) - (defvar *distribution-lock* (sb-thread:make-mutex :name "Wallclock profiling lock")) - - #+sb-thread - (declaim (inline pthread-kill)) - #+sb-thread - (define-alien-routine pthread-kill int (os-thread unsigned-long) (signal int)) - - ;;; A random thread will call this in response to either a timer firing, - ;;; This in turn will distribute the notice to those threads we are - ;;; interested using SIGPROF. - (defun thread-distribution-handler () - (declare (optimize speed (space 0))) - #+sb-thread - (let ((lock *distribution-lock*)) - ;; Don't flood the system with more interrupts if the last - ;; set is still being delivered. - (unless (sb-thread:mutex-value lock) - (sb-thread::with-system-mutex (lock) - (dolist (thread (profiled-threads)) - ;; This may occasionally fail to deliver the signal, but that - ;; seems better then using kill_thread_safely with it's 1 - ;; second backoff. - (let ((os-thread (sb-thread::thread-os-thread thread))) - (when os-thread - (pthread-kill os-thread sb-unix:sigprof))))))) - #-sb-thread - (unix-kill 0 sb-unix:sigprof)) + (defglobal *profiler-lock* (sb-thread:make-mutex :name "Statistical Profiler")) (defun sigprof-handler (signal code scp) - (declare (ignore signal code) (optimize speed (space 0)) + (declare (ignore signal code) (optimize speed) (disable-package-locks sb-di::x86-call-context) (muffle-conditions compiler-note) (type system-area-pointer scp)) @@ -375,7 +314,8 @@ ;; pointless there -- though it may be that our mach magic is ;; partially to blame? (or (not (eq :cpu profiling)) (profiled-thread-p self))) - (sb-thread::with-system-mutex (*profiler-lock* :without-gcing t) + (with-code-pages-pinned (:dynamic) + (with-system-mutex (*profiler-lock*) (let ((samples *samples*) ;; Don't touch the circularity hash-table *print-circle*) @@ -384,7 +324,9 @@ (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 #.sb-vm::ebp-offset))) + (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 @@ -422,13 +364,13 @@ (when (zerop i) (decf (samples-index samples) (+ +elements-per-trace-start+ - (* +elements-per-sample+ (1+ i))))) + (* +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))))))))) + (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 diff -Nru sbcl-2.0.6/contrib/sb-sprof/report.lisp sbcl-2.1.1/contrib/sb-sprof/report.lisp --- sbcl-2.0.6/contrib/sb-sprof/report.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-sprof/report.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -7,7 +7,7 @@ (defconstant +alloc-region-size+ #-gencgc - (get-page-size) + sb-c:+backend-page-bytes+ #+gencgc (max sb-vm:gencgc-alloc-granularity sb-vm:gencgc-card-bytes)) @@ -121,7 +121,7 @@ (accrued-percent (samples-percent call-graph accrued-count))) (incf total-count count) (incf total-percent percent) - (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~8@a ~s~%" + (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~8@a " (incf i) count percent @@ -129,8 +129,10 @@ accrued-percent total-count total-percent - (or (node-call-count node) "-") - (node-name node)) + (or (node-call-count node) "-")) + (if (stringp (node-name node)) + (format t "~a~%" (node-name node)) + (format t "~s~%" (node-name node))) (finish-output))) (print-separator) (format t "~& ~6d ~5,1f~36a elsewhere~%" @@ -145,8 +147,12 @@ (do-vertices (node call-graph) (when (cycle-p node) (flet ((print-info (indent index count percent name) - (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" - count percent indent name index))) + (format t "~&~6d ~5,1f ~11@t ~V@t " + count percent indent) + (if (stringp name) + (format t "~a" name) + (format t "~s" name)) + (format t " [~d]~%" index))) (print-separator) (format t "~&~6d ~5,1f ~a...~%" (node-count node) @@ -168,8 +174,12 @@ (flet ((find-call (from to) (find to (node-edges from) :key #'call-vertex)) (print-info (indent index count percent name) - (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" - count percent indent name index))) + (format t "~&~6d ~5,1f ~11@t ~V@t " + count percent indent) + (if (stringp name) + (format t "~a" name) + (format t "~s" name)) + (format t " [~d]~%" index))) (format t "~& Callers~%") (format t "~& Total. Function~%") (format t "~& Count % Count % Callees~%") @@ -185,13 +195,15 @@ (samples-percent call-graph (call-count call)) (node-name caller)))) ;; Print the node itself. - (format t "~&~6d ~5,1f ~6d ~5,1f ~s [~d]~%" + (format t "~&~6d ~5,1f ~6d ~5,1f " (node-count node) (samples-percent call-graph (node-count node)) (node-accrued-count node) - (samples-percent call-graph (node-accrued-count node)) - (node-name node) - (node-index node)) + (samples-percent call-graph (node-accrued-count node))) + (if (stringp (node-name node)) + (format t "~a" (node-name node)) + (format t "~s" (node-name node))) + (format t " [~d]~%" (node-index node)) ;; Print callees. (do-edges (call called node) (print-info 4 (node-index called) diff -Nru sbcl-2.0.6/contrib/sb-sprof/sb-sprof.texinfo sbcl-2.1.1/contrib/sb-sprof/sb-sprof.texinfo --- sbcl-2.0.6/contrib/sb-sprof/sb-sprof.texinfo 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-sprof/sb-sprof.texinfo 2021-01-30 11:22:38.000000000 +0000 @@ -118,12 +118,6 @@ @subsection Platform support -This module is known not to work consistently on the Alpha platform, -for technical reasons related to the implementation of a machine -language idiom for marking sections of code to be treated as atomic by -the garbage collector; However, it should work on other platforms, -and the deficiency on the Alpha will eventually be rectified. - Allocation profiling is only supported on SBCL builds that use the generational garbage collector. Tracking of call stacks at a depth of more than two levels is only supported on x86 and x86-64. diff -Nru sbcl-2.0.6/contrib/sb-sprof/test.lisp sbcl-2.1.1/contrib/sb-sprof/test.lisp --- sbcl-2.0.6/contrib/sb-sprof/test.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/contrib/sb-sprof/test.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -6,6 +6,17 @@ ;#+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)) diff -Nru sbcl-2.0.6/crossbuild-runner/backends/alpha/features sbcl-2.1.1/crossbuild-runner/backends/alpha/features --- sbcl-2.0.6/crossbuild-runner/backends/alpha/features 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/alpha/features 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -:64-bit-registers -:cheneygc diff -Nru sbcl-2.0.6/crossbuild-runner/backends/alpha/local-target-features sbcl-2.1.1/crossbuild-runner/backends/alpha/local-target-features --- sbcl-2.0.6/crossbuild-runner/backends/alpha/local-target-features 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/alpha/local-target-features 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -:cheneygc :64-bit-registers :little-endian diff -Nru sbcl-2.0.6/crossbuild-runner/backends/alpha/stuff-groveled-from-headers.lisp sbcl-2.1.1/crossbuild-runner/backends/alpha/stuff-groveled-from-headers.lisp --- sbcl-2.0.6/crossbuild-runner/backends/alpha/stuff-groveled-from-headers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/alpha/stuff-groveled-from-headers.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,145 +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 256) ; #x100 -(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 64)) -;;; langinfo -(defconstant codeset 14) ; #xe -;;; types, types, types -(define-alien-type clock-t (signed 64)) -(define-alien-type dev-t (unsigned 64)) -(define-alien-type gid-t (unsigned 32)) -(define-alien-type ino-t (unsigned 32)) -(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 64)) -(define-alien-type time-t (signed 64)) -(define-alien-type suseconds-t (signed 64)) -(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 32)) -(define-alien-type wst-dev-t (unsigned 32)) -(define-alien-type wst-off-t (unsigned 32)) -(define-alien-type wst-blksize-t (unsigned 64)) -(define-alien-type wst-blkcnt-t (unsigned 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 512) ; #x200 -(defconstant o_excl 2048) ; #x800 -(defconstant o_noctty 4096) ; #x1000 -(defconstant o_trunc 1024) ; #x400 -(defconstant o_append 8) ; #x8 -;;; -(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 35) ; #x23 -(defconstant eio 5) ; #x5 -(defconstant eexist 17) ; #x11 -(defconstant eloop 62) ; #x3e -(defconstant espipe 29) ; #x1d -(defconstant epipe 32) ; #x20 -(defconstant ewouldblock 35) ; #x23 - -;;; 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 20) ; #x14 -(defconstant sigcont 19) ; #x13 -(defconstant sigemt 7) ; #x7 -(defconstant sigfpe 8) ; #x8 -(defconstant sighup 1) ; #x1 -(defconstant sigill 4) ; #x4 -(defconstant sigint 2) ; #x2 -(defconstant sigio 23) ; #x17 -(defconstant sigkill 9) ; #x9 -(defconstant sigpipe 13) ; #xd -(defconstant sigprof 27) ; #x1b -(defconstant sigquit 3) ; #x3 -(defconstant sigsegv 11) ; #xb -(defconstant sigstop 17) ; #x11 -(defconstant sigsys 12) ; #xc -(defconstant sigterm 15) ; #xf -(defconstant sigtrap 5) ; #x5 -(defconstant sigtstp 18) ; #x12 -(defconstant sigttin 21) ; #x15 -(defconstant sigttou 22) ; #x16 -(defconstant sigurg 16) ; #x10 -(defconstant sigusr1 30) ; #x1e -(defconstant sigusr2 31) ; #x1f -(defconstant sigvtalrm 26) ; #x1a -(defconstant sigwinch 28) ; #x1c -(defconstant sigxcpu 24) ; #x18 -(defconstant sigxfsz 25) ; #x19 -(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 64)) - (tv-usec (signed 64)))) -(define-alien-type nil - (struct timespec - (tv-sec (signed 64)) - (tv-nsec (signed 64)))) - -(in-package "SB-KERNEL") - -;;; Our runtime types -(define-alien-type os-vm-size-t (unsigned 64)) diff -Nru sbcl-2.0.6/crossbuild-runner/backends/arm/stuff-groveled-from-headers.lisp sbcl-2.1.1/crossbuild-runner/backends/arm/stuff-groveled-from-headers.lisp --- sbcl-2.0.6/crossbuild-runner/backends/arm/stuff-groveled-from-headers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/arm/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -7,6 +7,7 @@ (defconstant rtld-lazy 1) ; #x1 (defconstant rtld-now 2) ; #x2 (defconstant rtld-global 256) ; #x100 + (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 40) ; #x28 -(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 21519) ; #x540f ;;; signals +(defconstant sizeof-sigset_t 128) ; #x80 +(defconstant sig_block 0) ; #x0 +(defconstant sig_unblock 1) ; #x1 +(defconstant sig_setmask 2) ; #x2 (defconstant sigalrm 14) ; #xe (defconstant sigbus 7) ; #x7 (defconstant sigchld 17) ; #x11 @@ -130,6 +136,16 @@ (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-alarm 8) ; #x8 +(defconstant clock-realtime-coarse 5) ; #x5 +(defconstant clock-monotonic-coarse 6) ; #x6 +(defconstant clock-monotonic-raw 4) ; #x4 +(defconstant clock-boottime 7) ; #x7 +(defconstant clock-boottime-alarn 9) ; #x9 +(defconstant clock-thread-cputime-id 3) ; #x3 ;;; structures (define-alien-type nil (struct timeval diff -Nru sbcl-2.0.6/crossbuild-runner/backends/arm64/stuff-groveled-from-headers.lisp sbcl-2.1.1/crossbuild-runner/backends/arm64/stuff-groveled-from-headers.lisp --- sbcl-2.0.6/crossbuild-runner/backends/arm64/stuff-groveled-from-headers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/arm64/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -7,6 +7,7 @@ (defconstant rtld-lazy 1) ; #x1 (defconstant rtld-now 2) ; #x2 (defconstant rtld-global 256) ; #x100 + (in-package "SB-UNIX") ;;; select() @@ -19,8 +20,6 @@ (defconstant pollnval 32) ; #x20 (defconstant pollerr 8) ; #x8 (define-alien-type nfds-t (unsigned 64)) -;;; langinfo -(defconstant codeset 14) ; #xe ;;; types, types, types (define-alien-type clock-t (signed 64)) (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 64)) +(define-alien-type ssize-t (signed 64)) (define-alien-type time-t (signed 64)) (define-alien-type suseconds-t (signed 64)) (define-alien-type uid-t (unsigned 32)) @@ -79,11 +79,13 @@ (defconstant eio 5) ; #x5 (defconstant eexist 17) ; #x11 (defconstant eloop 40) ; #x28 -(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 @@ -91,6 +93,10 @@ (defconstant tiocgpgrp 21519) ; #x540f ;;; signals +(defconstant sizeof-sigset_t 128) ; #x80 +(defconstant sig_block 0) ; #x0 +(defconstant sig_unblock 1) ; #x1 +(defconstant sig_setmask 2) ; #x2 (defconstant sigalrm 14) ; #xe (defconstant sigbus 7) ; #x7 (defconstant sigchld 17) ; #x11 @@ -129,6 +135,16 @@ (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-alarm 8) ; #x8 +(defconstant clock-realtime-coarse 5) ; #x5 +(defconstant clock-monotonic-coarse 6) ; #x6 +(defconstant clock-monotonic-raw 4) ; #x4 +(defconstant clock-boottime 7) ; #x7 +(defconstant clock-boottime-alarn 9) ; #x9 +(defconstant clock-thread-cputime-id 3) ; #x3 ;;; structures (define-alien-type nil (struct timeval diff -Nru sbcl-2.0.6/crossbuild-runner/backends/ppc/stuff-groveled-from-headers.lisp sbcl-2.1.1/crossbuild-runner/backends/ppc/stuff-groveled-from-headers.lisp --- sbcl-2.0.6/crossbuild-runner/backends/ppc/stuff-groveled-from-headers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/ppc/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -7,6 +7,7 @@ (defconstant rtld-lazy 1) ; #x1 (defconstant rtld-now 2) ; #x2 (defconstant rtld-global 256) ; #x100 + (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 32)) (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)) @@ -79,11 +79,13 @@ (defconstant eio 5) ; #x5 (defconstant eexist 17) ; #x11 (defconstant eloop 40) ; #x28 -(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 @@ -91,6 +93,10 @@ (defconstant tiocgpgrp 1074033783) ; #x40047477 ;;; signals +(defconstant sizeof-sigset_t 128) ; #x80 +(defconstant sig_block 0) ; #x0 +(defconstant sig_unblock 1) ; #x1 +(defconstant sig_setmask 2) ; #x2 (defconstant sigalrm 14) ; #xe (defconstant sigbus 7) ; #x7 (defconstant sigchld 17) ; #x11 @@ -129,6 +135,17 @@ (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-alarm 8) ; #x8 +(defconstant clock-realtime-coarse 5) ; #x5 +(defconstant clock-tai 11) ; #xb +(defconstant clock-monotonic-coarse 6) ; #x6 +(defconstant clock-monotonic-raw 4) ; #x4 +(defconstant clock-boottime 7) ; #x7 +(defconstant clock-boottime-alarn 9) ; #x9 +(defconstant clock-thread-cputime-id 3) ; #x3 ;;; structures (define-alien-type nil (struct timeval diff -Nru sbcl-2.0.6/crossbuild-runner/backends/ppc64/local-target-features sbcl-2.1.1/crossbuild-runner/backends/ppc64/local-target-features --- sbcl-2.0.6/crossbuild-runner/backends/ppc64/local-target-features 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/ppc64/local-target-features 2021-01-30 11:22:38.000000000 +0000 @@ -1 +1 @@ -:64-bit :gencgc :big-endian :sb-thread +:gencgc :big-endian :sb-thread diff -Nru sbcl-2.0.6/crossbuild-runner/backends/ppc64/stuff-groveled-from-headers.lisp sbcl-2.1.1/crossbuild-runner/backends/ppc64/stuff-groveled-from-headers.lisp --- sbcl-2.0.6/crossbuild-runner/backends/ppc64/stuff-groveled-from-headers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/ppc64/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -7,6 +7,7 @@ (defconstant rtld-lazy 1) ; #x1 (defconstant rtld-now 2) ; #x2 (defconstant rtld-global 256) ; #x100 + (in-package "SB-UNIX") ;;; select() @@ -19,8 +20,6 @@ (defconstant pollnval 32) ; #x20 (defconstant pollerr 8) ; #x8 (define-alien-type nfds-t (unsigned 64)) -;;; langinfo -(defconstant codeset 14) ; #xe ;;; types, types, types (define-alien-type clock-t (signed 64)) (define-alien-type dev-t (unsigned 64)) @@ -80,8 +79,8 @@ (defconstant eio 5) ; #x5 (defconstant eexist 17) ; #x11 (defconstant eloop 40) ; #x28 -(defconstant espipe 29) ; #x1d (defconstant epipe 32) ; #x20 +(defconstant espipe 29) ; #x1d (defconstant ewouldblock 11) ; #xb (defconstant sc-nprocessors-onln 84) ; #x54 @@ -94,6 +93,10 @@ (defconstant tiocgpgrp 1074033783) ; #x40047477 ;;; signals +(defconstant sizeof-sigset_t 128) ; #x80 +(defconstant sig_block 0) ; #x0 +(defconstant sig_unblock 1) ; #x1 +(defconstant sig_setmask 2) ; #x2 (defconstant sigalrm 14) ; #xe (defconstant sigbus 7) ; #x7 (defconstant sigchld 17) ; #x11 @@ -132,6 +135,17 @@ (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-alarm 8) ; #x8 +(defconstant clock-realtime-coarse 5) ; #x5 +(defconstant clock-tai 11) ; #xb +(defconstant clock-monotonic-coarse 6) ; #x6 +(defconstant clock-monotonic-raw 4) ; #x4 +(defconstant clock-boottime 7) ; #x7 +(defconstant clock-boottime-alarn 9) ; #x9 +(defconstant clock-thread-cputime-id 3) ; #x3 ;;; structures (define-alien-type nil (struct timeval diff -Nru sbcl-2.0.6/crossbuild-runner/backends/riscv/stuff-groveled-from-headers.lisp sbcl-2.1.1/crossbuild-runner/backends/riscv/stuff-groveled-from-headers.lisp --- sbcl-2.0.6/crossbuild-runner/backends/riscv/stuff-groveled-from-headers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/riscv/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -7,6 +7,7 @@ (defconstant rtld-lazy 1) ; #x1 (defconstant rtld-now 2) ; #x2 (defconstant rtld-global 256) ; #x100 + (in-package "SB-UNIX") ;;; select() @@ -19,8 +20,6 @@ (defconstant pollnval 32) ; #x20 (defconstant pollerr 8) ; #x8 (define-alien-type nfds-t (unsigned 64)) -;;; langinfo -(defconstant codeset 14) ; #xe ;;; types, types, types (define-alien-type clock-t (signed 64)) (define-alien-type dev-t (unsigned 64)) @@ -94,6 +93,10 @@ (defconstant tiocgpgrp 21519) ; #x540f ;;; signals +(defconstant sizeof-sigset_t 128) ; #x80 +(defconstant sig_block 0) ; #x0 +(defconstant sig_unblock 1) ; #x1 +(defconstant sig_setmask 2) ; #x2 (defconstant sigalrm 14) ; #xe (defconstant sigbus 7) ; #x7 (defconstant sigchld 17) ; #x11 @@ -132,6 +135,17 @@ (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-alarm 8) ; #x8 +(defconstant clock-realtime-coarse 5) ; #x5 +(defconstant clock-tai 11) ; #xb +(defconstant clock-monotonic-coarse 6) ; #x6 +(defconstant clock-monotonic-raw 4) ; #x4 +(defconstant clock-boottime 7) ; #x7 +(defconstant clock-boottime-alarn 9) ; #x9 +(defconstant clock-thread-cputime-id 3) ; #x3 ;;; structures (define-alien-type nil (struct timeval diff -Nru sbcl-2.0.6/crossbuild-runner/backends/x86/local-target-features sbcl-2.1.1/crossbuild-runner/backends/x86/local-target-features --- sbcl-2.0.6/crossbuild-runner/backends/x86/local-target-features 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/x86/local-target-features 2021-01-30 11:22:38.000000000 +0000 @@ -1 +1 @@ -:sb-thread :largefile :gencgc :little-endian +:largefile :gencgc :little-endian diff -Nru sbcl-2.0.6/crossbuild-runner/backends/x86/stuff-groveled-from-headers.lisp sbcl-2.1.1/crossbuild-runner/backends/x86/stuff-groveled-from-headers.lisp --- sbcl-2.0.6/crossbuild-runner/backends/x86/stuff-groveled-from-headers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/x86/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1,6 +1,22 @@ ;;;; This is an automatically generated file, please do not hand-edit it. ;;;; See the program "grovel-headers.c". +(in-package "SB-WIN32") + +(define-alien-type int-ptr (signed 32)) +(define-alien-type dword (signed 32)) +(define-alien-type bool (signed 32)) +(define-alien-type uint (unsigned 32)) +(define-alien-type ulong (unsigned 32)) + +(defconstant error_file_not_found 2) +(defconstant error_file_exists #x50) + +;; these are total fabrications +(defconstant max_path 1024) +(defconstant error-no-data 1) +(defconstant +exception-maximum-parameters+ 6) + (in-package "SB-ALIEN") ;;;flags for dlopen() @@ -92,6 +108,10 @@ (defconstant tiocgpgrp 21519) ; #x540f ;;; signals +(defconstant sizeof-sigset_t 128) ; #x80 +(defconstant sig_block 0) ; #x0 +(defconstant sig_unblock 1) ; #x1 +(defconstant sig_setmask 2) ; #x2 (defconstant sigalrm 14) ; #xe (defconstant sigbus 7) ; #x7 (defconstant sigchld 17) ; #x11 diff -Nru sbcl-2.0.6/crossbuild-runner/backends/x86-64/local-target-features sbcl-2.1.1/crossbuild-runner/backends/x86-64/local-target-features --- sbcl-2.0.6/crossbuild-runner/backends/x86-64/local-target-features 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/backends/x86-64/local-target-features 2021-01-30 11:22:38.000000000 +0000 @@ -1 +1 @@ -:win32 :avx2 :sb-safepoint :sb-thruption :sb-wtimer :sb-safepoint-strictly :sb-futex :64-bit :gencgc :sb-simd-pack :sb-simd-pack-256 :little-endian :sb-thread +:avx2 :gencgc :sb-simd-pack :sb-simd-pack-256 :little-endian diff -Nru sbcl-2.0.6/crossbuild-runner/build-all.sh sbcl-2.1.1/crossbuild-runner/build-all.sh --- sbcl-2.0.6/crossbuild-runner/build-all.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/crossbuild-runner/build-all.sh 2021-01-30 11:22:38.000000000 +0000 @@ -9,7 +9,7 @@ # or a host machine on which to run its native compiler. if [ -z "$*" ]; then - targets="alpha arm arm64 hppa mips ppc ppc64 riscv sparc x86 x86-64" + targets="arm arm64 mips ppc ppc64 riscv sparc x86 x86-64" else targets="$@" fi @@ -24,16 +24,15 @@ # 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 ":$arch" >> $ltf - # x86-64 is tested as if #+win32 - if [ $arch != "x86-64" ]; then - echo ':unix :linux :elf :sb-futex' >> $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 + else + echo ':unix :linux :elf' >> $ltf fi cat crossbuild-runner/backends/$arch/features >> $ltf cat crossbuild-runner/backends/$arch/local-target-features >> $ltf - case "$arch" in - alpha | hppa) ;; - *) echo ':linkage-table' >> $ltf - esac + echo ':linkage-table' >> $ltf echo ')))' >> $ltf cp -fv crossbuild-runner/backends/$arch/stuff-groveled-from-headers.lisp \ diff -Nru sbcl-2.0.6/debian/changelog sbcl-2.1.1/debian/changelog --- sbcl-2.0.6/debian/changelog 2020-07-12 08:18:34.000000000 +0000 +++ sbcl-2.1.1/debian/changelog 2021-02-03 20:37:00.000000000 +0000 @@ -1,3 +1,56 @@ +sbcl (2:2.1.1-2) unstable; urgency=medium + + * skip-stack-scan-precise-gencgc.patch: new patch from upstream, fixes + FTBFS on arm64 + + -- Sébastien Villemot Wed, 03 Feb 2021 21:37:00 +0100 + +sbcl (2:2.1.1-1) unstable; urgency=medium + + * New upstream release + + -- Sébastien Villemot Mon, 01 Feb 2021 21:23:49 +0100 + +sbcl (2:2.1.0-1) unstable; urgency=medium + + * New upstream release + * Remove --with-sb-linkable-runtime on kfreebsd-*, it is unsupported there + + -- Sébastien Villemot Sat, 02 Jan 2021 11:32:00 +0100 + +sbcl (2:2.0.11-2) unstable; urgency=medium + + * disable-fcb-threads-test.patch: new patch, disable a test that randomly + fails on at least i386 and arm64. + + -- Sébastien Villemot Wed, 09 Dec 2020 13:47:57 +0100 + +sbcl (2:2.0.11-1) unstable; urgency=medium + + * New upstream release + * Bump to S-V 4.5.1 + + -- Sébastien Villemot Sun, 29 Nov 2020 21:27:23 +0100 + +sbcl (2:2.0.10-1) unstable; urgency=medium + + * New upstream release + + -- Sébastien Villemot Tue, 27 Oct 2020 17:56:51 +0100 + +sbcl (2:2.0.9-1) unstable; urgency=low + + [ Sébastien Villemot ] + * New upstream release + * Remove --with-sb-pthread-futex on kfreebsd-*, this option no longer exists + * Add strace as a Build-Depends and an autopkgtest Depends, it is needed + by futex-wait test + + [ Debian Janitor ] + * Set upstream metadata fields: Repository. + + -- Sébastien Villemot Sat, 17 Oct 2020 19:43:29 +0200 + sbcl (2:2.0.6-2) unstable; urgency=medium * Update Breaks on cl-cffi, since autopkgtest for <= 1:0.21.0 will fail diff -Nru sbcl-2.0.6/debian/control sbcl-2.1.1/debian/control --- sbcl-2.0.6/debian/control 2020-07-12 08:17:04.000000000 +0000 +++ sbcl-2.1.1/debian/control 2020-11-29 20:27:04.000000000 +0000 @@ -21,8 +21,9 @@ cm-super-minimal, time, netbase, - ed -Standards-Version: 4.5.0 + ed, + strace [!kfreebsd-amd64 !kfreebsd-i386] +Standards-Version: 4.5.1 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 diff -Nru sbcl-2.0.6/debian/patches/armhf-is-not-v5.patch sbcl-2.1.1/debian/patches/armhf-is-not-v5.patch --- sbcl-2.0.6/debian/patches/armhf-is-not-v5.patch 2020-03-07 08:45:01.000000000 +0000 +++ sbcl-2.1.1/debian/patches/armhf-is-not-v5.patch 2020-10-27 16:55:59.000000000 +0000 @@ -15,6 +15,6 @@ -CFLAGS += -marm -march=armv5 +CFLAGS += -marm - NM = ./linux-nm ASSEM_SRC = arm-assem.S + ARCH_SRC = arm-arch.c diff -Nru sbcl-2.0.6/debian/patches/disable-fcb-threads-test.patch sbcl-2.1.1/debian/patches/disable-fcb-threads-test.patch --- sbcl-2.0.6/debian/patches/disable-fcb-threads-test.patch 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/debian/patches/disable-fcb-threads-test.patch 2020-12-09 12:46:44.000000000 +0000 @@ -0,0 +1,24 @@ +Description: Disable a test in fcb-threads.impure on all architectures + This test randomly fails on i386 and arm64: + https://buildd.debian.org/status/fetch.php?pkg=sbcl&arch=arm64&ver=2%3A2.0.10-1&stamp=1604935633&raw=0 + https://buildd.debian.org/status/fetch.php?pkg=sbcl&arch=i386&ver=2%3A2.0.11-1&stamp=1606727478&raw=0 + https://buildd.debian.org/status/fetch.php?pkg=sbcl&arch=i386&ver=2%3A2.0.11-1&stamp=1606722457&raw=0 + https://buildd.debian.org/status/fetch.php?pkg=sbcl&arch=i386&ver=2%3A2.0.11-1&stamp=1606686960&raw=0 + https://buildd.debian.org/status/fetch.php?pkg=sbcl&arch=i386&ver=2%3A2.0.11-1&stamp=1606686960&raw=0 +Author: Sébastien Villemot +Bug: https://bugs.launchpad.net/sbcl/+bug/1907252 +Last-Update: 2020-12-09 +--- +This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ +--- a/tests/fcb-threads.impure.lisp ++++ b/tests/fcb-threads.impure.lisp +@@ -142,7 +142,8 @@ + (setq *print-greetings-and-salutations* nil)) + + (with-test (:name :call-me-from-many-threads-and-gc +- :skipped-on (or :interpreter (and :x86 :win32))) ++ :skipped-on (or :interpreter (and :x86 :win32)) ++ :broken-on :sbcl) + ;; two trials, 5 threads, 40 calls each + (f 2 5 40 t) + ;; one trial, 10 threads, 10 calls diff -Nru sbcl-2.0.6/debian/patches/disable-timer-test.patch sbcl-2.1.1/debian/patches/disable-timer-test.patch --- sbcl-2.0.6/debian/patches/disable-timer-test.patch 2020-02-05 13:14:20.000000000 +0000 +++ sbcl-2.1.1/debian/patches/disable-timer-test.patch 2020-09-22 12:37:29.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 -@@ -287,7 +287,7 @@ +@@ -282,7 +282,7 @@ (with-test (:name (:timer :threaded-stress) :skipped-on (not :sb-thread) diff -Nru sbcl-2.0.6/debian/patches/kfreebsd-pthread-futex.patch sbcl-2.1.1/debian/patches/kfreebsd-pthread-futex.patch --- sbcl-2.0.6/debian/patches/kfreebsd-pthread-futex.patch 2020-05-31 16:39:51.000000000 +0000 +++ sbcl-2.1.1/debian/patches/kfreebsd-pthread-futex.patch 2020-12-09 12:40:17.000000000 +0000 @@ -15,25 +15,14 @@ + OS_LIBS += -lpthread + #OS_LIBS += -lthr endif ---- a/src/runtime/pthread-futex.c -+++ b/src/runtime/pthread-futex.c -@@ -261,7 +261,7 @@ again: - /* It's not possible to unwind frames across pthread_cond_wait(3). */ - for (;;) { - int i; -- sigset_t pendset; -+ sigset_t pendset, newset; - struct timespec abstime; - - ret = futex_relative_to_abs(&abstime, FUTEX_WAIT_NSEC); --- a/src/runtime/thread.c +++ b/src/runtime/thread.c -@@ -548,7 +548,7 @@ attach_os_thread(init_thread_data *scrib - stack_addr = (char*)pthread_get_stackaddr_np(os) - stack_size; - #else +@@ -668,7 +668,7 @@ static void attach_os_thread(init_thread + # else pthread_attr_t attr; --#if defined LISP_FEATURE_FREEBSD || defined LISP_FEATURE_DRAGONFLY -+#if (defined LISP_FEATURE_FREEBSD || defined LISP_FEATURE_DRAGONFLY) && !defined(__GLIBC__) - pthread_attr_get_np(os, &attr); - #else + pthread_attr_init(&attr); +-# if defined LISP_FEATURE_FREEBSD || defined LISP_FEATURE_DRAGONFLY ++# if (defined LISP_FEATURE_FREEBSD || defined LISP_FEATURE_DRAGONFLY) && !defined(__GLIBC__) + pthread_attr_get_np(th->os_thread, &attr); + # else int pthread_getattr_np(pthread_t, pthread_attr_t *); diff -Nru sbcl-2.0.6/debian/patches/series sbcl-2.1.1/debian/patches/series --- sbcl-2.0.6/debian/patches/series 2020-04-27 21:19:44.000000000 +0000 +++ sbcl-2.1.1/debian/patches/series 2021-02-03 20:34:45.000000000 +0000 @@ -4,3 +4,5 @@ armhf-is-not-v5.patch disable-timer-test.patch skip-some-autopkgtests.patch +disable-fcb-threads-test.patch +skip-stack-scan-precise-gencgc.patch diff -Nru sbcl-2.0.6/debian/patches/skip-stack-scan-precise-gencgc.patch sbcl-2.1.1/debian/patches/skip-stack-scan-precise-gencgc.patch --- sbcl-2.0.6/debian/patches/skip-stack-scan-precise-gencgc.patch 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/debian/patches/skip-stack-scan-precise-gencgc.patch 2021-02-03 20:36:39.000000000 +0000 @@ -0,0 +1,22 @@ +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.0.6/debian/rules sbcl-2.1.1/debian/rules --- sbcl-2.0.6/debian/rules 2020-06-13 14:50:21.000000000 +0000 +++ sbcl-2.1.1/debian/rules 2020-12-28 09:18:10.000000000 +0000 @@ -23,7 +23,7 @@ FEATURES := --fancy -ifneq (,$(filter amd64 i386, $(DEB_HOST_ARCH_CPU))) +ifneq (,$(filter amd64 i386, $(DEB_HOST_ARCH))) FEATURES += --with-sb-linkable-runtime endif diff -Nru sbcl-2.0.6/debian/tests/control sbcl-2.1.1/debian/tests/control --- sbcl-2.0.6/debian/tests/control 2020-01-28 13:32:36.000000000 +0000 +++ sbcl-2.1.1/debian/tests/control 2020-10-17 17:42:51.000000000 +0000 @@ -1,3 +1,3 @@ Test-Command: cd tests && env TEST_SBCL_HOME=/usr/lib/sbcl TEST_SBCL_RUNTIME=/usr/bin/sbcl TEST_SBCL_CORE=/usr/lib/sbcl/sbcl.core ASDF_OUTPUT_TRANSLATIONS="/:${AUTOPKGTEST_TMP}" ./run-tests.sh -Depends: sbcl, gcc, libc6-dev | libc-dev, ed +Depends: sbcl, gcc, libc6-dev | libc-dev, ed, strace Restrictions: allow-stderr diff -Nru sbcl-2.0.6/debian/upstream/metadata sbcl-2.1.1/debian/upstream/metadata --- sbcl-2.0.6/debian/upstream/metadata 2019-09-01 08:38:06.000000000 +0000 +++ sbcl-2.1.1/debian/upstream/metadata 2020-07-21 06:51:12.000000000 +0000 @@ -1 +1,2 @@ Archive: SourceForge +Repository: git://git.code.sf.net/p/sbcl/sbcl diff -Nru sbcl-2.0.6/doc/internals/string-types.texinfo sbcl-2.1.1/doc/internals/string-types.texinfo --- sbcl-2.0.6/doc/internals/string-types.texinfo 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/doc/internals/string-types.texinfo 2021-01-30 11:22:38.000000000 +0000 @@ -51,6 +51,7 @@ as two words: the first is the object header, with the appropriate widetag, and the second is the length field. No memory is needed for elements of these objects, as they can have none. +Such object are not strings though. Objects of type @code{simple-base-string} have the header word with widetag, then a word for the length, and after that a sequence of diff -Nru sbcl-2.0.6/doc/internals-notes/make-thread-bench sbcl-2.1.1/doc/internals-notes/make-thread-bench --- sbcl-2.0.6/doc/internals-notes/make-thread-bench 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/doc/internals-notes/make-thread-bench 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,143 @@ +(defglobal *counter* 0) +(declaim (fixnum *counter*)) + +;; how many threads to make, not all at once, of course +(defparameter howmany-threads 20000) + +(defun thread-lambda () + (atomic-incf *counter*)) + +(defun test1 (&optional (n howmany-threads)) + (setq *counter* 0) + (dotimes (i n) + (sb-thread:join-thread (sb-thread:make-thread #'thread-lambda))) + (assert (= *counter* n))) + +(defun test2 (&optional (n howmany-threads)) + (setq *counter* 0) + (let (prev-thread) + (dotimes (i n) + ;; while starting the new thread, join the previously made. + (let ((new-thread (sb-thread:make-thread #'thread-lambda))) + (when prev-thread + (sb-thread:join-thread prev-thread)) + (setq prev-thread new-thread))) + (sb-thread:join-thread prev-thread)) + (assert (= *counter* n))) + +(defun test3 (&optional (n howmany-threads)) + (setq *counter* 0) + ;; try making 10 at a time and waiting for those 10 before making more + (dotimes (i (/ n 10)) + (let ((threads)) + (dotimes (i 10) + (push (sb-thread:make-thread #'thread-lambda) threads)) + (dolist (thread threads) + (sb-thread:join-thread thread)))) + (assert (= *counter* n))) + +Without :pauseless-threadstart +------------------------------- + +$ perf stat ... --eval '(test1)' --quit + 6,435.72 msec task-clock:u # 1.103 CPUs utilized + 0 context-switches:u # 0.000 K/sec + 0 cpu-migrations:u # 0.000 K/sec + 219,735 page-faults:u # 0.034 M/sec + 1,484,016,696 cycles:u # 0.231 GHz + 17,008,247,359 stalled-cycles-frontend:u # 1146.10% frontend cycles idle + 525,232,002 instructions:u # 0.35 insn per cycle + # 32.38 stalled cycles per insn + 145,098,224 branches:u # 22.546 M/sec + 4,045,481 branch-misses:u # 2.79% of all branches + + 5.834005191 seconds time elapsed + 0.684522000 seconds user + 6.391622000 seconds sys + +$ perf stat ... --eval '(test2)' --quit + 6,383.26 msec task-clock:u # 1.182 CPUs utilized + 0 context-switches:u # 0.000 K/sec + 0 cpu-migrations:u # 0.000 K/sec + 220,625 page-faults:u # 0.035 M/sec + 1,435,852,231 cycles:u # 0.225 GHz + 16,839,228,290 stalled-cycles-frontend:u # 1172.77% frontend cycles idle + 524,776,029 instructions:u # 0.37 insn per cycle + # 32.09 stalled cycles per insn + 144,951,979 branches:u # 22.708 M/sec + 4,018,908 branch-misses:u # 2.77% of all branches + + 5.401308431 seconds time elapsed + 0.773771000 seconds user + 6.235207000 seconds sys + +$ perf stat ... --eval '(test3)' --quit + 7,813.04 msec task-clock:u # 1.133 CPUs utilized + 0 context-switches:u # 0.000 K/sec + 0 cpu-migrations:u # 0.000 K/sec + 131,699 page-faults:u # 0.017 M/sec + 1,477,424,012 cycles:u # 0.189 GHz + 20,769,787,623 stalled-cycles-frontend:u # 1405.81% frontend cycles idle + 525,748,318 instructions:u # 0.36 insn per cycle + # 39.51 stalled cycles per insn + 145,134,345 branches:u # 18.576 M/sec + 4,412,369 branch-misses:u # 3.04% of all branches + + 6.894458409 seconds time elapsed + 0.641120000 seconds user + 7.864134000 seconds sys + +Conclusion: approximately 300 microseconds to start a thread + +With :pauseless-threadstart +---------------------------- + +$ perf stat ... --eval '(test1)' --quit + 1,541.91 msec task-clock:u # 1.068 CPUs utilized + 0 context-switches:u # 0.000 K/sec + 0 cpu-migrations:u # 0.000 K/sec + 633 page-faults:u # 0.411 K/sec + 801,317,853 cycles:u # 0.520 GHz + 3,751,130,586 stalled-cycles-frontend:u # 468.12% frontend cycles idle + 352,170,311 instructions:u # 0.44 insn per cycle + # 10.65 stalled cycles per insn + 81,884,155 branches:u # 53.106 M/sec + 1,334,916 branch-misses:u # 1.63% of all branches + + 1.443664147 seconds time elapsed + 0.425407000 seconds user + 1.471034000 seconds sys + +$ perf stat ... --eval '(test2)' --quit + 1,249.01 msec task-clock:u # 1.550 CPUs utilized + 0 context-switches:u # 0.000 K/sec + 0 cpu-migrations:u # 0.000 K/sec + 573 page-faults:u # 0.459 K/sec + 668,480,325 cycles:u # 0.535 GHz + 3,086,418,550 stalled-cycles-frontend:u # 461.71% frontend cycles idle + 376,966,208 instructions:u # 0.56 insn per cycle + # 8.19 stalled cycles per insn + 95,790,671 branches:u # 76.694 M/sec + 918,120 branch-misses:u # 0.96% of all branches + + 0.805563424 seconds time elapsed + 0.325539000 seconds user + 1.162641000 seconds sys + +$ perf stat ... --eval '(test3)' --quit + 1,308.09 msec task-clock:u # 1.455 CPUs utilized + 0 context-switches:u # 0.000 K/sec + 0 cpu-migrations:u # 0.000 K/sec + 4,838 page-faults:u # 0.004 M/sec + 660,514,151 cycles:u # 0.505 GHz + 3,230,465,234 stalled-cycles-frontend:u # 489.08% frontend cycles idle + 364,307,811 instructions:u # 0.55 insn per cycle + # 8.87 stalled cycles per insn + 92,966,084 branches:u # 71.070 M/sec + 730,714 branch-misses:u # 0.79% of all branches + + 0.899161220 seconds time elapsed + 0.339090000 seconds user + 1.227741000 seconds sys + +Conclusion: 40 to 100 microseconds to start a thread diff -Nru sbcl-2.0.6/doc/internals-notes/structure-typep-change sbcl-2.1.1/doc/internals-notes/structure-typep-change --- sbcl-2.0.6/doc/internals-notes/structure-typep-change 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/doc/internals-notes/structure-typep-change 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,123 @@ + +Design for new implementation of TYPEP on structure-objects: + +* Assign every layout a permanent stable ID using 29 bits + (N-POSITIVE-FIXNUM-BITS for 32-bit words) and try to recycle the + unused IDs if layouts get GCd. + +* Embed all IDs of every type that a layout "is" directly in the layout. + A layout includes its own ID as the last element of the IS-A vector. + In contrast, the INHERITS vector did not include the structure itself + which always required picking off an exactly equal type as a special + case, and then also checking for type inheritance. + In the ID-based approach, (typep x 'THING) need not distinguish + between whether X is THING or a type descended from THING. + +* Reserve space for at least 6 IDs in the IS-A vector, which is 2 more + than the former ANCESTOR-n slots held. Additionally, the IS-A vector + can always holds _all_ the IDs, whereas the ANCESTOR-n slots did not, + and would fall back upon lookup in the INHERITS vector. + The IS-A vector is sized as required by the layout constructor. + Variable-length layouts are needed for the trailing bitmap anyway, + so it is no more trouble to further extend layouts with extra words. + Note that depth 0 is implicitly the ID of the type T, + and depth 1 is implicitly the ID of STRUCTURE-OBJECT, + so those are not stored in the ID vector. + +* The most common variant of the structure TYPEP test is changed from: + (OR (EQ THIS-LAYOUT EXPECT-LAYOUT) + (AND (> THIS-LAYOUT-DEPTH (LAYOUT-DEPTH EXPECT-LAYOUT)) + (EQ (SVREF INHERITS DEPTH) EXPECT-LAYOUT))) + to: + (EQ (NTH-ANCESTOR-ID) EXPECT-LAYOUT-ID) + which can usually execute safely without the depth check. + In case the depth of the type under test exceeds the mandatory minimum + length of the IS-A vector (6), then perform the depth test first + to avoid out-of-bounds indexing. + Lack of the depth check improves branch prediction rate. + +Test I: "perf stat" on make-host-1 +================================== +Old: + 30497.22 msec task-clock # 1.000 CPUs utilized + 162 context-switches # 0.005 K/sec + 0 cpu-migrations # 0.000 K/sec + 358179 page-faults # 0.012 M/sec + 85176684440 cycles # 2.793 GHz + 49191173035 stalled-cycles-frontend # 57.75% frontend cycles idle + 84764154618 instructions # 1.00 insn per cycle + # 0.58 stalled cycles per insn + 19746929213 branches # 647.499 M/sec + 607098366 branch-misses # 3.07% of all branches + + 30.503523458 seconds time elapsed + + 29.206010000 seconds user + 1.291911000 seconds sys + +New: + 28308.70 msec task-clock # 0.999 CPUs utilized + 521 context-switches # 0.018 K/sec + 3 cpu-migrations # 0.000 K/sec + 428089 page-faults # 0.015 M/sec + 79067487625 cycles # 2.793 GHz + 45445183758 stalled-cycles-frontend # 57.48% frontend cycles idle + 80724429510 instructions # 1.02 insn per cycle + # 0.56 stalled cycles per insn + 18319117558 branches # 647.120 M/sec + 552061322 branch-misses # 3.01% of all branches + + 28.324995675 seconds time elapsed + + 26.775357000 seconds user + 1.555962000 seconds sys + +delta: task-clock: -7.1% + cycles: -7.1% + intructions: -4.7% + branches: -7.2% + branch-miss: -9.0% + user sec: -8.3% + +Test II: "perf stat" on make-host-2 +=================================== +Old: + 87641.99 msec task-clock # 1.000 CPUs utilized + 403 context-switches # 0.005 K/sec + 0 cpu-migrations # 0.000 K/sec + 858614 page-faults # 0.010 M/sec + 244791150476 cycles # 2.793 GHz + 138448804561 stalled-cycles-frontend # 56.56% frontend cycles idle + 258526783085 instructions # 1.06 insn per cycle + # 0.54 stalled cycles per insn + 58641402544 branches # 669.102 M/sec + 1387692425 branch-misses # 2.37% of all branches + + 87.659365156 seconds time elapsed + + 84.883404000 seconds user + 2.759720000 seconds sys + +New: + 83026.56 msec task-clock # 1.000 CPUs utilized + 1244 context-switches # 0.015 K/sec + 7 cpu-migrations # 0.000 K/sec + 1119264 page-faults # 0.013 M/sec + 231835280270 cycles # 2.792 GHz + 129266360060 stalled-cycles-frontend # 55.76% frontend cycles idle + 254253852289 instructions # 1.10 insn per cycle + # 0.51 stalled cycles per insn + 56393384370 branches # 679.221 M/sec + 1281237117 branch-misses # 2.27% of all branches + + 83.048348272 seconds time elapsed + + 79.858200000 seconds user + 3.187928000 seconds sys + +delta: task-clock: -5.2% + cycles: -5.2% + intructions: -1.6% + branches: -3.8% + branch-miss: -7.6% + user sec: -5.9% diff -Nru sbcl-2.0.6/doc/manual/efficiency.texinfo sbcl-2.1.1/doc/manual/efficiency.texinfo --- sbcl-2.0.6/doc/manual/efficiency.texinfo 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/doc/manual/efficiency.texinfo 2021-01-30 11:22:38.000000000 +0000 @@ -262,8 +262,8 @@ As of SBCL 0.8.5 ``good'' functions are @code{+}, @code{-}; @code{logand}, @code{logior}, @code{logxor}, @code{lognot} and their combinations; and @code{ash} with the positive second -argument. ``Good'' widths are 32 on HPPA, MIPS, PPC, Sparc and x86 and -64 on Alpha. While it is possible to support smaller widths as well, +argument. ``Good'' widths are 32 on 32-bit CPUs and 64 on 64-bit CPUs. +While it is possible to support smaller widths as well, currently this is not implemented. @node Global and Always-Bound variables diff -Nru sbcl-2.0.6/doc/manual/intro.texinfo sbcl-2.1.1/doc/manual/intro.texinfo --- sbcl-2.0.6/doc/manual/intro.texinfo 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/doc/manual/intro.texinfo 2021-01-30 11:22:38.000000000 +0000 @@ -27,6 +27,29 @@ exceptions involve internal inconsistencies in the standard.) @xref{Reporting Bugs}. +@node Exceptions to ANSI Conformance +@comment node-name, next, previous, up +@subsection Exceptions + +@itemize + +@item +@findex @cl{prog2} +@code{prog2} returns the primary value of its second form, as +specified in the @strong{Arguments and Values} section of the +specification for that operator, not that of its first form, as +specified in the @strong{Description}. + +@item +@tindex @cl{string} +@tindex @cl{character} +@tindex @cl{nil} +The @code{string} type is considered to be the union of all types +@code{(array @emph{c} (@emph{size}))} for all non-@code{nil} subtypes @code{@emph{c}} of +@code{character}, excluding arrays specialized to the empty type. + +@end itemize + @node Extensions @comment node-name, next, previous, up @section Extensions diff -Nru sbcl-2.0.6/doc/sbcl.1 sbcl-2.1.1/doc/sbcl.1 --- sbcl-2.0.6/doc/sbcl.1 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/doc/sbcl.1 2021-01-30 11:22:38.000000000 +0000 @@ -298,7 +298,7 @@ .SH SYSTEM REQUIREMENTS SBCL currently runs on X86 (Linux, FreeBSD, OpenBSD, and NetBSD), -X86-64 (Linux), Alpha (Linux, Tru64), PPC (Linux, Darwin/MacOS X), +X86-64 (Linux), PPC (Linux), SPARC (Linux and Solaris 2.x), and MIPS (Linux). For information on other ongoing and possible ports, see the sbcl\-devel mailing list, and/or the web site. diff -Nru sbcl-2.0.6/float-math.lisp-expr sbcl-2.1.1/float-math.lisp-expr --- sbcl-2.0.6/float-math.lisp-expr 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/float-math.lisp-expr 2021-01-30 11:22:38.000000000 +0000 @@ -4,6 +4,7 @@ ( (* (#x0 #.(MAKE-SINGLE-FLOAT #x-80000000)) #.(MAKE-SINGLE-FLOAT #x-80000000)) (* (#x0 #.(MAKE-SINGLE-FLOAT #x0)) #.(MAKE-SINGLE-FLOAT #x0)) +(* (#x0 #.(MAKE-SINGLE-FLOAT #x358637BD)) #.(MAKE-SINGLE-FLOAT #x0)) (* (#x0 #.(MAKE-SINGLE-FLOAT #x3A83126F)) #.(MAKE-SINGLE-FLOAT #x0)) (* (#x0 #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x0)) (* (#x0 #.(MAKE-SINGLE-FLOAT #x4E000000)) #.(MAKE-SINGLE-FLOAT #x0)) @@ -62,6 +63,7 @@ (* (#.(MAKE-SINGLE-FLOAT #x3F800000) #x1) #.(MAKE-SINGLE-FLOAT #x3F800000)) (* (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x-80000000)) #.(MAKE-SINGLE-FLOAT #x-80000000)) (* (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x0)) #.(MAKE-SINGLE-FLOAT #x0)) +(* (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x358637BD)) #.(MAKE-SINGLE-FLOAT #x358637BD)) (* (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3A83126F)) #.(MAKE-SINGLE-FLOAT #x3A83126F)) (* (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x3F800000)) (* (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) @@ -70,6 +72,8 @@ (* (#.(MAKE-SINGLE-FLOAT #x4E000000) #x0) #.(MAKE-SINGLE-FLOAT #x0)) (* (#.(MAKE-SINGLE-FLOAT #x4E000000) #.(MAKE-SINGLE-FLOAT #x40490FDB)) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) (* (#.(MAKE-SINGLE-FLOAT #x4E000000) #.(MAKE-SINGLE-FLOAT #x4E6E6B28)) #.(MAKE-SINGLE-FLOAT #x5CEE6B28)) +(* (#.(MAKE-SINGLE-FLOAT #x538637BD) #xF4240) #.(MAKE-SINGLE-FLOAT #x5D800000)) +(* (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x49742400)) #.(MAKE-SINGLE-FLOAT #x5D800000)) (* (#.(MAKE-SINGLE-FLOAT #x5883126F) #x3E8) #.(MAKE-SINGLE-FLOAT #x5D800000)) (* (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x447A0000)) #.(MAKE-SINGLE-FLOAT #x5D800000)) (* (#.(MAKE-SINGLE-FLOAT #x5D800000) #x0) #.(MAKE-SINGLE-FLOAT #x0)) @@ -116,6 +120,7 @@ (* (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (* (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) (* (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x800000) #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) +(* (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #xF4240) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFE627)) (* (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #x3E8) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFF8)) (* (#.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (* (#.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #.(MAKE-SINGLE-FLOAT #x4E6E6B28)) #.(MAKE-DOUBLE-FLOAT #x458DCD65 #x0)) @@ -128,10 +133,12 @@ (* (#.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x40100000 #x0)) #.(MAKE-DOUBLE-FLOAT #x5FEFFFFF #xFFFFFFFF)) (* (#.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF)) #.(MAKE-DOUBLE-FLOAT #x7FAFFFFF #xFFFFFFFE)) (+ (#x0 #.(MAKE-SINGLE-FLOAT #x-40804189)) #.(MAKE-SINGLE-FLOAT #x-40804189)) +(+ (#x0 #.(MAKE-SINGLE-FLOAT #x-40800011)) #.(MAKE-SINGLE-FLOAT #x-40800011)) (+ (#x0 #.(MAKE-SINGLE-FLOAT #x0)) #.(MAKE-SINGLE-FLOAT #x0)) (+ (#x0 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (+ (#x1 #.(MAKE-SINGLE-FLOAT #x0)) #.(MAKE-SINGLE-FLOAT #x3F800000)) (+ (#x1 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) +(+ (#x218DEF416BD #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) #.(MAKE-SINGLE-FLOAT #x540637BD)) (+ (#x83126E978D4FD #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) #.(MAKE-SINGLE-FLOAT #x5903126F)) (+ (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-31800000)) #.(MAKE-SINGLE-FLOAT #x-31400000)) (+ (#.(MAKE-SINGLE-FLOAT #x-31800000) #x1) #.(MAKE-SINGLE-FLOAT #x-31800000)) @@ -144,12 +151,14 @@ (+ (#.(MAKE-SINGLE-FLOAT #x0) #x1) #.(MAKE-SINGLE-FLOAT #x3F800000)) (+ (#.(MAKE-SINGLE-FLOAT #x0) #x3) #.(MAKE-SINGLE-FLOAT #x40400000)) (+ (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40804189)) #.(MAKE-SINGLE-FLOAT #x-40804189)) +(+ (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40800011)) #.(MAKE-SINGLE-FLOAT #x-40800011)) (+ (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x0)) #.(MAKE-SINGLE-FLOAT #x0)) (+ (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (+ (#.(MAKE-SINGLE-FLOAT #x3F800000) #x-1) #.(MAKE-SINGLE-FLOAT #x0)) (+ (#.(MAKE-SINGLE-FLOAT #x4E000000) #.(MAKE-SINGLE-FLOAT #x4E800000)) #.(MAKE-SINGLE-FLOAT #x4EC00000)) (+ (#.(MAKE-SINGLE-FLOAT #x4E800000) #x1) #.(MAKE-SINGLE-FLOAT #x4E800000)) (+ (#.(MAKE-SINGLE-FLOAT #x4E800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x4E800000)) +(+ (#.(MAKE-SINGLE-FLOAT #x540637BD) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) #.(MAKE-SINGLE-FLOAT #x540637BD)) (+ (#.(MAKE-SINGLE-FLOAT #x5903126F) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) #.(MAKE-SINGLE-FLOAT #x5903126F)) (+ (#.(MAKE-SINGLE-FLOAT #x5E000000) #x1) #.(MAKE-SINGLE-FLOAT #x5E000000)) (+ (#.(MAKE-SINGLE-FLOAT #x5E000000) #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x5E000000)) @@ -189,6 +198,8 @@ (- (#.(MAKE-SINGLE-FLOAT #x-40800000)) #.(MAKE-SINGLE-FLOAT #x3F800000)) (- (#.(MAKE-SINGLE-FLOAT #x-3FB6F025)) #.(MAKE-SINGLE-FLOAT #x40490FDB)) (- (#.(MAKE-SINGLE-FLOAT #x-368C1A80)) #.(MAKE-SINGLE-FLOAT #x4973E580)) +(- (#.(MAKE-SINGLE-FLOAT #x-368BDC10)) #.(MAKE-SINGLE-FLOAT #x497423F0)) +(- (#.(MAKE-SINGLE-FLOAT #x-34800000)) #.(MAKE-SINGLE-FLOAT #x4B800000)) (- (#.(MAKE-SINGLE-FLOAT #x-32000000)) #.(MAKE-SINGLE-FLOAT #x4E000000)) (- (#.(MAKE-SINGLE-FLOAT #x-31800000)) #.(MAKE-SINGLE-FLOAT #x4E800000)) (- (#.(MAKE-SINGLE-FLOAT #x-31400000)) #.(MAKE-SINGLE-FLOAT #x4EC00000)) @@ -204,7 +215,9 @@ (- (#.(MAKE-SINGLE-FLOAT #x-800000)) #.(MAKE-SINGLE-FLOAT #x7F800000)) (- (#.(MAKE-SINGLE-FLOAT #x0)) #.(MAKE-SINGLE-FLOAT #x-80000000)) (- (#.(MAKE-SINGLE-FLOAT #x3F7FBE77)) #.(MAKE-SINGLE-FLOAT #x-40804189)) +(- (#.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) #.(MAKE-SINGLE-FLOAT #x-40800011)) (- (#.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x-40800000)) +(- (#.(MAKE-SINGLE-FLOAT #x4B800000)) #.(MAKE-SINGLE-FLOAT #x-34800000)) (- (#.(MAKE-SINGLE-FLOAT #x4E000000)) #.(MAKE-SINGLE-FLOAT #x-32000000)) (- (#.(MAKE-SINGLE-FLOAT #x4E6E6B28)) #.(MAKE-SINGLE-FLOAT #x-319194D8)) (- (#.(MAKE-SINGLE-FLOAT #x4EC00000)) #.(MAKE-SINGLE-FLOAT #x-31400000)) @@ -234,6 +247,7 @@ (- (#.(MAKE-DOUBLE-FLOAT #x-3E300001 #xFF800000)) #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000)) (- (#.(MAKE-DOUBLE-FLOAT #x-3E280001 #xFFC00000)) #.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFFC00000)) (- (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18)) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) +(- (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) #.(MAKE-DOUBLE-FLOAT #x43400000 #x0)) (- (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8)) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) (- (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) (- (#.(MAKE-DOUBLE-FLOAT #x-3C36DE05 #x54442D18)) #.(MAKE-DOUBLE-FLOAT #x43C921FB #x54442D18)) @@ -255,6 +269,7 @@ (- (#.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFFC00000)) #.(MAKE-DOUBLE-FLOAT #x-3E280001 #xFFC00000)) (- (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D)) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x537B1D3D)) (- (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18)) +(- (#.(MAKE-DOUBLE-FLOAT #x43400000 #x0)) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) (- (#.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) #.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8)) (- (#.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) (- (#.(MAKE-DOUBLE-FLOAT #x43C921FB #x54442D18)) #.(MAKE-DOUBLE-FLOAT #x-3C36DE05 #x54442D18)) @@ -327,10 +342,13 @@ (/ (#.(MAKE-SINGLE-FLOAT #x0) #x1) #.(MAKE-SINGLE-FLOAT #x0)) (/ (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x0)) (/ (#.(MAKE-SINGLE-FLOAT #x3F800000) #x3E8) #.(MAKE-SINGLE-FLOAT #x3A83126F)) +(/ (#.(MAKE-SINGLE-FLOAT #x3F800000) #xF4240) #.(MAKE-SINGLE-FLOAT #x358637BD)) (/ (#.(MAKE-SINGLE-FLOAT #x41600000) #x1) #.(MAKE-SINGLE-FLOAT #x41600000)) (/ (#.(MAKE-SINGLE-FLOAT #x41600000) #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x41600000)) (/ (#.(MAKE-SINGLE-FLOAT #x4973E580) #.(MAKE-SINGLE-FLOAT #x49742400)) #.(MAKE-SINGLE-FLOAT #x3F7FBE77)) (/ (#.(MAKE-SINGLE-FLOAT #x497423F0) #.(MAKE-SINGLE-FLOAT #x49742400)) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) +(/ (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #x1) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) +(/ (#.(MAKE-SINGLE-FLOAT #x4B800000) #x1) #.(MAKE-SINGLE-FLOAT #x4B800000)) (/ (#.(MAKE-SINGLE-FLOAT #x4B800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) #.(MAKE-SINGLE-FLOAT #x4D800000)) (/ (#.(MAKE-SINGLE-FLOAT #x4D800000) #x1) #.(MAKE-SINGLE-FLOAT #x4D800000)) (/ (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #x1) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) @@ -360,6 +378,8 @@ (/ (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #x1) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) (/ (#.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFF800000) #x1) #.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFF800000)) (/ (#.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFFC00000) #x1) #.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFFC00000)) +(/ (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #x1) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) +(/ (#.(MAKE-DOUBLE-FLOAT #x43400000 #x0) #x1) #.(MAKE-DOUBLE-FLOAT #x43400000 #x0)) (/ (#.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8) #x1) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) (/ (#.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #x1) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) (/ (#.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #x1) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) @@ -378,12 +398,15 @@ (< (#x-1000000000000001 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x-1000000000000000 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x-1000000000000000 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) +(< (#x-20000000000001 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x-80000000 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x-80000000 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x-20000001 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x-20000001 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x-20000000 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x-20000000 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) +(< (#x-1000001 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) +(< (#x-F423F #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x-F3E58 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x-433 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x-432 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) @@ -402,6 +425,7 @@ (< (#x0 #.(MAKE-SINGLE-FLOAT #x-20B6F025)) NIL) (< (#x0 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x0 #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(< (#x0 #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) T) (< (#x0 #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) T) (< (#x0 #.(MAKE-SINGLE-FLOAT #x4E000000)) T) (< (#x0 #.(MAKE-SINGLE-FLOAT #x4EC00000)) T) @@ -427,6 +451,7 @@ (< (#x0 #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) T) (< (#x0 #.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFF800000)) T) (< (#x0 #.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D)) T) +(< (#x0 #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) T) (< (#x0 #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) T) (< (#x0 #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) T) (< (#x0 #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) T) @@ -439,12 +464,14 @@ (< (#x1/2 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x1/2 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x1 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) +(< (#x1 #.(MAKE-SINGLE-FLOAT #x0)) NIL) (< (#x1 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x2 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x2 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#xE #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x35 #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x3E8 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) +(< (#xF4240 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x1FFFFFFF #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#x20000000 #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) @@ -474,11 +501,14 @@ (< (#.(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-40800011) #.(MAKE-SINGLE-FLOAT #x0)) T) (< (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x0)) T) (< (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) (< (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x-34800000) #x0) T) +(< (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x-34800000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x-32000000) #x0) T) (< (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-32000000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x4E000000)) T) @@ -516,6 +546,7 @@ (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3D800000)) T) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4E000000)) T) +(< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x538637BD)) T) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5883126F)) T) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5D800000)) T) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5E800000)) T) @@ -538,6 +569,8 @@ (< (#.(MAKE-SINGLE-FLOAT #x40490FDB) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) T) (< (#.(MAKE-SINGLE-FLOAT #x40490FDB) #.(MAKE-SINGLE-FLOAT #x5E490FDB)) T) (< (#.(MAKE-SINGLE-FLOAT #x40490FDB) #.(MAKE-SINGLE-FLOAT #x5F490FDB)) T) +(< (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x-34800000)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x4E000000) #x0) NIL) (< (#.(MAKE-SINGLE-FLOAT #x4E000000) #.(MAKE-SINGLE-FLOAT #x-32000000)) NIL) @@ -547,6 +580,9 @@ (< (#.(MAKE-SINGLE-FLOAT #x4E800000) #.(MAKE-SINGLE-FLOAT #x3F000000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x4E800000) #.(MAKE-SINGLE-FLOAT #x4E800000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x538637BD)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x540637BD) #.(MAKE-SINGLE-FLOAT #x540637BD)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x5883126F)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x5903126F) #.(MAKE-SINGLE-FLOAT #x5903126F)) NIL) @@ -579,6 +615,7 @@ (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x3E8) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #xF423F) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #xF4240) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1000000) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1FFFFFE1) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1FFFFFFB) NIL) @@ -586,6 +623,7 @@ (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x20000001) 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) @@ -631,6 +669,8 @@ (< (#.(MAKE-DOUBLE-FLOAT #x-3E280001 #xFFC00000) #x0) T) (< (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x537B1D3D) #x0) T) (< (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x537B1D3D)) T) +(< (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #x0) T) +(< (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #x0) T) (< (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-SINGLE-FLOAT #x0)) T) (< (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) @@ -663,6 +703,7 @@ (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-4006DE05 #x54442D18)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE6A09E #x667F3BCD)) T) +(< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) T) (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) T) (< (#.(MAKE-DOUBLE-FLOAT #x3FB99999 #x9999999A) #.(MAKE-DOUBLE-FLOAT #x3FB99999 #x9999999A)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0)) NIL) @@ -716,7 +757,9 @@ (< (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x43E00000 #x0)) T) (< (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x60000000) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x60000000)) NIL) +(< (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(< (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) NIL) @@ -764,6 +807,7 @@ (< (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #x7FFFFFFF) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #xFFFFFFFF) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #x1FFFFFFFFFFFFF) NIL) +(< (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #x20000000000000) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #xFFFFFFFFFFFFF81) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #xFFFFFFFFFFFFFFF) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #x1000000000000001) NIL) @@ -789,6 +833,7 @@ (<= (#x-1000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (<= (#x-20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (<= (#x-1 #.(MAKE-SINGLE-FLOAT #x0)) T) +(<= (#x0 #.(MAKE-SINGLE-FLOAT #x-34800000)) NIL) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x-32000000)) NIL) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x-31800000)) NIL) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x-31400000)) NIL) @@ -802,7 +847,9 @@ (<= (#x0 #.(MAKE-SINGLE-FLOAT #x-20B6F025)) NIL) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x-139194D8)) NIL) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x-129194D8)) NIL) +(<= (#x0 #.(MAKE-SINGLE-FLOAT #x0)) T) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x3F800000)) T) +(<= (#x0 #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) T) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) T) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x4E000000)) T) (<= (#x0 #.(MAKE-SINGLE-FLOAT #x4E800000)) T) @@ -826,6 +873,7 @@ (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3E280001 #xFFC00000)) NIL) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x537B1D3D)) NIL) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18)) NIL) +(<= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) NIL) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8)) NIL) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) NIL) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3C400000 #x0)) NIL) @@ -848,6 +896,7 @@ (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFF800000)) T) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D)) T) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) T) +(<= (#x0 #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) T) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) T) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) T) (<= (#x0 #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) T) @@ -865,9 +914,13 @@ (<= (#.(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 #x3F800000)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x4B800000)) 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) +(<= (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x0)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x540637BD)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x-40800000)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x0)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3DCCCCCD)) T) @@ -876,6 +929,9 @@ (<= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x5E490FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x5F490FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-3FB6F025) #.(MAKE-SINGLE-FLOAT #x40490FDB)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-34800000) #x0) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x-34800000)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-32000000) #x0) T) (<= (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-32000000)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) T) @@ -920,10 +976,12 @@ (<= (#.(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 #x0) #x1) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #x3FFFFFF7) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #x1FFFFFFFFFFFFFF7) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #x7FFFFFFFFFFFFFF7) 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) @@ -941,6 +999,8 @@ (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4E000000)) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4E800000)) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x538637BD)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x540637BD)) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5883126F)) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5903126F)) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5D800000)) T) @@ -970,8 +1030,13 @@ (<= (#.(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 #x3FC90FDB) #.(MAKE-SINGLE-FLOAT #x3FC90FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x40490FDB) #.(MAKE-SINGLE-FLOAT #x40490FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x447A0000) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x49742400) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #x0) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #x0) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) T) @@ -990,6 +1055,9 @@ (<= (#.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x3FC90FDB)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x40490FDB)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x538637BD)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x540637BD) #.(MAKE-SINGLE-FLOAT #x540637BD)) T) (<= (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x5883126F)) T) (<= (#.(MAKE-SINGLE-FLOAT #x5903126F) #.(MAKE-SINGLE-FLOAT #x5903126F)) T) @@ -1035,6 +1103,7 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x43400000 #x0)) 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) @@ -1096,6 +1165,9 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x60000000) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x60000000)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #x0) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #x0) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-SINGLE-FLOAT #x0)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) @@ -1272,8 +1344,12 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x60000000) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x60000000)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x41DFFFFF #xFFC00000) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) NIL) +(<= (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(<= (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #x0) NIL) +(<= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x4341C379 #x37E08000) #.(MAKE-DOUBLE-FLOAT #x40000000 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8) #x0) NIL) @@ -1332,9 +1408,11 @@ (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #x3E8 #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #xF3E58 #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #xF423F #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #xF4240 #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #x1FFFFFFF #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #x20000000 #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #xFFFFFFFF #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #x218DEF416BD #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #x83126E978D4FD #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #xFFFFFFFFFFFFFFF #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #x1000000000000000 #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) @@ -1343,11 +1421,14 @@ (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #xFFFFFFFFFFFFFFFF #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-3FB6F025) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-3D380000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-368C1A80) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-368BDC10) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-31800000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-31400000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) @@ -1366,6 +1447,7 @@ (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-800000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x3089705F) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x358637BD) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x3A83126F) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) @@ -1386,6 +1468,7 @@ (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x447A0000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x497423F0) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x49742400) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x4B800000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x4D800000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) @@ -1396,6 +1479,8 @@ (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x4F000000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x4F800000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x540637BD) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x5903126F) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x5CEE6B28) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) @@ -1427,6 +1512,7 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #x400 #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #x432 #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #x433 #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #xF4240 #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #x20000000 #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #xFFFFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) @@ -1466,6 +1552,7 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x60000000) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3E200000 #x0) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3C400000 #x0) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) @@ -1539,10 +1626,13 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x41DFFFFF #xFFC00000) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x41E00000 #x0) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x41EFFFFF #xFFE00000) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x43400000 #x0) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x4341C379 #x37E08000) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFE627) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFF8) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) @@ -1568,6 +1658,7 @@ (= (#x-20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x-1 #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#x0 #.(MAKE-SINGLE-FLOAT #x-80000000)) T) +(= (#x0 #.(MAKE-SINGLE-FLOAT #x-34800000)) NIL) (= (#x0 #.(MAKE-SINGLE-FLOAT #x-32000000)) NIL) (= (#x0 #.(MAKE-SINGLE-FLOAT #x-31800000)) NIL) (= (#x0 #.(MAKE-SINGLE-FLOAT #x-31400000)) NIL) @@ -1594,6 +1685,7 @@ (= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3E280001 #xFFC00000)) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x537B1D3D)) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18)) NIL) +(= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8)) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x-3C400000 #x0)) NIL) @@ -1630,6 +1722,7 @@ (= (#.(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) +(= (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x-34800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-32000000)) T) (= (#.(MAKE-SINGLE-FLOAT #x-3136F025) #.(MAKE-SINGLE-FLOAT #x-3136F025)) T) (= (#.(MAKE-SINGLE-FLOAT #x-22800000) #.(MAKE-SINGLE-FLOAT #x-22800000)) T) @@ -1638,6 +1731,7 @@ (= (#.(MAKE-SINGLE-FLOAT #x-20B6F025) #.(MAKE-SINGLE-FLOAT #x-20B6F025)) T) (= (#.(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) #x1FFFFFFFFFFFFFF7) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #x7FFFFFFFFFFFFFF7) NIL) @@ -1666,6 +1760,7 @@ (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) (= (#.(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) (= (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) T) (= (#.(MAKE-SINGLE-FLOAT #x4E000000) #x0) NIL) @@ -1674,6 +1769,8 @@ (= (#.(MAKE-SINGLE-FLOAT #x4E800000) #.(MAKE-SINGLE-FLOAT #x4E800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x-3136F025)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) T) +(= (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x538637BD)) T) (= (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x5883126F)) T) (= (#.(MAKE-SINGLE-FLOAT #x5D7FFFFF) #.(MAKE-SINGLE-FLOAT #x-22800000)) NIL) @@ -1704,6 +1801,7 @@ (= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x537B1D3D) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x537B1D3D) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3C36DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-3C36DE05 #x54442D18)) T) @@ -1780,8 +1878,11 @@ (= (#.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000) #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000)) T) (= (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) T) (= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) T) (= (#.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) T) (= (#.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #x0) NIL) @@ -1807,9 +1908,11 @@ (= (#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 #xFFFFFFFFFFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#x0 #x3FFFFFFFFFFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) +(= (#x0 #.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #x0) NIL) (= (#x0 #.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #x0) NIL) (= (#x0 #.(MAKE-SINGLE-FLOAT #x4E000000) #x0) NIL) (= (#x0 #.(MAKE-SINGLE-FLOAT #x4E800000) #x0) NIL) @@ -1839,6 +1942,7 @@ (= (#x0 #.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFF800000) #x0) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D) #x0) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18) #x0) NIL) +(= (#x0 #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #x0) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8) #x0) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #x0) NIL) (= (#x0 #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #x0) NIL) @@ -1853,6 +1957,8 @@ (= (#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-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) @@ -1894,7 +2000,9 @@ (= (#.(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 #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) (= (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x5883126F)) T) (= (#.(MAKE-SINGLE-FLOAT #x5D800000) #.(MAKE-SINGLE-FLOAT #x5D800000) #.(MAKE-SINGLE-FLOAT #x5D800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x5E800000)) T) @@ -1918,6 +2026,8 @@ (= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18) #x0 #x0) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x537B1D3D)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D)) NIL) +(= (#.(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-3C500000 #x0) #x0 #x0) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) T) @@ -1952,7 +2062,9 @@ (= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333) #.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333) #.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333)) T) (= (#.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) T) (= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) T) (= (#.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x43D00000 #x0) #.(MAKE-DOUBLE-FLOAT #x43D00000 #x0) #.(MAKE-DOUBLE-FLOAT #x43D00000 #x0)) T) (= (#.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x3F000000)) NIL) @@ -1997,6 +2109,7 @@ (> (#x0 #.(MAKE-SINGLE-FLOAT #x-20B6F025)) T) (> (#x0 #.(MAKE-SINGLE-FLOAT #x0)) NIL) (> (#x0 #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) +(> (#x0 #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) NIL) (> (#x0 #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) NIL) (> (#x0 #.(MAKE-SINGLE-FLOAT #x4E000000)) NIL) (> (#x0 #.(MAKE-SINGLE-FLOAT #x4EC00000)) NIL) @@ -2022,6 +2135,7 @@ (> (#x0 #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFF800000)) NIL) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D)) NIL) +(> (#x0 #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) NIL) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) NIL) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) NIL) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) NIL) @@ -2041,6 +2155,7 @@ (> (#x20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (> (#x20000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (> (#x3FFFFFF7 #.(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) (> (#xFFFFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) @@ -2069,6 +2184,9 @@ (> (#.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x-40804189)) NIL) (> (#.(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 #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) @@ -2082,6 +2200,10 @@ (> (#.(MAKE-SINGLE-FLOAT #x-3FB6F025) #.(MAKE-SINGLE-FLOAT #x-3FB6F025)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-3FB6F025) #.(MAKE-SINGLE-FLOAT #x40490FDB)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-368C1A80) #.(MAKE-SINGLE-FLOAT #x497423F0)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x-368BDC10) #.(MAKE-SINGLE-FLOAT #x497423F0)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x-34800000)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x4B800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-32000000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x4E000000)) NIL) @@ -2116,6 +2238,7 @@ (> (#.(MAKE-SINGLE-FLOAT #x-800000) #.(MAKE-SINGLE-FLOAT #x-800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #x-1) T) (> (#.(MAKE-SINGLE-FLOAT #x0) #x0) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x0) #x1) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) T) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-32000000)) T) @@ -2134,6 +2257,8 @@ (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x497423F0)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4E000000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4E800000)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x538637BD)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x540637BD)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5883126F)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5903126F)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5D800000)) NIL) @@ -2143,6 +2268,7 @@ (> (#.(MAKE-SINGLE-FLOAT #x3089705F) #.(MAKE-SINGLE-FLOAT #x3089705F)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x33000001) #.(MAKE-SINGLE-FLOAT #x33000001)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x33800001) #.(MAKE-SINGLE-FLOAT #x33800001)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x358637BD) #.(MAKE-SINGLE-FLOAT #x358637BD)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x3A83126F) #.(MAKE-SINGLE-FLOAT #x3A83126F)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x0)) T) (> (#.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL) @@ -2176,6 +2302,8 @@ (> (#.(MAKE-SINGLE-FLOAT #x42C80000) #.(MAKE-SINGLE-FLOAT #x42C80000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x447A0000) #.(MAKE-SINGLE-FLOAT #x447A0000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x49742400) #.(MAKE-SINGLE-FLOAT #x49742400)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x4B800000) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) T) (> (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x-32000000)) T) (> (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x4E000000) #x0) T) @@ -2187,6 +2315,8 @@ (> (#.(MAKE-SINGLE-FLOAT #x4EC90FDB) #x0) T) (> (#.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x4F000000) #.(MAKE-SINGLE-FLOAT #x4F800000)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x0)) T) +(> (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x538637BD)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x0)) T) (> (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x5883126F)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x5D7FFFFF) #.(MAKE-SINGLE-FLOAT #x-22800000)) T) @@ -2278,6 +2408,7 @@ (> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E300001 #xFF800000) #.(MAKE-DOUBLE-FLOAT #x-3E300001 #xFF800000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E300001 #xFF800000) #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000)) NIL) @@ -2292,6 +2423,9 @@ (> (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x60000000) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x60000000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x60000000) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x60000000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3E200000 #x0) #.(MAKE-DOUBLE-FLOAT #x41DFFFFF #xFFC00000)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x43400000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) @@ -2355,8 +2489,10 @@ (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFE627)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFF8)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x43D00000 #x0)) NIL) @@ -2427,15 +2563,22 @@ (> (#.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) T) (> (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) T) +(> (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x800000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x41CDCD65 #x0) #.(MAKE-DOUBLE-FLOAT #x41CDCD65 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0)) T) (> (#.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000) #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18) #x0) T) (> (#.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x537B1D3D)) T) (> (#.(MAKE-DOUBLE-FLOAT #x41E00000 #x0) #.(MAKE-DOUBLE-FLOAT #x41EFFFFF #xFFE00000)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) +(> (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (> (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x43400000 #x0) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) T) (> (#.(MAKE-DOUBLE-FLOAT #x4341C379 #x37E08000) #.(MAKE-DOUBLE-FLOAT #x4341C379 #x37E08000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) T) (> (#.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) NIL) @@ -2478,11 +2621,13 @@ (>= (#x0 #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x40490FDB)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x497423F0)) NIL) +(>= (#x0 #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x4E000000)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x4E6E6B28)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x4E800000)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x4EC00000)) NIL) +(>= (#x0 #.(MAKE-SINGLE-FLOAT #x540637BD)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x5903126F)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x5CEE6B28)) NIL) (>= (#x0 #.(MAKE-SINGLE-FLOAT #x5D7FFFFF)) NIL) @@ -2509,6 +2654,7 @@ (>= (#x0 #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (>= (#x0 #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000)) NIL) (>= (#x0 #.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFF800000)) NIL) +(>= (#x0 #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) NIL) (>= (#x0 #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) NIL) (>= (#x0 #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) NIL) (>= (#x0 #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) NIL) @@ -2545,16 +2691,20 @@ (>= (#x4000000000000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (>= (#.(MAKE-SINGLE-FLOAT #x-80000000) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x-40800000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x-34800000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) T) (>= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-40804189) #x0) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x-40804189)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x-40800011) #x0) NIL) +(>= (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x-40800011)) T) (>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #x0) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x-40800000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3DCCCCCD)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) +(>= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-4036F025)) T) (>= (#.(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) @@ -2562,6 +2712,11 @@ (>= (#.(MAKE-SINGLE-FLOAT #x-3FB6F025) #.(MAKE-SINGLE-FLOAT #x-3FB6F025)) T) (>= (#.(MAKE-SINGLE-FLOAT #x-3FB6F025) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-368C1A80) #x0) NIL) +(>= (#.(MAKE-SINGLE-FLOAT #x-368BDC10) #x0) NIL) +(>= (#.(MAKE-SINGLE-FLOAT #x-34800000) #x0) NIL) +(>= (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) +(>= (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x-34800000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-32000000) #x0) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-32000000)) T) @@ -2615,9 +2770,12 @@ (>= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x41600000)) NIL) +(>= (#.(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 #x3089705F) #x0) T) +(>= (#.(MAKE-SINGLE-FLOAT #x358637BD) #x0) T) +(>= (#.(MAKE-SINGLE-FLOAT #x358637BD) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x3A83126F) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x3A83126F) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x3D800000) #x0) T) @@ -2646,6 +2804,11 @@ (>= (#.(MAKE-SINGLE-FLOAT #x447A0000) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x447A0000) #.(MAKE-SINGLE-FLOAT #x40000000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x49742400) #x0) T) +(>= (#.(MAKE-SINGLE-FLOAT #x49742400) #.(MAKE-SINGLE-FLOAT #x40000000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x-34800000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x0)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) T) (>= (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x0)) T) (>= (#.(MAKE-SINGLE-FLOAT #x4E000000) #x0) T) @@ -2654,6 +2817,9 @@ (>= (#.(MAKE-SINGLE-FLOAT #x4E000000) #.(MAKE-SINGLE-FLOAT #x4E000000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x4E6E6B28) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x4E6E6B28) #.(MAKE-SINGLE-FLOAT #x40000000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x0)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x538637BD)) T) (>= (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x0)) T) (>= (#.(MAKE-SINGLE-FLOAT #x5883126F) #.(MAKE-SINGLE-FLOAT #x5883126F)) T) @@ -2669,6 +2835,7 @@ (>= (#.(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) +(>= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) NIL) @@ -2732,6 +2899,7 @@ (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x800000)) NIL) +(>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) NIL) @@ -2743,6 +2911,10 @@ (>= (#.(MAKE-DOUBLE-FLOAT #x-3E280001 #xFFC00000) #x0) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x60000000) #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x60000000)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #x0) NIL) +(>= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) +(>= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #x0) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #x0) NIL) @@ -2807,6 +2979,7 @@ (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x40000000 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x40080000 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x404A8000 #x0)) NIL) +(>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x1FFFFF #xFFFFFFFE) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x1FFFFF #xFFFFFFFE) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) @@ -2888,13 +3061,22 @@ (>= (#.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #x0) T) (>= (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3E200000 #x0)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x0) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x800000) #x0) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x41C00000 #x800000) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x800000)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x41CDCD65 #x0) #x0) T) (>= (#.(MAKE-DOUBLE-FLOAT #x41CDCD65 #x0) #.(MAKE-DOUBLE-FLOAT #x40000000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x41D00000 #x400000) #.(MAKE-DOUBLE-FLOAT #x41D00000 #x0)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x4341C379 #x37E08000) #x0) T) (>= (#.(MAKE-DOUBLE-FLOAT #x4341C379 #x37E08000) #.(MAKE-DOUBLE-FLOAT #x40000000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #x0) T) @@ -2921,6 +3103,7 @@ (ABS #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) (ABS #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) (ATAN (#.(MAKE-DOUBLE-FLOAT #x20000000 #x1)) #.(MAKE-DOUBLE-FLOAT #x20000000 #x1)) +(CEILING (#.(MAKE-SINGLE-FLOAT #x-34800000) #x1) &VALUES #x-1000000 #.(MAKE-SINGLE-FLOAT #x0)) (CEILING (#.(MAKE-SINGLE-FLOAT #x-32000000) #x1) &VALUES #x-20000000 #.(MAKE-SINGLE-FLOAT #x0)) (CEILING (#.(MAKE-SINGLE-FLOAT #x-319194D8) #x1) &VALUES #x-3B9ACA00 #.(MAKE-SINGLE-FLOAT #x0)) (CEILING (#.(MAKE-SINGLE-FLOAT #x-31400000) #x1) &VALUES #x-60000000 #.(MAKE-SINGLE-FLOAT #x0)) @@ -2936,6 +3119,7 @@ (CEILING (#.(MAKE-DOUBLE-FLOAT #x-3F72231A #x420F4374) #x1) &VALUES #x-3BB #.(MAKE-DOUBLE-FLOAT #x-401C66F8 #x3D0DD000)) (CEILING (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #x1) &VALUES #x-20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (CEILING (#.(MAKE-DOUBLE-FLOAT #x-3E280001 #xFFC00000) #x1) &VALUES #x-5FFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) +(CEILING (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #x1) &VALUES #x-20000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (CEILING (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #x1) &VALUES #x-773593FC4653600 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (CEILING (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #x1) &VALUES #x-1000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (CEILING (#.(MAKE-DOUBLE-FLOAT #x-3C300000 #x0) #x1) &VALUES #x-4000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) @@ -2952,12 +3136,15 @@ (COERCE (#x-1000000000000001 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x-22800000)) (COERCE (#x-1000000000000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) (COERCE (#x-1000000000000000 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x-22800000)) +(COERCE (#x-20000000000001 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) (COERCE (#x-80000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x-3E200000 #x0)) (COERCE (#x-80000000 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x-31000000)) (COERCE (#x-20000001 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x800000)) (COERCE (#x-20000001 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x-32000000)) (COERCE (#x-20000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) (COERCE (#x-20000000 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x-32000000)) +(COERCE (#x-1000001 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x-34800000)) +(COERCE (#x-F423F SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x-368BDC10)) (COERCE (#x-F3E58 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x-368C1A80)) (COERCE (#x-433 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x-3F6F3400 #x0)) (COERCE (#x-432 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x-3F6F3800 #x0)) @@ -2998,6 +3185,7 @@ (COERCE (#x3FF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x408FF800 #x0)) (COERCE (#x400 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40900000 #x0)) (COERCE (#xF423F SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x497423F0)) +(COERCE (#xF4240 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x49742400)) (COERCE (#x1000000 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4B800000)) (COERCE (#x1FFFFFE0 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xE0000000)) (COERCE (#x1FFFFFE1 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) @@ -3013,9 +3201,12 @@ (COERCE (#x80000000 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4F000000)) (COERCE (#xFFFFFFFF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41EFFFFF #xFFE00000)) (COERCE (#xFFFFFFFF SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4F800000)) +(COERCE (#x10C6F7A0B5E LONG-FLOAT) #.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000)) +(COERCE (#x218DEF416BD SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x540637BD)) (COERCE (#x4189374BC6A7E LONG-FLOAT) #.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8)) (COERCE (#x83126E978D4FD SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5903126F)) (COERCE (#x1FFFFFFFFFFFFF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) +(COERCE (#x20000000000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x43400000 #x0)) (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)) @@ -3065,6 +3256,7 @@ (COERCE (#.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18) SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x3FC90FDB)) (COERCE (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x40490FDB)) (COERCE (#.(MAKE-DOUBLE-FLOAT #x401C0000 #x0) SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x40E00000)) +(COERCE (#.(MAKE-DOUBLE-FLOAT #x4270C6F7 #xA0B5E000) SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x538637BD)) (COERCE (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5883126F)) (COSH (#.(MAKE-SINGLE-FLOAT #x0)) #.(MAKE-SINGLE-FLOAT #x3F800000)) (COSH (#.(MAKE-DOUBLE-FLOAT #x0 #x0)) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) @@ -3081,15 +3273,20 @@ (EXPT (#.(MAKE-DOUBLE-FLOAT #x40240000 #x0) #x3BB) #.(MAKE-DOUBLE-FLOAT #x7FF00000 #x0)) (FLOAT (#x0) #.(MAKE-SINGLE-FLOAT #x0)) (FLOAT (#x1) #.(MAKE-SINGLE-FLOAT #x3F800000)) +(FLOAT (#x-20000000000000 #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) +(FLOAT (#x-1000000 #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x-34800000)) (FLOAT (#x1/10 #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x3D800000)) (FLOAT (#x1 #.(MAKE-SINGLE-FLOAT #x-80000000)) #.(MAKE-SINGLE-FLOAT #x3F800000)) (FLOAT (#x1 #.(MAKE-SINGLE-FLOAT #x0)) #.(MAKE-SINGLE-FLOAT #x3F800000)) (FLOAT (#x1 #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) (FLOAT (#x1 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) (FLOAT (#x1 #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) +(FLOAT (#xFFFFFF #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) (FLOAT (#x1FFFFFFF #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x4E000000)) (FLOAT (#x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) +(FLOAT (#x10C6F7A0B5E #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x538637BD)) (FLOAT (#x4189374BC6A7E #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x5883126F)) +(FLOAT (#x1FFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) #.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF)) (FLOAT (#xFFFFFFFFFFFFFFF #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x5D800000)) (FLOAT (#xFFFFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) (FLOAT (#x3FFFFFFFFFFFFFFF #.(MAKE-SINGLE-FLOAT #x3F800000)) #.(MAKE-SINGLE-FLOAT #x5E800000)) @@ -3106,6 +3303,7 @@ (FLOOR (#.(MAKE-SINGLE-FLOAT #x-21800000) #x1) &VALUES #x-4000000000000000 #.(MAKE-SINGLE-FLOAT #x0)) (FLOOR (#.(MAKE-SINGLE-FLOAT #x0) #x1) &VALUES #x0 #.(MAKE-SINGLE-FLOAT #x0)) (FLOOR (#.(MAKE-SINGLE-FLOAT #x41600000) #x1) &VALUES #xE #.(MAKE-SINGLE-FLOAT #x0)) +(FLOOR (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #x1) &VALUES #xFFFFFF #.(MAKE-SINGLE-FLOAT #x0)) (FLOOR (#.(MAKE-SINGLE-FLOAT #x4D800000) #x1) &VALUES #x10000000 #.(MAKE-SINGLE-FLOAT #x0)) (FLOOR (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #x1) &VALUES #x1FFFFFE0 #.(MAKE-SINGLE-FLOAT #x0)) (FLOOR (#.(MAKE-SINGLE-FLOAT #x4E000000) #x1) &VALUES #x20000000 #.(MAKE-SINGLE-FLOAT #x0)) @@ -3129,6 +3327,7 @@ (FLOOR (#.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000) #x1) &VALUES #x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (FLOOR (#.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF) #x1) &VALUES #x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x3FEFFFFF #xE0000000)) (FLOOR (#.(MAKE-DOUBLE-FLOAT #x41D7FFFF #xFF800000) #x1) &VALUES #x5FFFFFFE #.(MAKE-DOUBLE-FLOAT #x0 #x0)) +(FLOOR (#.(MAKE-DOUBLE-FLOAT #x433FFFFF #xFFFFFFFF) #x1) &VALUES #x1FFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (FLOOR (#.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8) #x1) &VALUES #x773593FC4653600 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (FLOOR (#.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #x1) &VALUES #xFFFFFFFFFFFFF80 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) (FLOOR (#.(MAKE-DOUBLE-FLOAT #x43B00000 #x0) #x1) &VALUES #x1000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) diff -Nru sbcl-2.0.6/generate-version.sh sbcl-2.1.1/generate-version.sh --- sbcl-2.0.6/generate-version.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/generate-version.sh 2021-01-30 11:22:38.000000000 +0000 @@ -35,14 +35,7 @@ fi if [ -z "$SBCL_BUILDING_RELEASE_FROM" ] then - if [ "`git rev-list HEAD --not origin/master`" = '' ] - then - # If origin/master contains all the commits on current - # branch, use current head as the root instead. - version_root="$version_branchname" - else - version_root="origin/master" - fi + version_root=`git merge-base HEAD origin/master` else version_root="$SBCL_BUILDING_RELEASE_FROM" fi @@ -63,7 +56,7 @@ then version_dirty="" else - version_dirty="-dirty" + version_dirty="-WIP" fi # Now that we have all the pieces, put them together. cat >version.lisp-expr < customize-backend-subfeatures.lisp + - name: build - env: + 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' --arch=${{ matrix.arch }} - name: test diff -Nru sbcl-2.0.6/.github/workflows/windows.yml sbcl-2.1.1/.github/workflows/windows.yml --- sbcl-2.0.6/.github/workflows/windows.yml 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/.github/workflows/windows.yml 2021-01-30 11:22:38.000000000 +0000 @@ -12,12 +12,12 @@ - name: install host sbcl run: | cinst sbcl -source tools-for-build - echo "::add-path::/c/Program Files/Steel Bank Common Lisp/1.4.14" + echo "/c/Program Files/Steel Bank Common Lisp/1.4.14" | Out-File -Append $env:GITHUB_PATH - name: build env: SBCL_HOME: "/c/Program Files/Steel Bank Common Lisp/1.4.14" run: | - bash ./make.sh --xc-host='sbcl --dynamic-space-size 500MB --lose-on-corruption --disable-ldb --disable-debugger' + bash ./make.sh --xc-host='sbcl --lose-on-corruption --disable-ldb --disable-debugger' - name: make installer run: | bash ./make-windows-installer.sh diff -Nru sbcl-2.0.6/.gitignore sbcl-2.1.1/.gitignore --- sbcl-2.0.6/.gitignore 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/.gitignore 2021-01-30 11:22:38.000000000 +0000 @@ -27,7 +27,6 @@ src/runtime/sbcl.exe src/runtime/sbcl.h src/runtime/sbcl.mk -src/runtime/sbcl.nm src/runtime/shrinkwrap-sbcl* src/runtime/target-arch-os.h src/runtime/target-arch.h @@ -45,8 +44,6 @@ tools-for-build/grovel-headers tools-for-build/grovel-headers.exe tools-for-build/mmap-rwx -tools-for-build/os-provides-putwc-test -tools-for-build/os-provides-putwc-test.exe tools-for-build/where-is-mcontext contrib/*/test-passed contrib/*/test-output diff -Nru sbcl-2.0.6/make-config.sh sbcl-2.1.1/make-config.sh --- sbcl-2.0.6/make-config.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/make-config.sh 2021-01-30 11:22:38.000000000 +0000 @@ -305,9 +305,6 @@ CYGWIN* | WindowsNT | MINGW* | MSYS*) sbcl_os="win32" ;; - HP-UX) - sbcl_os="hpux" - ;; Haiku) sbcl_os="haiku" ;; @@ -363,7 +360,6 @@ i86pc) guessed_sbcl_arch=x86 ;; *x86_64) guessed_sbcl_arch=x86-64 ;; amd64) guessed_sbcl_arch=x86-64 ;; - [Aa]lpha) guessed_sbcl_arch=alpha ;; sparc*) guessed_sbcl_arch=sparc ;; sun*) guessed_sbcl_arch=sparc ;; *ppc) guessed_sbcl_arch=ppc ;; @@ -371,8 +367,6 @@ ppc64le) guessed_sbcl_arch=ppc64 ;; # is ok because there was never 32-bit LE Power*Macintosh) guessed_sbcl_arch=ppc ;; ibmnws) guessed_sbcl_arch=ppc ;; - parisc*) guessed_sbcl_arch=hppa ;; - 9000/800) guessed_sbcl_arch=hppa ;; mips*) guessed_sbcl_arch=mips ;; arm64) guessed_sbcl_arch=arm64 ;; *arm*) guessed_sbcl_arch=arm ;; @@ -397,6 +391,11 @@ guessed_sbcl_arch=x86-64 fi +# Under NetBSD, uname -m returns "evbarm" even if CPU is arm64. +if [ "$sbcl_os" = "netbsd" ] && [ `uname -p` = "aarch64" ]; then + guessed_sbcl_arch=arm64 +fi + echo //setting up CPU-architecture-dependent information if test -n "$SBCL_ARCH" then @@ -491,34 +490,26 @@ linux) printf ' :unix :linux :elf' >> $ltf case "$sbcl_arch" in - x86 | x86-64 | arm64) + arm64 | ppc64 | x86 | x86-64) printf ' :gcc-tls' >> $ltf esac + case "$sbcl_arch" in + arm | arm64 | ppc | ppc64 | x86 | x86-64) + printf ' :use-sys-mmap' >> $ltf + esac # If you add other platforms here, don't forget to edit # src/runtime/Config.foo-linux too. case "$sbcl_arch" in - mips | arm) + mips | arm | x86 | x86-64) printf ' :largefile' >> $ltf ;; - x86 | x86-64) - printf ' :sb-futex :largefile' >> $ltf - ;; - ppc | ppc64 | arm64 | riscv) - printf ' :sb-futex' >> $ltf - ;; esac link_or_copy Config.$sbcl_arch-linux Config link_or_copy $sbcl_arch-linux-os.h target-arch-os.h link_or_copy linux-os.h target-os.h ;; - hpux) - printf ' :unix :hpux :elf' >> $ltf - link_or_copy Config.$sbcl_arch-hpux Config - link_or_copy $sbcl_arch-hpux-os.h target-arch-os.h - link_or_copy hpux-os.h target-os.h - ;; haiku) printf ' :unix :haiku :elf :int4-breakpoints' >> $ltf link_or_copy Config.$sbcl_arch-haiku Config @@ -537,10 +528,6 @@ if [ $sbcl_os = "gnu-kfreebsd" ]; then printf ' :gnu-kfreebsd' >> $ltf fi - - if [ $sbcl_arch = "x86" ]; then - printf ' :restore-fs-segment-register-from-tls' >> $ltf - fi link_or_copy Config.$sbcl_arch-$sbcl_os Config ;; openbsd) @@ -564,7 +551,7 @@ darwin) printf ' :unix :bsd :darwin :mach-o' >> $ltf if [ $sbcl_arch = "x86" ]; then - printf ' :mach-exception-handler :restore-fs-segment-register-from-tls' >> $ltf + printf ' :mach-exception-handler' >> $ltf fi if [ $sbcl_arch = "x86-64" ]; then printf ' :mach-exception-handler' >> $ltf @@ -594,7 +581,6 @@ # Optional features -- We enable them by default, but the build # ought to work perfectly without them: # - printf ' :sb-futex' >> $ltf printf ' :sb-qshow' >> $ltf # # Required features -- Some of these used to be optional, but @@ -631,14 +617,6 @@ # (define-feature :c-stack-grows-downwards-not-upwards (features) # (member :x86 features)) -# KLUDGE: currently the x86 only works with the generational garbage -# collector (indicated by the presence of :GENCGC in *FEATURES*) and -# alpha, sparc and ppc with the stop'n'copy collector (indicated by -# the absence of :GENCGC in *FEATURES*). This isn't a great -# separation, but for now, rather than have :GENCGC in -# base-target-features.lisp-expr, we add it into local-target-features -# if we're building for x86. -- CSR, 2002-02-21 Then we do something -# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03 case "$sbcl_arch" in x86) if [ "$sbcl_os" = "win32" ]; then @@ -715,12 +693,7 @@ ;; esac -# There are only two architectures that don't have linkage tables, -# and they also don't run for half a dozen other reasons. -case "$sbcl_arch" in - alpha | hppa) ;; - *) printf ' :linkage-table' >> $ltf -esac +printf ' :linkage-table' >> $ltf # Use a little C program to try to guess the endianness. Ware # cross-compilers! diff -Nru sbcl-2.0.6/make-host-1.lisp sbcl-2.1.1/make-host-1.lisp --- sbcl-2.0.6/make-host-1.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/make-host-1.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -10,14 +10,6 @@ (format t "~&target ~S = ~S~%" sym val)))))) (in-package "SB-COLD") (progn - ;; Generating ldso-stubs should be driven by GNUmakefile, but that won't work - ;; because we generate it using Lisp code, and we don't presume the target - ;; to have a lisp implementation. So we generate it on the host by knowing - ;; something about which Config files depend on ldso-stubs. - (when (or (member :alpha sb-xc:*features*) - (member :hppa sb-xc:*features*)) - (let ((*readtable* *xc-readtable*)) (load "tools-for-build/ldso-stubs.lisp"))) - (setf *host-obj-prefix* "obj/from-host/") (load "src/cold/set-up-cold-packages.lisp") (load "src/cold/defun-load-or-cload-xcompiler.lisp") @@ -49,8 +41,7 @@ ;; that are known to build cleanly. (sb-int:simple-style-warning (lambda (c &aux (fc (simple-condition-format-control c))) - (when (and (feature-in-list-p '(:or :x86 :x86-64 :arm64) - :target) + (when (and (featurep '(:or :x86 :x86-64 :arm64)) in-summary (stringp fc) (search "undefined" fc)) @@ -160,12 +151,10 @@ #+ecl (proclaim '(optimize (safety 2) (debug 2))) (maybe-with-compilation-unit - (let ((*feature-evaluation-results* nil)) ;; If make-host-1 is parallelized, it will produce host fasls without loading ;; them. The host will have interpreted definitions of most everything, ;; which is OK because writing out the C headers is not compute-intensive. (load-or-cload-xcompiler #'host-cload-stem) - (write-feature-eval-results)) ;; propagate structure offset and other information to the C runtime ;; support code. (load "tools-for-build/corefile.lisp" :verbose nil) diff -Nru sbcl-2.0.6/make-host-2.lisp sbcl-2.1.1/make-host-2.lisp --- sbcl-2.0.6/make-host-2.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/make-host-2.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -25,15 +25,11 @@ functions types) (sb-xc:with-compilation-unit () - (let ((*feature-evaluation-results* nil)) - (load "src/cold/compile-cold-sbcl.lisp") - (sanity-check-feature-evaluation)) + (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* - (feature-in-list-p - '(:or :x86 :x86-64 :arm64) ; until all the rest are clean - :target)) + (featurep '(:or :x86 :x86-64 :arm64))) ; until all the rest are clean (setf fail t) (dolist (warning sb-c::*undefined-warnings*) (case (sb-c::undefined-warning-kind warning) @@ -42,10 +38,10 @@ (:function (setf functions t)))))) ;; Exit the compilation unit so that the summary is printed. Then complain. ;; win32 is not clean - (when (and fail (not (feature-in-list-p :win32 :target))) + (when (and fail (not (featurep :win32))) (cerror "Proceed anyway" "Undefined ~:[~;variables~] ~:[~;types~]~ - ~:[~;functions (incomplete SB-COLD::*UNDEFINED-FUN-WHITELIST*?)~]" + ~:[~;functions (incomplete SB-COLD::*UNDEFINED-FUN-ALLOWLIST*?)~]" variables types functions))) #-clisp ; DO-ALL-SYMBOLS seems to kill CLISP at random @@ -103,8 +99,7 @@ ;; As each platform's build becomes warning-free, ;; it should be added to the list here to prevent regresssions. (when (and likely-suspicious - (feature-in-list-p '(: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.0.6/make-target-1.sh sbcl-2.1.1/make-target-1.sh --- sbcl-2.0.6/make-target-1.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/make-target-1.sh 2021-01-30 11:22:38.000000000 +0000 @@ -43,7 +43,6 @@ # is its generation left enabled even for those builds. echo //building runtime system and symbol table file -# The clean is needed for Darwin's readonlyspace hack. $GNUMAKE -C src/runtime clean # $GNUMAKE -C src/runtime depend $GNUMAKE $SBCL_MAKE_JOBS -C src/runtime all diff -Nru sbcl-2.0.6/make-target-2-load.lisp sbcl-2.1.1/make-target-2-load.lisp --- sbcl-2.0.6/make-target-2-load.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/make-target-2-load.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -9,34 +9,48 @@ ;;; Remove symbols from CL:*FEATURES* that should not be exposed to users. (export 'sb-impl::+internal-features+ 'sb-impl) (let* ((non-target-features - '(;; :SB-AFTER-XC-CORE is essentially an option flag to make-host-2 + ;; + ;; FIXME: I suspect that this list should be changed to its inverse- + ;; features that _SHOULD_ go into SB-IMPL:+INTERNAL-FEATURES+ and + ;; comments about the reasoning behind each, rather than features to + ;; discard and reasons they're not needed. The default assumption should be + ;; to drop any build-time feature that lacks a rationale to preserve it. + ;; + ;; READ-FROM-STRING prevents making references to + ;; all these keywords from the source form itself. + (read-from-string " + (;; :SB-AFTER-XC-CORE is essentially an option flag to make-host-2 :SB-AFTER-XC-CORE ;; CONS-PROFILING sets the initial compiler policy which persists ;; into the default baseline policy. It has no relevance post-build ;; in as much as policy can be changed later arbitrarily. :CONS-PROFILING + ;; Used by nothing after compiling 'target-thread.lisp' or 'thread.c' + :SB-FUTEX :OS-THREAD-STACK + ;; These affect the BREAK instruction emitter, but the C code is able + ;; to handle anything, and post-build we don't care which it is. + :UD2-BREAKPOINTS :INT4-BREAKPOINTS ;; Uses of OS-PROVIDES-DLOPEN and -DLADDR are confined to src/code/foreign.lisp :OS-PROVIDES-DLOPEN :OS-PROVIDES-DLADDR ;; more-or-less confined to serve-event, except for a test which now ;; detects whether COMPUTE-POLLFDS is defined and therefore testable. :OS-PROVIDES-POLL - ;; The final batch of symbols is strictly for C. The prefix of - ;; "LISP_FEATURE_" on the corresponding #define is unfortunate. - :GCC-TLS - :RESTORE-FS-SEGMENT-REGISTER-FROM-TLS ; only for 'src/runtime/thread.h' - :OS-PROVIDES-BLKSIZE-T ; only for 'src/runtime/wrap.h' - :OS-PROVIDES-PUTWC)) ; only for 'src/runtime/backtrace.c' + ;; The final batch of symbols is strictly for C. The LISP_FEATURE_ + ;; prefix on the corresponding #define is unfortunate. + :GCC-TLS :USE-SYS-MMAP + :OS-PROVIDES-BLKSIZE-T)")) ; only for 'src/runtime/wrap.h' (public-features (cons sb-impl::!sbcl-architecture - '(:COMMON-LISP :SBCL :ANSI-CL :IEEE-FLOATING-POINT + (read-from-string " + (:COMMON-LISP :SBCL :ANSI-CL :IEEE-FLOATING-POINT :64-BIT ; choice of word size. 32-bit if absent :BIG-ENDIAN :LITTLE-ENDIAN ; endianness: pick one and only one :BSD :UNIX :LINUX :WIN32 :DARWIN :SUNOS :ANDROID ; OS: pick one or more - :FREEBSD :GNU-KFREEBSD :OPENBSD :NETBSD :DRAGONFLY :HAIKU :HPUX + :FREEBSD :GNU-KFREEBSD :OPENBSD :NETBSD :DRAGONFLY :HAIKU :MACH-O :ELF ; obj file format: pick zero or one ;; I would argue that this should not be exposed, - ;; but I would also anticipate blowblack from removing it. + ;; but I would also anticipate blowback from removing it. :CHENEYGC :GENCGC ; GC: pick one and only one ;; Can't use s-l-a-d :compression safely without it :SB-CORE-COMPRESSION @@ -56,7 +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. - :SB-FLUID :SB-DEVEL))) + :SB-FLUID :SB-DEVEL :SB-DEVEL-LOCK-PACKAGES)"))) (removable-features (append non-target-features public-features))) (defconstant sb-impl:+internal-features+ @@ -357,8 +371,28 @@ (sb-c::repack-xref :verbose 1)) (fmakunbound 'sb-c::repack-xref) -(progn - (load (merge-pathnames "src/code/shaketree" *load-pathname*)) +(load (merge-pathnames "src/code/shaketree" *load-pathname*)) +(defun asm-inst-p (symbol) + ;; Assembler instruction names can't be made external because to do so would + ;; conflict with common-lisp symbols. Notable examples are PUSH and POP. + ;; So other criteria must pertain to detecting the important symbols. + ;; And as we don't need to preserve Lisp macros but do need to retain + ;; assembler macro instructions, those merit special consideration. + ;; Additionally, a DEFUN may co-exist with an identically named macro + ;; instruction. (I'm not happy about it, but that's historical baggage). + ;; A macro instruction is recognizable to INST by a naming convention + ;; that is unused for anything else by way of being inconvenient to use - + ;; a symbol whose print name start with "M:" is a macro instruction. + (or (get symbol 'sb-disassem::instructions) + (let ((name (string symbol))) + (and (> (length name) 2) + (string= name "M:" :end1 2))))) +(let ((counts + (mapcar (lambda (x) + (list x + (sb-impl::package-external-symbol-count x) + (sb-impl::package-internal-symbol-count x))) + (sort (list-all-packages) #'string< :key 'package-name)))) (sb-impl::shake-packages ;; Development mode: retain all symbols with any system-related properties #+sb-devel @@ -377,7 +411,7 @@ sb-vm::map-stack-references sb-vm::thread-profile-data-slot sb-vm::thread-alloc-region-slot - sb-vm::primitive-object-size + sb-vm::reconstitute-object ;; need this for defining a vop which ;; tests the x86-64 allocation profiler sb-vm::pseudo-atomic @@ -390,12 +424,20 @@ #.(find-package "SB-ASSEM") #.(find-package "SB-DISASSEM") #.(find-package "SB-IMPL") + #.(find-package "SB-UNIX") #.(find-package "SB-PCL") #.(find-package "SB-MOP") #.(find-package "SB-PRETTY") #.(find-package "SB-KERNEL")) ;; Assume all and only external symbols must be retained (eq accessibility :external)) + (#.(find-package "SB-THREAD") + (or (eq accessibility :external) + ;; for some reason a recent change caused the tree-shaker to drop MAKE-SPINLOCK + ;; which makes sense. I'm not sure what was rooting the symbol. + ;; However the :spinlock-api test in threads.impure asserts that spinlock symbols + ;; exist despite being internal symbols. + (sb-int:info :function :deprecated symbol))) (#.(find-package "SB-FASL") ;; Retain +BACKEND-FASL-FILE-IMPLEMENTATION+ and +FASL-FILE-VERSION+ ;; (and anything else otherwise reachable) @@ -407,17 +449,38 @@ (member symbol '(sb-bignum:%allocate-bignum sb-bignum:make-small-bignum))) (t - ;; By default, retain any symbol with any attachments - (or (sb-kernel:symbol-info symbol) - (and (boundp symbol) (not (keywordp symbol))))))) + (if (eq (symbol-package symbol) + sb-assem::*backend-instruction-set-package*) + (or (eq accessibility :external) (asm-inst-p symbol)) + ;; By default, retain any symbol with any attachments + (or (sb-kernel:symbol-info symbol) + (and (boundp symbol) (not (keywordp symbol)))))))) :verbose nil :print nil) - (unintern 'sb-impl::shake-packages 'sb-impl)) + (unintern 'sb-impl::shake-packages 'sb-impl) + (let ((sum-delta-ext 0) + (sum-delta-int 0)) + (format t "~&~26TExternal | Internal~%") + (dolist (entry counts) + (let* ((ext (sb-impl::package-external-symbol-count (car entry))) + (int (sb-impl::package-internal-symbol-count (car entry))) + (delta-ext (- ext (cadr entry))) + (delta-int (- int (caddr entry)))) + (incf sum-delta-ext delta-ext) + (incf sum-delta-int delta-int) + (format t "~20a | ~5d (~5@d) | ~5d (~5@d)~%" + (package-name (car entry)) + ext delta-ext int delta-int))) + (format t "~28t (~5@d) | (~5@d) = (~d)~%" + sum-delta-ext sum-delta-int + (+ sum-delta-ext sum-delta-int)))) ;;; Use historical (stupid) behavior for storing pathname namestrings ;;; in fasls. (setq sb-c::*name-context-file-path-selector* 'truename) ;;; Lock internal packages +#-(and sb-devel + (not sb-devel-lock-packages)) (dolist (p (list-all-packages)) (unless (member p (mapcar #'find-package '("KEYWORD" "CL-USER"))) (sb-ext:lock-package p))) diff -Nru sbcl-2.0.6/NEWS sbcl-2.1.1/NEWS --- sbcl-2.0.6/NEWS 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/NEWS 2021-01-30 11:22:38.000000000 +0000 @@ -1,5 +1,227 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes in sbcl-2.1.1 relative to sbcl-2.1.0: + * platform support: + ** restore non-threaded NetBSD builds; + ** adjust how the finalizer thread is started; (lp#1906571, lp#1907872) + ** fix the encoding of PEXTR on x86-64; + * minor incompatible change: emit warnings for list iteration forms when the + 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. + (lp#1909659, reported by Michal Herda) + * bug fix: division by zero errors were in some cases not being signalled. + (lp#1910098, reported by il71) + * bug fix: erroneous coercions in the type system could lose precision. + (lp#1910294) + * bug fix: literal (read-time evaluated) NaNs in source code no longer cause + compiler crashes. (lp#1909881, reported by Michal Herda) + * bug fix: detect more erroneous syntax in method bodies. (lp#1912362, + reported by Paul M. Rodriguez) + * optimization: the compiler's understanding of EXPT is improved, reducing + the introduction of COMPLEX types. (lp#1908830, reported by Michael Fiano) + * optimization: the compiler is better at computing numeric contagion when + (COMPLEX FLOAT) types are involved. + * micro-optimizations: + ** moving from slightly-bigger-than-fixnum ranges is more efficient on x86-64; + ** encode character comparisons with smaller operands on x86-64; + ** truncating (and related operations) on floats can be inlined in more + cases on 64-bit platforms; + ** rounding can use specialized instructions on ARM64 and on x86-64 when + SSE4 is available; + +changes in sbcl-2.1.0 relative to sbcl-2.0.11: + * minor incompatible change: the MAKE-EA internal function, used in the + assembler, has been removed (affecting some libraries defining their own + Virtual Operations) + * new feature: SB-EXT:PRIMITIVE-OBJECT-SIZE can be used to interrogate the + low-level size in memory of objects. (lp#1636910, reported by anquegi) + * platform support: + ** pass required -std argument to the compiler on Solaris (lp#1885751, + thanks to Jesse Off) + ** better treatment of non-ASCII program arguments on Windows (lp#1907970, + reported by Timofei Shatrov) + ** implement the improved TYPEP with structure types on all other + supported platforms (32-bit PowerPC, ARM, ARM64, MIPS, SPARC, RISC-V) + * enhancement: stream dispatch (to vanilla ANSI / Gray / Simple variants) has + been rewritten and optimized, fixing a number of bugs including: + ** performance of WRITE-SEQUENCE on composite streams (lp#309136) + ** handling of CLOSE on SYNONYM-STREAM (lp#1904257, reported by Richard M + Kreuter) + ** handling of CLOSE on BROADCAST-STREAM with no components (lp#1904722, + reported by Richard M Kreuter) + ** loading SB-SIMPLE-STREAMS breaks functionality of other stream classes + (lp#1908132) + ** some excessive consing in READ-LINE + * enhancements related to RUN-PROGRAM: + ** improved the documentation related to the ARGS argument (lp#806733, + reported by mon_key) + ** added a PRESERVE-FDS argument + * bug fix: ensure that TYPE-OF returns something even on internal instances, + which may become visible in the debugger. (lp#1908261, reported by + Philipp Marek) + * bug fix: iteration variables established by standard forms should always + be considered used by the compiler. (lp#719585, reported by Roman + Marynchak) + * bug fix: don't allow compiler transformations to weaken the requirement + against extended (list-form) function names in FUNCALL and related + operators. (lp#310069) + * bug fix: improve automated version number generation in branches. + (lp#897867, thanks to Martin Cracauer) + * bug fix: add possibly-spurious futex wakes when unwinding from a call to + futex-wait, to avoid deadlocks from interrupted waits. (lp#1038034) + * bug fixes in the compiler: + ** error on malformed DESTRUCTURING-BIND (lp#1738638) + ** error on malformed SPECIAL declaration (lp#1740756) + ** error from use of VALUES type in COERCE (lp#1887712) + ** enforcement of FTYPE types involving &OPTIONAL (lp#1903932) + ** checking for proper-list-ness before applying transforms (lp#1905512) + ** compilation of LAMBDA form including a malformed DEFUN (lp#1906056) + ** memory fault from VALUES-related handling in high DEBUG code + (lp#1906563) + ** transforms handle explicit NIL arguments in :END arguments to SEARCH + (lp#1907924) + * bug fix: return COMPILED-FUNCTION for TYPE-OF on compiled functions. + (lp#1906583) + * some bugs were also closed in this release cycle as obsolete, having been + fixed by the passage of time or other change in the environment: + ** floating point error reporting on OS X (lp#309454) + ** load-shared-library not working from non-main threads on OS X (lp#592425) + * optimization: CONSTANTLY on constant arguments returns a more efficient + function. (lp#1852585) + * optimization: perform fewer Lisp/Alien representation conversions in + callbacks. + * optimization: perform fewer redundant widetag tests when doing type tests + of complicated union types. + * optimization: signed-integer division on machine-word sized operands is + now implemented using multiplication, affecting TRUNCATE, FLOOR, CEILING, + MOD and REM. (This optimization was already performed on unsigned-integer + division) + +changes in sbcl-2.0.11 relative to sbcl-2.0.10: + * minor incompatible change: (ARRAY NIL (*)) is not a subtype of STRING, + as is consistent with a majority of maintained CL implementations. + * minor incompatible change: ARRAY-RANK-LIMIT is decreased from 65529 to 256 + * optimization: TYPEP on structure types is faster and more compact on + x86[-64] and ppc64. + * optimization: LOGCOUNT is faster on arm64. + * optimization: SIGNUM can be inlined if its argument type is known. + (lp#1903533) + * bug fix: compiler crash in tail call handling. (lp#1903938) + * bug fix: crash in traceroot. (lp#1903419, reported by Michal Herda) + * bug fix: DESCRIBE called with a string as second argument no longer mutates + that string. (lp#1903901, reported by Michal Herda) + * bug fix: stack clobbering by 256-bit SIMD packs on x86-64. (lp#1901685, + reported by Marco Heisig) + +changes in sbcl-2.0.10 relative to sbcl-2.0.9: + * minor incompatible change: the funarg given to SB-SPROF:MAP-TRACES + does not receive a wallclock time with each trace. + * minor incompatible change: INTERNAL-TIME-UNITS-PER-SECOND has been + increased to 10^6 on 64-bit architectures. + * minor incompatible change: SIGPIPE is ignored by default again. (lp#1897624) + * minor incompatible change: the system code compiled under the + :LINKAGE-TABLE feature is now unconditionally compiled in, and the + corresponding entry in *FEATURES* has been removed. + * enhancement: style-warnings are issued for variables which have an + assignment but no "for-value reference" (per CLHS glossary entry) + * bug fix: SB-CLTL2:MACROEXPAND-ALL did not expand MULTIPLE-VALUE-BIND + and MULTIPLE-VALUE-SETQ + * bug fix: CPUID-based feature detection had an index/mask confusion + (lp#1899239) + * bug fix: fix a deadlock on Windows (lp#1896802) + * bug fix: eliminate type errors when wall clocks go back (lp#1028026, + lp#1032111) + * bug fix: fix EOF handling in read-char-no-hang on concatenenated streams + (lp#690408, reported by Willem Broekema) + * bug fix: fix MAP-INTO on extended sequences (lp#1855375, thanks to James + Kalenius) + * bug fix: SB-GMP can now raise -1, 0 and 1 to the power of a bignum. + (thanks to Aaron Chen) + * bug fixes in tests: + ** add a C function declaration (lp#1897627, thanks to Bob Felts) + ** parse vmmap output more liberally (lp#1897722, reported by Bob Felts) + +changes in sbcl-2.0.9 relative to sbcl-2.0.8: + * incompatible change: HPPA and DEC Alpha architecture + support has been removed. + * minor incompatible change: the compiler signals a warning at + compile-time when an initform of T, NIL or 0 does not match a + STANDARD-CLASS slot's declared type. + * minor incompatible change: the runtime no longer uses SIGPIPE internally, + so the signal is deliverable to user code as is customary. Ignoring the + signal - in lieu of the OS default of process termination - is obtainable + via (SB-SYS:ENABLE-INTERRUPT SB-UNIX:SIGPIPE :IGNORE). + * platform support: + ** a number of obsolete portability layers (particularly on the Windows + platform) have been removed in favour of direct calling of the native + interfaces. + ** RUN-PROGRAM now accepts a :WINDOW argument to control whether a + subprocess window should be displayed. (Thanks to Luis Borges de + Oliveira) + ** the use of futexes implied by :SB-FUTEX is now implemented on FreeBSD. + * bug fix: SB-SPROF can distinguish between SBCL-internal assembly routines. + * bug fix: SB-SPROF has better output in its reports for anonymous + functions. + * optimization: CALL-NEXT-METHOD with supplied arguments in required + positions is now faster if the supplied arguments are EQL to the original + arguments. + +changes in sbcl-2.0.8 relative to sbcl-2.0.7: + * platform support: + ** added support for NetBSD/ARM64; + ** threads on Linux now have OS-visible names; + ** removed unnecessary emulation of pthread functions on Windows; + ** work around a sigwait() bug on Mac OS X; + ** allow safepoint build on Mac OS X, though it probably doesn't + work very well (reported by Chris Wagner, lp#1382811) + ** removed stub support for HPUX. + * optimization: SB-THREAD:MAKE-THREAD is faster on most platforms. + * optimization: faster RATIONAL when the result is a RATIO. + * optimization: improved cross-type comparisons (float/ratio/bignum). + * bug fix: EQUALP on pathnames was wrong + * bug fixes: fix compiler issues in: + ** COUNT (lp#1889391) + ** VECTOR-LENGTH (lp#1888919) + ** constant-folding (lp#1888384) + ** FIND and POSITION (lp#1887316) + +changes in sbcl-2.0.7 relative to sbcl-2.0.6: + * minor incompatible change: SB-THREAD:THREAD-OS-TID returns NIL for + a thread which has exited. + * minor incompatible change: OPEN no longer calls TRUENAME implicitly + on a string filespec prior to issuing an open() system call. + * minor incompatible change: PATHNAME is no longer a STRUCTURE-OBJECT. + * documentation: HASH-FUNCTION is a function designator. (lp#1888028, + reported by Jacek Zlydach) + * bug fix: eliminated a potential garbage-collector deadlock + when linking with TCMalloc. + * bug fix: foreign threads (those not made by SB-THREAD:MAKE-THREAD) + can not crash with a "GC_PENDING, but why?" error when returning + back from Lisp into the foreign caller. + * bug fix: sb-fasteval crashed trying to install a JIT-compiled + DEFSTRUCT accessor in a locked package. + * bug fix: removed misuse of putwc() which caused stdio streams + to drop characters. + * bug fix: the "maximum interrupt nesting depth exceeded" error + generated in the C runtime is significantly less likely to occur. + * bug fix: sb-sprof should no longer segfault from calling pthread_kill() + on a nonexistent thread. + * bug fix: a portability issue arising from various build hosts + (lp#1886255, reported by Pierre Neidhardt) + * bug fix: spurious compiler warnings from REDUCE with :INITIAL-VALUE. + (lp#1885515, reported by Michael South) + * bug fix: an inconsistency between class hierarchies and the type system + under some circumstances involving redefinition. (lp#1886397, reported by + Atilla Lendvai) + * bug fix: the USE-VALUE restart for OPEN on non-existent files is more + likely to function as expected. (lp#1886587) + * bug fix: various invalid inputs to ROTATE-BYTE no longer cause compiler + errors. (lp#1887164, lp#1888152) + * optimization: PPC64 on linux uses the __thread annotation on C variables + in preference to pthread_setspecific() and pthread_getspecific(). + changes in sbcl-2.0.6 relative to sbcl-2.0.5: * planned incompatible change: the defined symbols in the Metaobject Protocol, currently accessible from both SB-MOP and SB-PCL packages, will diff -Nru sbcl-2.0.6/package-data-list.lisp-expr sbcl-2.1.1/package-data-list.lisp-expr --- sbcl-2.0.6/package-data-list.lisp-expr 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/package-data-list.lisp-expr 2021-01-30 11:22:38.000000000 +0000 @@ -322,7 +322,7 @@ "HALT" "IF-EQ" "CONSTANT-TN-P" - "INHIBIT-SAFEPOINTS" + "INSERT-SAFEPOINTS" "COMPILER-MACRO-APPLICATION-MISSED-WARNING" "INLINING-DEPENDENCY-FAILURE" "INSERT-STEP-CONDITIONS" @@ -386,6 +386,7 @@ "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" @@ -415,6 +416,7 @@ "IR2-BLOCK-BLOCK" "VOP-BLOCK" "VOP-NEXT" "NEXT-VOP-IS" "REPLACE-VOPS" + "VOP-NAME" "VOP-CODEGEN-INFO" "IMMEDIATE-CONSTANT-SC" "BOXED-IMMEDIATE-SC-P" @@ -656,7 +658,6 @@ "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" - "ANSI-STREAM-WRITE-STRING" "DISPATCH-TABLES" "CHARACTER-MACRO-HASH-TABLE" "CHARACTER-MACRO-ARRAY" "TOKEN-DELIMITERP" "WHITESPACE[2]P" "WITH-READ-BUFFER" ;; other @@ -736,6 +737,7 @@ ;; Hooks into init & save sequences "*INIT-HOOKS*" "*SAVE-HOOKS*" "*EXIT-HOOKS*" + "*FORCIBLY-TERMINATE-THREADS-ON-EXIT*" ;; Controlling exiting other threads. "*EXIT-TIMEOUT*" @@ -870,6 +872,7 @@ ;; 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 @@ -1271,6 +1274,7 @@ "COPY-LIST-MACRO" "DO-ANONYMOUS" "DOVECTOR" "DOHASH" "DOPLIST" "ENSURE-GETHASH" + "GET-SIMILAR" "NAMED-LET" "ONCE-ONLY" "DEFENUM" @@ -1310,6 +1314,7 @@ "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" @@ -1655,7 +1660,7 @@ "%MEMBER-KEY-TEST-NOT" "%MEMBER-TEST" "%MEMBER-TEST-NOT" - "%MULTIPLY-HIGH" + "%MULTIPLY-HIGH" "%SIGNED-MULTIPLY-HIGH" "%NEGATE" "%POW" "%OTHER-POINTER-WIDETAG" "%PCL-INSTANCE-P" @@ -1685,6 +1690,7 @@ "%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" @@ -1723,6 +1729,7 @@ "*EMPTY-TYPE*" "*EVAL-CALLS*" "*GC-INHIBIT*" "*GC-PENDING*" + "*GC-PIN-CODE-PAGES*" #+sb-thread "*STOP-FOR-GC-PENDING*" "*IN-WITHOUT-GCING*" "*UNIVERSAL-TYPE*" @@ -1805,6 +1812,8 @@ "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" @@ -1865,8 +1874,9 @@ "INVALID-UNWIND-ERROR" "IRRATIONAL" "KEY-INFO" "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE" - "LAYOUT-BITMAP" "LAYOUT-CLASSOID-NAME" - "LAYOUT-DEPTHOID" "LAYOUT-EQUALP-IMPL" "LAYOUT-INVALID-ERROR" + "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" @@ -1877,14 +1887,11 @@ "LIST-SUBSEQ*" "ANSI-STREAM" "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE" - "ANSI-STREAM-ELEMENT-TYPE" - "ANSI-STREAM-FILE-POSITION" "ANSI-STREAM-IN" "ANSI-STREAM-IN-BUFFER" "ANSI-STREAM-IN-INDEX" - "ANSI-STREAM-INPUT-STREAM-P" "ANSI-STREAM-MISC" - "ANSI-STREAM-N-BIN" "ANSI-STREAM-OPEN-STREAM-P" + "ANSI-STREAM-MISC" + "ANSI-STREAM-N-BIN" "ANSI-STREAM-OUT" "ANSI-STREAM-SOUT" - "ANSI-STREAM-OUTPUT-STREAM-P" "COMPLEX-VECTOR" "LIST-TO-VECTOR*" "LOGICAL-HOST" "LOGICAL-HOST-DESIGNATOR" @@ -2027,7 +2034,7 @@ "SEQUENCEP" "SEQUENCE-COUNT" "SEQUENCE-END" "SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE" "SET-ARRAY-HEADER" "SET-HEADER-BITS" "SET-HEADER-DATA" - "UNSET-HEADER-BITS" + "UNSET-HEADER-BITS" "TEST-HEADER-BIT" "SHIFT-TOWARDS-END" "SHIFT-TOWARDS-START" "SHRINK-VECTOR" "%SHRINK-VECTOR" "SIGNED-BYTE-32-P" "SIGNED-BYTE-64-P" @@ -2114,7 +2121,7 @@ "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-OR-INVALID" + "UPDATE-OBJECT-LAYOUT" "VALID-MACROEXPAND-HOOK" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-SPECIFIER-TYPE" "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP" @@ -2231,10 +2238,10 @@ "SET-SYMBOL-GLOBAL-VALUE" "OUTPUT-SYMBOL" "%COERCE-NAME-TO-FUN" "DEFAULT-STRUCTURE-PRINT" - "LAYOUT" "LAYOUT-LENGTH" "LAYOUT-PURE" "DSD-RAW-TYPE" + "LAYOUT" "LAYOUT-LENGTH" "LAYOUT-PURE" "DEFSTRUCT-DESCRIPTION" "UNDECLARE-STRUCTURE" "UNDEFINE-FUN-NAME" "DD-TYPE" "CLASSOID-STATE" "INSTANCE" - "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT" "DSD-NAME" + "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT" "%TYPEP" "%%TYPEP" "DD-NAME" "CLASSOID-SUBCLASSES" "CLASSOID-LAYOUT" "CLASSOID-NAME" "CLASSOID-P" "NOTE-NAME-DEFINED" @@ -2242,29 +2249,28 @@ "%CODE-SERIALNO" "DD-SLOTS" "DD-INCLUDE" "SLOT-SETTER-LAMBDA-FORM" "SLOT-ACCESS-TRANSFORM" - "%IMAGPART" "DSD-ACCESSOR-NAME" "%CODE-DEBUG-INFO" + "%IMAGPART" "%CODE-DEBUG-INFO" "LAYOUT-CLASSOID" "LAYOUT-INVALID" "LAYOUT-FLAGS" - "DSD-TYPE" "%INSTANCEP" "DEFSTRUCT-SLOT-DESCRIPTION" + "%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" - "DSD-INDEX" "GET-DSD-INDEX" + "GET-DSD-INDEX" "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" "PROCLAIM-AS-FUN-NAME" "BECOME-DEFINED-FUN-NAME" - "%NUMERATOR" "CLASSOID-TYPEP" "DSD-READ-ONLY" - "DSD-DEFAULT" "LAYOUT-INHERITS" "DD-LENGTH" + "%NUMERATOR" "CLASSOID-TYPEP" + "LAYOUT-INHERITS" "DD-LENGTH" "SET-LAYOUT-INHERITS" "%CODE-ENTRY-POINT" "%CODE-FUN-OFFSET" - "CODE-ENTRY-POINTS" ; new accessor - returns a vector "CODE-N-ENTRIES" "CODE-N-NAMED-CALLS" "CODE-OBJ-IS-FILLER-P" - "%CODE-ENTRY-POINTS" ; prefer %CODE-ENTRY-POINT instead of this "%DENOMINATOR" "%OTHER-POINTER-P" "%OTHER-POINTER-SUBTYPE-P" @@ -2312,6 +2318,10 @@ "+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**" @@ -2690,99 +2700,7 @@ "ILLEGAL-CLASS-NAME-ERROR" "CLASS-NOT-FOUND-ERROR" - "SPECIALIZER-NAME-SYNTAX-ERROR") - ;; FIXME: After a little while, these reexports can probably go - ;; away, as they're superseded by the use of SB-MOP as the - ;; publically-accessible package. - :reexport ( ;; CL symbols - "ADD-METHOD" - "ALLOCATE-INSTANCE" - "CLASS-NAME" "COMPUTE-APPLICABLE-METHODS" - "ENSURE-GENERIC-FUNCTION" "MAKE-INSTANCE" - "METHOD-QUALIFIERS" "REMOVE-METHOD" - ;; MOP symbols - "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" - "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")) + "SPECIALIZER-NAME-SYNTAX-ERROR")) #s(sb-cold:package-data :name "SB-PRETTY" @@ -2854,7 +2772,7 @@ "%PRIMITIVE" "%STANDARD-CHAR-P" "*EXIT-ERROR-HANDLER*" - "*EXIT-IN-PROCESS*" + "*EXIT-IN-PROGRESS*" "*ALLOW-WITH-INTERRUPTS*" "*INTERRUPTS-ENABLED*" "*INTERRUPT-PENDING*" @@ -2866,7 +2784,6 @@ "*PERIODIC-POLLING-PERIOD*" "*RUNTIME-DLHANDLE*" "*SHARED-OBJECTS*" - #-linkage-table "*STATIC-FOREIGN-SYMBOLS*" "*STDERR*" "*STDIN*" "*STDOUT*" "*TTY*" @@ -2881,7 +2798,6 @@ "DEALLOCATE-SYSTEM-MEMORY" "DECODE-TIMEOUT" "DECODE-INTERNAL-TIME" - "DEFAULT-INTERRUPT" "DEFER-DEADLINE" "DYNAMIC-FOREIGN-SYMBOLS-P" "DLOPEN-OR-LOSE" @@ -2896,8 +2812,7 @@ "FOREIGN-SYMBOL-SAP" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-DATAREF-SAP" - "GET-MACHINE-VERSION" "GET-PAGE-SIZE" "GET-SYSTEM-INFO" - "IGNORE-INTERRUPT" + "GET-MACHINE-VERSION" "GET-SYSTEM-INFO" "IN-INTERRUPTION" "INTERACTIVE-INTERRUPT" "INT-SAP" @@ -2938,6 +2853,7 @@ "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" @@ -3016,7 +2932,6 @@ "UID-USERNAME" "UID-HOMEDIR" "USER-HOMEDIR" - "WITH-RESTARTED-SYSCALL" "SB-MKSTEMP" "UNIX-OFFSET" "FD-TYPE" @@ -3058,6 +2973,8 @@ "UNIX-UNLINK" "UNIX-WRITE" "WCONTINUED" "WNOHANG" "WUNTRACED" "W_OK" "X_OK" + "SC-NPROCESSORS-ONLN" + "VOID-SYSCALL" ;; signals "SIGALRM" "SIGBUS" "SIGCHLD" "SIGCONT" "SIGEMT" "SIGFPE" @@ -3076,7 +2993,7 @@ "FD-ISSET" "FD-SET" "UNIX-FAST-SELECT" "UNIX-KILL" "FD-ZERO" "FD-CLR" - "FD-SETSIZE" "UNIX-FAST-GETRUSAGE" + "FD-SETSIZE" "UNIX-KILLPG")) #s(sb-cold:package-data @@ -3091,6 +3008,7 @@ "*PRIMITIVE-OBJECTS*" "+HIGHEST-NORMAL-GENERATION+" "+PSEUDO-STATIC-GENERATION+" + "+ARRAY-FILL-POINTER-P+" "+VECTOR-SHAREABLE+" "+VECTOR-SHAREABLE-NONSTD+" "%COMPILER-BARRIER" "%DATA-DEPENDENCY-BARRIER" @@ -3172,6 +3090,8 @@ "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" @@ -3221,7 +3141,6 @@ "IS-LISP-POINTER" #+gencgc "LARGE-OBJECT-SIZE" "LIST-ALLOCATED-OBJECTS" "LIST-POINTER-LOWTAG" - "LOCKFREE-LIST-NODE-FLAG" ;; FIXME: Possibly these other parameters (see ;; compiler/{x86,sparc}/parms.lisp) should be defined ;; conditionally on #+LONG-FLOAT) @@ -3372,10 +3291,10 @@ "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-SUBTYPE" - "VECTOR-WEAK-VISITED-SUBTYPE" - "VECTOR-HASHING-SUBTYPE" - "VECTOR-ADDR-HASHING-SUBTYPE" + "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" @@ -3392,6 +3311,12 @@ :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")) @@ -3501,7 +3426,7 @@ slot-makunbound make-load-form-saving-slots sb-vm:map-allocated-objects - sb-vm::primitive-object-size + sb-ext:primitive-object-size sb-vm::remove-static-links) ;; CLOS implementation (sb-mop:class-finalized-p @@ -3604,6 +3529,30 @@ 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 diff -Nru sbcl-2.0.6/slam.sh sbcl-2.1.1/slam.sh --- sbcl-2.0.6/slam.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/slam.sh 2021-01-30 11:22:38.000000000 +0000 @@ -65,8 +65,8 @@ ####################################################################### warm_option="" -if [ "$1" == --load ]; then - warm_option="--load" +if [ "$1" == --load -o "$1" == --load-with-sb-devel ]; then + warm_option="$1" shift fi diff -Nru sbcl-2.0.6/src/assembly/alpha/alloc.lisp sbcl-2.1.1/src/assembly/alpha/alloc.lisp --- sbcl-2.0.6/src/assembly/alpha/alloc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/alpha/alloc.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -;;;; stuff to handle allocation of stuff we don't want to do inline - -;;;; 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") - -;;; (Given that the pseudo-atomic sequence is so short, there is -;;; nothing that qualifies. But we want to keep the file around -;;; in case we decide to add something later.) - diff -Nru sbcl-2.0.6/src/assembly/alpha/arith.lisp sbcl-2.1.1/src/assembly/alpha/arith.lisp --- sbcl-2.0.6/src/assembly/alpha/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/alpha/arith.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,418 +0,0 @@ -;;;; stuff to handle simple cases for generic arithmetic - -;;;; 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") - -(define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp temp3 non-descriptor-reg nl2-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and x 3 temp) - (inst bne temp DO-STATIC-FUN) - (inst and y 3 temp) - (inst bne temp DO-STATIC-FUN) - (inst addq x y res) - - ; Check whether we need a bignum. - (inst sra res 31 temp) - (inst beq temp DONE) - (inst not temp temp) - (inst beq temp DONE) - (inst sra res 2 temp3) - - ; from move-from-signed - (inst li 2 temp2) - (inst sra temp3 31 temp) - (inst cmoveq temp 1 temp2) - (inst not temp temp) - (inst cmoveq temp 1 temp2) - (inst sll temp2 n-widetag-bits temp2) - (inst bis temp2 bignum-widetag temp2) - - (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) - (inst bis alloc-tn other-pointer-lowtag res) - (storew temp2 res 0 other-pointer-lowtag) - (storew temp3 res bignum-digits-offset other-pointer-lowtag) - (inst srl temp3 32 temp) - (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag)) - DONE - (lisp-return lra lip :offset 2) - - DO-STATIC-FUN - (inst ldl lip (static-fun-offset 'two-arg-+) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip)) - - -(define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp temp3 non-descriptor-reg nl2-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and x 3 temp) - (inst bne temp DO-STATIC-FUN) - (inst and y 3 temp) - (inst bne temp DO-STATIC-FUN) - (inst subq x y res) - - ; Check whether we need a bignum. - (inst sra res 31 temp) - (inst beq temp DONE) - (inst not temp temp) - (inst beq temp DONE) - (inst sra res 2 temp3) - - ; from move-from-signed - (inst li 2 temp2) - (inst sra temp3 31 temp) - (inst cmoveq temp 1 temp2) - (inst not temp temp) - (inst cmoveq temp 1 temp2) - (inst sll temp2 n-widetag-bits temp2) - (inst bis temp2 bignum-widetag temp2) - - (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) - (inst bis alloc-tn other-pointer-lowtag res) - (storew temp2 res 0 other-pointer-lowtag) - (storew temp3 res bignum-digits-offset other-pointer-lowtag) - (inst srl temp3 32 temp) - (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag)) - DONE - (lisp-return lra lip :offset 2) - - DO-STATIC-FUN - (inst ldl lip (static-fun-offset 'two-arg--) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip)) - - -(define-assembly-routine (generic-* - (:cost 25) - (:return-style :full-call) - (:translate *) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lo non-descriptor-reg nl1-offset) - (:temp hi non-descriptor-reg nl2-offset) - (:temp temp2 non-descriptor-reg nl3-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not a fixnum, call the static function. - (inst and x 3 temp) - (inst bne temp DO-STATIC-FUN) - (inst and y 3 temp) - (inst bne temp DO-STATIC-FUN) - - ;; Remove the tag from one arg so that the result will have the - ;; correct fixnum tag. - (inst sra x 2 temp) - (inst mulq temp y lo) - (inst sra lo 32 hi) - (inst sll lo 32 res) - (inst sra res 32 res) - ;; Check to see if the result will fit in a fixnum. (I.e. the high - ;; word is just 32 copies of the sign bit of the low word). - (inst sra res 31 temp) - (inst xor hi temp temp) - (inst beq temp DONE) - ;; Shift the double word hi:res down two bits into hi:low to get rid - ;; of the fixnum tag. - (inst sra lo 2 lo) - (inst sra lo 32 hi) - - ;; Do we need one word or two? Assume two. - (inst li (logior (ash 2 n-widetag-bits) bignum-widetag) temp2) - (inst sra lo 31 temp) - (inst xor temp hi temp) - (inst bne temp two-words) - - ;; Only need one word, fix the header. - (inst li (logior (ash 1 n-widetag-bits) bignum-widetag) temp2) - ;; Allocate one word. - (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) - (inst bis alloc-tn other-pointer-lowtag res) - (storew temp2 res 0 other-pointer-lowtag)) - ;; Store one word - (storew lo res bignum-digits-offset other-pointer-lowtag) - ;; Out of here - (lisp-return lra lip :offset 2) - - TWO-WORDS - ;; Allocate two words. - (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset))) - (inst bis alloc-tn other-pointer-lowtag res) - (storew temp2 res 0 other-pointer-lowtag)) - ;; Store two words. - (storew lo res bignum-digits-offset other-pointer-lowtag) - (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) - ;; out of here - (lisp-return lra lip :offset 2) - - DO-STATIC-FUN - (inst ldl lip (static-fun-offset 'two-arg-*) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip) - - DONE) - - -;;;; division - -(define-assembly-routine (signed-truncate - (:note "(signed-byte 64) truncate") - (:cost 60) - (:policy :fast-safe) - (:translate truncate) - (:arg-types signed-num signed-num) - (:result-types signed-num signed-num)) - - ((:arg dividend signed-reg nl0-offset) - (:arg divisor signed-reg nl1-offset) - - (:res quo signed-reg nl2-offset) - (:res rem signed-reg nl3-offset) - - (:temp quo-sign signed-reg nl5-offset) - (:temp rem-sign signed-reg nargs-offset) - (:temp temp1 non-descriptor-reg nl4-offset)) - - (let ((error (generate-error-code nil 'division-by-zero-error - dividend divisor))) - (inst beq divisor error)) - - (inst xor dividend divisor quo-sign) - (inst move dividend rem-sign) - (let ((label (gen-label))) - (inst bge dividend label) - (inst subq zero-tn dividend dividend) - (emit-label label)) - (let ((label (gen-label))) - (inst bge divisor label) - (inst subq zero-tn divisor divisor) - (emit-label label)) - (inst move zero-tn rem) - (inst move zero-tn quo) - - (dotimes (i 64) - (inst srl dividend 63 temp1) - (inst sll rem 1 rem) - (inst bis temp1 rem rem) - (inst cmple divisor rem temp1) - (inst sll quo 1 quo) - (inst bis temp1 quo quo) - (inst sll dividend 1 dividend) - (inst subq temp1 1 temp1) - (inst zap divisor temp1 temp1) - (inst subq rem temp1 rem)) - - (let ((label (gen-label))) - ;; If the quo-sign is negative, we need to negate quo. - (inst bge quo-sign label) - (inst subq zero-tn quo quo) - (emit-label label)) - (let ((label (gen-label))) - ;; If the rem-sign is negative, we need to negate rem. - (inst bge rem-sign label) - (inst subq zero-tn rem rem) - (emit-label label))) - - -;;;; comparison routines - -(macrolet - ((define-cond-assem-rtn (name translate static-fn cmp not-p) - `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and x 3 temp) - (inst bne temp DO-STATIC-FN) - (inst and y 3 temp) - (inst beq temp DO-COMPARE) - - DO-STATIC-FN - (inst ldl lip (static-fun-offset ',static-fn) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip) - - DO-COMPARE - ,cmp - (inst move null-tn res) - (inst ,(if not-p 'bne 'beq) temp done) - (load-symbol res t) - DONE))) - - (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil) - (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil)) - - -(define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst cmpeq x y temp) - (inst bne temp RETURN-T) - (inst and x 3 temp) - (inst beq temp RETURN-NIL) - (inst and y 3 temp) - (inst bne temp DO-STATIC-FN) - - RETURN-NIL - (inst move null-tn res) - (lisp-return lra lip :offset 2) - - DO-STATIC-FN - (inst ldl lip (static-fun-offset 'eql) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip) - - RETURN-T - (load-symbol res t)) - -(define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and x 3 temp) - (inst bne temp DO-STATIC-FN) - (inst and y 3 temp) - (inst bne temp DO-STATIC-FN) - (inst cmpeq x y temp) - (inst bne temp RETURN-T) - - (inst move null-tn res) - (lisp-return lra lip :offset 2) - - DO-STATIC-FN - (inst ldl lip (static-fun-offset 'two-arg-=) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip) - - RETURN-T - (load-symbol res t)) - -(define-assembly-routine (generic-/= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate /=) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and x 3 temp) - (inst bne temp DO-STATIC-FN) - (inst and y 3 temp) - (inst bne temp DO-STATIC-FN) - (inst cmpeq x y temp) - (inst bne temp RETURN-NIL) - - (load-symbol res t) - (lisp-return lra lip :offset 2) - - DO-STATIC-FN - (inst ldl lip (static-fun-offset 'two-arg-/=) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip) - - RETURN-NIL - (inst move null-tn res)) diff -Nru sbcl-2.0.6/src/assembly/alpha/array.lisp sbcl-2.1.1/src/assembly/alpha/array.lisp --- sbcl-2.0.6/src/assembly/alpha/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/alpha/array.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -;;;; support routines for arrays and vectors - -;;;; 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") - - -(macrolet ((foo (name) -`(define-assembly-routine (,name - (:policy :fast-safe) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset)) - ;; This is kinda sleezy, changing words like this. But we can because - ;; the vop thinks it is temporary. - (inst addq words (+ (1- (ash 1 n-lowtag-bits)) - (* vector-data-offset n-word-bytes)) - words) - (inst li (lognot lowtag-mask) ndescr) - (inst and words ndescr words) - (inst srl type word-shift ndescr) - - (pseudo-atomic () - (inst bis alloc-tn other-pointer-lowtag result) - (inst addq alloc-tn words alloc-tn) - (storew ndescr result 0 other-pointer-lowtag) - (storew length result vector-length-slot other-pointer-lowtag))))) - (foo allocate-vector-on-heap) - (foo allocate-vector-on-stack)) ; get crossbuild to pass for what that's worth diff -Nru sbcl-2.0.6/src/assembly/alpha/assem-rtns.lisp sbcl-2.1.1/src/assembly/alpha/assem-rtns.lisp --- sbcl-2.0.6/src/assembly/alpha/assem-rtns.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/alpha/assem-rtns.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,229 +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-VM") - -;;;; Return-multiple with other than one value - -#+sb-assembling ;; We don't want a vop for this one. -(define-assembly-routine - (return-multiple - (:return-style :none)) - - ;; These four are really arguments. - ((:temp nvals any-reg nargs-offset) - (:temp vals any-reg nl0-offset) - (:temp ocfp any-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - - ;; These are just needed to facilitate the transfer - (:temp lip interior-reg lip-offset) - (:temp count any-reg nl2-offset) - (:temp dst any-reg nl4-offset) - (:temp temp descriptor-reg l0-offset) - - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - - ;; Note, because of the way the RETURN-MULTIPLE VOP is written, we - ;; can assume that we are never called with NVALS == 1 and that A0 - ;; has already been loaded. - (inst ble nvals default-a0-and-on) - (inst ldl a1 (* 1 n-word-bytes) vals) - (inst subq nvals (fixnumize 2) count) - (inst ble count default-a2-and-on) - (inst ldl a2 (* 2 n-word-bytes) vals) - (inst subq nvals (fixnumize 3) count) - (inst ble count default-a3-and-on) - (inst ldl a3 (* 3 n-word-bytes) vals) - (inst subq nvals (fixnumize 4) count) - (inst ble count default-a4-and-on) - (inst ldl a4 (* 4 n-word-bytes) vals) - (inst subq nvals (fixnumize 5) count) - (inst ble count default-a5-and-on) - (inst ldl a5 (* 5 n-word-bytes) vals) - (inst subq nvals (fixnumize 6) count) - (inst ble count done) - - ;; Copy the remaining args to the top of the stack. - (inst addq vals (* 6 n-word-bytes) vals) - (inst addq cfp-tn (* 6 n-word-bytes) dst) - - LOOP - (inst ldl temp 0 vals) - (inst addq vals n-word-bytes vals) - (inst stl temp 0 dst) - (inst subq count (fixnumize 1) count) - (inst addq dst n-word-bytes dst) - (inst bne count loop) - - (inst br zero-tn done) - - DEFAULT-A0-AND-ON - (inst move null-tn a0) - (inst move null-tn a1) - DEFAULT-A2-AND-ON - (inst move null-tn a2) - DEFAULT-A3-AND-ON - (inst move null-tn a3) - DEFAULT-A4-AND-ON - (inst move null-tn a4) - DEFAULT-A5-AND-ON - (inst move null-tn a5) - DONE - - ;; Clear the stack. - (move cfp-tn ocfp-tn) - (move ocfp cfp-tn) - (inst addq ocfp-tn nvals csp-tn) - - ;; Return. - (lisp-return lra lip)) - -;;;; tail-call-variable - -#+sb-assembling ;; no vop for this one either -(define-assembly-routine - (tail-call-variable - (:return-style :none)) - - ;; These are really args. - ((:temp args any-reg nl0-offset) - (:temp lexenv descriptor-reg lexenv-offset) - - ;; We need to compute this - (:temp nargs any-reg nargs-offset) - - ;; These are needed by the blitting code. - (:temp src any-reg nl1-offset) - (:temp dst any-reg nl2-offset) - (:temp count any-reg cfunc-offset) - (:temp temp descriptor-reg l0-offset) - - ;; Needed for the jump - (:temp lip interior-reg lip-offset) - - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - - - ;; Calculate NARGS (as a fixnum) - (inst subq csp-tn args nargs) - - ;; Load the argument regs (must do this now, 'cause the blt might - ;; trash these locations) - (inst ldl a0 (* 0 n-word-bytes) args) - (inst ldl a1 (* 1 n-word-bytes) args) - (inst ldl a2 (* 2 n-word-bytes) args) - (inst ldl a3 (* 3 n-word-bytes) args) - (inst ldl a4 (* 4 n-word-bytes) args) - (inst ldl a5 (* 5 n-word-bytes) args) - - ;; Calc SRC, DST, and COUNT - (inst subq nargs (fixnumize register-arg-count) count) - (inst addq args (* n-word-bytes register-arg-count) src) - (inst ble count done) - (inst addq cfp-tn (* n-word-bytes register-arg-count) dst) - - LOOP - ;; Copy one arg. - (inst ldl temp 0 src) - (inst addq src n-word-bytes src) - (inst stl temp 0 dst) - (inst subq count (fixnumize 1) count) - (inst addq dst n-word-bytes dst) - (inst bgt count loop) - - DONE - ;; We are done. Do the jump. - (progn - (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) - (lisp-jump temp lip))) - - -;;;; non-local exit noise - -(define-assembly-routine - (unwind - (:translate %unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) a0-offset) - (:arg start (any-reg descriptor-reg) ocfp-offset) - (:arg count (any-reg descriptor-reg) nargs-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp cur-uwp any-reg nl0-offset) - (:temp next-uwp any-reg nl1-offset) - (:temp target-uwp any-reg nl2-offset) - (:temp temp1 non-descriptor-reg nl3-offset)) - (declare (ignore start count)) - - (load-symbol-value cur-uwp *current-unwind-protect-block*) - (let ((error (generate-error-code nil 'invalid-unwind-error))) - (inst beq block error)) - - (loadw target-uwp block unwind-block-uwp-slot) - (inst cmpeq cur-uwp target-uwp temp1) - (inst beq temp1 do-uwp) - - (move block cur-uwp) - - do-exit - - (loadw cfp-tn cur-uwp unwind-block-cfp-slot) - (loadw code-tn cur-uwp unwind-block-code-slot) - (progn - (loadw lra cur-uwp unwind-block-entry-pc-slot) - (lisp-return lra lip :frob-code nil)) - - do-uwp - - (loadw next-uwp cur-uwp unwind-block-uwp-slot) - (store-symbol-value next-uwp *current-unwind-protect-block*) - (inst br zero-tn do-exit)) - -(define-assembly-routine - throw - ((:arg target descriptor-reg a0-offset) - (:arg start any-reg ocfp-offset) - (:arg count any-reg nargs-offset) - (:temp catch any-reg a1-offset) - (:temp tag descriptor-reg a2-offset) - (:temp temp1 non-descriptor-reg nl0-offset)) - - (progn start count) ; We just need them in the registers. - - (load-symbol-value catch *current-catch-block*) - - loop - - (let ((error (generate-error-code nil 'unseen-throw-tag-error target))) - (inst beq catch error)) - - (loadw tag catch catch-block-tag-slot) - (inst cmpeq tag target temp1) - (inst bne temp1 exit) - (loadw catch catch catch-block-previous-catch-slot) - (inst br zero-tn loop) - - exit - - (move catch target) - (inst li (make-fixup 'unwind :assembly-routine) temp1) - (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine))) diff -Nru sbcl-2.0.6/src/assembly/alpha/support.lisp sbcl-2.1.1/src/assembly/alpha/support.lisp --- sbcl-2.0.6/src/assembly/alpha/support.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/alpha/support.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -;;;; the machine-specific support routines needed by the file assembler - -;;;; 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") - -(defun generate-call-sequence (name style vop options) - (declare (ignore options)) - (ecase style - ((:raw :none) - (values - `((inst li (make-fixup ',name :assembly-routine) temp) - (inst jsr lip-tn temp)) - '((:temporary (:sc non-descriptor-reg) temp)) - nil)) - (:full-call - (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) - (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code ,lra code-tn lra-label ,temp) - (note-next-instruction ,vop :call-site) - ; here - (inst li (make-fixup ',name :assembly-routine) temp1) - (inst jsr lip-tn temp1 (make-fixup ',name :assembly-routine)) - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (without-scheduling () - (move ocfp-tn csp-tn) - (inst nop)) - (inst compute-code-from-lra code-tn code-tn - lra-label ,temp) - (when cur-nfp - (maybe-load-stack-nfp-tn cur-nfp ,nfp-save temp1)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp1) - (:save-p t))))))) - -(defun generate-return-sequence (style) - (ecase style - (:raw - `((inst ret zero-tn lip-tn))) - (:full-call - `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose - 'descriptor-reg) - :offset lra-offset) - lip-tn :offset 2))) - (:none))) - -(defun return-machine-address (scp) - (context-register scp lip-offset)) diff -Nru sbcl-2.0.6/src/assembly/alpha/tramps.lisp sbcl-2.1.1/src/assembly/alpha/tramps.lisp --- sbcl-2.0.6/src/assembly/alpha/tramps.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/alpha/tramps.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -;;;; Undefined-function and closure trampoline definitions - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. - -(in-package "SB-VM") - -(define-assembly-routine - (xundefined-tramp (:return-style :none) - (:align n-lowtag-bits) - (:export undefined-tramp - (undefined-tramp-tagged - (+ xundefined-tramp - fun-pointer-lowtag)))) - ((:temp fdefn-tn descriptor-reg fdefn-offset) - (:temp nl0-tn non-descriptor-reg nl0-offset) - (:temp ocfp-tn non-descriptor-reg ocfp-offset) - (:temp lra-tn descriptor-reg lra-offset)) - (inst lword simple-fun-widetag) ;; header - (inst lword (make-fixup 'undefined-tramp-tagged - :assembly-routine)) ;; self - (dotimes (i (- simple-fun-insts-offset 2)) - (inst lword nil-value)) - - ;; If we are called with stack arguments (or in a tail-call - ;; scenario), we end up with an allocated stack frame, but the frame - ;; link information is uninitialized. Fix things by allocating and - ;; initializing our stack frame "properly". - - UNDEFINED-TRAMP - (inst lda code-tn - (- fun-pointer-lowtag - (ash simple-fun-insts-offset word-shift)) - lip-tn) - - (inst cmpule nargs-tn (fixnumize register-arg-count) nl0-tn) - (inst beq nl0-tn NO-STACK-ARGS) - (inst addq cfp-tn (fixnumize register-arg-count) csp-tn) - (inst br zero-tn FINISH-FRAME-SETUP) - - NO-STACK-ARGS - (inst addq cfp-tn nargs-tn csp-tn) - - FINISH-FRAME-SETUP - (storew ocfp-tn cfp-tn ocfp-save-offset) - (storew lra-tn cfp-tn lra-save-offset) - (error-call nil 'undefined-fun-error fdefn-tn)) - -(define-assembly-routine - (closure-tramp (:return-style :none) - (:align n-lowtag-bits)) - ((:temp fdefn-tn descriptor-reg fdefn-offset) - (:temp lexenv-tn descriptor-reg lexenv-offset)) - (loadw lexenv-tn fdefn-tn fdefn-fun-slot other-pointer-lowtag) - (loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag) - (inst lda lip-tn (- (ash simple-fun-insts-offset word-shift) - fun-pointer-lowtag) - code-tn) - (inst jsr zero-tn lip-tn 1)) - -(define-assembly-routine - (xfuncallable-instance-tramp (:return-style :none) - (:align n-lowtag-bits) - (:export (funcallable-instance-tramp - (+ xfuncallable-instance-tramp - fun-pointer-lowtag)))) - ((:temp code-tn descriptor-reg code-offset) - (:temp lexenv-tn descriptor-reg lexenv-offset)) - (inst lword simple-fun-widetag) - (inst lword (make-fixup 'funcallable-instance-tramp - :assembly-routine)) - (dotimes (i (- simple-fun-insts-offset 2)) - (inst lword nil-value)) - - (loadw lexenv-tn lexenv-tn funcallable-instance-function-slot fun-pointer-lowtag) - (loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag) - (inst lda lip-tn (- (ash simple-fun-insts-offset word-shift) - fun-pointer-lowtag) - code-tn) - (inst jsr zero-tn lip-tn 1)) diff -Nru sbcl-2.0.6/src/assembly/arm/assem-rtns.lisp sbcl-2.1.1/src/assembly/arm/assem-rtns.lisp --- sbcl-2.0.6/src/assembly/arm/assem-rtns.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/arm/assem-rtns.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -35,7 +35,7 @@ ;; We don't need to copy stack values at this point, so default any ;; unsupplied values that should be in arg-passing registers. First - ;; piece of black magic: A computed jump. + ;; piece of deep magic: A computed jump. (inst add pc-tn pc-tn nvals) ;; Eat a word of padding for the computed jump. (inst word 0) @@ -47,7 +47,7 @@ (inst mov r2 null-tn) ;; We've defaulted any unsupplied parameters, but now we need to - ;; load the supplied parameters. Second piece of black magic: A + ;; load the supplied parameters. Second piece of deep magic: A ;; hairier computed jump. (inst rsb count nvals (fixnumize 2)) (inst add pc-tn pc-tn count) diff -Nru sbcl-2.0.6/src/assembly/assemfile.lisp sbcl-2.1.1/src/assembly/assemfile.lisp --- sbcl-2.0.6/src/assembly/assemfile.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/assemfile.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -157,7 +157,7 @@ (emit-alignment sb-vm:n-lowtag-bits ;; EMIT-LONG-NOP does not exist for (not x86-64) #+x86-64 :long-nop)) - (when *compile-print* + (when cl:*compile-print* (format *error-output* "~S assembled~%" ',name))))) (defun arg-or-res-spec (reg) @@ -226,15 +226,9 @@ :key #'car) (:generator ,cost ,@(mapcar (lambda (arg) - #+(or hppa alpha) `(move ,(reg-spec-name arg) - ,(reg-spec-temp arg)) - #-(or hppa alpha) `(move ,(reg-spec-temp arg) - ,(reg-spec-name arg))) + `(move ,(reg-spec-temp arg) ,(reg-spec-name arg))) args) ,@call-sequence ,@(mapcar (lambda (res) - #+(or hppa alpha) `(move ,(reg-spec-temp res) - ,(reg-spec-name res)) - #-(or hppa alpha) `(move ,(reg-spec-name res) - ,(reg-spec-temp res))) + `(move ,(reg-spec-name res) ,(reg-spec-temp res))) results)))))) diff -Nru sbcl-2.0.6/src/assembly/hppa/alloc.lisp sbcl-2.1.1/src/assembly/hppa/alloc.lisp --- sbcl-2.0.6/src/assembly/hppa/alloc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/hppa/alloc.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -(in-package "SB-VM") - -;;; Given that the pseudo-atomic sequence is so short, there is -;;; nothing that qualifies. But we want to keep the file around -;;; in case we decide to add something later. - diff -Nru sbcl-2.0.6/src/assembly/hppa/arith.lisp sbcl-2.1.1/src/assembly/hppa/arith.lisp --- sbcl-2.0.6/src/assembly/hppa/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/hppa/arith.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,296 +0,0 @@ -(in-package "SB-VM") - - -;;;; Multiplication and Division helping routines. - -;;; ?? FIXME: Where are generic-* and generic-/? -#+sb-assembling -(define-assembly-routine - multiply - ((:arg x (signed-reg) nl0-offset) - (:arg y (signed-reg) nl1-offset) - - (:res res (signed-reg) nl2-offset) - - (:temp tmp (unsigned-reg) nl3-offset) - (:temp sign (unsigned-reg) nl4-offset)) - - ;; Determine the sign of the result. - (inst extrs x 0 1 sign :=) - (inst sub zero-tn x x) - (inst extrs y 0 1 tmp :=) - (inst sub zero-tn y y) - (inst xor sign tmp sign) - - ;; Make sure X is less then Y. - (inst comclr x y tmp :<<) - (inst xor x y tmp) - (inst xor x tmp x) - (inst xor y tmp y) - ;; Blow out of here if the result is zero. - (inst comb := x zero-tn done) - (inst li 0 res) - - LOOP - (inst extru x 31 1 zero-tn :ev) - (inst add y res res) - (inst extru x 30 1 zero-tn :ev) - (inst sh1add y res res) - (inst extru x 29 1 zero-tn :ev) - (inst sh2add y res res) - (inst extru x 28 1 zero-tn :ev) - (inst sh3add y res res) - - (inst srl x 4 x) - (inst comb :<> x zero-tn loop) - (inst sll y 4 y) - - DONE - (inst xor res sign res) - (inst sub res sign res)) - -(define-assembly-routine - (truncate) - ((:arg dividend signed-reg nl0-offset) - (:arg divisor signed-reg nl1-offset) - - (:res quo signed-reg nl2-offset) - (:res rem signed-reg nl3-offset)) - ;; Move abs(divident) into quo. - (inst move dividend quo :>=) - (inst sub zero-tn quo quo) - ;; Do one divive-step with -divisor to prime V (use rem as a temp) - (inst sub zero-tn divisor rem) - (inst ds zero-tn rem zero-tn) - ;; Shift the divident/quotient one bit, setting the carry flag. - (inst add quo quo quo) - ;; The first real divive-step. - (inst ds zero-tn divisor rem) - (inst addc quo quo quo) - ;; And 31 more of them. - (dotimes (i 31) - (inst ds rem divisor rem) - (inst addc quo quo quo)) - ;; If the remainder is negative, we need to add the absolute value of the - ;; divisor. - (inst comb :>= rem zero-tn remainder-positive :nullify t) - (inst comclr divisor zero-tn zero-tn :<) - (inst add rem divisor rem :tr) - (inst sub rem divisor rem) - REMAINDER-POSITIVE - ;; Now we have to fix the signs of quo and rem. - (inst xor divisor dividend zero-tn :>=) - (inst sub zero-tn quo quo) - (inst move dividend zero-tn :>=) - (inst sub zero-tn rem rem)) - - -;;;; Generic arithmetic. - -(define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - (:res res (descriptor-reg any-reg) a0-offset) - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp1 non-descriptor-reg nl1-offset) - (:temp temp2 non-descriptor-reg nl2-offset) - (:temp lra descriptor-reg lra-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not fixnum, use two-arg-+ to summarize - (inst or x y temp) - (inst extru temp 31 3 zero-tn :=) - (inst b DO-STATIC-FUN :nullify t) - ;; check for overflow - (inst add x y temp) - (inst xor temp x temp1) - (inst xor temp y temp2) - (inst and temp1 temp2 temp1) - (inst bc :< nil temp1 zero-tn DO-OVERFLOW) - (inst move temp res) - (lisp-return lra :offset 1) - - DO-OVERFLOW - ;; We did overflow, so do the bignum version - (inst sra x n-fixnum-tag-bits temp1) - (inst sra y n-fixnum-tag-bits temp2) - (inst add temp1 temp2 temp) - (with-fixed-allocation (res nil temp2 bignum-widetag - (1+ bignum-digits-offset) nil) - (storew temp res bignum-digits-offset other-pointer-lowtag)) - (lisp-return lra :offset 1) - - DO-STATIC-FUN - (inst ldw (static-fun-offset 'two-arg-+) null-tn lip) - (inst li (fixnumize 2) nargs) - (move cfp-tn ocfp) - (inst bv lip) - (move csp-tn cfp-tn t)) - -(define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp1 non-descriptor-reg nl1-offset) - (:temp temp2 non-descriptor-reg nl2-offset) - (:temp lra descriptor-reg lra-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not fixnum, use two-arg-+ to summarize - (inst or x y temp) - (inst extru temp 31 3 zero-tn :=) - (inst b DO-STATIC-FUN :nullify t) - (inst sub x y temp) - ;; check for overflow - (inst xor x y temp1) - (inst xor x temp temp2) - (inst and temp2 temp1 temp1) - (inst bc :< nil temp1 zero-tn DO-OVERFLOW) - (inst move temp res) - (lisp-return lra :offset 1) - - DO-OVERFLOW - ;; We did overflow, so do the bignum version - (inst sra x n-fixnum-tag-bits temp1) - (inst sra y n-fixnum-tag-bits temp2) - (inst sub temp1 temp2 temp) - (with-fixed-allocation (res nil temp2 bignum-widetag - (1+ bignum-digits-offset) nil) - (storew temp res bignum-digits-offset other-pointer-lowtag)) - (lisp-return lra :offset 1) - - DO-STATIC-FUN - (inst ldw (static-fun-offset 'two-arg--) null-tn lip) - (inst li (fixnumize 2) nargs) - (move cfp-tn ocfp) - (inst bv lip) - (move csp-tn cfp-tn t)) - - -;;;; Comparison routines. - -(macrolet - ((define-cond-assem-rtn (name translate static-fn cond) - `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst extru x 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - - (inst comclr x y zero-tn ,cond) - (inst move null-tn res :tr) - (load-symbol res t) - (lisp-return lra :offset 1) - - DO-STATIC-FN - (inst ldw (static-fun-offset ',static-fn) null-tn lip) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn)))) - - (define-cond-assem-rtn generic-< < two-arg-< :<) - (define-cond-assem-rtn generic-> > two-arg-> :>)) - - -(define-assembly-routine - (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - - (inst comb := x y return-t :nullify t) - (inst extru x 31 2 zero-tn :<>) - (inst b return-nil :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - - RETURN-NIL - (inst move null-tn res) - (lisp-return lra :offset 1) - - DO-STATIC-FN - (inst ldw (static-fun-offset 'eql) null-tn lip) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn) - - RETURN-T - (load-symbol res t)) - -(define-assembly-routine - (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - - (inst comb := x y return-t :nullify t) - (inst extru x 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - - (inst move null-tn res) - (lisp-return lra :offset 1) - - DO-STATIC-FN - (inst ldw (static-fun-offset 'two-arg-=) null-tn lip) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn) - - RETURN-T - (load-symbol res t)) diff -Nru sbcl-2.0.6/src/assembly/hppa/array.lisp sbcl-2.1.1/src/assembly/hppa/array.lisp --- sbcl-2.0.6/src/assembly/hppa/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/hppa/array.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -(in-package "SB-VM") diff -Nru sbcl-2.0.6/src/assembly/hppa/assem-rtns.lisp sbcl-2.1.1/src/assembly/hppa/assem-rtns.lisp --- sbcl-2.0.6/src/assembly/hppa/assem-rtns.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/hppa/assem-rtns.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,201 +0,0 @@ -(in-package "SB-VM") - -;;;; Return-multiple with other than one value - -#+sb-assembling ;; we don't want a vop for this one. -(define-assembly-routine - (return-multiple - (:return-style :none)) - ;; These four are really arguments. - ((:temp nvals any-reg nargs-offset) - (:temp vals any-reg nl0-offset) - (:temp ocfp any-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - ;; These are just needed to facilitate the transfer - (:temp count any-reg nl2-offset) - (:temp dst any-reg nl3-offset) - (:temp temp descriptor-reg l0-offset) - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - ;; Note, because of the way the return-multiple vop is written, we can - ;; assume that we are never called with nvals == 1 and that a0 has already - ;; been loaded. ;FIX-lav: look at old hppa , replace comb+addi with addib - (inst comb :<= nvals zero-tn DEFAULT-A0-AND-ON) - (inst addi (- (fixnumize 2)) nvals count) - (inst comb :<= count zero-tn DEFAULT-A2-AND-ON) - (inst ldw (* 1 n-word-bytes) vals a1) - (inst addib :<= (- (fixnumize 1)) count DEFAULT-A3-AND-ON) - (inst ldw (* 2 n-word-bytes) vals a2) - (inst addib :<= (- (fixnumize 1)) count DEFAULT-A4-AND-ON) - (inst ldw (* 3 n-word-bytes) vals a3) - (inst addib :<= (- (fixnumize 1)) count DEFAULT-A5-AND-ON) - (inst ldw (* 4 n-word-bytes) vals a4) - (inst addib :<= (- (fixnumize 1)) count done) - (inst ldw (* 5 n-word-bytes) vals a5) - ;; Copy the remaining args to the top of the stack. - (inst addi (fixnumize register-arg-count) vals vals) - (inst addi (fixnumize register-arg-count) cfp-tn dst) - LOOP - (inst ldwm n-word-bytes vals temp) - (inst addib :<> (- (fixnumize 1)) count LOOP) - (inst stwm temp n-word-bytes dst) - (inst b DONE :nullify t) - - DEFAULT-A0-AND-ON - (move null-tn a0) - (move null-tn a1) - DEFAULT-A2-AND-ON - (move null-tn a2) - DEFAULT-A3-AND-ON - (move null-tn a3) - DEFAULT-A4-AND-ON - (move null-tn a4) - DEFAULT-A5-AND-ON - (move null-tn a5) - DONE - ;; Clear the stack. - (move cfp-tn ocfp-tn) - (move ocfp cfp-tn) - (inst add ocfp-tn nvals csp-tn) - (lisp-return lra)) - - -;;;; tail-call-variable. - -#+sb-assembling ;; no vop for this one either. -(define-assembly-routine - (tail-call-variable - (:return-style :none)) - ;; These are really args. - ((:temp args any-reg nl0-offset) - (:temp lexenv descriptor-reg lexenv-offset) - ;; We need to compute this - (:temp nargs any-reg nargs-offset) - ;; These are needed by the blitting code. - (:temp src any-reg nl1-offset) - (:temp dst any-reg nl2-offset) - (:temp count any-reg nl3-offset) - (:temp temp descriptor-reg l0-offset) - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - ;; Calculate NARGS (as a fixnum) - (inst sub csp-tn args nargs) - ;; Load the argument regs (must do this now, 'cause the blt might - ;; trash these locations) - (loadw a0 args 0) - (loadw a1 args 1) - (loadw a2 args 2) - (loadw a3 args 3) - (loadw a4 args 4) - (loadw a5 args 5) - ;; Calc SRC, DST, and COUNT - (inst addi (- (fixnumize register-arg-count)) nargs count) - (inst comb :<= count zero-tn done) - (inst addi (fixnumize register-arg-count) args src) - (inst addi (fixnumize register-arg-count) cfp-tn dst) - LOOP - ;; Copy one arg and increase src - (inst ldwm n-word-bytes src temp) - (inst addib :<> (- (fixnumize 1)) count LOOP) - (inst stwm temp n-word-bytes dst) - DONE - ;; We are done. Do the jump. - (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) - (lisp-jump temp)) - - -;;;; Non-local exit noise. - -(define-assembly-routine - (unwind - (:translate %unwind) - (:return-style :none) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) a0-offset) - (:arg start (any-reg descriptor-reg) ocfp-offset) - (:arg count (any-reg descriptor-reg) nargs-offset) - (:temp lra descriptor-reg lra-offset) - (:temp cur-uwp any-reg nl0-offset) - (:temp next-uwp any-reg nl1-offset) - (:temp target-uwp any-reg nl2-offset)) - (declare (ignore start count)) - - - (let ((error (generate-error-code nil 'invalid-unwind-error))) - (inst bc := nil block zero-tn error)) - - (load-symbol-value cur-uwp *current-unwind-protect-block*) - (loadw target-uwp block unwind-block-uwp-slot) - (inst bc :<> nil cur-uwp target-uwp DO-UWP) - - (move block cur-uwp) - - DO-EXIT - (loadw cfp-tn cur-uwp unwind-block-cfp-slot) - (loadw code-tn cur-uwp unwind-block-code-slot) - (loadw lra cur-uwp unwind-block-entry-pc-slot) - (lisp-return lra :frob-code nil) - - DO-UWP - (loadw next-uwp cur-uwp unwind-block-uwp-slot) - (inst b DO-EXIT) - (store-symbol-value next-uwp *current-unwind-protect-block*)) - -(define-assembly-routine - (throw - (:return-style :none)) - ((:arg target descriptor-reg a0-offset) - (:arg start any-reg ocfp-offset) - (:arg count any-reg nargs-offset) - (:temp catch any-reg a1-offset) - (:temp tag descriptor-reg a2-offset) - (:temp fix descriptor-reg nl0-offset)) - (declare (ignore start count)) ; We just need them in the registers. - - (load-symbol-value catch *current-catch-block*) - - LOOP - (let ((error (generate-error-code nil 'unseen-throw-tag-error target))) - (inst bc := nil catch zero-tn error)) - (loadw tag catch catch-block-tag-slot) - (inst comb := tag target EXIT :nullify t) - (inst b LOOP) - (loadw catch catch catch-block-previous-catch-slot) - EXIT - (let ((fixup (make-fixup 'unwind :assembly-routine))) - (inst ldil fixup fix) - (inst ble fixup lisp-heap-space fix)) - (move catch target t)) - -#+hpux -(define-assembly-routine - (return-from-lisp-stub (:return-style :none)) - ((:temp lip interior-reg lip-offset) - (:temp nl0 descriptor-reg nl0-offset) - (:temp nl1 descriptor-reg nl1-offset) - (:temp lra descriptor-reg lra-offset)) - ; before calling into lisp we must save our return address (reg_LRA) - (store-symbol-value lra *c-lra*) - ; note the lra we calculate next must "simulate" an fixnum, - ; because compute-calling-frame will use fixnump on this value. - ; either use 16 or 20, finetune it... - (inst addi 19 nl0 lra) ; then setup the new LRA (rest of this routine after branch) - (inst bv lip :nullify t) - (inst word return-pc-widetag) - ; ok, we are back from the lisp-call, lets return to c - ; FIX-lav: steal more stuff from call_into_lisp here, ideally the whole thing - (inst move ocfp-tn csp-tn) ; dont think we should ever get here - (inst nop) - (load-symbol-value nl0 *c-lra*) - (inst addi 1 nl0 nl0) - (inst ble 0 c-text-space nl0 :nullify t)) diff -Nru sbcl-2.0.6/src/assembly/hppa/support.lisp sbcl-2.1.1/src/assembly/hppa/support.lisp --- sbcl-2.0.6/src/assembly/hppa/support.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/hppa/support.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -;;;; the machine-specific support routines needed by the file assembler - -;;;; 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") - -(defun generate-call-sequence (name style vop options) - (declare (ignore options)) - (ecase style - ((:raw :none) - (with-unique-names (fixup) - (values - `((let ((fixup (make-fixup ',name :assembly-routine))) - (inst ldil fixup ,fixup) - (inst ble fixup lisp-heap-space ,fixup :nullify t))) - `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) - ,fixup))))) - (:full-call - (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) - (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code code-tn lra-label ,temp ,lra) - (note-next-instruction ,vop :call-site) - (let ((fixup (make-fixup ',name :assembly-routine))) - (inst ldil fixup ,temp) - (inst be fixup lisp-heap-space ,temp :nullify t)) - (without-scheduling () - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (inst move ocfp-tn csp-tn) - (inst nop)) ; this nop is here because of emit-return-pc align - (inst compute-code-from-lra code-tn lra-label ,temp code-tn) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:save-p t))))))) - -(defun generate-return-sequence (style) - (ecase style - (:raw - `((inst bv lip-tn :nullify t))) - (:full-call - `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset lra-offset) - :offset 1))) - (:none))) - -(defun return-machine-address (scp) - (context-register scp lip-offset)) diff -Nru sbcl-2.0.6/src/assembly/hppa/tramps.lisp sbcl-2.1.1/src/assembly/hppa/tramps.lisp --- sbcl-2.0.6/src/assembly/hppa/tramps.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/hppa/tramps.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -;;;; Undefined-function and closure trampoline definitions - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. - -(in-package "SB-VM") - -(define-assembly-routine - (xundefined-tramp (:return-style :none) - (:align n-lowtag-bits) - (:export undefined-tramp - (undefined-tramp-tagged - (+ xundefined-tramp - fun-pointer-lowtag)))) - ((:temp lra-tn descriptor-reg lra-offset) - (:temp temp non-descriptor-reg nl0-offset)) - (inst word simple-fun-widetag) ;; header - (inst word (make-fixup 'undefined-tramp-tagged - :assembly-routine)) ;; self - (dotimes (i (- simple-fun-insts-offset 2)) - (inst word nil-value)) - - UNDEFINED-TRAMP - ;; Point reg_CODE to the header and tag it as function, since the - ;; debugger regards a function pointer in reg_CODE which doesn't - ;; point to a code object as undefined function. This is (BACKTRACE - ;; UNDEFINED-FUNCTION BUG-353) in the test suite. - (inst addi (- fun-pointer-lowtag - (ash simple-fun-insts-offset word-shift)) - lip-tn code-tn) - - ;; If we are called with stack arguments (or in a tail-call - ;; scenario), we end up with an allocated stack frame, but the frame - ;; link information is uninitialized. Fix things by allocating and - ;; initializing our stack frame "properly". This is (BACKTRACE - ;; UNDEFINED-FUNCTION BUG-346) in the test suite. - - ;; The :NULLIFY T here is technically optional: If we don't nullify - ;; then we execute the following branch, which also doesn't nullify, - ;; and its branch-delay slot becomes (due to the COMIB) the - ;; instruction at NO-STACK-ARGS, and its target is the following - ;; instruction. But that's a bug waiting to happen in the unlikely - ;; event that someone needs to change this logic. - (inst addi (- (fixnumize register-arg-count)) nargs-tn temp) - (inst comb :< temp zero-tn NO-STACK-ARGS :nullify t) - - (inst b FINISH-FRAME-SETUP) - (inst addi (fixnumize register-arg-count) cfp-tn csp-tn) - - NO-STACK-ARGS - (inst add cfp-tn nargs-tn csp-tn) - - FINISH-FRAME-SETUP - (storew ocfp-tn cfp-tn ocfp-save-offset) - (storew lra-tn cfp-tn lra-save-offset) - - ;; Now that the preliminaries are dealt with, actually trap. - (error-call nil 'undefined-fun-error fdefn-tn)) - -; we need closure-tramp and funcallable-instance-tramp in -; same space as other lisp-code, because caller is doing -; normal lisp-calls where we doesnt specify space. -; if we doesnt have the lisp-function (code from defun, closure, lambda etc..) -; machine-address, resolve it here and jump to it. -(define-assembly-routine - (closure-tramp (:return-style :none)) - ((:temp lip interior-reg lip-offset) - (:temp nl0 descriptor-reg nl0-offset)) - (inst ldw (- (* fdefn-fun-slot n-word-bytes) - other-pointer-lowtag) - fdefn-tn lexenv-tn) - (inst ldw (- (* closure-fun-slot n-word-bytes) - fun-pointer-lowtag) - lexenv-tn nl0) - (inst addi (- (* simple-fun-insts-offset n-word-bytes) - fun-pointer-lowtag) - nl0 lip) - (inst bv lip :nullify t)) - -(define-assembly-routine - (funcallable-instance-tramp-header - (:return-style :none) - (:align n-lowtag-bits) - (:export (funcallable-instance-tramp - (+ funcallable-instance-tramp-header - fun-pointer-lowtag)))) - nil - (inst word simple-fun-widetag) ;;header - (inst word (make-fixup 'funcallable-instance-tramp :assembly-routine)) ;; self - (dotimes (i (- simple-fun-insts-offset 2)) - (inst word nil-value)) - (loadw lexenv-tn lexenv-tn - funcallable-instance-function-slot - fun-pointer-lowtag) - (loadw code-tn lexenv-tn - closure-fun-slot - fun-pointer-lowtag) - (inst addi (- (* simple-fun-insts-offset n-word-bytes) - fun-pointer-lowtag) code-tn lip-tn) - (inst bv lip-tn :nullify t)) diff -Nru sbcl-2.0.6/src/assembly/x86-64/alloc.lisp sbcl-2.1.1/src/assembly/x86-64/alloc.lisp --- sbcl-2.0.6/src/assembly/x86-64/alloc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/x86-64/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -80,7 +80,7 @@ (pseudo-atomic () (assemble () ; for conversion of tagbody-like labels to assembler labels RETRY - (inst bts :qword free-tls-index-ea lock-bit :lock) + (inst bts :qword :lock free-tls-index-ea lock-bit) (inst jmp :nc got-tls-index-lock) (inst pause) ; spin loop hint ;; TODO: yielding the CPU here might be a good idea @@ -93,7 +93,7 @@ ;; CMP against memory showed the tls-index to be valid, so clear the lock ;; and re-read the memory (safe because transition can only occur to ;; a nonzero value), then jump out to end the PA section. - (inst btr :qword free-tls-index-ea lock-bit :lock) + (inst btr :qword :lock free-tls-index-ea lock-bit) (inst mov :dword symbol (tls-index-of symbol)) (inst jmp done) NEW-TLS-INDEX @@ -109,7 +109,7 @@ ;; Load scratch-reg with a constant that clears the lock bit ;; and bumps the free index in one go. (inst mov scratch-reg (+ (- (ash 1 lock-bit)) n-word-bytes)) - (inst add :qword free-tls-index-ea scratch-reg :lock) + (inst add :qword :lock free-tls-index-ea scratch-reg) (inst pop scratch-reg) DONE)) ; end PSEUDO-ATOMIC (inst ret) @@ -117,7 +117,7 @@ ;; The disassembly of this code looks nicer when the failure path ;; immediately follows the ordinary path vs. being in *ELSEWHERE*. (inst pop scratch-reg) ; balance the stack - (inst btr :qword free-tls-index-ea lock-bit :lock) + (inst btr :qword :lock free-tls-index-ea lock-bit) (%clear-pseudo-atomic) ;; There's a spurious RET instruction auto-inserted, but no matter. (error-call nil 'tls-exhausted-error))) diff -Nru sbcl-2.0.6/src/assembly/x86-64/arith.lisp sbcl-2.1.1/src/assembly/x86-64/arith.lisp --- sbcl-2.0.6/src/assembly/x86-64/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/x86-64/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -301,11 +301,7 @@ (inst not rdx) POSITIVE)) (unless (memq :popcnt *backend-subfeatures*) - ;; POPCNT = ECX bit 23 - (multiple-value-bind (byte bit) (floor (+ 23 n-fixnum-tag-bits) - n-byte-bits) - (inst test :byte - (static-symbol-value-ea '*cpuid-fn1-ecx* byte) (ash 1 bit))) + (test-cpu-feature cpu-has-popcnt) (inst jmp :z slow)) ;; 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 diff -Nru sbcl-2.0.6/src/assembly/x86-64/assem-rtns.lisp sbcl-2.1.1/src/assembly/x86-64/assem-rtns.lisp --- sbcl-2.0.6/src/assembly/x86-64/assem-rtns.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/x86-64/assem-rtns.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -422,7 +422,7 @@ (inst cmp temp-reg-tn (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 (ea rdi-tn) temp-reg-tn :lock) + (inst bts :dword :lock (ea rdi-tn) temp-reg-tn) (inst jmp store)) TRY-DYNAMIC-SPACE @@ -440,20 +440,20 @@ (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 (ea 6 temp-reg-tn) (lognot (ash 1 5)) :lock)) + (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 (ea 8 temp-reg-tn) (lognot (ash 1 5)) :lock))) + (inst and :byte :lock (ea 8 temp-reg-tn) (lognot (ash 1 5))))) 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 ;; set 'written' flag in the code header - (inst or :byte (ea (- 3 other-pointer-lowtag) rdi-tn) #x40 :lock) + (inst or :byte :lock (ea (- 3 other-pointer-lowtag) rdi-tn) #x40) ;; store newval into object (inst mov (ea (- other-pointer-lowtag) rdi-tn temp-reg-tn n-word-bytes) rax-tn))) @@ -480,7 +480,7 @@ (inst push rax-tn) (inst mov rax-tn (thread-slot-ea thread-varyobj-card-marks-slot)) - (inst bts :dword (ea rax-tn) temp-reg-tn :lock) + (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.0.6/src/assembly/x86-64/support.lisp sbcl-2.1.1/src/assembly/x86-64/support.lisp --- sbcl-2.0.6/src/assembly/x86-64/support.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/x86-64/support.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -9,6 +9,11 @@ (in-package "SB-VM") +(defun test-cpu-feature (feature-bit) + (multiple-value-bind (byte bit) + (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) (declare (ignorable vop)) (let ((fixup diff -Nru sbcl-2.0.6/src/assembly/x86-64/tramps.lisp sbcl-2.1.1/src/assembly/x86-64/tramps.lisp --- sbcl-2.0.6/src/assembly/x86-64/tramps.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/assembly/x86-64/tramps.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -57,13 +57,6 @@ (inst xor :byte rdi-tn 1) ; clear the bit (inst jmp (make-fixup "alloc" :foreign))) -;;; There's no layout allocator preserving YMM regs because MAKE-LAYOUT entails a full call. -#+immobile-space -(define-assembly-routine (alloc-layout) () - (with-registers-preserved (c xmm :except r11-tn) - (inst call (make-fixup "alloc_layout" :foreign)) - (inst mov r11-tn rax-tn))) - ;;; 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. @@ -137,8 +130,7 @@ (define-assembly-routine (ensure-symbol-hash (:return-style :raw)) () #+avx2 (progn - (inst mov temp-reg-tn (ea (make-fixup "avx2_supported" :foreign-dataref))) - (inst test :byte (ea temp-reg-tn) 1) + (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 @@ -156,8 +148,7 @@ () #+avx2 (progn - (inst mov temp-reg-tn (ea (make-fixup "avx2_supported" :foreign-dataref))) - (inst test :byte (ea temp-reg-tn) 1) + (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 @@ -173,19 +164,16 @@ (define-assembly-routine (invalid-layout-trap (:return-style :none)) () #+avx2 (progn - (inst mov temp-reg-tn (ea (make-fixup "avx2_supported" :foreign-dataref))) - (inst test :byte (ea temp-reg-tn) 1) + (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)) ; arg1 - (inst mov rdi-tn (ea 24 rbp-tn)) ; arg2 - (call-static-fun 'update-object-layout-or-invalid 2) - (inst mov (ea 24 rbp-tn) rdx-tn)) ; result to arg passing loc - (inst ret 8)) ; remove 1 arg. Caller pops the result + (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) - (inst mov rdx-tn (ea 16 rbp-tn)) ; arg1 - (inst mov rdi-tn (ea 24 rbp-tn)) ; arg2 - (call-static-fun 'update-object-layout-or-invalid 2) - (inst mov (ea 24 rbp-tn) rdx-tn)) ; result to arg passing loc - (inst ret 8)) ; remove 1 arg. Caller pops the result + (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 diff -Nru sbcl-2.0.6/src/code/alien-callback.lisp sbcl-2.1.1/src/code/alien-callback.lisp --- sbcl-2.0.6/src/code/alien-callback.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/alien-callback.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -110,16 +110,13 @@ ;; bother anyone about that sad fact (declare (muffle-conditions compiler-note) (optimize speed)) - ;; FIXME: the saps are not gc safe - (let ((args-sap (int-sap - (sb-kernel:get-lisp-obj-address args-pointer))) - (res-sap (int-sap - (sb-kernel:get-lisp-obj-address result-pointer)))) + (let ((args-sap (descriptor-sap args-pointer)) + (res-sap (descriptor-sap result-pointer))) (declare (ignorable args-sap res-sap)) - (with-alien + (let ,(loop with offset = 0 - for spec in argument-specs + for spec in argument-specs ;; KLUDGE: At least one platform requires additional ;; alignment beyond a single machine word for certain ;; arguments. Accept an additional delta (for the @@ -130,8 +127,7 @@ for (accessor-form alignment) = (multiple-value-list (alien-callback-accessor-form spec 'args-sap offset)) - collect `(,(pop argument-names) ,spec - :local ,accessor-form) + collect `(,(pop argument-names) ,accessor-form) do (incf offset (+ (alien-callback-argument-bytes spec env) (or alignment 0)))) ,(flet ((store (spec real-type) @@ -295,11 +291,17 @@ (in-package "SB-THREAD") #+sb-thread (defun enter-foreign-callback (index return arguments) - (let ((thread (without-gcing - ;; Hold off GCing until *current-thread* is set up - (let ((thread (make-foreign-thread :name "foreign callback"))) - (init-thread-local-storage thread) - thread)))) - (dx-flet ((enter () - (sb-alien::enter-alien-callback index return arguments))) - (new-lisp-thread-trampoline thread nil #'enter nil)))) + (let ((thread (init-thread-local-storage (make-foreign-thread)))) + #+pauseless-threadstart + (dx-let ((startup-info (vector nil ; trampoline is n/a + nil ; cell in *STARTING-THREADS* is n/a + #'sb-alien::enter-alien-callback + (list index return arguments) + nil nil))) ; sigmask + fpu state bits + (copy-primitive-thread-fields thread) + (setf (thread-startup-info thread) startup-info) + (update-all-threads (thread-primitive-thread thread) thread) + (run)) + #-pauseless-threadstart + (dx-let ((args (list index return arguments))) + (run thread nil #'sb-alien::enter-alien-callback args)))) diff -Nru sbcl-2.0.6/src/code/alieneval.lisp sbcl-2.1.1/src/code/alieneval.lisp --- sbcl-2.0.6/src/code/alieneval.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/code/alieneval.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,1300 @@ +;;;; This file contains parts of the Alien implementation that +;;;; are not part of the compiler. + +;;;; 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-ALIEN") + +#-sb-xc-host (sb-impl::define-thread-local *saved-fp* nil) + +(defvar *default-c-string-external-format* nil) + + +;;;; utility functions + +(defun align-offset (offset alignment) + (let ((extra (rem offset alignment))) + (if (zerop extra) offset (+ offset (- alignment extra))))) + +(defun guess-alignment (bits) + (cond ((null bits) nil) + #-(or (and x86 (not win32)) (and ppc darwin)) ((> bits 32) 64) + ((> bits 16) 32) + ((> bits 8) 16) + ((> bits 1) 8) + (t 1))) + + +;;;; ALIEN-TYPE-INFO stuff + +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) + +(defstruct (alien-type-class (:copier nil)) + (name nil :type symbol) + (defstruct-name nil :type symbol) + (include nil :type (or null alien-type-class)) + (unparse nil :type (or null function)) + (type= nil :type (or null function)) + (lisp-rep nil :type (or null function)) + (alien-rep nil :type (or null function)) + (extract-gen nil :type (or null function)) + (deposit-gen nil :type (or null function)) + (naturalize-gen nil :type (or null function)) + (deport-gen nil :type (or null function)) + (deport-alloc-gen nil :type (or null function)) + (deport-pin-p nil :type (or null function)) + ;; Cast? + (arg-tn nil :type (or null function)) + (result-tn nil :type (or null function)) + (subtypep nil :type (or null function))) + +(defmethod print-object ((type-class alien-type-class) stream) + (print-unreadable-object (type-class stream :type t) + (prin1 (alien-type-class-name type-class) stream))) + +;;; An benefit of EQL tables of symbols is that they will never rehash due to key +;;; movement, because they use the symbol's hash which is constant even across +;;; core restart, whereas EQ tables might rehash. +;;; Perhaps we should consider using SXHASH on symbols for EQ tables. +;;; And frankly, why isn't this particular table not a globaldb info instead? +(defglobal *alien-type-classes* (make-hash-table)) ; keys are symbols + +(defun alien-type-class-or-lose (name) + (or (gethash name *alien-type-classes*) + (error "no alien type class ~S" name))) + +(defun create-alien-type-class-if-necessary (name defstruct-name include) + (let ((old (gethash name *alien-type-classes*)) + (include (and include (alien-type-class-or-lose include)))) + (if old + (setf (alien-type-class-include old) include) + (setf (gethash name *alien-type-classes*) + (make-alien-type-class :name name + :defstruct-name defstruct-name + :include include))))) + +(defconstant-eqx +method-slot-alist+ + '((:unparse . alien-type-class-unparse) + (:type= . alien-type-class-type=) + (:subtypep . alien-type-class-subtypep) + (:lisp-rep . alien-type-class-lisp-rep) + (:alien-rep . alien-type-class-alien-rep) + (:extract-gen . alien-type-class-extract-gen) + (:deposit-gen . alien-type-class-deposit-gen) + (:naturalize-gen . alien-type-class-naturalize-gen) + (:deport-gen . alien-type-class-deport-gen) + (:deport-alloc-gen . alien-type-class-deport-alloc-gen) + (:deport-pin-p . alien-type-class-deport-pin-p) + ;; cast? + (:arg-tn . alien-type-class-arg-tn) + (:result-tn . alien-type-class-result-tn)) + #'equal) + +(defun method-slot (method) + (cdr (or (assoc method +method-slot-alist+) + (error "no method ~S" method)))) + +) ; EVAL-WHEN + +;;; We define a keyword "BOA" constructor so that we can reference the +;;; slot names in init forms. +(defmacro define-alien-type-class ((name &key include include-args) &rest slots) + (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE"))) + (multiple-value-bind (include include-defstruct overrides) + (etypecase include + (null + (values nil 'alien-type nil)) + (symbol + (values + include + (alien-type-class-defstruct-name + (alien-type-class-or-lose include)) + nil)) + (list + (values + (car include) + (alien-type-class-defstruct-name + (alien-type-class-or-lose (car include))) + (cdr include)))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (create-alien-type-class-if-necessary ',name ',defstruct-name + ',(or include 'root))) + (setf (info :source-location :alien-type ',name) + (sb-c:source-location)) + (def!struct (,defstruct-name + (:include ,include-defstruct + (class ',name) + ,@overrides) + (:copier nil) + (:constructor + ,(symbolicate "MAKE-" defstruct-name) + (&key class bits alignment + ,@(mapcar (lambda (x) + (if (atom x) x (car x))) + slots) + ,@include-args + ;; KLUDGE + &aux (alignment (or alignment (guess-alignment bits)))))) + ,@slots))))) + +(defmacro define-alien-type-method ((class method) lambda-list &rest body) + (let ((defun-name (symbolicate class "-" method "-METHOD"))) + `(progn + (defun ,defun-name ,lambda-list + ,@body) + (setf (,(method-slot method) (alien-type-class-or-lose ',class)) + #',defun-name)))) + +(defmacro invoke-alien-type-method (method type &rest args) + (let ((slot (method-slot method))) + (once-only ((type type)) + `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type)) + (alien-type-class-include class))) + ((null class) + (error "method ~S not defined for ~S" + ',method (alien-type-class ,type))) + (let ((fn (,slot class))) + (when fn + (return fn)))) + ,type ,@args)))) + + +;;;; the root alien type + +(eval-when (:compile-toplevel :load-toplevel :execute) + (create-alien-type-class-if-necessary 'root 'alien-type nil)) + +(defmethod print-object ((type alien-type) stream) + (print-unreadable-object (type stream :type t) + (sb-impl:print-type-specifier stream (unparse-alien-type type)))) + + +;;;; type parsing and unparsing + +(defvar *new-auxiliary-types* nil) + +;;; Process stuff in a new scope. +(defmacro with-auxiliary-alien-types (env &body body) + ``(symbol-macrolet ((&auxiliary-type-definitions& + ,(append *new-auxiliary-types* + (auxiliary-type-definitions ,env)))) + ,(let ((*new-auxiliary-types* nil)) + ,@body))) + +;;; CMU CL used COMPILER-LET to bind *AUXILIARY-TYPE-DEFINITIONS*, and +;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we +;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve +;;; a similar effect. +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) + (defun auxiliary-type-definitions (env) + (multiple-value-bind (result expanded-p) + (%macroexpand '&auxiliary-type-definitions& env) + (if expanded-p + result + ;; This is like having the global symbol-macro definition be + ;; NIL, but global symbol-macros make me vaguely queasy, so + ;; I do it this way instead. + nil)))) + +;;; Parse TYPE as an alien type specifier and return the resultant +;;; ALIEN-TYPE structure. +(defun parse-alien-type (type env) + (declare (type sb-kernel:lexenv-designator env)) + (if (consp type) + (let ((translator (info :alien-type :translator (car type)))) + (unless translator + (error "unknown alien type: ~/sb-impl:print-type-specifier/" + type)) + (funcall translator type env)) + (ecase (info :alien-type :kind type) + (:primitive + (let ((translator (info :alien-type :translator type))) + (unless translator + (error "no translator for primitive alien type ~ + ~/sb-impl:print-type-specifier/" + type)) + (funcall translator (list type) env))) + (:defined + (or (info :alien-type :definition type) + (error "no definition for alien type ~/sb-impl:print-type-specifier/" + type))) + (:unknown + (error "unknown alien type: ~/sb-impl:print-type-specifier/" + type))))) + +(defun auxiliary-alien-type (kind name env) + (declare (type sb-kernel:lexenv-designator env)) + (flet ((aux-defn-matches (x) + (and (eq (first x) kind) (eq (second x) name)))) + (let ((in-auxiliaries + (or (find-if #'aux-defn-matches *new-auxiliary-types*) + (find-if #'aux-defn-matches (auxiliary-type-definitions env))))) + (if in-auxiliaries + (values (third in-auxiliaries) t) + (info :alien-type kind name))))) + +(defun (setf auxiliary-alien-type) (new-value kind name env) + (declare (type sb-kernel:lexenv-designator env)) + (flet ((aux-defn-matches (x) + (and (eq (first x) kind) (eq (second x) name)))) + (when (find-if #'aux-defn-matches *new-auxiliary-types*) + (error "attempt to multiply define ~A ~S" kind name)) + (when (find-if #'aux-defn-matches (auxiliary-type-definitions env)) + (error "attempt to shadow definition of ~A ~S" kind name))) + (push (list kind name new-value) *new-auxiliary-types*) + new-value) + +(defun verify-local-auxiliaries-okay () + (dolist (info *new-auxiliary-types*) + (destructuring-bind (kind name defn) info + (declare (ignore defn)) + (when (info :alien-type kind name) + (error "attempt to shadow definition of ~A ~S" kind name))))) + +;;; the list of record types that have already been unparsed. This is +;;; used to keep from outputting the slots again if the same structure +;;; shows up twice. +(defvar *record-types-already-unparsed*) + +(defun unparse-alien-type (type) + "Convert the alien-type structure TYPE back into a list specification of + the type." + (declare (type alien-type type)) + (let ((*record-types-already-unparsed* nil)) + (%unparse-alien-type type))) + +;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we +;;; need to recurse inside the binding of +;;; *RECORD-TYPES-ALREADY-UNPARSED*. +(defun %unparse-alien-type (type) + (invoke-alien-type-method :unparse type)) + + +;;;; alien type defining stuff + +(defmacro define-alien-type-translator (name lambda-list &body body) + (let ((defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")) + (macro-lambda + (make-macro-lambda nil lambda-list body + 'define-alien-type-translator name))) + `(progn + (defun ,defun-name ,(second macro-lambda) ,@(cddr macro-lambda)) + (%define-alien-type-translator ',name #',defun-name)))) + +(defun %define-alien-type-translator (name translator) + (setf (info :alien-type :kind name) :primitive) + (setf (info :alien-type :translator name) translator) + (clear-info :alien-type :definition name) + name) + +(defmacro define-alien-type (name type &environment env) + "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for + STRUCT and UNION types, in which case the name is taken from the type + specifier." + (with-auxiliary-alien-types env + (let ((alien-type (parse-alien-type type env))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(when *new-auxiliary-types* + `((%def-auxiliary-alien-types ',*new-auxiliary-types* + (sb-c:source-location)))) + ,@(when name + `((%define-alien-type ',name ',alien-type (sb-c:source-location)))))))) + +(defun %def-auxiliary-alien-types (types source-location) + (dolist (info types) + ;; Clear up the type we're about to define from the toplevel + ;; *new-auxiliary-types* (local scopes take care of themselves). + ;; Unless this is done we never actually get back the full type + ;; from INFO, since the *new-auxiliary-types* have precendence. + (setf *new-auxiliary-types* + (remove info *new-auxiliary-types* + :test (lambda (a b) + (and (eq (first a) (first b)) + (eq (second a) (second b)))))) + (destructuring-bind (kind name defn) info + (let ((old (info :alien-type kind name))) + (unless (or (null old) (alien-type-= old defn)) + (warn "redefining ~A ~S to be:~% ~S,~%was:~% ~S" + kind name defn old))) + (setf (info :alien-type kind name) defn + (info :source-location :alien-type name) source-location)))) + +(defun %define-alien-type (name new source-location) + (ecase (info :alien-type :kind name) + (:primitive + (error "~/sb-impl:print-type-specifier/ is a built-in alien type." + name)) + (:defined + (let ((old (info :alien-type :definition name))) + (unless (or (null old) (alien-type-= new old)) + (warn "redefining ~S to be:~% ~ + ~/sb-impl:print-type-specifier/,~%was~% ~ + ~/sb-impl:print-type-specifier/" + name + (unparse-alien-type new) + (unparse-alien-type old))))) + (:unknown)) + (setf (info :alien-type :definition name) new) + (setf (info :alien-type :kind name) :defined) + (setf (info :source-location :alien-type name) source-location) + name) + + +;;;; Interfaces to the different methods + +(defun alien-type-= (type1 type2) + "Return T iff TYPE1 and TYPE2 describe equivalent alien types." + (or (eq type1 type2) + (and (eq (alien-type-class type1) + (alien-type-class type2)) + (invoke-alien-type-method :type= type1 type2)))) + +(defun alien-subtype-p (type1 type2) + "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the + only supported subtype relationships are is that any pointer type is a + subtype of (* t), and any array type first dimension will match + (array nil ...). Otherwise, the two types have to be + ALIEN-TYPE-=." + (or (eq type1 type2) + (invoke-alien-type-method :subtypep type1 type2))) + +(defun compute-naturalize-lambda (type) + `(lambda (alien ignore) + (declare (ignore ignore)) + ,(invoke-alien-type-method :naturalize-gen type 'alien))) + +(defun compute-deport-lambda (type) + (declare (type alien-type type)) + (/noshow "entering COMPUTE-DEPORT-LAMBDA" type) + (multiple-value-bind (form value-type) + (invoke-alien-type-method :deport-gen type 'value) + `(lambda (value ignore) + (declare (type ,(or value-type + (compute-lisp-rep-type type) + `(alien ,type)) + value) + (ignore ignore)) + ,form))) + +(defun compute-deport-alloc-lambda (type) + `(lambda (value ignore) + (declare (ignore ignore)) + ,(invoke-alien-type-method :deport-alloc-gen type 'value))) + +(defun compute-extract-lambda (type) + (let ((extract (invoke-alien-type-method :extract-gen type 'sap 'offset))) + `(lambda (sap offset ignore) + (declare (type system-area-pointer sap) + (type unsigned-byte offset) + (ignore ignore)) + ,(if (eq (alien-type-class type) 'integer) + extract + `(naturalize ,extract ',type))))) + +(defun compute-deposit-lambda (type) + (declare (type alien-type type)) + `(lambda (value sap offset ignore) + (declare (type system-area-pointer sap) + (type unsigned-byte offset) + (ignore ignore)) + (let ((alloc-tmp (deport-alloc value ',type))) + (maybe-with-pinned-objects (alloc-tmp) (,type) + (let ((value (deport alloc-tmp ',type))) + ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value) + ;; Note: the reason we don't just return the pre-deported value + ;; is because that would inhibit any (deport (naturalize ...)) + ;; optimizations that might have otherwise happen. Re-naturalizing + ;; the value might cause extra consing, but is flushable, so probably + ;; results in better code. + (naturalize value ',type)))))) + +(defun compute-lisp-rep-type (type) + (invoke-alien-type-method :lisp-rep type)) + +;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function +;;; return values). See the :ALIEN-REP method for INTEGER for +;;; details. +(defun compute-alien-rep-type (type &optional (context :normal)) + (invoke-alien-type-method :alien-rep type context)) + + +;;;; default methods + +(defun missing-alien-operation-error (type operation) + (error "Cannot ~A aliens of type ~/sb-impl:print-type-specifier/." + operation type)) + +(define-alien-type-method (root :unparse) (type) + `( ,(type-of type))) + +(define-alien-type-method (root :type=) (type1 type2) + (declare (ignore type1 type2)) + t) + +(define-alien-type-method (root :subtypep) (type1 type2) + (alien-type-= type1 type2)) + +(define-alien-type-method (root :lisp-rep) (type) + (declare (ignore type)) + nil) + +(define-alien-type-method (root :alien-rep) (type context) + (declare (ignore type context)) + '*) + +(define-alien-type-method (root :naturalize-gen) (type alien) + (declare (ignore alien)) + (missing-alien-operation-error "represent" type)) + +(define-alien-type-method (root :deport-gen) (type object) + (declare (ignore object)) + (missing-alien-operation-error "represent" type)) + +(define-alien-type-method (root :deport-alloc-gen) (type object) + (declare (ignore type)) + object) + +(define-alien-type-method (root :deport-pin-p) (type) + (declare (ignore type)) + ;; Override this method to return T for classes which take a SAP to a + ;; GCable lisp object when deporting. + nil) + +(define-alien-type-method (root :extract-gen) (type sap offset) + (declare (ignore sap offset)) + (missing-alien-operation-error "represent" type)) + +(define-alien-type-method (root :deposit-gen) (type sap offset value) + `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value)) + +(define-alien-type-method (root :arg-tn) (type state) + (declare (ignore state)) + (missing-alien-operation-error "pass as argument to CALL-OUT" + (unparse-alien-type type))) + +(define-alien-type-method (root :result-tn) (type state) + (declare (ignore state)) + (missing-alien-operation-error "return from CALL-OUT" + (unparse-alien-type type))) + +;;;; the INTEGER type + +(define-alien-type-class (integer) + (signed t :type (member t nil))) + +(define-alien-type-translator signed (&optional (bits sb-vm:n-word-bits)) + (make-alien-integer-type :bits bits)) + +(define-alien-type-translator integer (&optional (bits sb-vm:n-word-bits)) + (make-alien-integer-type :bits bits)) + +(define-alien-type-translator unsigned (&optional (bits sb-vm:n-word-bits)) + (make-alien-integer-type :bits bits :signed nil)) + +(define-alien-type-method (integer :unparse) (type) + (list (if (alien-integer-type-signed type) 'signed 'unsigned) + (alien-integer-type-bits type))) + +(define-alien-type-method (integer :type=) (type1 type2) + (and (eq (alien-integer-type-signed type1) + (alien-integer-type-signed type2)) + (= (alien-integer-type-bits type1) + (alien-integer-type-bits type2)))) + +(define-alien-type-method (integer :lisp-rep) (type) + (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) + (alien-integer-type-bits type))) + +(define-alien-type-method (integer :alien-rep) (type context) + ;; When returning integer values that are narrower than a machine + ;; register from a function, some platforms leave the higher bits of + ;; 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). + (ecase context + ((:normal #-(or x86 x86-64) :result) + (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) + (alien-integer-type-bits type))) + #+(or x86 x86-64) + (:result + (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) + (max (alien-integer-type-bits type) + sb-vm:n-machine-word-bits))))) + +;;; As per the comment in the :ALIEN-REP method above, this is defined +;;; elsewhere for x86oids. +#-(or x86 x86-64) +(define-alien-type-method (integer :naturalize-gen) (type alien) + (declare (ignore type)) + alien) + +(define-alien-type-method (integer :deport-gen) (type value) + (declare (ignore type)) + value) + +(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))))) + (if ref-fun + `(,ref-fun ,sap (/ ,offset sb-vm:n-byte-bits)) + (error "cannot extract ~W-bit integers" + (alien-integer-type-bits type))))) + +;;;; the BOOLEAN type + +(define-alien-type-class (boolean :include integer :include-args (signed))) + +;;; FIXME: Check to make sure that we aren't attaching user-readable +;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance. +(define-alien-type-translator boolean (&optional (bits sb-vm:n-word-bits)) + (make-alien-boolean-type :bits bits :signed nil)) + +(define-alien-type-method (boolean :unparse) (type) + `(boolean ,(alien-boolean-type-bits type))) + +(define-alien-type-method (boolean :lisp-rep) (type) + (declare (ignore type)) + `(member t nil)) + +(define-alien-type-method (boolean :naturalize-gen) (type alien) + (let ((bits (alien-boolean-type-bits type))) + (if (= bits sb-vm:n-word-bits) + `(not (zerop ,alien)) + `(logtest ,alien ,(ldb (byte bits 0) -1))))) + +(define-alien-type-method (boolean :deport-gen) (type value) + (declare (ignore type)) + `(if ,value 1 0)) + +;;;; the ENUM type + +(define-alien-type-class (enum :include (integer (bits 32)) + :include-args (signed)) + name ; name of this enum (if any) + from ; alist from symbols to integers + to ; alist or vector from integers to symbols + kind ; kind of from mapping, :VECTOR or :ALIST + offset) ; offset to add to value for :VECTOR from mapping + +(define-alien-type-translator enum (&whole + type name + &rest mappings + &environment env) + (cond (mappings + (let ((result (parse-enum name mappings))) + (when name + (multiple-value-bind (old old-p) + (auxiliary-alien-type :enum name env) + (when old-p + (unless (alien-type-= result old) + (cerror "Continue, clobbering the old definition" + "Incompatible alien enum type definition: ~S" name) + (setf (alien-enum-type-from old) (alien-enum-type-from result) + (alien-enum-type-to old) (alien-enum-type-to result) + (alien-enum-type-kind old) (alien-enum-type-kind result) + (alien-enum-type-offset old) (alien-enum-type-offset result) + (alien-enum-type-signed old) (alien-enum-type-signed result))) + (setf result old)) + (unless old-p + (setf (auxiliary-alien-type :enum name env) result)))) + result)) + (name + (multiple-value-bind (result found) + (auxiliary-alien-type :enum name env) + (unless found + (error "unknown enum type: ~S" name)) + result)) + (t + (error "empty enum type: ~S" type)))) + +(defun parse-enum (name elements) + (when (null elements) + (error "An enumeration must contain at least one element.")) + (let ((min nil) + (max nil) + (from-alist ()) + (prev -1)) + (declare (list from-alist)) + (dolist (el elements) + (multiple-value-bind (sym val) + (if (listp el) + (values (first el) (second el)) + (values el (1+ prev))) + (setf prev val) + (unless (symbolp sym) + (error "The enumeration element ~S is not a symbol." sym)) + (unless (integerp val) + (error "The element value ~S is not an integer." val)) + (unless (and max (> max val)) (setq max val)) + (unless (and min (< min val)) (setq min val)) + (when (rassoc val from-alist) + (style-warn "The element value ~S is used more than once." val)) + (when (assoc sym from-alist :test #'eq) + (error "The enumeration element ~S is used more than once." sym)) + (push (cons sym val) from-alist))) + (let* ((signed (minusp min)) + (min-bits (if signed + (1+ (max (integer-length min) + (integer-length max))) + (integer-length max)))) + (when (> min-bits 32) + (error "can't represent enums needing more than 32 bits")) + (setf from-alist (sort from-alist #'< :key #'cdr)) + (cond + ;; If range is at least 20% dense, use vector mapping. Crossover + ;; point solely on basis of space would be 25%. Vector mapping + ;; is always faster, so give the benefit of the doubt. + ((>= (/ (length from-alist) (1+ (- max min))) 2/10) + ;; If offset is small and ignorable, ignore it to save time. + (when (< 0 min 10) (setq min 0)) + (let ((to (make-array (1+ (- max min))))) + (dolist (el from-alist) + (setf (svref to (- (cdr el) min)) (car el))) + (make-alien-enum-type :name name :signed signed + :from from-alist :to to :kind + :vector :offset (- min)))) + (t + (make-alien-enum-type :name name :signed signed + :from from-alist + :to (mapcar (lambda (x) (cons (cdr x) (car x))) + from-alist) + :kind :alist)))))) + +(define-alien-type-method (enum :unparse) (type) + `(enum ,(alien-enum-type-name type) + ,@(let ((prev -1)) + (mapcar (lambda (mapping) + (let ((sym (car mapping)) + (value (cdr mapping))) + (prog1 + (if (= (1+ prev) value) + sym + `(,sym ,value)) + (setf prev value)))) + (alien-enum-type-from type))))) + +(define-alien-type-method (enum :type=) (type1 type2) + (and (eq (alien-enum-type-name type1) + (alien-enum-type-name type2)) + (equal (alien-enum-type-from type1) + (alien-enum-type-from type2)))) + +(define-alien-type-method (enum :lisp-rep) (type) + `(member ,@(mapcar #'car (alien-enum-type-from type)))) + +(define-alien-type-method (enum :naturalize-gen) (type alien) + (ecase (alien-enum-type-kind type) + (:vector + `(svref ',(alien-enum-type-to type) + (+ ,alien ,(alien-enum-type-offset type)))) + (:alist + `(ecase ,alien + ,@(mapcar (lambda (mapping) + `(,(car mapping) ',(cdr mapping))) + (alien-enum-type-to type)))))) + +(define-alien-type-method (enum :deport-gen) (type value) + `(ecase ,value + ,@(mapcar (lambda (mapping) + `(,(car mapping) ,(cdr mapping))) + (alien-enum-type-from type)))) + +;;;; the FLOAT types + +(define-alien-type-class (float) + (type (missing-arg) :type symbol)) + +(define-alien-type-method (float :unparse) (type) + (alien-float-type-type type)) + +(define-alien-type-method (float :lisp-rep) (type) + (alien-float-type-type type)) + +(define-alien-type-method (float :alien-rep) (type context) + (declare (ignore context)) + (alien-float-type-type type)) + +(define-alien-type-method (float :naturalize-gen) (type alien) + (declare (ignore type)) + alien) + +(define-alien-type-method (float :deport-gen) (type value) + (declare (ignore type)) + value) + +(define-alien-type-class (single-float :include (float (bits 32)) + :include-args (type))) + +(define-alien-type-translator single-float () + (make-alien-single-float-type :type 'single-float)) + +(define-alien-type-method (single-float :extract-gen) (type sap offset) + (declare (ignore type)) + `(sap-ref-single ,sap (/ ,offset sb-vm:n-byte-bits))) + +(define-alien-type-class (double-float :include (float (bits 64)) + :include-args (type))) + +(define-alien-type-translator double-float () + (make-alien-double-float-type :type 'double-float)) + +(define-alien-type-method (double-float :extract-gen) (type sap offset) + (declare (ignore type)) + `(sap-ref-double ,sap (/ ,offset sb-vm:n-byte-bits))) + + +;;;; the SAP type + +(define-alien-type-class (system-area-pointer)) + +(define-alien-type-translator system-area-pointer () + (make-alien-system-area-pointer-type + :bits sb-vm:n-machine-word-bits)) + +(define-alien-type-method (system-area-pointer :unparse) (type) + (declare (ignore type)) + 'system-area-pointer) + +(define-alien-type-method (system-area-pointer :lisp-rep) (type) + (declare (ignore type)) + 'system-area-pointer) + +(define-alien-type-method (system-area-pointer :alien-rep) (type context) + (declare (ignore type context)) + 'system-area-pointer) + +(define-alien-type-method (system-area-pointer :naturalize-gen) (type alien) + (declare (ignore type)) + alien) + +(define-alien-type-method (system-area-pointer :deport-gen) (type object) + (declare (ignore type)) + (/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object) + object) + +(define-alien-type-method (system-area-pointer :extract-gen) (type sap offset) + (declare (ignore type)) + `(sap-ref-sap ,sap (/ ,offset sb-vm:n-byte-bits))) + + +;;;; the ALIEN-VALUE type + +(define-alien-type-class (alien-value :include system-area-pointer)) + +(define-alien-type-method (alien-value :lisp-rep) (type) + (declare (ignore type)) + nil) + +(define-alien-type-method (alien-value :naturalize-gen) (type alien) + `(%sap-alien ,alien ',type)) + +(define-alien-type-method (alien-value :deport-gen) (type value) + (declare (ignore type)) + (/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value) + `(alien-sap ,value)) + + +;;;; the POINTER type + +(define-alien-type-class (pointer :include (alien-value (bits + sb-vm:n-machine-word-bits))) + (to nil :type (or alien-type null))) + +(define-alien-type-translator * (to &environment env) + (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env)))) + +(define-alien-type-method (pointer :unparse) (type) + (let ((to (alien-pointer-type-to type))) + `(* ,(if to + (%unparse-alien-type to) + t)))) + +(define-alien-type-method (pointer :type=) (type1 type2) + (let ((to1 (alien-pointer-type-to type1)) + (to2 (alien-pointer-type-to type2))) + (if to1 + (if to2 + (alien-type-= to1 to2) + nil) + (null to2)))) + +(define-alien-type-method (pointer :subtypep) (type1 type2) + (and (alien-pointer-type-p type2) + (let ((to1 (alien-pointer-type-to type1)) + (to2 (alien-pointer-type-to type2))) + (if to1 + (if to2 + (alien-subtype-p to1 to2) + t) + (null to2))))) + +(define-alien-type-method (pointer :deport-gen) (type value) + (/noshow "doing alien type method POINTER :DEPORT-GEN" type value) + (values + ;; FIXME: old version, highlighted a bug in xc optimization + `(etypecase ,value + (null + (int-sap 0)) + (system-area-pointer + ,value) + ((alien ,type) + (alien-sap ,value))) + ;; new version, works around bug in xc optimization + #+nil + `(etypecase ,value + (system-area-pointer + ,value) + ((alien ,type) + (alien-sap ,value)) + (null + (int-sap 0))) + `(or null system-area-pointer (alien ,type)))) + +;;;; the MEM-BLOCK type + +(define-alien-type-class (mem-block :include alien-value)) + +(define-alien-type-method (mem-block :extract-gen) (type sap offset) + (declare (ignore type)) + `(sap+ ,sap (truncate ,offset sb-vm:n-byte-bits))) + +(define-alien-type-method (mem-block :deposit-gen) (type sap offset value) + (let ((bits (alien-mem-block-type-bits type))) + (unless bits + (error "can't deposit aliens of type ~S (unknown size)" type)) + `(sb-kernel:system-area-ub8-copy ,value 0 ,sap + (truncate ,offset sb-vm:n-byte-bits) + ',(truncate bits sb-vm:n-byte-bits)))) + +;;;; the ARRAY type + +(define-alien-type-class (array :include mem-block) + (element-type (missing-arg) :type alien-type) + (dimensions (missing-arg) :type list)) + +(define-alien-type-translator array (ele-type &rest dims &environment env) + + (when dims + (unless (typep (first dims) '(or index null)) + (error "The first dimension is not a non-negative fixnum or NIL: ~S" + (first dims))) + (let ((loser (find-if-not (lambda (x) (typep x 'index)) + (rest dims)))) + (when loser + (error "A dimension is not a non-negative fixnum: ~S" loser)))) + + (let ((parsed-ele-type (parse-alien-type ele-type env))) + (make-alien-array-type + :element-type parsed-ele-type + :dimensions dims + :alignment (alien-type-alignment parsed-ele-type) + :bits (if (and (alien-type-bits parsed-ele-type) + (every #'integerp dims)) + (* (align-offset (alien-type-bits parsed-ele-type) + (alien-type-alignment parsed-ele-type)) + (reduce #'* dims)))))) + +(define-alien-type-method (array :unparse) (type) + `(array ,(%unparse-alien-type (alien-array-type-element-type type)) + ,@(alien-array-type-dimensions type))) + +(define-alien-type-method (array :type=) (type1 type2) + (and (equal (alien-array-type-dimensions type1) + (alien-array-type-dimensions type2)) + (alien-type-= (alien-array-type-element-type type1) + (alien-array-type-element-type type2)))) + +(define-alien-type-method (array :subtypep) (type1 type2) + (and (alien-array-type-p type2) + (let ((dim1 (alien-array-type-dimensions type1)) + (dim2 (alien-array-type-dimensions type2))) + (and (= (length dim1) (length dim2)) + (or (and dim2 + (null (car dim2)) + (equal (cdr dim1) (cdr dim2))) + (equal dim1 dim2)) + (alien-subtype-p (alien-array-type-element-type type1) + (alien-array-type-element-type type2)))))) + +;;;; the RECORD type + +(def!struct (alien-record-field (:copier nil)) + (name (missing-arg) :type symbol) + (type (missing-arg) :type alien-type) + (bits nil :type (or unsigned-byte null)) + (offset 0 :type unsigned-byte)) +(defmethod print-object ((field alien-record-field) stream) + (print-unreadable-object (field stream :type t) + (format stream + "~S ~S~@[:~D~]" + (alien-record-field-type field) + (alien-record-field-name field) + (alien-record-field-bits field)))) +(!set-load-form-method alien-record-field (:xc :target)) + +(define-alien-type-class (record :include mem-block) + (kind :struct :type (member :struct :union)) + (name nil :type (or symbol null)) + (fields nil :type list)) + +(define-alien-type-translator struct (name &rest fields &environment env) + (parse-alien-record-type :struct name fields env)) + +(define-alien-type-translator union (name &rest fields &environment env) + (parse-alien-record-type :union name fields env)) + +;;; FIXME: This is really pretty horrible: we avoid creating new +;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the +;;; system already. This way forward-references sans fields get +;;; "updated" for free to contain the field info. Maybe rename +;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use +;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729 +(defun parse-alien-record-type (kind name fields env) + (declare (type sb-kernel:lexenv-designator env)) + (flet ((frob-type (type new-fields alignment bits) + (setf (alien-record-type-fields type) new-fields + (alien-record-type-alignment type) alignment + (alien-record-type-bits type) bits))) + (cond (fields + (multiple-value-bind (new-fields alignment bits) + (parse-alien-record-fields kind fields env) + (let* ((old (and name (auxiliary-alien-type kind name env))) + (old-fields (and old (alien-record-type-fields old)))) + (when (and old-fields + (notevery #'record-fields-match-p old-fields new-fields)) + (cerror "Continue, clobbering the old definition." + "Incompatible alien record type definition~%Old: ~S~%New: ~S" + (unparse-alien-type old) + `(,(unparse-alien-record-kind kind) + ,name + ,@(let ((*record-types-already-unparsed* '())) + (mapcar #'unparse-alien-record-field new-fields)))) + (frob-type old new-fields alignment bits)) + (if old-fields + old + (let ((type (or old (make-alien-record-type :name name :kind kind)))) + (when (and name (not old)) + (setf (auxiliary-alien-type kind name env) type)) + (frob-type type new-fields alignment bits) + type))))) + (name + (or (auxiliary-alien-type kind name env) + (setf (auxiliary-alien-type kind name env) + (make-alien-record-type :name name :kind kind)))) + (t + (make-alien-record-type :kind kind))))) + +;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union +;;; types. KIND is the kind we are paring the fields of, and FIELDS is the +;;; list of field specifications. +;;; +;;; Result is a list of field objects, overall alignment, and number of bits +(defun parse-alien-record-fields (kind fields env) + (declare (type list fields)) + (let ((total-bits 0) + (overall-alignment 1) + (parsed-fields nil)) + (dolist (field fields) + (destructuring-bind (var type &key alignment bits offset) field + (declare (ignore bits)) + (let* ((field-type (parse-alien-type type env)) + (bits (alien-type-bits field-type)) + (parsed-field + (make-alien-record-field :type field-type + :name var))) + (unless alignment + (setf alignment (alien-type-alignment field-type))) + (push parsed-field parsed-fields) + (when (null bits) + (error "unknown size: ~S" (unparse-alien-type field-type))) + (when (null alignment) + (error "unknown alignment: ~S" (unparse-alien-type field-type))) + (setf overall-alignment (max overall-alignment alignment)) + (ecase kind + (:struct + (let ((offset (or offset (align-offset total-bits alignment)))) + (setf (alien-record-field-offset parsed-field) offset) + (setf total-bits (+ offset bits)))) + (:union + (setf total-bits (max total-bits bits))))))) + (values (nreverse parsed-fields) + overall-alignment + (align-offset total-bits overall-alignment)))) + +(define-alien-type-method (record :unparse) (type) + `(,(unparse-alien-record-kind (alien-record-type-kind type)) + ,(alien-record-type-name type) + ,@(unless (member type *record-types-already-unparsed* :test #'eq) + (push type *record-types-already-unparsed*) + (mapcar #'unparse-alien-record-field + (alien-record-type-fields type))))) + +(defun unparse-alien-record-kind (kind) + (case kind + (:struct 'struct) + (:union 'union) + (t '???))) + +(defun unparse-alien-record-field (field) + `(,(alien-record-field-name field) + ,(%unparse-alien-type (alien-record-field-type field)) + ,@(when (alien-record-field-bits field) + (list :bits (alien-record-field-bits field))) + ,@(when (alien-record-field-offset field) + (list :offset (alien-record-field-offset field))))) + +;;; Test the record fields. Keep a hashtable table of already compared +;;; types to detect cycles. +(defun record-fields-match-p (field1 field2) + (and (eq (alien-record-field-name field1) + (alien-record-field-name field2)) + (eql (alien-record-field-bits field1) + (alien-record-field-bits field2)) + (eql (alien-record-field-offset field1) + (alien-record-field-offset field2)) + (alien-type-= (alien-record-field-type field1) + (alien-record-field-type field2)))) + +(defvar *alien-type-matches* nil + "A hashtable used to detect cycles while comparing record types.") + +(define-alien-type-method (record :type=) (type1 type2) + (and (eq (alien-record-type-name type1) + (alien-record-type-name type2)) + (eq (alien-record-type-kind type1) + (alien-record-type-kind type2)) + (eql (alien-type-bits type1) + (alien-type-bits type2)) + (eql (alien-type-alignment type1) + (alien-type-alignment type2)) + (flet ((match-fields (&optional old) + (setf (gethash type1 *alien-type-matches*) (cons type2 old)) + (every #'record-fields-match-p + (alien-record-type-fields type1) + (alien-record-type-fields type2)))) + (if *alien-type-matches* + (let ((types (gethash type1 *alien-type-matches*))) + (or (memq type2 types) (match-fields types))) + (let ((*alien-type-matches* (make-hash-table :test #'eq))) + (match-fields)))))) + + +;;;; the FUNCTION and VALUES alien types + +;;; not documented in CMU CL:-( +;;; +;;; reverse engineering observations: +;;; * seems to be set when translating return values +;;; * seems to enable the translation of (VALUES), which is the +;;; Lisp idiom for C's return type "void" (which is likely +;;; why it's set when when translating return values) +(defvar *values-type-okay* nil) + +;;; Calling-convention spec, typically one of predefined keywords. +;;; Add or remove as needed for target platform. It makes sense to +;;; support :cdecl everywhere. +;;; +;;; Null convention is supposed to be platform-specific most-universal +;;; callout convention. For x86, SBCL calls foreign functions in a way +;;; allowing them to be either stdcall or cdecl; null convention is +;;; appropriate here, as it is for specifying callbacks that could be +;;; accepted by foreign code both in cdecl and stdcall form. +(def!type calling-convention () `(or null (member :stdcall :cdecl))) + +;;; Convention could be a values type class, stored at result-type. +;;; However, it seems appropriate only for epilogue-related +;;; conventions, those not influencing incoming arg passing. +;;; +;;; As of x86's :stdcall and :cdecl, supported by now, both are +;;; epilogue-related, but future extensions (like :fastcall and +;;; miscellaneous non-x86 stuff) might affect incoming argument +;;; translation as well. + +(define-alien-type-class (fun :include mem-block) + (result-type (missing-arg) :type alien-type) + (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))) + (stub nil :type (or null function)) + (convention nil :type calling-convention)) +;;; The safe default is to assume that everything is varargs. +;;; On x86-64 we have to emit a spurious instruction because of it. +;;; So until all users fix their lambda lists to be explicit about &REST +;;; (which is never gonna happen), be backward-compatible, unless +;;; locally toggled to get rid of noise instructions if so inclined. +(defglobal *alien-fun-type-varargs-default* :unspecified) + +;;; KLUDGE: non-intrusive, backward-compatible way to allow calling +;;; convention specification for function types is unobvious. +;;; +;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list +;;; starting with a convention keyword; its second item is a real +;;; 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) + (typecase result-type + ((cons calling-convention *) + (values (second result-type) (first result-type))) + (t result-type))) + (varargs (eq (car (last arg-types)) '&rest))) + (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))))) + +(define-alien-type-method (fun :unparse) (type) + `(function ,(let ((result-type + (%unparse-alien-type (alien-fun-type-result-type type))) + (convention (alien-fun-type-convention type))) + (if convention (list convention result-type) + result-type)) + ,@(mapcar #'%unparse-alien-type + (alien-fun-type-arg-types type)) + ,@(when (alien-fun-type-varargs type) + '(&rest)))) + +(define-alien-type-method (fun :type=) (type1 type2) + (and (alien-type-= (alien-fun-type-result-type type1) + (alien-fun-type-result-type type2)) + (eq (alien-fun-type-convention type1) + (alien-fun-type-convention type2)) + (= (length (alien-fun-type-arg-types type1)) + (length (alien-fun-type-arg-types type2))) + (every #'alien-type-= + (alien-fun-type-arg-types type1) + (alien-fun-type-arg-types type2)))) + +(define-alien-type-class (values) + (values (missing-arg) :type list)) + +(define-alien-type-translator values (&rest values &environment env) + (unless *values-type-okay* + (error "cannot use values types here")) + (let ((*values-type-okay* nil)) + (make-alien-values-type + :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env)) + values)))) + +(define-alien-type-method (values :unparse) (type) + `(values ,@(mapcar #'%unparse-alien-type + (alien-values-type-values type)))) + +(define-alien-type-method (values :type=) (type1 type2) + (and (= (length (alien-values-type-values type1)) + (length (alien-values-type-values type2))) + (every #'alien-type-= + (alien-values-type-values type1) + (alien-values-type-values type2)))) + + +;;;; alien variables + +;;; Information describing a heap-allocated alien. +(def!struct (heap-alien-info (:copier nil)) + ;; The type of this alien. + (type (missing-arg) :type alien-type) + ;; Its name. + (alien-name (missing-arg) :type simple-string) + ;; Data or code? + (datap (missing-arg) :type boolean)) +(!set-load-form-method heap-alien-info (:xc :target)) + +(defmethod print-object ((info heap-alien-info) stream) + (print-unreadable-object (info stream :type t) + (format stream "~S ~S~@[ (data)~]" + (heap-alien-info-alien-name info) + (unparse-alien-type (heap-alien-info-type info)) + (heap-alien-info-datap info)))) + +;;; The form to evaluate to produce the SAP pointing to where in the heap +;;; it is. +(defun heap-alien-info-sap-form (info) + `(foreign-symbol-sap ,(heap-alien-info-alien-name info) + ,(heap-alien-info-datap info))) + +#-sb-xc-host ; No FOREIGN-SYMBOL-SAP +(defun heap-alien-info-sap (info) + (foreign-symbol-sap (heap-alien-info-alien-name info) + (heap-alien-info-datap info))) + +;;; information about local aliens. The WITH-ALIEN macro builds one of +;;; these structures and LOCAL-ALIEN and friends communicate +;;; information about how that local alien is represented. +(def!struct (local-alien-info + (:copier nil) + (:constructor make-local-alien-info + (&key type force-to-memory-p + &aux (force-to-memory-p (or force-to-memory-p + (alien-array-type-p type) + (alien-record-type-p type)))))) + ;; the type of the local alien + (type (missing-arg) :type alien-type) + ;; Must this local alien be forced into memory? Using the ADDR macro + ;; on a local alien will set this. + (force-to-memory-p nil :type (member t nil))) +(!set-load-form-method local-alien-info (:xc :target)) +(defmethod print-object ((info local-alien-info) stream) + (print-unreadable-object (info stream :type t) + (format stream + "~:[~;(forced to stack) ~]~S" + (local-alien-info-force-to-memory-p info) + (unparse-alien-type (local-alien-info-type info))))) + +(in-package "SB-IMPL") + +(defun extern-alien-name (name) + (handler-case (cl:coerce name 'base-string) + (error () + (error "invalid external alien name: ~S" name)))) + +(declaim (ftype (sfunction (string hash-table) (or integer null)) + find-foreign-symbol-in-table)) +(defun find-foreign-symbol-in-table (name table) + (values (gethash (extern-alien-name name) table))) + +(in-package "SB-ALIEN") + +#+sb-xc +(defmacro maybe-with-pinned-objects (variables types &body body) + (declare (ignorable variables types)) + (let ((pin-variables + ;; Only pin things on GENCGC, since on CHENEYGC it'd imply + ;; disabling the GC. Which is something we don't want to do + ;; every time we're calling to C. + #+gencgc + (loop for variable in variables + for type in types + when (invoke-alien-type-method :deport-pin-p type) + collect variable))) + (if pin-variables + `(with-pinned-objects ,pin-variables + ,@body) + `(progn + ,@body)))) diff -Nru sbcl-2.0.6/src/code/alloc.lisp sbcl-2.1.1/src/code/alloc.lisp --- sbcl-2.0.6/src/code/alloc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -12,6 +12,15 @@ (in-package "SB-VM") +(define-alien-routine ("os_allocate" allocate-system-memory) + system-area-pointer + (bytes unsigned)) + +(define-alien-routine ("os_deallocate" deallocate-system-memory) + void + (addr system-area-pointer) + (bytes unsigned)) + (!define-load-time-global *allocator-mutex* (sb-thread:make-mutex :name "Allocator")) (defun allocate-static-vector (widetag length words) @@ -24,7 +33,7 @@ ;; 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 (sb-thread::with-system-mutex (*allocator-mutex*) + (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))) @@ -273,12 +282,12 @@ (setf (hole-size hole) (- hole-end hole)))) (add-to-freelist hole)) -(defun allocate-immobile-obj (n-bytes word0 word1 lowtag errorp) +(defun alloc-immobile-code (n-bytes word0 word1 lowtag errorp) (declare (type (and fixnum unsigned-byte) n-bytes)) (setq n-bytes (align-up n-bytes (* 2 n-word-bytes))) ;; Can't allocate fewer than 4 words due to min hole size. (aver (>= n-bytes (* 4 n-word-bytes))) - (sb-thread::with-system-mutex (*allocator-mutex* :without-gcing t) + (with-system-mutex (*allocator-mutex* :without-gcing t) (unless (zerop varyobj-holes) ;; If deferred sweep needs to happen, do so now. ;; Concurrency could potentially be improved here: at most one thread @@ -319,7 +328,7 @@ (sb-debug:print-backtrace) (sb-impl::%halt)) (t - (return-from allocate-immobile-obj nil)))) + (return-from alloc-immobile-code nil)))) (set-varyobj-space-free-pointer free-ptr) addr)))) (aver (not (logtest addr lowtag-mask))) ; Assert proper alignment @@ -366,34 +375,42 @@ ;; so that we needn't inhibit GC. (%make-lisp-obj (logior addr lowtag))))) -;;; I don't know whether immobile space vectors actually work. -;;; I think the idea was to use them as fd-stream buffers when applicable -;;; instead of having a finalizer on OS-allocated memory. -(defun allocate-immobile-vector (widetag length words) - (allocate-immobile-obj (pad-data-block (+ words vector-data-offset)) - widetag - (fixnumize length) - other-pointer-lowtag - t)) - -(defun allocate-immobile-simple-vector (n-elements) - (allocate-immobile-vector simple-vector-widetag n-elements n-elements)) -(defun allocate-immobile-bit-vector (n-elements) - (allocate-immobile-vector simple-bit-vector-widetag n-elements - (ceiling n-elements n-word-bits))) -(defun allocate-immobile-byte-vector (n-elements) - (allocate-immobile-vector simple-array-unsigned-byte-8-widetag n-elements - (ceiling n-elements n-word-bytes))) -(defun allocate-immobile-word-vector (n-elements) - (allocate-immobile-vector #+64-bit simple-array-unsigned-byte-64-widetag - #-64-bit simple-array-unsigned-byte-32-widetag - n-elements n-elements)) - -(defun alloc-immobile-symbol () - (values (%primitive alloc-immobile-fixedobj other-pointer-lowtag symbol-size - (logior (ash (1- symbol-size) n-widetag-bits) symbol-widetag)))) +;;; Size-class segregation (implying which page we try to allocate to) +;;; is done from lisp now, not C. There are 4 objects types we'll see, +;;; each in its own size class (even if some are coincidentally the same size). +;;; - Symbols +;;; - FDEFNs +;;; - Layouts +;;; - Funcallable instances +;;; The first two are truly fixed in size. The latter two could occur in several +;;; sizes, each occupying a different size-class. This isn't implemented yet. +(defun alloc-immobile-fixedobj (nwords header) + (let* ((widetag (logand (truly-the fixnum header) widetag-mask)) + (aligned-nwords (truly-the fixnum (align-up nwords 2))) + (size-class + ;; If you change this, then be sure to update tests/immobile-space.impure + ;; which hardcodes a size class to not conflict with anything. + (ecase widetag + (#.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) + (t (error "Oversized layout")))) + ;; TODO: allow different sizes of funcallable-instance + (#.funcallable-instance-widetag 7)))) + (values (%primitive alloc-immobile-fixedobj + size-class + aligned-nwords + header)))) + (defun make-immobile-symbol (name) - (let ((symbol (truly-the symbol (alloc-immobile-symbol)))) + (let ((symbol (truly-the symbol + (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)) @@ -440,10 +457,10 @@ #+gencgc (or #+immobile-code (when (member space '(:immobile :auto)) - ;; We don't need to inhibit GC here - ALLOCATE-IMMOBILE-OBJ does it. + ;; We don't need to inhibit GC here - ALLOC-IMMOBILE-CODE does it. ;; Indicate that there are initially 2 boxed words, otherwise ;; immobile space GC thinks this object is freeable. - (allocate-immobile-obj (ash total-words word-shift) + (alloc-immobile-code (ash total-words word-shift) (logior (ash total-words code-header-size-shift) code-header-widetag) (ash 2 n-fixnum-tag-bits) diff -Nru sbcl-2.0.6/src/code/alpha-vm.lisp sbcl-2.1.1/src/code/alpha-vm.lisp --- sbcl-2.0.6/src/code/alpha-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/alpha-vm.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -;;;; Alpha-specific implementation stuff - -;;;; 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") - -#-sb-xc-host -(defun machine-type () - "Return a string describing the type of the local machine." - "Alpha") - -(defconstant-eqx +fixup-kinds+ - #(:jmp-hint :bits-63-48 :bits-47-32 :ldah :lda :absolute32) - #'equalp) -(!with-bigvec-or-sap -(defun fixup-code-object (code offset value kind flavor) - (declare (ignore flavor)) - (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) - (error "Unaligned instruction? offset=#x~X." offset)) - (let ((sap (code-instructions code))) - (ecase kind - (:jmp-hint - (aver (zerop (ldb (byte 2 0) value))) - #+nil - (setf (sap-ref-16 sap offset) - (logior (sap-ref-16 sap offset) - (ldb (byte 14 0) (ash value -2))))) - (:bits-63-48 - (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) - (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value)))) - (:bits-47-32 - (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value)))) - (:ldah - (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value)))) - (:lda - (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))) - (:absolute32 - (setf (sap-ref-32 sap offset) value)))) - nil)) - -;;;; "sigcontext" access functions, cut & pasted from x86-vm.lisp then -;;;; hacked for types. -;;;; -;;;; KLUDGE: The alpha has 64-bit registers, so these potentially -;;;; return 64 bit numbers (which means bignums ... ew) We think that -;;;; 99 times of 100 (i.e. unless something is badly wrong) we'll get -;;;; answers that fit in 32 bits anyway. Which probably won't help us -;;;; stop passing bignums around as the compiler can't prove they fit -;;;; in 32 bits. But maybe the stuff it does on x86 to unbox 32-bit -;;;; constants happens magically for 64-bit constants here. Just -;;;; maybe. -- Dan Barlow, ca. 2001-05-05 -;;;; -;;;; See also x86-vm for commentary on signed vs unsigned. - -#-sb-xc-host (progn -;;; This is like CONTEXT-REGISTER, but returns the value of a float -;;; register. FORMAT is the type of float to return. - -;;; FIXME: Whether COERCE actually knows how to make a float out of a -;;; long is another question. This stuff still needs testing. -(define-alien-routine ("os_context_float_register_addr" - context-float-register-addr) - (* long) - (context (* os-context-t)) - (index int)) -(defun context-float-register (context index format) - (declare (type (alien (* os-context-t)) context)) - (coerce (deref (context-float-register-addr context index)) format)) -(defun %set-context-float-register (context index format new) - (declare (type (alien (* os-context-t)) context)) - (setf (deref (context-float-register-addr context index)) - (coerce new format))) - -;;; This sets the software fp_control word, which is not the same -;;; thing as the hardware fpcr. We have to do this so that OS FPU -;;; completion works properly - -;;; Note that this means we can't set rounding modes; we'd have to do -;;; that separately. That said, almost everybody seems to agree that -;;; changing the rounding mode is rarely a good idea, because it upsets -;;; libm functions. So adding that is not a priority. Sorry. -;;; -dan 2001.02.06 - -(define-alien-routine - ("arch_get_fp_control" floating-point-modes) (unsigned 64)) - -(define-alien-routine - ("arch_set_fp_control" %floating-point-modes-setter) void (fp (unsigned 64))) - -(defun (setf floating-point-modes) (val) (%floating-point-modes-setter val)) - -;;; Given a signal context, return the floating point modes word in -;;; the same format as returned by FLOATING-POINT-MODES. -(define-alien-routine ("os_context_fp_control" context-floating-point-modes) - (unsigned 64) (context (* os-context-t))) - - -(defun internal-error-args (context) - (declare (type (alien (* os-context-t)) context)) - (let* ((pc (context-pc context)) - (trap-number (sap-ref-8 pc 3))) - (declare (type system-area-pointer pc)) - (sb-kernel::decode-internal-error-args (sap+ pc 4) trap-number))) -) ; end PROGN diff -Nru sbcl-2.0.6/src/code/ansi-stream.lisp sbcl-2.1.1/src/code/ansi-stream.lisp --- sbcl-2.0.6/src/code/ansi-stream.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/ansi-stream.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -49,7 +49,7 @@ ;;; :line-length - Return the length of a line of output. ;;; :charpos - Return current output position on the line. ;;; :file-length - Return the file length of a file stream. -;;; :file-position - Return or change the current position of a +;;; :[gs]et-file-position - Return or change the current position of a ;;; file stream. ;;; :file-name - Return the name of an associated file. ;;; :interactive-p - Is this an interactive device? @@ -90,6 +90,31 @@ (deftype ansi-stream-cin-buffer () `(simple-array character (,+ansi-stream-in-buffer-length+))) +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun %stream-opcode (name) + (ecase name + (:listen 0) + (:unread 1) + (:force-output 2) + (:finish-output 3) + (:charpos 4) + (:get-file-position 5) + (:set-file-position 6) + (:element-type 7) + (:element-mode 8) + (:external-format 9) + (:line-length 10) + (:file-length 11) + (:file-string-length 12) + (:clear-input 13) + (:clear-output 14) + (:close 15) + (:interactive-p 16) + ;; This is used by string streams and is not an opcode seen + ;; by STREAM-MISC-DISPATCH. The new stream pseudomethod convention + ;; can't pass random keywords to the misc method. + (:reset-unicode-p 17)))) + ;;; base class for ANSI standard streams (as opposed to the Gray ;;; streams extension) (defstruct (ansi-stream (:constructor nil) @@ -119,7 +144,7 @@ (sout #'ill-out :type function) ; string output function ;; other, less-used methods - (misc #'no-op-placeholder :type function) + (misc #'no-op-placeholder :type (function (stream (integer 0 17) t) *)) ;; Absolute character position, acting also as a generalized boolean ;; in lieu of testing FORM-TRACKING-STREAM-P to see if we must @@ -289,3 +314,70 @@ ;;; This is not something that the standard macro permits. (defmacro %with-output-to-string ((var) &body body) (expand-with-output-to-string var ''character body t)) + +;;; A macro to better exploit jump tables. Even though jumping based on symbol-hash +;;; is possible, it is of course slightly faster to dispatch on small integers, +;;; and for architectures which don't implement jump tables, +;;; using integers eliminates the load of many code header constants. +;;; Streams which don't want to handle every operation (don't end in a T clause) +;;; should specify :DEFAULT NIL to avoid an error. +(defmacro stream-misc-case ((operation &key (default 'error)) &rest clauses) + (let* ((otherwise) + (clauses + (mapcar (lambda (clause) + (let ((key (car clause))) + (cons (if (eq key 't) + (setq otherwise t) + (mapcar #'%stream-opcode (ensure-list (car clause)))) + (cdr clause)))) + clauses))) + `(,(if (and (not otherwise) (eq default 'error)) 'ecase 'case) ,operation + ,@clauses))) + +(defmacro call-ansi-stream-misc (stream operation &optional (arg nil argp)) + ;; Never stuff in a placeholder in the three operations that take an argument. + (aver (or argp (not (memq operation '(:set-file-position :file-string-length :unread))))) + `(funcall (ansi-stream-misc ,stream) ,stream + ;; If operation is a literal keyword, translate it, otherwise + ;; it is a variable whose values is the opcode for passthru. + ,(if (keywordp operation) (%stream-opcode operation) operation) + ,(if argp arg 0))) + +;;; This predicate assumes some things: +;;; - that a simple-stream class will never be FUNCALLABLE-STANDARD-OBJECT +;;; (so that we need only check for %INSTANCEP) +;;; - a class will never be redefined such that it moves from one part of the stream +;;; hierarchy to the other. (i.e. you don't redefine MY-STREAM-CLASS such that +;;; it was a Gray stream and becomes a simple-stream or vice-versa) +;;; - instance invalidation, if it needs to happen, will happen somewhere later in +;;; the stream protocol. (the layout-invalid trap can be deferred) +;;; This is OK because the next level of dispatch is not to a generic function +;;; in the simple-stream layering. It is generic at the "device" but not the API. +(defmacro simple-stream-p (x) + `(and (%instancep ,x) + (logtest (layout-flags (%instance-layout ,x)) + sb-kernel::+simple-stream-layout-flag+))) + +;;; This macro is for the first-level of dispatch which usually entails +;;; deciding whether the argument is actually a stream or merely a designator +;;; for a stream (T or NIL), and then figuring out which family of stream +;;; it belongs to: ANSI, Gray, or simple. +(defmacro stream-api-dispatch ((streamvar &optional initform) &key native simple gray) + ;; Most CL: stream APIs use explicit-check, so we should assert that the thing + ;; is actually a stream. + ;; If the CL interface bypasses STREAM-API-DISPATCH then it is up to generic layer + ;; to signal an error, the class of which seems unfortunately subject to debate. + (aver (and native (or simple gray))) + `(let ,(if initform `((,streamvar ,initform))) + ;; Dispatch native first, then if sb-simple-streams have been loaded, + ;; those, and finally punt to a generic function. + (block stream + ;; Assume that simple-stream can not inherit funcallable-standard-object. + (when (%instancep ,streamvar) + (let ((layout (%instance-layout ,streamvar))) + (cond ((sb-c::%structure-is-a layout ,(find-layout 'ansi-stream)) + (let ((,streamvar (truly-the ansi-stream ,streamvar))) + (return-from stream ,native))) + ((logtest (layout-flags layout) +simple-stream-layout-flag+) + (return-from stream ,simple))))) + (let ((,streamvar (the stream ,streamvar))) ,gray)))) diff -Nru sbcl-2.0.6/src/code/aprof.lisp sbcl-2.1.1/src/code/aprof.lisp --- sbcl-2.0.6/src/code/aprof.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/aprof.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -553,7 +553,7 @@ (sum-pct 0) (sum-bytes 0)) (when (eq stream nil) - (setq stream (make-broadcast-stream))) ; lazy's person's approach + (setq stream sb-impl::*null-broadcast-stream*)) ; lazy's person's approach (cond ((not detail) (format stream "~& % Sum % Bytes Allocations Function~%") (format stream "~& ------- ------- ----------- ----------- --------~%")) diff -Nru sbcl-2.0.6/src/code/arm64-vm.lisp sbcl-2.1.1/src/code/arm64-vm.lisp --- sbcl-2.0.6/src/code/arm64-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/arm64-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -2,39 +2,15 @@ ;;; (in-package "SB-VM") -#-sb-xc-host (defun machine-type () "Return a string describing the type of the local machine." "ARM64") - -;;;; FIXUP-CODE-OBJECT -(defconstant-eqx +fixup-kinds+ #(:absolute :cond-branch :uncond-branch) - #'equalp) -(!with-bigvec-or-sap -(defun fixup-code-object (code offset fixup kind flavor) - (declare (type index offset)) - (declare (ignore flavor)) - (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) - (error "Unaligned instruction? offset=#x~X." offset)) - (let ((sap (code-instructions code))) - (ecase kind - (:absolute - (setf (sap-ref-word sap offset) fixup)) - (:cond-branch - (setf (ldb (byte 19 5) (sap-ref-32 sap offset)) - (ash (- fixup (+ (sap-int sap) offset)) -2))) - (:uncond-branch - (setf (ldb (byte 26 0) (sap-ref-32 sap offset)) - (ash (- fixup (+ (sap-int sap) offset)) -2))))) - nil)) - ;;;; "Sigcontext" access functions, cut & pasted from sparc-vm.lisp, ;;;; then modified for ARM. ;;;; ;;;; See also x86-vm for commentary on signed vs unsigned. -#-sb-xc-host (progn (define-alien-routine ("os_context_float_register_addr" context-float-register-addr) (* unsigned) (context (* os-context-t)) (index int)) @@ -84,11 +60,9 @@ (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)))) -) ; end PROGN ;;; Undo the effects of XEP-ALLOCATE-FRAME ;;; and point PC to FUNCTION -#-sb-xc-host (defun context-call-function (context function &optional arg-count) (with-pinned-objects (function) (with-pinned-context-code-object (context) diff -Nru sbcl-2.0.6/src/code/arm-vm.lisp sbcl-2.1.1/src/code/arm-vm.lisp --- sbcl-2.0.6/src/code/arm-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/arm-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -2,32 +2,15 @@ ;;; (in-package "SB-VM") -#-sb-xc-host (defun machine-type () "Return a string describing the type of the local machine." "ARM") -;;;; FIXUP-CODE-OBJECT - -(defconstant-eqx +fixup-kinds+ #(:absolute) #'equalp) -(!with-bigvec-or-sap -(defun fixup-code-object (code offset fixup kind flavor) - (declare (type index offset)) - (declare (ignore flavor)) - (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) - (error "Unaligned instruction? offset=#x~X." offset)) - (let ((sap (code-instructions code))) - (ecase kind - (:absolute - (setf (sap-ref-32 sap offset) fixup)))) - nil)) - ;;;; "Sigcontext" access functions, cut & pasted from sparc-vm.lisp, ;;;; then modified for ARM. ;;;; ;;;; See also x86-vm for commentary on signed vs unsigned. -#-sb-xc-host (progn (defun context-float-register (context index format) (declare (ignorable context index)) (warn "stub CONTEXT-FLOAT-REGISTER") @@ -48,4 +31,3 @@ (trap-number (sap-ref-8 pc 4))) (declare (type system-area-pointer pc)) (sb-kernel::decode-internal-error-args (sap+ pc 5) trap-number))) -) ; end PROGN diff -Nru sbcl-2.0.6/src/code/array.lisp sbcl-2.1.1/src/code/array.lisp --- sbcl-2.0.6/src/code/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,7 +11,6 @@ (in-package "SB-VM") -#-sb-fluid (declaim (inline adjustable-array-p array-displacement)) @@ -26,7 +25,6 @@ (defun (setf ,name) (value array) (setf (,name array) value))))) (def %array-fill-pointer) - (def %array-fill-pointer-p) (def %array-available-elements) (def %array-data) (def %array-displacement) @@ -441,6 +439,17 @@ (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))) + ;;; 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 @@ -509,12 +518,13 @@ (simple simple-array-widetag) (t complex-array-widetag)) array-rank))) - (if fill-pointer - (setf (%array-fill-pointer-p array) t - (%array-fill-pointer array) - (if (eq fill-pointer t) dimension-0 fill-pointer)) - (setf (%array-fill-pointer-p array) nil - (%array-fill-pointer array) total-size)) + (cond (fill-pointer + (set-header-bits array sb-vm:+array-fill-pointer-p+) + (setf (%array-fill-pointer array) + (if (eq fill-pointer t) dimension-0 fill-pointer))) + (t + (unset-header-bits array sb-vm:+array-fill-pointer-p+) + (setf (%array-fill-pointer array) total-size))) (setf (%array-available-elements array) total-size) (setf (%array-data array) data) (setf (%array-displaced-from array) nil) @@ -807,7 +817,6 @@ (setf ,symbol (make-array (1+ widetag-mask) :initial-element #'hairy-ref-error)) ,@(loop for widetag in '(complex-vector-widetag - complex-vector-nil-widetag complex-bit-vector-widetag #+sb-unicode complex-character-string-widetag complex-base-string-widetag @@ -1033,9 +1042,7 @@ (defun array-rank (array) "Return the number of dimensions of ARRAY." - (if (array-header-p array) - (%array-rank array) - 1)) + (%array-rank array)) (defun array-dimension (array axis-number) "Return the length of dimension AXIS-NUMBER of ARRAY." @@ -1095,11 +1102,9 @@ (setf (info :function :predicate-truth-constraint 'array-has-fill-pointer-p) '(and vector (not simple-array))) -(declaim (inline array-has-fill-pointer-p)) (defun array-has-fill-pointer-p (array) "Return T if the given ARRAY has a fill pointer, or NIL otherwise." - (declare (array array)) - (and (array-header-p array) (%array-fill-pointer-p array))) + (array-has-fill-pointer-p array)) (defun fill-pointer-error (vector &optional arg) (declare (optimize allow-non-returning-tail-call)) @@ -1192,7 +1197,7 @@ (let* ((old-length (length vector)) (min-extension (or min-extension (min old-length - (- sb-xc:array-dimension-limit old-length)))) + (- array-dimension-limit old-length)))) (new-length (the index (+ old-length (max 1 min-extension)))) (fill-pointer (1+ old-length))) @@ -1518,10 +1523,10 @@ (setf (%array-available-elements array) length) (cond (fill-pointer (setf (%array-fill-pointer array) fill-pointer) - (setf (%array-fill-pointer-p array) t)) + (set-header-bits array sb-vm:+array-fill-pointer-p+)) (t (setf (%array-fill-pointer array) length) - (setf (%array-fill-pointer-p array) nil))) + (unset-header-bits array sb-vm:+array-fill-pointer-p+))) (setf (%array-displacement array) displacement) (if (listp dimensions) (dotimes (axis (array-rank array)) @@ -1659,9 +1664,9 @@ (loop for i below rank do (%set-array-dimension result i (%array-dimension array i))) + ;; fill-pointer-p defaults to 0 (setf (%array-displaced-from result) nil (%array-displaced-p result) nil - (%array-fill-pointer-p result) nil (%array-fill-pointer result) size (%array-available-elements result) size) result)) @@ -1897,7 +1902,7 @@ (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-subtype sb-vm:n-widetag-bits) + (let ((type (logior (ash vector-weak-flag sb-vm:n-widetag-bits) sb-vm: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 @@ -1917,4 +1922,4 @@ (defun weak-vector-p (x) (and (simple-vector-p x) - (eql (get-header-data x) vector-weak-subtype))) + (eql (get-header-data x) vector-weak-flag))) diff -Nru sbcl-2.0.6/src/code/avltree.lisp sbcl-2.1.1/src/code/avltree.lisp --- sbcl-2.0.6/src/code/avltree.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/avltree.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -143,6 +143,7 @@ ((< key node-key) (find-in (avlnode-left tree))) (t tree)))))) +;;; Find a node with key less than or equal to KEY and as near it as possible. (defun avl-find<= (key root) (declare (sb-vm:word key)) (named-let find-in ((tree root) (result nil)) @@ -153,6 +154,18 @@ (t tree))) result))) +;;; Find a node with key greater than or equal to KEY and as near it as possible. +(defun avl-find>= (key root) + (declare (sb-vm:word key)) + (named-let find-in ((tree root) (result nil)) + (if tree + (let ((node-key (avlnode-key tree))) + (cond ((> key node-key) (find-in (avlnode-right tree) result)) + ((< key node-key) (find-in (avlnode-left tree) tree)) + (t tree))) + result))) + +(export '(avltree-list avl-find>= avl-find<=)) (defun avltree-list (tree &optional (transducer #'avlnode-data)) (let (result) (named-let recurse ((node tree)) @@ -162,8 +175,19 @@ (recurse (avlnode-right node)))) result)) +(defun avltree-filter (predicate tree) + (let (result) + (named-let recurse ((node tree)) + (when node + (let ((value (funcall predicate node))) + (when value + (push value result))) + (recurse (avlnode-left node)) + (recurse (avlnode-right node)))) + result)) + (defmethod print-object ((self avlnode) stream) - (write-string "#= d2 (expt 2 (1- digit-size))) - (lognot (logand sb-xc:most-positive-fixnum (lognot d2))) + (lognot (logand most-positive-fixnum (lognot d2))) (logand lower-ones-digit d2))))) @@ -646,7 +646,7 @@ ;;; Allocate a single word bignum that holds fixnum. This is useful when ;;; we are trying to mix fixnum and bignum operands. -#-sb-fluid (declaim (inline make-small-bignum)) +(declaim (inline make-small-bignum)) (defun make-small-bignum (fixnum) (let ((res (%allocate-bignum 1))) (setf (%bignum-ref res 0) (%fixnum-to-digit fixnum)) @@ -1480,6 +1480,37 @@ (%sign-digit bignum n-digits))))) (ldb (byte low-part-size bit-index) ; low part (%bignum-ref bignum word-index))))))))) + +;;; Basically shift the bignum right by byte-pos, but assumes it's +;;; right at the end of the bignum. +(defun last-bignum-part=>fixnum (byte-pos bignum) + (declare (type bit-index byte-pos) + (bignum bignum) + (optimize speed)) + (let ((n-digits (%bignum-length bignum))) + (multiple-value-bind (word-index bit-index) (floor byte-pos digit-size) + (cond ((<= (+ bit-index sb-vm:n-fixnum-bits) digit-size) ; contained in one word + (sb-c::mask-signed-field sb-vm:n-fixnum-bits + (ash (%bignum-ref bignum word-index) (- bit-index)))) + (t + ;; At least one bit is obtained from each of two words, + ;; and not more than two words. + (let* ((low-part-size + (truly-the (integer 1 #.(1- sb-vm:n-positive-fixnum-bits)) + (- digit-size bit-index))) + (high-part-size + (truly-the (integer 1 #.(1- sb-vm:n-positive-fixnum-bits)) + (- sb-vm:n-fixnum-bits low-part-size)))) + (logior + (let ((word-index (1+ word-index))) + (sb-c::mask-signed-field sb-vm:n-fixnum-bits + (if (< word-index n-digits) ; next word exists + (ash (%bignum-ref bignum word-index) low-part-size) + (truly-the word + (mask-field (byte high-part-size low-part-size) + (%sign-digit bignum n-digits)))))) + (ldb (byte low-part-size bit-index) + (%bignum-ref bignum word-index))))))))) ;;;; TRUNCATE @@ -1881,7 +1912,7 @@ ;;; 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. -#-sb-fluid (declaim (maybe-inline %normalize-bignum-buffer)) +(declaim (maybe-inline %normalize-bignum-buffer)) (defun %normalize-bignum-buffer (result len) (declare (type bignum result) (type bignum-length len)) @@ -1943,7 +1974,7 @@ (declare (type index i)) (let ((xi (%bignum-ref x i))) (mixf result - (logand sb-xc:most-positive-fixnum + (logand most-positive-fixnum (logxor xi (ash xi -7)))))) result)) @@ -1956,3 +1987,21 @@ (clear-info :function :inlining-data s) (clear-info :function :inlinep s) (clear-info :source-location :declaration s)) + +;;; Return T if the least significant N-BITS bits of BIGNUM are all +;;; zero, else NIL. If the integer-length of BIGNUM is less than N-BITS, +;;; the result is NIL, too. +(declaim (inline bignum-lower-bits-zero-p)) +(defun bignum-lower-bits-zero-p (bignum n-bits) + (declare (type bignum bignum) + (type bit-index n-bits)) + (multiple-value-bind (n-full-digits n-bits-partial-digit) + (floor n-bits digit-size) + (declare (type bignum-length n-full-digits)) + (when (> (%bignum-length bignum) n-full-digits) + (dotimes (index n-full-digits) + (declare (type bignum-index index)) + (unless (zerop (%bignum-ref bignum index)) + (return-from bignum-lower-bits-zero-p nil))) + (zerop (logand (1- (ash 1 n-bits-partial-digit)) + (%bignum-ref bignum n-full-digits)))))) diff -Nru sbcl-2.0.6/src/code/bignum-random.lisp sbcl-2.1.1/src/code/bignum-random.lisp --- sbcl-2.0.6/src/code/bignum-random.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/bignum-random.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -14,24 +14,6 @@ (in-package "SB-BIGNUM") -;;; Return T if the least significant N-BITS bits of BIGNUM are all -;;; zero, else NIL. If the integer-length of BIGNUM is less than N-BITS, -;;; the result is NIL, too. -(declaim (inline bignum-lower-bits-zero-p)) -(defun bignum-lower-bits-zero-p (bignum n-bits) - (declare (type bignum bignum) - (type bit-index n-bits)) - (multiple-value-bind (n-full-digits n-bits-partial-digit) - (floor n-bits digit-size) - (declare (type bignum-length n-full-digits)) - (when (> (%bignum-length bignum) n-full-digits) - (dotimes (index n-full-digits) - (declare (type bignum-index index)) - (unless (zerop (%bignum-ref bignum index)) - (return-from bignum-lower-bits-zero-p nil))) - (zerop (logand (1- (ash 1 n-bits-partial-digit)) - (%bignum-ref bignum n-full-digits)))))) - ;;; Return a nonnegative integer of DIGIT-SIZE many pseudo random bits. (declaim (inline random-bignum-digit)) (defun random-bignum-digit (state) @@ -56,7 +38,7 @@ (declaim (inline concatenate-random-bignum)) (defun concatenate-random-bignum (random-chunk bit-count state) (declare (type bignum-element-type random-chunk) - (type (integer 0 #.sb-xc:most-positive-fixnum) bit-count) + (type (integer 0 #.most-positive-fixnum) bit-count) (type random-state state)) (let* ((n-total-bits (+ 1 n-random-chunk-bits bit-count)) ; sign bit (length (ceiling n-total-bits digit-size)) @@ -133,7 +115,7 @@ ;;; generate and compare the complete random number and risk to reject ;;; it. (defun %random-bignum (arg state) - (declare (type (integer #.(1+ sb-xc:most-positive-fixnum)) arg) + (declare (type (integer #.(1+ most-positive-fixnum)) arg) (type random-state state) (inline bignum-lower-bits-zero-p)) (let ((n-bits (bignum-integer-length arg))) diff -Nru sbcl-2.0.6/src/code/bit-bash.lisp sbcl-2.1.1/src/code/bit-bash.lisp --- sbcl-2.0.6/src/code/bit-bash.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/bit-bash.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -76,7 +76,7 @@ (:little-endian (ash (ldb (byte (- n-word-bits count) 0) number) count))))))) -#-sb-fluid (declaim (inline start-mask end-mask)) +(declaim (inline start-mask end-mask)) ;;; Produce a mask that contains 1's for the COUNT "start" bits and ;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT @@ -94,7 +94,7 @@ (declare (fixnum count)) (shift-towards-end most-positive-word (- count))) -#-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref)) +(declaim (inline word-sap-ref %set-word-sap-ref)) (defun word-sap-ref (sap offset) (declare (type system-area-pointer sap) (type index offset) @@ -138,15 +138,7 @@ (values system-area-pointer index)) (let ((address (sap-int sap)) (word-mask (1- (ash 1 word-shift)))) - (values (int-sap #-alpha (word-logical-andc2 address word-mask) - ;; KLUDGE: WORD-LOGICAL-ANDC2 is defined in - ;; terms of n-word-bits. On all systems - ;; where n-word-bits is not equal to - ;; n-machine-word-bits we have to do this - ;; another way. At this time, these - ;; systems are alphas, though there was - ;; some talk about an x86-64 build option. - #+alpha (ash (ash address (- word-shift)) word-shift)) + (values (int-sap (word-logical-andc2 address word-mask)) (+ ,(ecase bitsize ((1 2 4) `(* (logand address word-mask) (/ n-byte-bits ,bitsize))) @@ -160,7 +152,7 @@ (defmacro !define-byte-bashers (bitsize) (let* ((bytes-per-word (/ n-word-bits bitsize)) (byte-offset `(integer 0 (,bytes-per-word))) - (word-offset `(integer 0 ,(ceiling sb-xc:array-dimension-limit 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"))) diff -Nru sbcl-2.0.6/src/code/cas.lisp sbcl-2.1.1/src/code/cas.lisp --- sbcl-2.0.6/src/code/cas.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/cas.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -18,7 +18,7 @@ (casser (case (dsd-raw-type slotd) ((t) '%instance-cas) - #+(or x86 x86-64 riscv) + #+(or arm64 ppc ppc64 riscv x86 x86-64) ((word) '%raw-instance-cas/word) #+riscv ((signed-word) '%raw-instance-cas/signed-word)))) @@ -85,7 +85,7 @@ ;; 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 (sb-xc:macroexpand place environment))) + (let ((expanded (macroexpand place environment))) (flet ((invalid-place () (error "Invalid place to CAS: ~S -> ~S" place expanded))) (unless (consp expanded) @@ -114,7 +114,7 @@ (vals nil) (args nil)) (dolist (x (reverse (cdr expanded))) - (cond ((sb-xc:constantp x environment) + (cond ((constantp x environment) (push x args)) (t (let ((tmp (gensymify x))) @@ -230,9 +230,15 @@ " `(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 (sb-xc:constantp name env) + (if (constantp name env) (values nil nil (constant-form-value name env)) (values (gensymify name) name nil)) (let ((symbol (or tmp `',cname))) @@ -265,7 +271,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun expand-atomic-frob (name specified-place diff env - &aux (place (sb-xc:macroexpand specified-place 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)) @@ -380,7 +386,7 @@ EXPERIMENTAL: Interface subject to change." sb-vm:n-word-bits most-positive-word - sb-xc:most-positive-fixnum sb-xc:most-negative-fixnum) + most-positive-fixnum most-negative-fixnum) (expand-atomic-frob 'atomic-incf place diff env)) (defmacro atomic-decf (&environment env place &optional (diff 1)) @@ -409,5 +415,140 @@ EXPERIMENTAL: Interface subject to change." sb-vm:n-word-bits most-positive-word - sb-xc:most-negative-fixnum sb-xc:most-positive-fixnum) + most-negative-fixnum most-positive-fixnum) (expand-atomic-frob 'atomic-decf place diff env)) + +;;; Out-of-line definitions for various primitive cas functions. +(macrolet ((def (name lambda-list ref &optional set) + #+compare-and-swap-vops + (declare (ignore ref set)) + `(defun ,name (,@lambda-list old new) + #+compare-and-swap-vops + (,name ,@lambda-list old new) + #-compare-and-swap-vops + (progn + #+sb-thread + ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?") + #-sb-thread + (let ((current (,ref ,@lambda-list))) + ;; Shouldn't this be inside a WITHOUT-INTERRUPTS ? + (when (eq current old) + ,(if set + `(,set ,@lambda-list new) + `(setf (,ref ,@lambda-list) new))) + current))))) + (def %compare-and-swap-car (cons) car) + (def %compare-and-swap-cdr (cons) cdr) + (def %instance-cas (instance index) %instance-ref %instance-set) + #+(or x86-64 x86 riscv) + (def %raw-instance-cas/word (instance index) + %raw-instance-ref/word + %raw-instance-set/word) + #+riscv + (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)) + +;; Atomic increment/decrement ops on tagged storage cells (as contrasted with +;; specialized arrays and raw structure slots) are defined in terms of CAS. + +;; This code would be more concise if workable versions +;; of +-MODFX, --MODFX were defined generically. +(macrolet ((modular (fun a b) + #+(or x86 x86-64) + `(,(package-symbolicate "SB-VM" fun "-MODFX") ,a ,b) + #-(or x86 x86-64) + ;; algorithm of https://graphics.stanford.edu/~seander/bithacks + `(let ((res (logand (,fun ,a ,b) + (ash sb-ext:most-positive-word + (- sb-vm:n-fixnum-tag-bits)))) + (m (ash 1 (1- sb-vm:n-fixnum-bits)))) + (- (logxor res m) m)))) + + ;; Atomically frob the CAR or CDR of a cons, or a symbol-value. + ;; The latter will be a global value because the ATOMIC-INCF/DECF + ;; macros work on a symbol only if it is known global. + (macrolet ((def-frob (name op type slot) + `(defun ,name (place delta) + (declare (type ,type place) (type fixnum delta)) + (loop (let ((old (the fixnum (,slot place)))) + (when (eq (cas (,slot place) old + (modular ,op old delta)) old) + (return old))))))) + (def-frob %atomic-inc-symbol-global-value + symbol symbol-value) + (def-frob %atomic-dec-symbol-global-value - symbol symbol-value) + (def-frob %atomic-inc-car + cons car) + (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.0.6/src/code/class.lisp sbcl-2.1.1/src/code/class.lisp --- sbcl-2.0.6/src/code/class.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/class.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -19,14 +19,6 @@ ;;; The CLASSOID structure is a supertype of all classoid types. ;;; Its definition occurs in 'early-classoid.lisp' - -(defmethod make-load-form ((self classoid) &optional env) - (declare (ignore env)) - (let ((name (classoid-name self))) - (if (and name (eq (find-classoid name nil) self)) - `(find-classoid ',name) - (error "can't use anonymous or undefined class as constant:~% ~S" - self)))) #+sb-xc-host (defmethod sb-xc:make-load-form ((self classoid) &optional env) (declare (ignore env)) @@ -65,10 +57,13 @@ ;;; 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) (format stream - "for ~S~@[, INVALID=~S~]" + #+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)))) @@ -76,20 +71,13 @@ (defun layout-proper-name (layout) (classoid-proper-name (layout-classoid layout)))) -;;; If we can't find any existing layout, then we create a new one -;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we -;;; used to immediately check for compatibility, but for -;;; cross-compilability reasons (i.e. convenience of using this -;;; function in a MAKE-LOAD-FORM expression) that functionality has -;;; been split off into INIT-OR-CHECK-LAYOUT. +;;; 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)) -;; The comment "This seems ..." is misleading but I don't have a better one. -;; FIND-LAYOUT is used by FIND-AND-INIT-OR-CHECK-LAYOUT which is used -;; by FOP-LAYOUT, so clearly it's used when reading fasl files. (defun find-layout (name) - ;; This seems to be currently used only from the compiler, but make - ;; it thread-safe all the same. We need to lock *F-R-L* before doing - ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel. + (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*)) (with-world-lock () (let ((classoid (find-classoid name nil))) @@ -100,46 +88,6 @@ (or classoid (make-undefined-classoid name)))))))))) -;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH, -;;; INHERITS, DEPTHOID, and BITMAP. -;;; Otherwise require that it be consistent with the existing values. -;;; -;;; UNDEFINED-CLASS values are interpreted specially as "we don't know -;;; anything about the class", so if LAYOUT is initialized, any -;;; preexisting class slot value is OK, and if it's not initialized, -;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This -;;; is no longer true, :UNINITIALIZED used instead. -(declaim (ftype (sfunction (layout classoid layout-length fixnum simple-vector - layout-depthoid layout-bitmap) layout) - %init-or-check-layout)) -(defun %init-or-check-layout (layout classoid length flags inherits depthoid bitmap) - ;; BITMAP is redundant information about the primitive object representation - ;; which is fully captured by the defstruct description, and not stored in the - ;; host layout. - (cond ((eq (layout-invalid layout) :uninitialized) - ;; There was no layout before, we just created one which - ;; we'll now initialize with our information. - (setf (layout-classoid layout) classoid) - (set-layout-inherits layout inherits) - (assign-layout-slots layout :depthoid depthoid :length length :flags flags) - #-sb-xc-host ; Assign target-only slots - (when (logtest +structure-layout-flag+ flags) - ;; STRING-STREAM and FILE-STREAM have depthoid=4 but are not structure types - (setf (layout-bitmap layout) bitmap)) - ;; Finally, make it valid. - (setf (layout-invalid layout) nil)) - ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this - ;; clause is not needed? - ((not *type-system-initialized*) - (setf (layout-classoid layout) classoid)) - (t - ;; 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 - ;; information which is known with certainty. - (check-layout layout classoid length inherits depthoid bitmap))) - layout) - ;;; 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 @@ -148,38 +96,44 @@ ;;; 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)) - (when (layout-invalid layout) - (sb-c:compiler-error "can't dump reference to obsolete class: ~S" - (layout-classoid layout))) - (let* ((classoid (layout-classoid layout)) - (name (classoid-name classoid))) - (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)))) - (unless name - (sb-c:compiler-error "can't dump anonymous LAYOUT: ~S" layout)) - ;; Since LAYOUT refers to a class which refers back to the LAYOUT, - ;; we have to do this in two stages, like the TREE-WITH-PARENT - ;; example in the MAKE-LOAD-FORM entry in the ANSI spec. - (values - ;; "creation" form (which actually doesn't create a new LAYOUT if - ;; there's a preexisting one with this name) - `(find-layout ',name) - ;; "initialization" form (which actually doesn't initialize - ;; preexisting LAYOUTs, just checks that they're consistent). - `(%init-or-check-layout ,layout - ,(layout-classoid layout) - ,(layout-length layout) - ,(layout-flags layout) - ,(layout-inherits layout) - ,(layout-depthoid layout) - ,(layout-bitmap layout))))) + (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. @@ -190,9 +144,9 @@ simple-vector layout-depthoid layout-bitmap)) - redefine-layout-warning)) -(defun redefine-layout-warning (old-context old-layout - context length inherits depthoid bitmap) + 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))) @@ -237,50 +191,35 @@ name old-context context) t)))) -;;; Require that LAYOUT data be consistent with CLASSOID, LENGTH, -;;; INHERITS, DEPTHOID, and BITMAP. -(declaim (ftype (function (layout classoid index simple-vector layout-depthoid layout-bitmap)) - check-layout)) -(defun check-layout (layout classoid length inherits depthoid bitmap) - (aver (eq (layout-classoid layout) classoid)) - (when (redefine-layout-warning "current" layout - "compile time" length inherits depthoid bitmap) - ;; Classic CMU CL had more options here. There are several reasons - ;; why they might want more options which are less appropriate for - ;; us: (1) It's hard to fit the classic CMU CL flexible approach - ;; into the ANSI-style MAKE-LOAD-FORM system, and having a - ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to - ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2) - ;; We have CLOS now, and if you want to be able to flexibly - ;; redefine classes without restarting the system, it'd make sense - ;; to use that, so supporting complexity in order to allow - ;; modifying DEFSTRUCTs without restarting the system is a low - ;; priority. (3) We now have the ability to rebuild the SBCL - ;; system from scratch, so we no longer need this functionality in - ;; order to maintain the SBCL system by modifying running images. - (error "The loaded code expects an incompatible layout for class ~S." - (layout-proper-name layout))) - (values)) - -;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a -;;; single function call -;;; -;;; Used by the loader to forward-reference layouts for classes whose -;;; definitions may not have been loaded yet. This allows type tests -;;; to be loaded when the type definition hasn't been loaded yet. -(defun find-and-init-or-check-layout (name depthoid flags length bitmap inherits) - (truly-the ; avoid an "assertion too complex to check" optimizer note - (values layout &optional) - (with-world-lock () - (let ((layout (find-layout name))) - (%init-or-check-layout layout - (or (find-classoid name nil) - (layout-classoid layout)) - length - flags - inherits - depthoid - bitmap))))) +(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*)) + (with-world-lock () + (let ((classoid (find-classoid name nil))) + (or (and classoid (classoid-layout classoid)) + (ensure-gethash + name table + (make-layout + (hash-layout-name name) + (or classoid (make-undefined-classoid name)) + :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) + (not *type-system-initialized*)) + (setf (layout-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 + ;; information which is known with certainty. + (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)))) + layout)) ;;; Record LAYOUT as the layout for its class, adding it as a subtype ;;; of all superclasses. This is the operation that "installs" a @@ -328,15 +267,35 @@ ;; 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))) + (depthoid (layout-depthoid layout)) ; "new" depthoid + (extra-id-words ; "old" extra words + (calculate-extra-id-words (layout-depthoid destruct-layout))) + (id ; read my ID before screwing with the depthoid + (layout-id destruct-layout))) (aver (logtest +structure-layout-flag+ (layout-flags layout))) (aver (= (length inherits) depthoid)) + ;; DEPTHOID implies the number of words of "extra" IDs preceding the bitmap. + ;; Layout alteration is forbidden if it would affect the number of such words. + ;; So MUTABLE-LAYOUT-P should have checked that this is OK, but assert it + ;; 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) - (layout-bitmap destruct-layout) (layout-bitmap layout)) - (set-layout-inherits destruct-layout inherits) + (layout-info destruct-layout) (layout-info layout)) + ;; 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. + ;; The calculation of the min word count of 3 or 6 is done as + ;; (/ (- (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 @@ -373,6 +332,18 @@ ;;; elements are filled with their successors, ensuring that each ;;; element contains a valid layout. ;;; +;;; *** FIXME *** the preceding comment seems dubious, and I'm not sure whether +;;; to fix the code or the comment or both. The code works as-is, but is too hairy. +;;; I fail to see how "still-empty" elements can exist after filling in mandatory +;;; elements. It seems to anticipate being able to create a type whose INHERITS vector +;;; length exceeds depthoid, or, say, a type at depthoid 5 which inherits STREAM but +;;; might lack an entry at depth index 1 for example. As to why I think the comment +;;; is false: FILE-STREAM and STRING-STREAM each have depthoid 4, but their INHERITS +;;; vector has length 2. So they don't store elements that would be at index 2 and 3. +;;; Length less than depthoid is opposite of what the fill-in logic supports. +;;; How, in practice, could a user achieve such weird states as need this logic? +;;; If impossible, then simplify it. + ;;; This reordering may destroy CPL ordering, so the inherits should ;;; not be read as being in CPL order. (defun order-layout-inherits (layouts) @@ -529,12 +500,12 @@ ;; modulo potential differences with respect to ;; conditions). #+sb-xc-host - (let ((old (class-of old-value)) - (new (class-of new-value))) + (let ((old (cl:class-of old-value)) + (new (cl:class-of new-value))) (unless (eq old new) (bug "Trying to change the metaclass of ~S from ~S to ~S in the ~ cross-compiler." - name (class-name old) (class-name new)))) + name (cl:class-name old) (cl:class-name new)))) #-sb-xc-host (let ((old (classoid-of old-value)) (new (classoid-of new-value))) @@ -613,7 +584,8 @@ ;;; Again, this should be compiler-only, but easier to make this ;;; thread-safe. (defun insured-find-classoid (name predicate constructor) - (declare (type function predicate constructor)) + (declare (type function predicate) + (type (or function symbol) constructor)) (let ((table *forward-referenced-layouts*)) (with-system-mutex ((hash-table-lock table)) (let* ((old (find-classoid name nil)) @@ -949,7 +921,7 @@ (integer :translation integer :inherits (rational real number) :prototype-form 0) (fixnum - :translation (integer ,sb-xc:most-negative-fixnum ,sb-xc:most-positive-fixnum) + :translation (integer ,most-negative-fixnum ,most-positive-fixnum) :inherits (integer rational real number) :codes ,(mapcar #'symbol-value sb-vm::fixnum-lowtags) :prototype-form 42) @@ -957,7 +929,7 @@ :translation (and integer (not fixnum)) :inherits (integer rational real number) :codes (,sb-vm:bignum-widetag) - :prototype-form ,(1+ sb-xc:most-positive-fixnum)) + :prototype-form ,(1+ most-positive-fixnum)) (array :translation array :codes (,sb-vm:complex-array-widetag) :hierarchical-p nil @@ -1002,16 +974,15 @@ :prototype-form "") (vector-nil :translation (vector nil) - :codes (,sb-vm:complex-vector-nil-widetag) - :direct-superclasses (string) - :inherits (string vector array sequence) + :inherits (vector array sequence) :prototype-form (make-array 0 :element-type 'nil :fill-pointer t)) + ;; This name is imperfect. It should be SIMPLE-RANK1-ARRAY-NIL + ;; to clearly convey that the dimensions are '(*) and not '*. (simple-array-nil :translation (simple-array nil (*)) :codes (,sb-vm:simple-array-nil-widetag) - :direct-superclasses (vector-nil simple-string) - :inherits (vector-nil simple-string string vector simple-array - array sequence) + :direct-superclasses (vector-nil) + :inherits (vector-nil vector simple-array array sequence) :prototype-form (make-array 0 :element-type 'nil)) (base-string :translation base-string @@ -1055,6 +1026,16 @@ :inherits (symbol list sequence) :direct-superclasses (symbol list) :prototype-form 'nil) + + ;; KLUDGE: the length must match the subsequent defstruct. + (pathname :depth 1 + :length ,(+ 7 sb-vm:instance-data-start) + :prototype-form (make-pathname)) + (logical-pathname :depth 2 + :length ,(+ 7 sb-vm:instance-data-start) + :prototype-form (make-pathname :host "SYS") + :inherits (pathname)) + ;; These last few are strange. STREAM has only T as an ancestor, ;; so you'd think it would be at depth 1. FILE- and STRING-STREAM ;; each have STREAM and T as ancestors, so you'd think they'd be at depth @@ -1110,6 +1091,7 @@ codes state depth + (length 0) prototype-form (hierarchical-p t) ; might be modified below (direct-superclasses (if inherits @@ -1156,14 +1138,13 @@ (depthoid (if hierarchical-p (or depth (length inherits-vector)) -1))) - (register-layout - (find-and-init-or-check-layout name - depthoid - 0 ; flags - 0 ; length - +layout-all-tagged+ - inherits-vector) - :invalidate nil))))) + (register-layout (load-layout name + depthoid + inherits-vector + length + +layout-all-tagged+ + 0) ; flags + :invalidate nil))))) (/show0 "done with loop over +!BUILT-IN-CLASSES+")) ;;; Now that we have set up the class heterarchy, seal the sealed @@ -1186,8 +1167,9 @@ (warn "making ~(~A~) class ~S writable" it (classoid-name classoid)) (setf (classoid-state classoid) nil))) -;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe -;;; structure type tests to fail. Remove class from all superclasses +;;; Mark LAYOUT as invalid. This is called only on CONDITION and STRUCTURE +;;; subtypes when redefining incompatibly. PCL objects use invalidate-wrapper. +;;; Remove class from all superclasses ;;; too (might not be registered, so might not be in subclasses of the ;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to ;;; invalidate the wrappers for specialized dispatch functions, which @@ -1196,7 +1178,6 @@ (declare (type layout layout)) #+sb-xc-host (warn "Why are we invalidating layout ~S?" layout) (setf (layout-invalid layout) t) - (assign-layout-slots layout :depthoid -1) ;; Ensure that the INVALID slot conveying ancillary data describing the ;; invalidity reason is published before causing the invalid layout trap. (sb-thread:barrier (:write)) diff -Nru sbcl-2.0.6/src/code/cold-init-helper-macros.lisp sbcl-2.1.1/src/code/cold-init-helper-macros.lisp --- sbcl-2.0.6/src/code/cold-init-helper-macros.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/cold-init-helper-macros.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -75,7 +75,7 @@ (case method ((nil) ; default (values '(cl:make-load-form-saving-slots obj :environment env) - '(sb-xc:make-load-form-saving-slots obj :environment env))) + '(make-load-form-saving-slots obj :environment env))) (t (assert (not (member :host usable-by))) (values nil `(funcall ,method obj env)))) diff -Nru sbcl-2.0.6/src/code/cold-init.lisp sbcl-2.1.1/src/code/cold-init.lisp --- sbcl-2.0.6/src/code/cold-init.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/cold-init.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -73,12 +73,13 @@ *trace-output* *error-output*) (/show "testing '/SHOW" *print-length* *print-level*) ; show anything (unless (!c-runtime-noinform-p) - (write-string "COLD-INIT... ")) + ;; 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) - ;; Establish **initial-handler-clusters** - (show-and-call sb-kernel::!target-error-cold-init) ;; And now *CURRENT-THREAD* and *HANDLER-CLUSTERS* - (sb-thread::init-initial-thread) + (sb-thread::init-main-thread) ;; Assert that FBOUNDP doesn't choke when its answer is NIL. ;; It was fine if T because in that case the legality of the arg is certain. @@ -159,8 +160,10 @@ (%defun name (fdefinition name) inline-expansion dxable-args))) (unless (!c-runtime-noinform-p) - (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) + (progn (write `("Length(TLFs)=" ,(length *!cold-toplevels*)) :escape nil) + (terpri))) (loop with *package* = *package* ; rebind to self, as if by LOAD for index-in-cold-toplevels from 0 @@ -195,7 +198,7 @@ ;; 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) - (show-and-call time-reinit) + #+win32 (show-and-call reinit-internal-real-time) ;; Set sane values again, so that the user sees sane values instead ;; of whatever is left over from the last DECLAIM/PROCLAIM. @@ -224,7 +227,6 @@ (show-and-call float-cold-init-or-reinit) (show-and-call !class-finalize) - (show-and-call sb-pcl::!fixup-print-object-method-guards) ;; The reader and printer are initialized very late, so that they ;; can do hairy things like invoking the compiler as part of their @@ -258,11 +260,10 @@ (logically-readonlyize (sb-c::sc-move-vops sc)) (logically-readonlyize (sb-c::sc-move-costs sc)))) - ; hppa heap is segmented, lisp and c uses a stub to call eachother - #+hpux (%primitive sb-vm::setup-return-from-lisp-stub) ;; The system is finally ready for GC. (/show0 "enabling GC") (setq *gc-inhibit* nil) + #+sb-thread (finalizer-thread-start) ;; The show is on. (/show0 "going into toplevel loop") @@ -316,12 +317,12 @@ excepting errors from *EXIT-HOOKS*, which cause warnings and stop execution of the hook that signaled, but otherwise allow the exit process to continue normally." - (if (or abort *exit-in-process*) + (if (or abort *exit-in-progress*) (os-exit (or code 1) :abort t) (let ((code (or code 0))) (with-deadline (:seconds nil :override t) (sb-thread:grab-mutex *exit-lock*)) - (setf *exit-in-process* code + (setf *exit-in-progress* code *exit-timeout* timeout) (throw '%end-of-the-world t))) (critically-unreachable "After trying to die in EXIT.")) @@ -332,12 +333,13 @@ (sb-thread::init-job-control) (sb-thread::get-foreground)) -(defun reinit () +(defun reinit (total) ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS. (without-gcing ;; Until *CURRENT-THREAD* has been set, nothing the slightest bit complicated ;; can be called, as pretty much anything can assume that it is set. - (sb-thread::init-initial-thread) + (when total ; newly started process, and not a failed save attempt + (sb-thread::init-main-thread)) ;; Initializing the standard streams calls ALLOC-BUFFER which calls FINALIZE (finalizers-reinit) ;; Initialize streams next, so that any errors can be printed @@ -350,11 +352,12 @@ (float-cold-init-or-reinit)) (gc-reinit) (foreign-reinit) - (time-reinit) + #+win32 (reinit-internal-real-time) ;; If the debugger was disabled in the saved core, we need to ;; 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*)) ;;;; some support for any hapless wretches who end up debugging cold diff -Nru sbcl-2.0.6/src/code/common-os.lisp sbcl-2.1.1/src/code/common-os.lisp --- sbcl-2.0.6/src/code/common-os.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/common-os.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -61,7 +61,10 @@ (init-var-ignoring-errors *posix-argv* (loop for i from 0 - for arg = (sb-alien:deref (sb-alien:extern-alien posix_argv (* sb-alien:c-string)) i) + for arg = (sb-alien:deref (sb-alien:extern-alien posix_argv + (* (sb-alien:c-string + #+win32 :external-format #+win32 :ucs-2))) + i) while arg collect arg)) (/show0 "setting *DEFAULT-PATHNAME-DEFAULTS*") diff -Nru sbcl-2.0.6/src/code/condition.lisp sbcl-2.1.1/src/code/condition.lisp --- sbcl-2.0.6/src/code/condition.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/condition.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -73,8 +73,12 @@ (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 @@ -966,6 +970,14 @@ (: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) @@ -995,7 +1007,11 @@ () (:default-initargs :references '((:ansi-cl :function make-array) - (:ansi-cl :function sb-xc:upgraded-array-element-type)))) + (: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) () @@ -1224,7 +1240,7 @@ "An attempt to access an array of element-type ~ NIL was made. Congratulations!"))) (:default-initargs - :references '((:ansi-cl :function sb-xc:upgraded-array-element-type) + :references '((:ansi-cl :function upgraded-array-element-type) (:ansi-cl :section (15 1 2 1)) (:ansi-cl :section (15 1 2 2))))) @@ -1355,7 +1371,7 @@ () (:default-initargs :format-control - #.(sb-xc:macroexpand-1 ; stuff in a literal # + #.(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))))) @@ -1923,7 +1939,15 @@ (program-error-message condition))))) (define-condition simple-control-error (simple-condition control-error) ()) -(define-condition simple-file-error (simple-condition file-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 @@ -1932,9 +1956,26 @@ :format-arguments arguments)) (t (apply #'error datum :pathname pathname arguments)))) -(define-condition file-exists (simple-file-error) ()) -(define-condition file-does-not-exist (simple-file-error) ()) -(define-condition delete-file-error (simple-file-error) ()) +(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) ()) diff -Nru sbcl-2.0.6/src/code/cross-byte.lisp sbcl-2.1.1/src/code/cross-byte.lisp --- sbcl-2.0.6/src/code/cross-byte.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/cross-byte.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -55,7 +55,7 @@ (declaim (ftype function bug)) (define-setf-expander sb-xc:ldb (cross-byte int &environment env) (multiple-value-bind (temps vals stores store-form access-form) - (get-setf-expansion int env) + (cl:get-setf-expansion int env) (when (cdr stores) (bug "SETF SB-XC:LDB too hairy!")) (let ((btemp (gensym)) @@ -69,8 +69,8 @@ `(cl:ldb (uncross-byte ,btemp) ,access-form))))) (define-setf-expander sb-xc:mask-field (cross-byte int &environment env) - (multiple-value-bind (temps vals stores store-form access-form) - (get-setf-expansion int env) + (multiple-value-bind (temps vals stores store-form access-form) + (cl:get-setf-expansion int env) (when (cdr stores) (bug "SETF SB-XC:MASK-FIELD too hairy!")) (let ((btemp (gensym)) diff -Nru sbcl-2.0.6/src/code/cross-early.lisp sbcl-2.1.1/src/code/cross-early.lisp --- sbcl-2.0.6/src/code/cross-early.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/cross-early.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,19 @@ (in-package "SB-IMPL") +(defmacro sb-xc:declaim (&rest declaration-specifiers) + #+(or sb-devel sb-fluid) + (setq declaration-specifiers + (remove-if (lambda (declaration-specifier) + (member (first declaration-specifier) + '(#+sb-fluid inline + #+sb-fluid maybe-inline + #+sb-fluid sb-ext:freeze-type + #+sb-devel start-block + #+sb-devel end-block))) + declaration-specifiers)) + `(cl:declaim ,@declaration-specifiers)) + ;;; The STRUCTURE!OBJECT abstract class is the base of the hierarchy ;;; of objects that need to be identifiable as SBCL system objects ;;; in the host Lisp. This type does not exist in the target. diff -Nru sbcl-2.0.6/src/code/cross-float.lisp sbcl-2.1.1/src/code/cross-float.lisp --- sbcl-2.0.6/src/code/cross-float.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/cross-float.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -185,7 +185,7 @@ (exp-marker (if (and marker-pos (char-not-equal (char string marker-pos) #\E)) (char-upcase (char string marker-pos)) - (ecase *read-default-float-format* + (ecase cl:*read-default-float-format* ((cl:single-float cl:short-float) #\F) ((cl:double-float cl:long-float) #\D)))) (significand (if marker-pos (subseq string 0 marker-pos) string)) @@ -714,28 +714,28 @@ ;;; These use "#." so that they are dumped as literals rather than having to ;;; call read-from-string at load-time (and failing) due to the reader intercept. ;; #define __FLT_MAX__ 3.40282347e+38F -(defconstant sb-xc:most-positive-single-float +(defconstant most-positive-single-float #.(make-flonum (read-from-string "+3.40282347F38") 'single-float)) -(defconstant sb-xc:most-negative-single-float +(defconstant most-negative-single-float #.(make-flonum (read-from-string "-3.40282347F38") 'single-float)) ;; #define __DBL_MAX__ 1.7976931348623157e+308 -(defconstant sb-xc:most-positive-double-float +(defconstant most-positive-double-float #.(make-flonum (read-from-string "+1.7976931348623157D308") 'double-float)) -(defconstant sb-xc:most-negative-double-float +(defconstant most-negative-double-float #.(make-flonum (read-from-string "-1.7976931348623157D308") 'double-float)) ;;; PI is needed in order to build the cross-compiler mainly so that vm-fndb ;;; can define bounds on irrational functions. -(defconstant sb-xc:pi +(defconstant pi #.(make-flonum (read-from-string "3.14159265358979323846264338327950288419716939937511L0") 'double-float)) (eval-when (:compile-toplevel :execute) (setq sb-cold::*choke-on-host-irrationals* t)) ;;; These two constants are used in 'late-type' -(defconstant sb-xc:most-positive-long-float sb-xc:most-positive-double-float) -(defconstant sb-xc:most-negative-long-float sb-xc:most-negative-double-float) +(defconstant most-positive-long-float most-positive-double-float) +(defconstant most-negative-long-float most-negative-double-float) (defun substitute-minus-zero (list) (substitute $0.0d0 @@ -851,11 +851,11 @@ (if (and (eq (flonum-format a) (flonum-format c)) (or (eq (flonum-format b) (flonum-format a)) (eq (flonum-format b) 'single-float))) - (cond ((and (eql a sb-xc:most-negative-single-float) - (eql c sb-xc:most-positive-single-float)) + (cond ((and (eql a most-negative-single-float) + (eql c most-positive-single-float)) (not (float-infinity-p b))) - ((and (eql a sb-xc:most-negative-double-float) - (eql c sb-xc:most-positive-double-float)) + ((and (eql a most-negative-double-float) + (eql c most-positive-double-float)) (not (float-infinity-p b))) (t (error "Unhandled"))) @@ -992,6 +992,7 @@ (assert (eq (make-flonum :+infinity format) (sb-xc:- (make-flonum :-infinity format)))) (assert (eq (make-flonum :-infinity format) (sb-xc:- (make-flonum :+infinity format)))) (assert (eq (sb-xc:- (coerce 0 format)) (make-flonum :minus-zero format))) + (let ((*break-on-signals* nil)) (flet ((assert-not-number (x) (handler-case (realnumify x) (:no-error (x) (error "Expected an error, got ~S" x)) @@ -1001,7 +1002,7 @@ (assert-not-number nan) (assert (float-nan-p nan))) (dolist (symbol '(:+infinity :-infinity :minus-zero)) - (assert-not-number (make-flonum symbol format))))) + (assert-not-number (make-flonum symbol format)))))) #+host-quirks-sbcl ; Cross-check some more things if we can (loop for (our-symbol host-single host-double) diff -Nru sbcl-2.0.6/src/code/cross-misc.lisp sbcl-2.1.1/src/code/cross-misc.lisp --- sbcl-2.0.6/src/code/cross-misc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/cross-misc.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -30,6 +30,10 @@ (defmacro truly-the (type expr) `(the ,type ,expr)) +(defmacro the* ((type &rest args) expr) + (declare (ignore args)) + `(the ,type ,expr)) + (defmacro named-lambda (name args &body body) (declare (ignore name)) `#'(lambda ,args ,@body)) @@ -198,10 +202,16 @@ ;;; host CL package. This works around situations where the host has *more* ;;; symbols exported from CL than should be. (defun sb-xc:symbol-package (symbol) - (let ((p (cl:symbol-package symbol))) + (let ((p (cl:symbol-package symbol)) + (name (string symbol))) (if (and p - (or (eq (find-symbol (string symbol) "XC-STRICT-CL") symbol) - (eq (find-symbol (string symbol) "SB-XC") symbol))) + (or (eq (find-symbol name "XC-STRICT-CL") symbol) + (eq (find-symbol name "SB-XC") symbol) + ;; OK if the name of a symbol in the host CL package + ;; is found in XC-STRICT-CL, even if the symbols + ;; differ. + (and (find-symbol name "XC-STRICT-CL") + (eq (find-symbol name "CL") symbol)))) *cl-package* p))) @@ -223,8 +233,8 @@ ;;; Needed for constant-folding (defun system-area-pointer-p (x) x nil) ; nothing is a SAP -;;; Needed for DEFINE-MOVE-FUN LOAD-SYSTEM-AREA-POINTER -(defun sap-int (x) (error "can't take SAP-INT ~S" x)) +(defmacro sap-ref-word (sap offset) + `(#+64-bit sap-ref-64 #-64-bit sap-ref-32 ,sap ,offset)) (defun logically-readonlyize (x) x) @@ -238,8 +248,9 @@ ;;; For macro lambdas that are processed by the host (declaim (declaration top-level-form)) -;;; The opposite of the whitelist - if certain full calls are seen, it is probably -;;; the result of a missed transform and/or misconfiguration. +;;; The opposite of *undefined-fun-allowlist* - if certain full calls +;;; are seen, it is probably the result of a missed transform and/or +;;; misconfiguration. (defparameter *full-calls-to-warn-about* '(;mask-signed-field ;; Too many to fix )) @@ -335,7 +346,7 @@ (destructuring-bind (symbol value) (matchp '((quote ?) ? . :ignore) (cdr form)) `(progn (defconstant ,symbol ,value) (sb-c::%defconstant ',symbol ,symbol nil)))) - (sb-xc:defconstant ; we see this maro as well. The host expansion will not do, + (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) diff -Nru sbcl-2.0.6/src/code/cross-type.lisp sbcl-2.1.1/src/code/cross-type.lisp --- sbcl-2.0.6/src/code/cross-type.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/cross-type.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -150,7 +150,7 @@ ;; probably not a function. What about FMT-CONTROL instances? (values nil t))) ((system-area-pointer stream fdefn weak-pointer file-stream - code-component lra) + code-component lra pathname logical-pathname) (values nil t))) (cond ((eq name 'pathname) (values (pathnamep obj) t)) @@ -226,6 +226,7 @@ ;; subtypes of structure-object in make-host-1. '(hash-table lexenv sb-c::abstract-lexenv condition restart + pathname sb-impl::host sb-impl::pattern synonym-stream ;; why on earth is LABEL needed here? sb-assem:label)))) diff -Nru sbcl-2.0.6/src/code/deadline.lisp sbcl-2.1.1/src/code/deadline.lisp --- sbcl-2.0.6/src/code/deadline.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/deadline.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -32,7 +32,7 @@ (declaim (inline seconds-to-internal-time)) (defun seconds-to-internal-time (seconds) (the internal-time - (values (truncate (* seconds sb-xc:internal-time-units-per-second))))) + (values (truncate (* seconds internal-time-units-per-second))))) (eval-when (:compile-toplevel :load-toplevel :execute) ; for "#." (defconstant safe-internal-seconds-limit @@ -46,7 +46,7 @@ ;; #. is needed to make the value constant per se as opposed to ;; constant by decree, otherwise genesis runs into a problem. #.(floor (ash 1 (1- sb-kernel::internal-time-bits)) - sb-xc:internal-time-units-per-second))) + internal-time-units-per-second))) (declaim (inline seconds-to-maybe-internal-time)) (defun seconds-to-maybe-internal-time (seconds) @@ -115,8 +115,8 @@ "Returns internal time value TIME decoded into seconds and microseconds." (declare (type internal-time time)) (multiple-value-bind (sec frac) - (truncate time sb-xc:internal-time-units-per-second) - (values sec (* frac sb-unix::micro-seconds-per-internal-time-unit)))) + (truncate time internal-time-units-per-second) + (values sec (* frac sb-unix::microseconds-per-internal-time-unit)))) (defun signal-timeout (datum &rest arguments) "Signals a timeout condition while inhibiting further timeouts due to diff -Nru sbcl-2.0.6/src/code/debug-info.lisp sbcl-2.1.1/src/code/debug-info.lisp --- sbcl-2.0.6/src/code/debug-info.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/debug-info.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -418,7 +418,9 @@ ;; Location contexts ;; A (simple-array * (*)) or a context if there's only one context. (contexts nil :type t :read-only t) - (tlf-num+offset nil :type integer)) + ;; 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))) ;;; 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 diff -Nru sbcl-2.0.6/src/code/debug-int.lisp sbcl-2.1.1/src/code/debug-int.lisp --- sbcl-2.0.6/src/code/debug-int.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/debug-int.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -338,14 +338,11 @@ (compiled-frame-escaped obj)))) -(define-load-time-global *debug-funs-mutex* (sb-thread:make-mutex :name "CDF lock")) ;;; This maps SB-C::COMPILED-DEBUG-FUNs to ;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not ;;; duplicate COMPILED-DEBUG-FUN structures. -#+cheneygc ; can't write to debuf-info in a purified code object +#+cheneygc ; can't write to debug-info in a purified code object (define-load-time-global *compiled-debug-funs* - ;; The table's lock is redundant - I'm working on removal of the default - ;; assumption of synchronization on all weak tables, but it's unrelated. (make-hash-table :test 'eq :weakness :key)) ;;;; breakpoints @@ -441,11 +438,11 @@ (end-starter nil :type (or null breakpoint))) ;;; Map a SB-C::COMPILED-DEBUG-FUN to a SB-DI::COMPILED-DEBUG-FUN. -;;; The mapping is memoized into %CODE-DEBUG-INFO of COMPONENT +;;; The mapping is memoized into a slot of %CODE-DEBUG-INFO of COMPONENT ;;; except on #+cheneygc where that is assumed not to be possible ;;; (even if it is possible), because usually it's not, because -;;; code might reside in readonly space, and it can only have pointers -;;; to static space, not dynamic space. +;;; code and the debug structures are defined with :PURE T and might reside +;;; in readonly space, which can only have pointers to static space. ;;; ;;; BTW, the nomenclature here is utter and total confusion. ;;; The type of the object in the argument named COMPILER-DEBUG-FUN @@ -454,21 +451,31 @@ ;;; of the slot in the SB-DI:: version of the structure. (defun make-compiled-debug-fun (compiler-debug-fun component) (declare (code-component component)) - ;; Technically this could all be lockfree if we had compare-and-swap - ;; on the debug-info slot. Not worth the effort. - (sb-thread::with-system-mutex (*debug-funs-mutex*) - #+gencgc - (let* ((info (ensure-list (sb-vm::%%code-debug-info component))) - (found (assoc compiler-debug-fun (cdr info) :test #'eq))) - (if found - (cdr found) - (let* ((my-debug-fun (%make-compiled-debug-fun compiler-debug-fun component)) - (new-pair (cons compiler-debug-fun my-debug-fun))) - (setf (%code-debug-info component) (list* (car info) new-pair (cdr info))) - my-debug-fun))) - #+cheneygc - (ensure-gethash compiler-debug-fun *compiled-debug-funs* - (%make-compiled-debug-fun compiler-debug-fun component)))) + #+gencgc + (let ((memo-cell + (let* ((info (sb-vm::%%code-debug-info component)) + (val (sb-c::compiled-debug-info-tlf-num+offset info))) + (if (consp val) + val + (let* ((list (list val)) + (old (cas (sb-c::compiled-debug-info-tlf-num+offset info) val list))) + (if (eq old val) list old)))))) + ;; The CDR of TLF-NUM+OFFSET slot is an alist from compiler -> debugger structure. + (let ((new-df nil) (new-pair nil) (new-alist nil) (alist (cdr memo-cell))) + (loop + ;; This list generally contains 5 items or less. At least, in our tests it does + ;; which I assume is typical. + (awhen (assoc compiler-debug-fun alist :test #'eq) (return (cdr it))) + (if new-alist + (rplacd new-alist alist) + (setq new-df (%make-compiled-debug-fun compiler-debug-fun component) + new-pair (cons compiler-debug-fun new-df) + new-alist (cons new-pair alist))) + (let ((old (cas (cdr memo-cell) alist new-alist))) + (if (eq old alist) (return new-df) (setq alist old)))))) + #+cheneygc + (ensure-gethash compiler-debug-fun *compiled-debug-funs* + (%make-compiled-debug-fun compiler-debug-fun component))) ;;;; CODE-LOCATIONs @@ -509,7 +516,7 @@ ;;; address, whereas the one in C is an index into code->constants. (defconstant real-lra-slot sb-vm:code-constants-offset) -#-sb-fluid (declaim (inline control-stack-pointer-valid-p)) +(declaim (inline control-stack-pointer-valid-p)) (defun control-stack-pointer-valid-p (x &optional (aligned t)) (declare (type system-area-pointer x)) (let* (#-stack-grows-downward-not-upward @@ -606,17 +613,14 @@ (defun code-header-from-pc (pc) (declare (system-area-pointer pc)) - (macrolet ((heap-scan () - `(let ((component-ptr - (sb-alien:alien-funcall - (sb-alien:extern-alien - "component_ptr_from_pc" - (function system-area-pointer system-area-pointer)) - pc))) - (unless (sap= component-ptr (int-sap 0)) - (%make-lisp-obj - (logior (sap-int component-ptr) sb-vm:other-pointer-lowtag)))))) - (without-gcing (heap-scan)))) + (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))) + (unless (= base-ptr 0) + (%make-lisp-obj (logior base-ptr sb-vm:other-pointer-lowtag)))))) ;;;; (OR X86 X86-64) support @@ -636,7 +640,7 @@ ;;; address. ;;; ;;; XXX Could be a little smarter. -#-sb-fluid (declaim (inline ra-pointer-valid-p)) +(declaim (inline ra-pointer-valid-p)) (defun ra-pointer-valid-p (ra) (declare (type system-area-pointer ra)) (and @@ -945,27 +949,13 @@ (defun nth-interrupt-context (n) (declare (muffle-conditions compiler-note)) - (declare (type (mod #.(- sb-vm:max-interrupts sb-vm::thread-header-slots)) n) + (declare (type (mod #.sb-vm:max-interrupts) n) (optimize (speed 3) (safety 0))) - (let* ((n (- -1 (+ sb-vm::thread-header-slots n) - #+sb-safepoint - ;; the C safepoint page - (/ sb-c:+backend-page-bytes+ n-word-bytes))) - (context-pointer - ;; The Alpha code is quite possibly wrong; I have no idea. - (sb-vm::current-thread-offset-sap - #-alpha n - #+alpha (* 2 n)))) - (sb-alien:sap-alien context-pointer (* os-context-t)))) - -;;; With :LINKAGE-TABLE symbols which come from the runtime go through -;;; an indirection table, but the debugger needs to know the actual -;;; address. -(defun static-foreign-symbol-address (name) - #+linkage-table - (find-dynamic-foreign-symbol-address name) - #-linkage-table - (foreign-symbol-address name)) + (let ((tls-words (ash (sb-alien:extern-alien "dynamic_values_bytes" + (sb-alien:unsigned 32)) + (- sb-vm:word-shift)))) + (sb-alien:sap-alien (sb-vm::current-thread-offset-sap (+ tls-words n)) + (* os-context-t)))) (defun catch-runaway-unwind (block) (declare (ignorable block)) @@ -1021,8 +1011,7 @@ (unless (control-stack-pointer-valid-p cfp) (return (values nil nil nil t))) (when (sap= frame-pointer cfp) - (without-gcing - (/noshow0 "in WITHOUT-GCING") + (with-code-pages-pinned (:dynamic) (return (escaped-frame-from-context context))))))) #+(or x86 x86-64) @@ -1898,7 +1887,7 @@ prev-name) (t (geti)))) ;; Keep the condition in sync with DUMP-1-VAR - (large-fixnums (>= (integer-length sb-xc:most-positive-fixnum) 62)) + (large-fixnums (>= (integer-length most-positive-fixnum) 62)) (sc+offset (if deleted 0 (if large-fixnums (ldb (byte 27 8) flags) (geti)))) (save-sc+offset (and save @@ -2379,13 +2368,8 @@ (int-sap (sb-vm:context-register escaped sb-vm::nfp-offset)) - #-alpha (sap-ref-sap fp (* nfp-save-offset - sb-vm:n-word-bytes)) - #+alpha - (sb-vm::make-number-stack-pointer - (sap-ref-32 fp (* nfp-save-offset - sb-vm:n-word-bytes)))))) + sb-vm:n-word-bytes))))) ,@body)) (number-stack-offset (&optional (offset 0)) #+(or x86 x86-64) @@ -2560,15 +2544,9 @@ (int-sap (sb-vm:context-register escaped sb-vm::nfp-offset)) - #-alpha (sap-ref-sap fp (* nfp-save-offset - sb-vm:n-word-bytes)) - #+alpha - (sb-vm::make-number-stack-pointer - (sap-ref-32 fp - (* nfp-save-offset - sb-vm:n-word-bytes)))))) + sb-vm:n-word-bytes))))) ,@body)) (number-stack-offset (&optional (offset 0)) #+(or x86 x86-64) @@ -3483,7 +3461,8 @@ (let ((ocfp (int-sap (sb-vm:context-register scp #-(or x86 x86-64) sb-vm::ocfp-offset - #+(or x86 x86-64) sb-vm::ebx-offset))) + #+x86-64 sb-vm::rbx-offset + #+x86 sb-vm::ebx-offset))) (nargs (boxed-context-register scp sb-vm::nargs-offset)) (reg-arg-offsets '#.sb-vm::*register-arg-offsets*) (results nil)) @@ -3507,8 +3486,7 @@ (defun make-bpt-lra (real-lra) (declare (type #-(or x86 x86-64) lra #+(or x86 x86-64) system-area-pointer real-lra)) (macrolet ((symbol-addr (name) - ;; "static" is not really correct if #+linkage-table - `(static-foreign-symbol-address ,name)) + `(find-dynamic-foreign-symbol-address ,name)) (trap-offset () `(- (symbol-addr "fun_end_breakpoint_trap") src-start))) ;; These are really code labels, not variables: but this way we get @@ -3535,7 +3513,7 @@ (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 sort of OK. + ;; 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. diff -Nru sbcl-2.0.6/src/code/debug.lisp sbcl-2.1.1/src/code/debug.lisp --- sbcl-2.0.6/src/code/debug.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/debug.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -465,11 +465,19 @@ (< a (get-lisp-obj-address sb-vm:*control-stack-end*))) sb-thread:*current-thread*) (all-threads - ;; find a stack whose base is nearest and below A. - (awhen (sb-thread::avl-find<= a sb-thread::*all-threads*) - (let ((thread (sb-thread::avlnode-data it))) - (when (< a (sb-thread::thread-stack-end thread)) - thread)))))))) + (macrolet ((in-stack-range-p () + `(and (>= a (sb-thread::thread-control-stack-start thread)) + (< a (sb-thread::thread-control-stack-end thread))))) + #+win32 ; exhaustive search + (dolist (thread (sb-thread:list-all-threads)) ; conses, but I don't care + (when (in-stack-range-p) + (return thread))) + #-win32 + ;; find a stack whose primitive-thread is nearest and above A. + (awhen (sb-thread::avl-find>= a sb-thread::*all-threads*) + (let ((thread (sb-thread::avlnode-data it))) + (when (in-stack-range-p) + thread))))))))) ;;;; frame printing @@ -673,7 +681,7 @@ (defun ensure-printable-object (object) (handler-case - (with-open-stream (out (make-broadcast-stream)) + (with-open-stream (out sb-impl::*null-broadcast-stream*) (prin1 object out) object) (error (cond) @@ -1636,7 +1644,7 @@ (show-restarts *debug-restarts* *debug-io*)) (!def-debug-command "BACKTRACE" () - (print-backtrace :count (read-if-available sb-xc:most-positive-fixnum))) + (print-backtrace :count (read-if-available most-positive-fixnum))) (!def-debug-command "PRINT" () (print-frame-call *current-frame* *debug-io*)) @@ -1933,3 +1941,39 @@ (if (listen-skip-whitespace *debug-io*) (read *debug-io*) default)) + +#+(and sb-devel x86-64) +(defun show-catch-tags () + (declare (notinline format)) + (let ((sap (descriptor-sap sb-vm:*current-catch-block*))) + (loop + (let ((tag (sap-ref-lispobj sap (ash sb-vm:catch-block-tag-slot 3))) + (link (sap-ref-sap sap (ash sb-vm:catch-block-previous-catch-slot 3)))) + (format t "~S ~A~%" tag link) + (setq sap link) + (if (= (sap-int sap) 0) (return)))))) + +;;; Sometimes in cold-init it is not possible to call LIST-BACKTRACE +;;; because that depends on a zillion things being set up correctly. +;;; This simple version seems to always work. +#+(or x86 x86-64) +(defun ultralite-backtrace (&optional (decode-pcs t)) + ;; this misses the current frame but that's perfectly fine for its intended use + (let ((fp (current-fp)) (list)) + (loop + (let ((prev-fp (sap-ref-sap fp 0))) + (cond ((and (sap> prev-fp fp) + (sap< prev-fp (descriptor-sap sb-vm:*control-stack-end*))) + (push (sap-ref-sap fp sb-vm:n-word-bytes) list) ; pc + (setq fp prev-fp)) + (t + (return))))) + (setq list (nreverse list)) + (if decode-pcs + (mapcar (lambda (pc) + (let ((code (sb-di::code-header-from-pc pc))) + (if code + (cons code (sap- pc (code-instructions code))) + pc))) + list) + list))) diff -Nru sbcl-2.0.6/src/code/debug-var-io.lisp sbcl-2.1.1/src/code/debug-var-io.lisp --- sbcl-2.0.6/src/code/debug-var-io.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/debug-var-io.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -210,7 +210,7 @@ lz-compress)) (defun lz-compress (input) (if (> (length input) +max-lz-size+) - (sb-xc:coerce input '(simple-array (unsigned-byte 8) (*))) + (coerce input '(simple-array (unsigned-byte 8) (*))) (let* ((length (length input)) (output (make-array length :element-type '(unsigned-byte 8) @@ -270,7 +270,7 @@ (mask-signed-field 8 (the (unsigned-byte 8) x))) input) #+sb-xc-host - (sb-xc:coerce output '(simple-array (unsigned-byte 8) (*))) + (coerce output '(simple-array (unsigned-byte 8) (*))) #-sb-xc-host (%shrink-vector (%array-data output) (fill-pointer output))))) #+(or) diff -Nru sbcl-2.0.6/src/code/defbangstruct.lisp sbcl-2.1.1/src/code/defbangstruct.lisp --- sbcl-2.0.6/src/code/defbangstruct.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/defbangstruct.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -53,7 +53,7 @@ `(progn (sb-xc:defstruct ,@args) ,@(when supertype - `((aver (subtypep ',supertype 'structure!object)))) + `((aver (cl:subtypep ',supertype 'structure!object)))) (defstruct (,name ,@(unless supertype '((:include structure!object))) ,@(remove :pure options :key #'car)) @@ -69,7 +69,7 @@ (defmacro sb-xc:defstruct (&rest args) `(push (make-delayed-defstruct ',args) *delayed-defstructs*)) ;;; But instead it's this. No eval-when needed, since we LOAD this file. -(setf (macro-function 'sb-xc:defstruct) +(setf (cl:macro-function 'sb-xc:defstruct) (lambda (form environment) (declare (ignore environment)) `(push (make-delayed-defstruct ',(cdr form)) *delayed-defstructs*))) diff -Nru sbcl-2.0.6/src/code/defmacro.lisp sbcl-2.1.1/src/code/defmacro.lisp --- sbcl-2.0.6/src/code/defmacro.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/defmacro.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -62,13 +62,13 @@ ;; and comparing it with the new one. (warn 'redefinition-with-defmacro :name name :new-function definition :new-location source-location)) - (setf (sb-xc:macro-function name) definition))) + (setf (macro-function name) definition))) name) #+sb-xc-host -(let ((real-expander (macro-function 'sb-xc:defmacro))) +(let ((real-expander (cl:macro-function 'sb-xc:defmacro))) ;; Inform the cross-compiler how to expand SB-XC:DEFMACRO (= DEFMACRO). - (setf (sb-xc:macro-function 'sb-xc:defmacro) + (setf (macro-function 'sb-xc:defmacro) (lambda (form env) (declare (ignore env)) ;; Since SB-KERNEL:LEXENV isn't compatible with the host, @@ -77,5 +77,17 @@ (funcall real-expander form nil))) ;; Building the cross-compiler should skip the compile-time-too ;; processing SB-XC:DEFMACRO. - (setf (macro-function '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.0.6/src/code/defsetfs.lisp sbcl-2.1.1/src/code/defsetfs.lisp --- sbcl-2.0.6/src/code/defsetfs.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/defsetfs.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -199,14 +199,14 @@ ;; it. In particular, this must fail: (SETF (GET 'SYM 'IND (ERROR "Foo")) 3). (defsetf get (symbol indicator &optional default &environment e) (newval) - (let ((constp (sb-xc:constantp default e))) + (let ((constp (constantp default e))) ;; always reference default's temp var to "use" it `(%put ,symbol ,indicator ,(if constp newval `(progn ,default ,newval))))) ;; A possible optimization for read/modify/write of GETHASH ;; would be to predetermine the vector element where the key/value pair goes. (defsetf gethash (key hashtable &optional default &environment e) (newval) - (let ((constp (sb-xc:constantp default e))) + (let ((constp (constantp default e))) ;; always reference default's temp var to "use" it `(%puthash ,key ,hashtable ,(if constp newval `(progn ,default ,newval))))) @@ -215,7 +215,7 @@ (define-setf-expander the (&whole form type place &environment env) (binding* ((op (car form)) ((temps subforms store-vars setter getter) - (sb-xc:get-setf-expansion place env))) + (get-setf-expansion place env))) (values temps subforms store-vars `(multiple-value-bind ,store-vars (,op ,type (values ,@store-vars)) ,setter) @@ -223,7 +223,7 @@ (define-setf-expander getf (place prop &optional default &environment env) (binding* (((place-tempvars place-tempvals stores set get) - (sb-xc:get-setf-expansion place env)) + (get-setf-expansion place env)) ((call-tempvars call-tempvals call-args bitmask) (collect-setf-temps (list prop default) env '(indicator default))) (newval (gensym "NEW"))) @@ -245,7 +245,7 @@ (let (all-dummies all-vals newvals setters getters) (dolist (place places) (multiple-value-bind (dummies vals newval setter getter) - (sb-xc:get-setf-expansion place env) + (get-setf-expansion place env) ;; ANSI 5.1.2.3 explains this logic quite precisely. -- ;; CSR, 2004-06-29 (setq all-dummies (append all-dummies dummies (cdr newval)) @@ -307,7 +307,7 @@ (collect-setf-temps (list spec) env '(bytespec)))) (byte (if (cdr byte-args) (cons 'byte byte-args) (car byte-args))) ((place-tempvars place-tempvals stores setter getter) - (sb-xc:get-setf-expansion place env)) + (get-setf-expansion place env)) (newval (sb-xc:gensym "NEW")) (new-int `(,store-fun ,(if (eq load-fun 'logbitp) `(if ,newval 1 0) newval) diff -Nru sbcl-2.0.6/src/code/defstruct.lisp sbcl-2.1.1/src/code/defstruct.lisp --- sbcl-2.0.6/src/code/defstruct.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/defstruct.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -140,24 +140,25 @@ ;; and we don't have structures whose slot indices run into the thousands. (bits 0 :type fixnum :read-only t) (default nil :read-only t)) ; default value expression -#-sb-fluid (declaim (freeze-type defstruct-slot-description)) +(declaim (freeze-type defstruct-slot-description)) (eval-when (:compile-toplevel) ;; Ensure that rsd-index is representable in 3 bits. (Can easily be changed) (assert (<= (1+ (length *raw-slot-data*)) 8))) -;; genesis needs to know how many bits are to the right of the 'index' field -;; in the packed BITS slot of a DSD. -(defconstant +dsd-index-shift+ 6) -(defun pack-dsd-bits (index read-only safe-p always-boundp rsd-index) - (logior (ash index +dsd-index-shift+) - (if read-only (ash 1 5) 0) - (if safe-p (ash 1 4) 0) - (if always-boundp (ash 1 3) 0) +(defconstant sb-vm:dsd-index-shift 7) +(defconstant sb-vm:dsd-raw-type-mask #b111) +(defun pack-dsd-bits (index read-only safe-p always-boundp gc-ignorable rsd-index) + (logior (ash index sb-vm:dsd-index-shift) + (if read-only (ash 1 6) 0) + (if safe-p (ash 1 5) 0) + (if always-boundp (ash 1 4) 0) + (if gc-ignorable (ash 1 3) 0) (the (unsigned-byte 3) (if rsd-index (1+ rsd-index) 0)))) (declaim (inline dsd-always-boundp dsd-safe-p + dsd-gc-ignorable ; dsd-read-only ; compilation order problem )) @@ -187,22 +188,24 @@ ;; Index into *RAW-SLOT-DATA* vector of the RAW-SLOT-DATA for this slot. ;; The index is NIL if this slot is not raw. (defun dsd-rsd-index (dsd) - (let ((val (ldb (byte 3 0) (dsd-bits dsd)))) + (let ((val (logand (dsd-bits dsd) sb-vm:dsd-raw-type-mask))) (if (plusp val) (the (mod #.(length *raw-slot-data*)) (1- val))))) +;;; GC-ignorable slots are a superset of raw slots. +(defun dsd-gc-ignorable (dsd) (logbitp 3 (dsd-bits dsd))) ;; Whether the slot is always bound. Slots are almost always bound, ;; the exception being those which appear as an &AUX var with no value ;; in a BOA constructor. -(defun dsd-always-boundp (dsd) (logbitp 3 (dsd-bits dsd))) +(defun dsd-always-boundp (dsd) (logbitp 4 (dsd-bits dsd))) ;; Whether the slot is known to be always of the specified type ;; A slot may be SAFE-P even if not always-boundp. -(defun dsd-safe-p (dsd) (logbitp 4 (dsd-bits dsd))) -(defun dsd-read-only (dsd) (logbitp 5 (dsd-bits dsd))) +(defun dsd-safe-p (dsd) (logbitp 5 (dsd-bits dsd))) +(defun dsd-read-only (dsd) (logbitp 6 (dsd-bits dsd))) ;; its position in the implementation sequence (defun dsd-index (dsd) - (the index (ash (dsd-bits dsd) (- +dsd-index-shift+)))) + (the index (ash (dsd-bits dsd) (- sb-vm:dsd-index-shift)))) (sb-c:define-source-transform dsd-index (dsd) - `(truly-the index (ash (dsd-bits ,dsd) ,(- +dsd-index-shift+)))) + `(truly-the index (ash (dsd-bits ,dsd) ,(- sb-vm:dsd-index-shift)))) (!set-load-form-method defstruct-slot-description (:host :xc :target)) (defmethod print-object ((x defstruct-slot-description) stream) @@ -466,10 +469,9 @@ (optimize-speed (and (not delayp) (sb-c:policy env (< space 3))))) `(progn - ,@(!expander-for-defstruct - null-env-p optimize-speed delayp - name-and-options slot-descriptions - :target)))) + ,@(!expander-for-defstruct null-env-p optimize-speed delayp + name-and-options slot-descriptions + :target)))) ;;;; functions to generate code for various parts of DEFSTRUCT definitions @@ -764,13 +766,20 @@ (layout-inherits super) (vector super))))) (proto-classoid (if (dd-class-p dd) + ;; The classoid needs a layout whereby to convey inheritance. + ;; Classoids only store a *direct* superclass list. + ;; Both the layout and classoid are throwaway objects. + ;; 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-layout (hash-layout-name (dd-name dd)) - classoid :inherits inherits))) - (setf (layout-invalid layout) nil - (classoid-layout classoid) layout) + (layout (make-temporary-layout (hash-layout-name (dd-name dd)) + classoid inherits))) + (setf (classoid-layout classoid) layout) classoid))) (ancestor-slot-comparator-list)) + #+sb-xc-host + (when (member (dd-name dd) '(pathname logical-pathname)) + (setf (dd-alternate-metaclass dd) '(t built-in-classoid nil))) ;; Type parsing should be done assuming that prototype classoid ;; exists, which fixes a problem when redefining a DEFTYPE which ;; appeared to be a raw slot. e.g. @@ -788,6 +797,8 @@ (let ((comparator (nth-value 1 (parse-1-dsd proto-classoid dd slot-description)))) (comparator-list comparator))) + (when (dd-class-p dd) + (setf (dd-bitmap dd) (calculate-dd-bitmap dd))) (values inherits (comparator-list))))) ;;;; stuff to parse slot descriptions @@ -905,7 +916,7 @@ ;; But also, don't call SB-XC:TYPEP on a type-specifier because it does ;; not receive a type-context which specifies the proto-classoid. (when (and (typep type '(cons (eql or))) (member 'null type)) - (setq ctype *universal-type*)) ; a little white lie + (setq ctype *universal-type*)) ; a harmless lie (unless ctype (let ((context (make-type-context type proto-classoid nil))) @@ -924,7 +935,7 @@ index (dsd-index included-slot)) (when (and safe-p (not (equal type (dsd-type included-slot))) - (not (sb-xc:subtypep (dsd-type included-slot) type))) + (not (subtypep (dsd-type included-slot) type))) (setf safe-p nil))) (t ;; Compute the index of this DSD. First decide whether the slot is raw. @@ -964,10 +975,15 @@ (when (or rsd-index (neq (dd-type defstruct) 'structure)) (setf always-boundp t safe-p nil))) ; "demote" to unsafe. - (let ((dsd (make-dsd name type accessor-name - (pack-dsd-bits index read-only safe-p - always-boundp rsd-index) - default))) + (let* ((gc-ignorable + (csubtypep ctype + (specifier-type '(or fixnum boolean character + #+64-bit single-float)))) + (dsd (make-dsd name type accessor-name + (pack-dsd-bits index read-only safe-p + always-boundp gc-ignorable + rsd-index) + default))) #-sb-xc-host (push (cons dsd spec) *dsd-source-form*) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list dsd))) (let ((comparator @@ -1004,7 +1020,7 @@ ;; 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-info included-layout))) + (included-dd (layout-dd included-layout))) (when (dd-alternate-metaclass included-dd) (error "can't :INCLUDE class ~S (has alternate metaclass)" included-name))))) @@ -1095,6 +1111,8 @@ (layout-inherits super) (vector super (classoid-layout (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) (vector super)))))) @@ -1120,7 +1138,10 @@ (unless (dsd-read-only slot) (fmakunbound `(setf ,(dsd-accessor-name slot))))))) (setq layout (classoid-layout classoid)))) - (setf (find-classoid (dd-name dd)) 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)) + (setf (find-classoid (dd-name dd)) classoid)) (when source-location (setf (classoid-source-location classoid) source-location)))) @@ -1301,7 +1322,10 @@ (t (unless (eq (classoid-layout classoid) layout) (register-layout layout :invalidate nil)) - (setf (find-classoid (dd-name dd)) 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)) + (setf (find-classoid (dd-name dd)) classoid)))) ;; At this point the class should be set up in the INFO database. ;; But the logic that enforces this is a little tangled and @@ -1317,8 +1341,8 @@ (dolist (ctor (dd-constructors dd)) (setf (info :function :source-transform (car ctor)) info)))) -;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not -;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD. +;;; Do (COMPILE LOAD EVAL)-time actions for the structure described by DD +;;; which may be a "normal" defstruct or an alternate-metaclass struct. ;;; This includes generation of a style-warning about previously compiled ;;; calls to the accessors and/or predicate that weren't inlined. (defun %compiler-defstruct (dd inherits) @@ -1404,7 +1428,7 @@ (dolist (name (intersection onames nnames)) (let ((os (find name oslots :key #'dsd-name :test #'string=)) (ns (find name nslots :key #'dsd-name :test #'string=))) - (unless (sb-xc:subtypep (dsd-type ns) (dsd-type os)) + (unless (subtypep (dsd-type ns) (dsd-type os)) (retyped name)) (unless (and (= (dsd-index os) (dsd-index ns)) (eq (dsd-raw-type os) (dsd-raw-type ns))) @@ -1434,16 +1458,33 @@ ;;; Return true if destructively modifying OLD-LAYOUT into NEW-LAYOUT ;;; would be possible in as much as it won't harm the garbage collector. ;;; Harm potentially results from turning a raw word into a tagged word. +;;; There are additional mutations which would be permissible but don't +;;; strike me as important - e.g. permitting a fixnum slot to become type T +;;; is permissible, but the fixnum may or may not be marked as tagged +;;; in the bitmap, depending on whether any raw slot exists. +;;; I can't imagine that many users will complain that they can no longer +;;; incompatibly redefine defstructs involving raw slots. +;;; Additionally, it is no longer possible to RECKLESSLY-CONTINUE on a defstruct +;;; if the number of words in the layout would differ due to extra ID words, +;;; but given that it was already not possible if the bitmaps differ, +;;; it does not seem a big sacrifice to disallow redefining structures +;;; at depthoids in excess of 7 (LAYOUT-ID-VECTOR-FIXED-CAPACITY) unless +;;; 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))) - (aver (= old-bitmap (dd-bitmap (layout-info old-layout)))) - (aver (= new-bitmap (dd-bitmap (layout-info new-layout)))) - (dotimes (i (dd-length (layout-info 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)))) + ;; 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) + (when (and (logbitp i new-bitmap) ; a tagged (i.e. scavenged) slot + (not (logbitp i old-bitmap))) ; that was opaque bits + (return nil))))) t)) ;;; This function is called when we are incompatibly redefining a @@ -1453,6 +1494,7 @@ (defun %redefine-defstruct (classoid old-layout new-layout) (declare (type classoid classoid) (type layout old-layout new-layout)) + (declare (ignorable old-layout)) ; for host (let ((name (classoid-proper-name classoid))) (restart-case (error "~@" @@ -1465,6 +1507,7 @@ already-loaded code and instances.~@:>" name)) (register-layout new-layout)) + #-sb-xc-host (recklessly-continue () :test (lambda (c) (declare (ignore c)) @@ -1484,49 +1527,146 @@ (values)) ;;; Compute DD's bitmap, storing 1 for each tagged word. -;;; The bitmap should be stored as a negative fixnum in two cases: -;;; (1) if the positive value is a bignum but the negative is a fixnum. -;;; (2) if there are no raw slots at all. -;;; Example: given (DEFSTRUCT S A B C), the computed bitmap is #b11111 - -;;; one bit for the layout; one each for A, B, C; and one for padding. -;;; Whether this is stored as 31 or -1 is mostly immaterial, -;;; but -1 is preferable because GC has a special case for it. -;;; Suppose instead we have 1 untagged word followed by N tagged words -;;; for N > n-fixnum-bits. The computed bitmap is #b111...11101 -;;; but the sign-extended value is -3, which is a fixnum. -;;; If both the + and - values are fixnums, and raw slots are present, -;;; we'll choose the positive value. -(defun dd-bitmap (dd) - ;; With compact instances, LAYOUT is not reflected in the bitmap. - ;; Without compact instances, the 0th bitmap bit (for the LAYOUT) is always 1. - ;; In neither case is the place for the layout represented in in DD-SLOTS. - (let ((bitmap sb-vm:instance-data-start)) +;;; The GC can parse signed fixnums and bignums, with which we can +;;; represent an unlimited number of "&rest" slots all with the same +;;; nature - tagged or raw. If REST is :TAGGED or :UNTAGGED, it +;;; specifies a particular nature. If :UNSPECIFIC, then we sign-extend +;;; from the last specified slot which tends to reduce the bitmap to +;;; -1 in the case of everything being tagged, (or -2 if non-compact +;;; header), or a small positive fixnum if the last is untagged. +;;; +;;; Bit indices correspond to physical word indices excluding +;;; the header word. So the least-significant bit of a bitmap is +;;; always the word just after the instance header word. +;;; +;;; Examples: (Legend: u=untaggged slot, t=tagged slot) +;;; +;;; logical arithmetic +;;; bitmap value +;;; Funcallable object: +;;; Non-compact header: #b...1100 -4 +;;; word0: header +;;; word1: (*) entry address +;;; word2: (u) layout +;;; word3: (t) implementation-fun +;;; word4: (t) tagged slots ... +;;; Compact header: +;;; External trampoline: #b...1111 -1 +;;; word0: header/layout +;;; word1: (*) entry address +;;; word2: (t) implementation-fun +;;; word3: (t) tagged slots ... +;;; Internal trampoline: #b..00110 6 +;;; word0: header/layout +;;; word1: (*) entry address [= word 4] +;;; word2: (t) implementation-fun +;;; word3: (t) tagged slot +;;; word4: (u) machine code +;;; word5: (u) machine code +;;; (*) entry address can be treated as either tagged or raw. +;;; For some architectures it has a lowtag, but points to +;;; read-only space. For others it is a fixnum. +;;; In either case the GC need not observe the value. +;;; Compact-header with external trampoline can indicate +;;; all slots as tagged. The other two cases above have at +;;; least one slot which must be marked raw. +;;; +;;; Ordinary instance with only tagged slots: +;;; Non-compact header: #b...1110 -2 +;;; word0: header +;;; word1: (u) layout +;;; word2: (t) tagged slots ... +;;; Compact header: #b...1111 -1 +;;; word0: header/layout +;;; word1: (t) tagged slots ... +;;; Ordinary instance with only raw slots slots: +;;; [this also includes objects whose slots all have types +;;; ignorable by GC such as fixum/character] +;;; Non-compact header: #b...0000 0 +;;; word0: header +;;; word1: (u) layout +;;; word2: (u) raw slots ... +;;; Compact header: #b...0000 0 +;;; word0: header/layout +;;; word1: (u) raw slots ... +;;; +;;; Notes: +;;; 1. LAYOUT has to be scanned separately regardless of where stored. +;;; (compact header or not). Hence it is regarded as an untagged slot. +;;; 2. For funcallable objects these examples are exhaustive of all +;;; possible bitmaps. The instance length can be anything, +;;; but untagged slots are not generally supported. +;;; For ordinary instance the examples are merely illustrative. +;;; +(defun calculate-dd-bitmap (dd &optional (rest :unspecific)) + (declare (type (member :unspecific :tagged :untagged) rest)) + #+sb-xc-host + (when (eq (dd-name dd) 'layout) + (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 + (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, + ;; and the "maximal" bitmap contains a 1 for each which *may* be scanned. + ;; If a non-raw slot type can be ignored - such as (OR FIXNUM NULL), then it + ;; sets a 1 in the maximal bitmap but not in the minimal bitmap. + ;; Note that the GC can always add one slot for a stable hash, but that slot + ;; can only hold a fixnum, so need not be traced even though it is a descriptor. + (let ((n-bits (dd-length dd)) + (any-raw) + (maximal-bitmap 0) + (minimal-bitmap 0)) (dolist (slot (dd-slots dd)) - (when (eql t (dsd-raw-type slot)) - (setf bitmap (logior bitmap (ash 1 (dsd-index slot)))))) - ;; The garbage collector can add one more word, but it doesn't need - ;; to be accounted for in the bitmap. - ;; If the bitmap is -1 ("all tagged"), we leave it alone; if a positive - ;; number, the added trailing slot can be regarded as untagged. - (let* ((length (dd-length dd)) - (n-bits (logior length 1))) - (when (evenp length) ; Add padding word if necessary. - (setq bitmap (logior bitmap (ash 1 length)))) - (when (and (logbitp (1- n-bits) bitmap) - ;; Bitmap of -1 implies that all slots are tagged, - ;; and no extraordinary GC treatment is needed. - ;; If all are tagged but any special treatment is required, - ;; then the bitmap can't be -1. - (named-let admits-bitmap-optimization ((dd dd)) - (cond ((eq (dd-name dd) 'list-node) nil) - ((not (dd-include dd)) t) - ((admits-bitmap-optimization - (find-defstruct-description (car (dd-include dd)))))))) - (let ((sign-ext (logior (ash -1 n-bits) bitmap))) - (when (or (and (fixnump sign-ext) (sb-xc:typep bitmap 'bignum)) - (eql sign-ext -1)) - (return-from dd-bitmap sign-ext))))) - bitmap)) + (cond ((eql t (dsd-raw-type slot)) + (let ((bit (ash 1 (dsd-index slot)))) + (setf maximal-bitmap (logior maximal-bitmap bit)) + (unless (dsd-gc-ignorable slot) + (setf minimal-bitmap (logior minimal-bitmap bit))))) + (t + (setq any-raw t)))) + + ;; If the structure has a custom GC scavenging method then always return + ;; the minimal bitmap, and disallow arbitrary trailing slots. + ;; The optimization for all-tagged (avoiding use of the bitmap) + ;; indicates in addition to no raw slots, no custom GC method either. + ;; As of now this only pertains to lockfree-singly-linked-list nodes + ;; and descendant types. (The lockfree list uses one pointer bit + ;; as a pending-deletion flag. See "src/code/target-lflist.lisp") + (when (named-let has-custom-gc-method ((dd dd)) + (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)))))))) + (aver (eq rest :unspecific)) + (return-from calculate-dd-bitmap minimal-bitmap)) + + ;; The minimal bitmap will have the least number of bits set, and the maximal + ;; will have the most, but it is not always a performance improvement to prefer + ;; fewer bits. If the total number of bits is large, and there are no raw slots, + ;; then the "all tagged" treatment may be better because it does not need to + ;; parse the bitmap. But if there are any raw slots, the minimal bitmap is best. + (let ((bitmap + (if (or (= minimal-bitmap 0) ; don't need a bitmap + any-raw ; must use a bitmap + ;; for other cases, it is not clear-cut + (and (> (logcount maximal-bitmap) 10) ; arb + (< (logcount minimal-bitmap) + (floor (logcount maximal-bitmap) 2)))) + minimal-bitmap + maximal-bitmap))) + + ;; If the trailing slots have tagged nature, extend bitmap with + ;; an infinite sequence of 1 bits. If :UNSPECIFIC, replicate + ;; the most-significant-bit whether it be 0 or 1. + (cond ((or (eq rest :tagged) + (and (eq rest :unspecific) + (plusp n-bits) + (logbitp (1- n-bits) bitmap))) + (dpb bitmap (byte n-bits 0) -1)) + (t + bitmap))))) ;;; This is called when we are about to define a structure class. It ;;; returns a (possibly new) class object and the layout which should @@ -1544,14 +1684,20 @@ (t (values 'structure-classoid 'make-structure-classoid))) (insured-find-classoid (dd-name info) - (if (eq class 'structure-classoid) - (lambda (x) - (sb-xc:typep x 'structure-classoid)) - (lambda (x) - (sb-xc:typep x (classoid-name (find-classoid class))))) - (fdefinition constructor))) + (ecase class + (structure-classoid #'structure-classoid-p) + (built-in-classoid #'built-in-classoid-p) + (static-classoid #'static-classoid-p) + (condition-classoid #'condition-classoid-p)) + constructor)) (setf (classoid-direct-superclasses classoid) (case (dd-name info) + ;; Argh, could this case be any more opaque??? + ;; It's ostensibly the set of types whose superclasse would come out wrong + ;; if we didn't fudge them manually. But the computation of the superclass + ;; list is obfuscated. I think we have assertions about this somewhere. + ;; But ideally we remove this junky case from the target image somehow + ;; while leaving it in for self-build. ((ansi-stream fd-stream sb-impl::string-input-stream sb-impl::string-output-stream @@ -1562,18 +1708,23 @@ (list (layout-classoid (svref inherits (1- (length inherits)))))))) (let* ((old-layout (or compiler-layout old-layout)) - (flags (if (dd-alternate-metaclass info) 0 +structure-layout-flag+)) + (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*) - (set-layout-inherits (make-layout (hash-layout-name (dd-name info)) classoid :flags flags :inherits inherits :depthoid (length inherits) :length (dd-length info) - :info info) - inherits)))) + :info info)))) (cond ((not old-layout) (values classoid new-layout nil)) @@ -1588,7 +1739,7 @@ ;; exercised in this code path anyway. -- WHN 19990510 (not (eq (layout-classoid new-layout) (layout-classoid old-layout))) (error "shouldn't happen: weird state of OLD-LAYOUT?")) - ((redefine-layout-warning old-context + ((warn-if-altered-layout old-context old-layout new-context (layout-length new-layout) @@ -1993,35 +2144,36 @@ slot-names) (let* ((dd (make-defstruct-description t class-name)) (conc-name (string (gensymify* class-name "-"))) - ;; Without compact instance headers, the index starts at 1 for - ;; named slots, because slot 0 is the LAYOUT. - ;; This is the same in ordinary structures too: see (INCF DD-LENGTH) - ;; in PARSE-DEFSTRUCT-NAME-AND-OPTIONS. - ;; With compact instance headers, slot 0 is a data slot. - (slot-index sb-vm:instance-data-start)) + (slot-index 0)) ;; We do *not* fill in the COPIER-NAME and PREDICATE-NAME ;; because alternate-metaclass structures can not have either. (case dd-type - ;; We don't support inheritance of alternate metaclass stuff, - ;; and it's not a general-purpose facility, so sanity check our - ;; own code. + ;; We don't fully support inheritance of alternate metaclass stuff, + ;; so sanity check our own code. (structure - (aver (eq superclass-name 't))) + (aver (eq superclass-name 't)) + ;; Without compact instance headers, the index starts at 1 for + ;; named slots, because slot 0 is the LAYOUT. + ;; This is the same in ordinary structures too: see (INCF DD-LENGTH) + ;; in PARSE-DEFSTRUCT-NAME-AND-OPTIONS. + ;; With compact instance headers, slot 0 is a data slot. + (incf slot-index sb-vm:instance-data-start)) (funcallable-structure (aver (eq superclass-name 'function))) (t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type))) - (setf (dd-alternate-metaclass dd) (list superclass-name + (setf (dd-type dd) dd-type + (dd-alternate-metaclass dd) (list superclass-name metaclass-name metaclass-constructor) (dd-slots dd) (mapcar (lambda (slot-name) (make-dsd slot-name t (symbolicate conc-name slot-name) (pack-dsd-bits (prog1 slot-index (incf slot-index)) - nil t t nil) + nil t t nil nil) nil)) slot-names) (dd-length dd) slot-index - (dd-type dd) dd-type) + (dd-bitmap dd) (calculate-dd-bitmap dd)) dd)) (sb-xc:defmacro !defstruct-with-alternate-metaclass @@ -2033,7 +2185,7 @@ (metaclass-constructor (missing-arg)) (dd-type (missing-arg))) - (declare (type (and list (not null)) slot-names)) + (declare (type list slot-names)) (declare (type (and symbol (not null)) superclass-name metaclass-name @@ -2063,6 +2215,8 @@ `(progn (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) @@ -2122,6 +2276,13 @@ ;;; 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) @@ -2129,22 +2290,16 @@ ;; 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))) - ;; with compact headers, 0 is an ordinary slot index. - ;; without, it's the layout. - (if (eql index (1- sb-vm:instance-data-start)) - (error "XC Host should use %INSTANCE-LAYOUT, not %INSTANCE-REF 0") - (let* ((dd (layout-info layout)) - ;; If data starts at 1, then subtract 1 from index. - ;; otherwise use the index as-is. - (dsd (elt (dd-slots dd) - (- index sb-vm:instance-data-start))) - (accessor-name (dsd-accessor-name dsd))) - ;; Why AVER these: because it is slightly abstraction-breaking - ;; to assume that the slot-index N is the NTH item in the DSDs. - ;; The target Lisp never assumes that. - (aver (and (eql (dsd-index dsd) index) (eq (dsd-raw-type dsd) t))) - (funcall accessor-name instance))))) + (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)) @@ -2163,9 +2318,19 @@ ;;; 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. (defmacro new-instance (type) `(allocate-instance (find-class ',type))) +(defmacro new-struct (type) `(allocate-struct ',type)) (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. @@ -2178,10 +2343,11 @@ ;;; unless dictated otherwise by the SAFE-P flag in the DSD. ;;; * (defstruct S a (b (error "Must supply me") :type symbol)) ;;; * (defmethod make-load-form ((x S) &optional e) (m-l-f-s-s x :slot-names '(a))) -;;; After these definitions, a dumped S will have 0 in slot B. +;;; After these definitions, a dumped S will have # in slot B. ;;; -(defun sb-xc:make-load-form-saving-slots (object &key (slot-names nil slot-names-p) - environment) +(defun make-load-form-saving-slots (object &key (slot-names nil slot-names-p) + environment + &aux (type (type-of object))) (declare (ignore environment)) (flet ((quote-p (thing) (not (self-evaluating-p thing)))) (declare (inline quote-p)) @@ -2189,9 +2355,8 @@ ;; unless there is a MAKE-LOAD-FORM on the class without a proper-name. ;; This is better than returning a creation form that produces ;; something completely different. - (values (let ((type (type-of object))) - `(,(if (symbolp type) 'new-instance 'allocate-instance) ,type)) - (if (typep object 'structure-object) + (if (typep object 'structure-object) + (values `(new-struct ,(the symbol type)) ; no anonymous defstructs `(setf ,@(mapcan (lambda (dsd) (declare (type defstruct-slot-description dsd)) @@ -2202,8 +2367,9 @@ (val (funcall acc object ind))) (list `(,acc ,object ,ind) (if (quote-p val) `',val val))))) - (dd-slots (layout-info (%instance-layout object))))) - #-sb-xc-host + (dd-slots (layout-dd (%instance-layout object)))))) + #-sb-xc-host + (values `(,(if (symbolp type) 'new-instance 'allocate-instance) ,type) (loop for slot in (sb-mop:class-slots (class-of object)) for name = (sb-mop:slot-definition-name slot) when (if slot-names-p @@ -2248,29 +2414,16 @@ (error (condition) (sb-c:compiler-error condition))) (cond ((and (listp creation-form) (typep constant 'structure-object) - (typep creation-form - '(cons (eql new-instance) (cons symbol null))) + (typep creation-form '(cons (eql new-struct) (cons symbol null))) (eq (second creation-form) (type-of constant)) (typep init-form '(cons (eql setf))) (canonical-p (cdr init-form) - (dd-slots (layout-info (%instance-layout constant))) + (dd-slots (layout-dd (%instance-layout constant))) constant)) (values nil 'sb-fasl::fop-struct)) (t (values creation-form init-form)))))) -(defmacro get-dsd-index (type-name slot-name) - ;; Without the NOTINLINE we get: - ; caught STYLE-WARNING: - ; Derived type of SB-C::VAL is - ; (VALUES NULL &OPTIONAL), - ; conflicting with its asserted type - ; SB-KERNEL:DEFSTRUCT-SLOT-DESCRIPTION. - (declare (notinline find dsd-bits)) - (dsd-index (find slot-name - (dd-slots (find-defstruct-description type-name)) - :key #'dsd-name))) - ;;; Compute a SAP to the specified slot in INSTANCE. ;;; This looks mildly redundant with DEFINE-STRUCTURE-SLOT-ADDRESSOR, ;;; but that one returns an integer, not a SAP. diff -Nru sbcl-2.0.6/src/code/deftypes-for-target.lisp sbcl-2.1.1/src/code/deftypes-for-target.lisp --- sbcl-2.0.6/src/code/deftypes-for-target.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/deftypes-for-target.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -101,11 +101,9 @@ `(simple-array base-char (,size))) (sb-xc:deftype string (&optional size) `(or (array character (,size)) - (array nil (,size)) (base-string ,size))) (sb-xc:deftype simple-string (&optional size) `(or (simple-array character (,size)) - (simple-array nil (,size)) (simple-base-string ,size))) ;;; On Unicode builds, SIMPLE-CHARACTER-STRING is a builtin type. ;;; For non-Unicode it is convenient to be able to use the type name @@ -169,9 +167,9 @@ '(or list symbol classoid class)) ;;; array rank, total size... -(sb-xc:deftype array-rank () `(integer 0 (,sb-xc:array-rank-limit))) +(sb-xc:deftype array-rank () `(integer 0 (,array-rank-limit))) (sb-xc:deftype array-total-size () - `(integer 0 (,sb-xc:array-total-size-limit))) + `(integer 0 (,array-total-size-limit))) ;;; The range returned by SXHASH and PSXHASH ;;; Do not confuse this type with the type that EQ-HASH and related hash @@ -179,7 +177,7 @@ ;;; precludes us from using the entire fixnum range. Doing so avoids ;;; an extra AND operation, which is pretty much effectless in as much as ;;; the hash code is masked down to a much smaller value anyway. -(sb-xc:deftype hash-code () `(integer 0 ,sb-xc:most-positive-fixnum)) +(sb-xc:deftype hash-code () `(integer 0 ,most-positive-fixnum)) ;;; something legal in an evaluated context ;;; FIXME: could probably go away @@ -208,7 +206,7 @@ '(or float (complex float))) ;;; character components -(sb-xc:deftype char-code () `(integer 0 (,sb-xc:char-code-limit))) +(sb-xc:deftype char-code () `(integer 0 (,char-code-limit))) ;;; a consed sequence result. If a vector, is a simple array. (sb-xc:deftype consed-sequence () diff -Nru sbcl-2.0.6/src/code/describe.lisp sbcl-2.1.1/src/code/describe.lisp --- sbcl-2.0.6/src/code/describe.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/describe.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -100,6 +100,9 @@ (defun describe (object &optional (stream-designator *standard-output*)) "Print a description of OBJECT to STREAM-DESIGNATOR." + ;; This DECLARE works around a compiler bug that FTYPE does not force + ;; type-checking of the optional argument. + (declare (stream-designator stream-designator)) (let ((stream (out-stream-from-designator stream-designator)) (*print-right-margin* (or *print-right-margin* 72)) (*print-circle* t) @@ -247,6 +250,15 @@ (print-standard-describe-header object stream) (describe-instance object stream)) +(defmethod describe-object ((object pathname) stream) + (print-standard-describe-header object stream) + (loop for name across #(host device directory name type version) + for i from (get-dsd-index pathname host) + do (awhen (%instance-ref object i) + (format stream "~% ~10A = ~A" name + (prin1-to-line (if (eq name 'directory) (car it) it))))) + (terpri stream)) + (defmethod describe-object ((object character) stream) (print-standard-describe-header object stream) (format stream "~%Char-code: ~S~%Char-name: ~A" diff -Nru sbcl-2.0.6/src/code/destructuring-bind.lisp sbcl-2.1.1/src/code/destructuring-bind.lisp --- sbcl-2.0.6/src/code/destructuring-bind.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/destructuring-bind.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +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") - -(macrolet (#+sb-xc-host ; Bootstrap NAMED-DS-BIND - (named-ds-bind (name lambda-list expression &body body) - (declare (ignore name)) - `(cl:destructuring-bind ,lambda-list ,expression ,@body))) - - (sb-xc:defmacro destructuring-bind (lambda-list expression &body body - &environment env) - (declare (ignore env)) ; could be policy-sensitive (but isn't) - "Bind the variables in LAMBDA-LIST to the corresponding values in the -tree structure resulting from the evaluation of EXPRESSION." - `(binding* ,(sb-c::expand-ds-bind lambda-list expression t nil) - ,@body)) - - (let () - ;; This is a variant of destructuring-bind that provides the name - ;; of the containing construct in generated error messages. - ;; There is a cyclic dependence between it and DEFMACRO. - (sb-xc:defmacro named-ds-bind (name lambda-list expression &body body - &environment env) - (declare (ignore env)) ; could be policy-sensitive (but isn't) - `(binding* ,(sb-c::expand-ds-bind lambda-list expression t nil name - (and (eq (car name) :macro) - (eq (cddr name) 'deftype) - ''*)) - ,@body)))) - -#+sb-xc-host -(progn - ;; The expander for NAMED-DS-BIND in the host could almost always be - ;; the above MACROLET, but that would fail to use the default of '* for - ;; optional args of SB-XC:DEFTYPE that lack an overriding default. - ;; So install our expander even if it produces suboptimal code for the host. - (defmacro named-ds-bind (&whole form &rest args) - (declare (ignore args)) - (funcall (sb-xc:macro-function 'named-ds-bind) form nil)) - - ;; A similar problem in reverse: 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 (sb-xc:macro-function 'binding*) - (lambda (form env) (declare (ignore env)) (cl:macroexpand-1 form nil)))) diff -Nru sbcl-2.0.6/src/code/dyncount.lisp sbcl-2.1.1/src/code/dyncount.lisp --- sbcl-2.0.6/src/code/dyncount.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/dyncount.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -109,7 +109,7 @@ (setf (vop-stats-cost res) cost) res)) -#-sb-fluid (declaim (freeze-type dyncount-info vop-stats)) +(declaim (freeze-type dyncount-info vop-stats)) ;;; Add the Info into the cumulative result on the VOP name plist. We use ;;; plists so that we will touch minimal system code outside of this file @@ -389,7 +389,7 @@ (defun entry-report (entries cut-off compensated compare total-cost) (let ((counter (if (and cut-off (> (length entries) cut-off)) cut-off - sb-xc:most-positive-fixnum))) + most-positive-fixnum))) (dolist (entry entries) (let* ((cost (vop-stats-cost entry)) (name (vop-stats-name entry)) diff -Nru sbcl-2.0.6/src/code/early-alieneval.lisp sbcl-2.1.1/src/code/early-alieneval.lisp --- sbcl-2.0.6/src/code/early-alieneval.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-alieneval.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,153 +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-ALIEN") - -(defglobal *alien-type-classes* (make-hash-table)) ; keys are symbols - -#-sb-xc-host (sb-impl::define-thread-local *saved-fp* nil) - -(defvar *new-auxiliary-types* nil) - -;;; the list of record types that have already been unparsed. This is -;;; used to keep from outputting the slots again if the same structure -;;; shows up twice. -(defvar *record-types-already-unparsed*) - -;;; not documented in CMU CL:-( -;;; -;;; reverse engineering observations: -;;; * seems to be set when translating return values -;;; * seems to enable the translation of (VALUES), which is the -;;; Lisp idiom for C's return type "void" (which is likely -;;; why it's set when when translating return values) -(defvar *values-type-okay* nil) - -(defvar *default-c-string-external-format* nil) - -(defmacro define-alien-type-translator (name lambda-list &body body) - (let ((defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")) - (macro-lambda - (make-macro-lambda nil lambda-list body - 'define-alien-type-translator name))) - `(progn - (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - (defun ,defun-name ,(second macro-lambda) ,@(cddr macro-lambda))) - (eval-when (:compile-toplevel :load-toplevel :execute) - (%define-alien-type-translator ',name #',defun-name))))) - -;;; Process stuff in a new scope. -(defmacro with-auxiliary-alien-types (env &body body) - ``(symbol-macrolet ((&auxiliary-type-definitions& - ,(append *new-auxiliary-types* - (auxiliary-type-definitions ,env)))) - ,(let ((*new-auxiliary-types* nil)) - ,@body))) - -(defmacro define-alien-type (name type &environment env) - "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for - STRUCT and UNION types, in which case the name is taken from the type - specifier." - (with-auxiliary-alien-types env - (let ((alien-type (parse-alien-type type env))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(when *new-auxiliary-types* - `((%def-auxiliary-alien-types ',*new-auxiliary-types* - (sb-c:source-location)))) - ,@(when name - `((%define-alien-type ',name ',alien-type (sb-c:source-location)))))))) - -(defstruct (alien-type-class (:copier nil)) - (name nil :type symbol) - (defstruct-name nil :type symbol) - (include nil :type (or null alien-type-class)) - (unparse nil :type (or null function)) - (type= nil :type (or null function)) - (lisp-rep nil :type (or null function)) - (alien-rep nil :type (or null function)) - (extract-gen nil :type (or null function)) - (deposit-gen nil :type (or null function)) - (naturalize-gen nil :type (or null function)) - (deport-gen nil :type (or null function)) - (deport-alloc-gen nil :type (or null function)) - (deport-pin-p nil :type (or null function)) - ;; Cast? - (arg-tn nil :type (or null function)) - (result-tn nil :type (or null function)) - (subtypep nil :type (or null function))) - -(defmethod print-object ((type-class alien-type-class) stream) - (print-unreadable-object (type-class stream :type t) - (prin1 (alien-type-class-name type-class) stream))) - -(defun alien-type-class-or-lose (name) - (or (gethash name *alien-type-classes*) - (error "no alien type class ~S" name))) - -(defun create-alien-type-class-if-necessary (name defstruct-name include) - (let ((old (gethash name *alien-type-classes*)) - (include (and include (alien-type-class-or-lose include)))) - (if old - (setf (alien-type-class-include old) include) - (setf (gethash name *alien-type-classes*) - (make-alien-type-class :name name - :defstruct-name defstruct-name - :include include))))) - -(defconstant-eqx +method-slot-alist+ - '((:unparse . alien-type-class-unparse) - (:type= . alien-type-class-type=) - (:subtypep . alien-type-class-subtypep) - (:lisp-rep . alien-type-class-lisp-rep) - (:alien-rep . alien-type-class-alien-rep) - (:extract-gen . alien-type-class-extract-gen) - (:deposit-gen . alien-type-class-deposit-gen) - (:naturalize-gen . alien-type-class-naturalize-gen) - (:deport-gen . alien-type-class-deport-gen) - (:deport-alloc-gen . alien-type-class-deport-alloc-gen) - (:deport-pin-p . alien-type-class-deport-pin-p) - ;; cast? - (:arg-tn . alien-type-class-arg-tn) - (:result-tn . alien-type-class-result-tn)) - #'equal) - -(defun method-slot (method) - (cdr (or (assoc method +method-slot-alist+) - (error "no method ~S" method)))) - -(defmacro invoke-alien-type-method (method type &rest args) - (let ((slot (method-slot method))) - (once-only ((type type)) - `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type)) - (alien-type-class-include class))) - ((null class) - (error "method ~S not defined for ~S" - ',method (alien-type-class ,type))) - (let ((fn (,slot class))) - (when fn - (return fn)))) - ,type ,@args)))) - -#+sb-xc -(defmacro maybe-with-pinned-objects (variables types &body body) - (declare (ignorable variables types)) - (let ((pin-variables - ;; Only pin things on GENCGC, since on CHENEYGC it'd imply - ;; disabling the GC. Which is something we don't want to do - ;; every time we're calling to C. - #+gencgc - (loop for variable in variables - for type in types - when (invoke-alien-type-method :deport-pin-p type) - collect variable))) - (if pin-variables - `(with-pinned-objects ,pin-variables - ,@body) - `(progn - ,@body)))) diff -Nru sbcl-2.0.6/src/code/early-array.lisp sbcl-2.1.1/src/code/early-array.lisp --- sbcl-2.0.6/src/code/early-array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -9,12 +9,13 @@ (in-package "SB-IMPL") -(defconstant sb-xc:array-rank-limit 65529 +;;; 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 sb-xc:array-dimension-limit (- sb-xc:most-positive-fixnum 2) +(defconstant array-dimension-limit (- most-positive-fixnum 2) "the exclusive upper bound on any given dimension of an array") -(defconstant sb-xc:array-total-size-limit (- sb-xc:most-positive-fixnum 2) +(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.0.6/src/code/early-class.lisp sbcl-2.1.1/src/code/early-class.lisp --- sbcl-2.0.6/src/code/early-class.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-class.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -98,7 +98,7 @@ (setq layout old-layout) (unless (eq (classoid-layout class) layout) (register-layout layout))) - ((redefine-layout-warning "current" + ((warn-if-altered-layout "current" old-layout "new" (layout-length layout) @@ -109,17 +109,6 @@ ((not (classoid-layout class)) (register-layout layout))) - ;; This looks totally bogus - it essentially means that the LAYOUT-INFO - ;; of a condition is good for nothing, because it describes something - ;; that is not the condition class being defined. - ;; In addition to which, the INFO for CONDITION itself describes - ;; slots which do not exist, viz: - ;; (dd-slots (layout-info (classoid-layout (find-classoid 'condition)))) - ;; => (# - ;; #) - (setf (layout-info layout) - (layout-info (classoid-layout (find-classoid 'condition)))) - (setf (find-classoid name) class) ;; Initialize CPL slot. diff -Nru sbcl-2.0.6/src/code/early-classoid.lisp sbcl-2.1.1/src/code/early-classoid.lisp --- sbcl-2.0.6/src/code/early-classoid.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-classoid.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -50,6 +50,11 @@ ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots ;; (including included ones) (slots () :type list) + ;; bit mask containing a 1 for each word that the garbage collector must visit + ;; (as opposed to a raw slot). Certain slot types (notably fixnum) may have either + ;; a 0 or a 1 in the mask because it does not matter if it is seen by GC. + ;; Bit index 0 in the mask is the word just after the header, and so on. + (bitmap +layout-all-tagged+ :type integer) ;; a list of (NAME . INDEX) pairs for accessors of included structures (inherited-accessor-alist () :type list) ;; number of data words, including the layout itself if the layout @@ -82,7 +87,7 @@ ;; PURIFY). ;; This is only meaningful if DD-CLASS-P = T. (pure nil :type (member t nil))) -#-sb-fluid (declaim (freeze-type defstruct-description)) +(declaim (freeze-type defstruct-description)) (!set-load-form-method defstruct-description (:host :xc :target)) ;;;; basic LAYOUT stuff @@ -91,9 +96,12 @@ ;;; 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 +pcl-object-layout-flag+ #b00010000) -(defconstant sb-vm:lockfree-list-node-flag #b01000000) ; exported for use in gc-private.h +(defconstant +simple-stream-layout-flag+ #b00010000) +(defconstant +file-stream-layout-flag+ #b00100000) +(defconstant +string-stream-layout-flag+ #b01000000) +(defconstant +stream-layout-flag+ #b10000000) ;;; The LAYOUT structure is pointed to by the first cell of instance ;;; (or structure) objects. It represents what we need to know for @@ -130,15 +138,10 @@ ;;; 32-bit is not done yet. Three slots are still used, instead of two. -;;; Maximum value of N in ANCESTOR_N. Couldn't come up with a better name. -(defconstant sb-c::layout-inherits-max-optimized-depth 5) -(sb-xc:defstruct (layout - ;; Accept a specific subset of keywords - #+64-bit (:constructor %make-layout - (clos-hash classoid flags info bitmap)) - #-64-bit (:constructor %make-layout - (clos-hash classoid depthoid length flags info bitmap)) - (:copier nil)) +(sb-xc:defstruct (layout (:copier nil) + ;; Parsing DEFSTRUCT uses a temporary layout + (:constructor make-temporary-layout + (clos-hash classoid inherits &aux (invalid nil)))) ;; A packed field containing the DEPTHOID, LENGTH, and FLAGS #+64-bit (flags 0 :type (signed-byte #.sb-vm:n-word-bits)) @@ -188,79 +191,32 @@ #-64-bit (length 0 :type layout-length) ; smaller than SB-INT:INDEX ;; If this layout has some kind of compiler meta-info, then this is ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here. - (info nil :type (or null defstruct-description)) - ;; Map of raw slot indices. - (bitmap +layout-all-tagged+ :type layout-bitmap) + ;; If this layout is for an object of metatype STANDARD-CLASS, + ;; then these are the EFFECTIVE-SLOT-DEFINITION metaobjects. + ;; The two are mutually exclusive. + (%info nil :type (or list defstruct-description)) ;; EQUALP comparator for two instances with this layout ;; Could be the generalized function, or a type-specific one ;; if the defstruct was compiled in a policy of SPEED 3. (equalp-impl #'equalp-err :type (sfunction (t t) boolean) :read-only t) - ;; If this layout is for an object of metatype STANDARD-CLASS, - ;; these are the EFFECTIVE-SLOT-DEFINITION metaobjects. - (slot-list nil :type list) ;; Information about slots in the class to PCL: this provides fast ;; access to slot-definitions and locations by name, etc. ;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details. (slot-table #(1 nil) :type simple-vector) - ;; inherited layouts or 0, only pertinent to structure classoids. - ;; There is no need to store the layout at depths 0 or 1 - ;; since they're predetermined to be T and STRUCTURE-OBJECT. - (ancestor_2 0) - (ancestor_3 0) - (ancestor_4 0) - (ancestor_5 0)) + (id-word0 0 :type word) + (id-word1 0 :type word) + (id-word2 0 :type word) + #-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)) -(defun equalp-err (a b) - (bug "EQUALP ~S ~S" a b)) - -;;; 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 set-layout-inherits (layout inherits &optional depthoid) - `(let* ((l ,layout) (i ,inherits) (d ,(or depthoid '(length i)))) - (declare (ignorable i d)) - ;; I tried putting a /SHOW here for debugging, but it's just too broken - ;; because layouts affect the printer dispatch mechanism. - #+nil - (let ((*print-pretty* nil)) - (fresh-line) - (write-string "SET-INHERITS ") - (write (layout-classoid-name l)) - (write-string " ") - (write (map 'list #'layout-classoid-name i)) - (terpri)) - (setf (layout-inherits l) i) - #-sb-xc-host - (setf (layout-ancestor_2 l) (if (> d 2) (svref i 2) 0) - (layout-ancestor_3 l) (if (> d 3) (svref i 3) 0) - (layout-ancestor_4 l) (if (> d 4) (svref i 4) 0) - (layout-ancestor_5 l) (if (> d 5) (svref i 5) 0)) - l)) - -#-sb-xc-host -(defun make-layout (clos-hash classoid - &key (depthoid -1) (length 0) (flags 0) - (inherits #() inheritsp) - (info nil) - (bitmap (if info (dd-bitmap info) +layout-all-tagged+))) - (let ((layout (%make-layout clos-hash classoid - #+64-bit (pack-layout-flags depthoid length flags) - #-64-bit depthoid #-64-bit length #-64-bit flags - info bitmap))) - (when inheritsp - (set-layout-inherits layout inherits)) - layout)) - ;;; The cross-compiler representation of a LAYOUT omits several things: -;;; * BITMAP - obtainable via (DD-MAPMAP (LAYOUT-INFO layout)). +;;; * BITMAP - obtainable via (DD-BITMAP (LAYOUT-INFO layout)). ;;; GC wants it in the layout to avoid double indirection. ;;; * EQUALP-TESTS - needed only for the target's implementation of EQUALP. ;;; * SLOT-TABLE, and SLOT-LIST - used only by the CLOS implementation. -;;; * ANCESTOR_N are optimizations for TYPEP. +;;; * 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 @@ -268,8 +224,13 @@ #+sb-xc-host (progn (defstruct (layout (:include structure!object) - (:constructor make-layout - (clos-hash classoid &key depthoid length flags inherits info))) + (:constructor host-make-layout + (clos-hash classoid &key id info depthoid inherits + length flags invalid))) + (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) + (index->accessor-map #() :type simple-vector) ;; CLOS-HASH is needed to convert some TYPECASE forms to jump tables. ;; Theoretically we don't need this in the cross-compiler, because the ;; layout has a classoid which has a name which has a known hash. @@ -282,15 +243,216 @@ (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+))) -(defmacro sb-c::layout-nth-ancestor-slot (n) - `(case ,n - (2 'layout-ancestor_2) - (3 'layout-ancestor_3) - (4 'layout-ancestor_4) - (5 'layout-ancestor_5))) +(defun equalp-err (a b) + (bug "EQUALP ~S ~S" a b)) + +(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))))) + +;;; 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))) + +(defconstant layout-id-vector-fixed-capacity 7) +(defmacro calculate-extra-id-words (depthoid) + ;; There are 1 or 2 ids per word depending on n-word-bytes. + ;; We can always store IDs at depthoids 2,3,4,5,6,7, + ;; so depthoid less than or equal to 7 needs no extra words. + ;; 0 and 1 for T and STRUCTURE-OBJECT respectively are not stored. + `(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)))))) + +;;; 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)) + ;; 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 @@ -324,10 +486,6 @@ (defun layout-for-pcl-obj-p (x) (logtest (layout-flags x) +pcl-object-layout-flag+)) -(declaim (inline sb-fasl:dumpable-layout-p)) -(defun sb-fasl:dumpable-layout-p (x) - (and (typep x 'layout) (not (layout-for-pcl-obj-p x)))) - ;;; The CLASSOID structure is a supertype of all classoid types. A ;;; CLASSOID is also a CTYPE structure as recognized by the type ;;; system. (FIXME: It's also a type specifier, though this might go @@ -499,6 +657,14 @@ (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 diff -Nru sbcl-2.0.6/src/code/early-cl.lisp sbcl-2.1.1/src/code/early-cl.lisp --- sbcl-2.0.6/src/code/early-cl.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-cl.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -26,51 +26,51 @@ ;;; 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 sb-xc:boole-clr 0 +(defconstant boole-clr 0 "Boole function op, makes BOOLE return 0.") -(defconstant sb-xc:boole-set 1 +(defconstant boole-set 1 "Boole function op, makes BOOLE return -1.") -(defconstant sb-xc:boole-1 2 +(defconstant boole-1 2 "Boole function op, makes BOOLE return integer1.") -(defconstant sb-xc:boole-2 3 +(defconstant boole-2 3 "Boole function op, makes BOOLE return integer2.") -(defconstant sb-xc:boole-c1 4 +(defconstant boole-c1 4 "Boole function op, makes BOOLE return complement of integer1.") -(defconstant sb-xc:boole-c2 5 +(defconstant boole-c2 5 "Boole function op, makes BOOLE return complement of integer2.") -(defconstant sb-xc:boole-and 6 +(defconstant boole-and 6 "Boole function op, makes BOOLE return logand of integer1 and integer2.") -(defconstant sb-xc:boole-ior 7 +(defconstant boole-ior 7 "Boole function op, makes BOOLE return logior of integer1 and integer2.") -(defconstant sb-xc:boole-xor 8 +(defconstant boole-xor 8 "Boole function op, makes BOOLE return logxor of integer1 and integer2.") -(defconstant sb-xc:boole-eqv 9 +(defconstant boole-eqv 9 "Boole function op, makes BOOLE return logeqv of integer1 and integer2.") -(defconstant sb-xc:boole-nand 10 +(defconstant boole-nand 10 "Boole function op, makes BOOLE return log nand of integer1 and integer2.") -(defconstant sb-xc:boole-nor 11 +(defconstant boole-nor 11 "Boole function op, makes BOOLE return lognor of integer1 and integer2.") -(defconstant sb-xc:boole-andc1 12 +(defconstant boole-andc1 12 "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.") -(defconstant sb-xc:boole-andc2 13 +(defconstant boole-andc2 13 "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.") -(defconstant sb-xc:boole-orc1 14 +(defconstant boole-orc1 14 "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.") -(defconstant sb-xc:boole-orc2 15 +(defconstant boole-orc2 15 "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.") diff -Nru sbcl-2.0.6/src/code/early-constants.lisp sbcl-2.1.1/src/code/early-constants.lisp --- sbcl-2.0.6/src/code/early-constants.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-constants.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -9,7 +9,7 @@ (in-package "SB-IMPL") -(defconstant-eqx sb-xc:lambda-list-keywords +(defconstant-eqx lambda-list-keywords '(&allow-other-keys &aux &body diff -Nru sbcl-2.0.6/src/code/early-defmethod.lisp sbcl-2.1.1/src/code/early-defmethod.lisp --- sbcl-2.0.6/src/code/early-defmethod.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-defmethod.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,14 @@ ;;;; Rudimentary DEFMETHOD +;;; This stub ensures that: +;;; - Argument specializations are stored in a way that permits an extremely simple +;;; single-dispatch implementation with correct behavior of MAKE-LOAD-FORM and +;;; PRINT-OBJECT. Subject to not needing method combination or CALL-NEXT-METHOD, +;;; exactly one primary method is chosen respecting class precedence order. +;;; - 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) (when (member name '((setf documentation) documentation) :test 'equal) @@ -20,16 +28,16 @@ ;; It's ignored during cold-init, but eventually takes effect. (assert (eq lambda-list :after)) (setq qualifier lambda-list lambda-list (pop body))) - (ecase name + (case name (make-load-form - ;; Expect one mandatory class-name and the optional environment. + ;; Expect one specialized arg and one optional (assert (typep lambda-list '(cons (cons symbol (cons symbol null)) (cons (eql &optional) (cons symbol null)))))) (print-object - ;; Expect one unqualified mandatory arg and one unqualified. + ;; Expect one specialized arg and one unspecialized (assert (typep lambda-list '(cons (cons symbol (cons symbol null)) - (cons symbol null)))))) + (cons symbol null)))))) (binding* ((specializer (cadar lambda-list)) ; only one allowd (unspecialized-ll `(,(caar lambda-list) ,@(cdr lambda-list))) ((forms decls) (parse-body body nil))) ; Note: disallowing docstring @@ -46,14 +54,17 @@ (declare (ignore .pv. .next-method-call.) (ignorable ,(car unspecialized-ll))) ,@decls - ;; Fail at compile-time if any transformational magic needs to happen. + ;; Fail at compile-time if any fancy slot access would happen, if compiled + ;; by the eventual implementation. + ;; (SETF SLOT-VALUE) is not a legal macro name, so transform it as a + ;; an ignorable function that uses a legal macro name. (macrolet ,(mapcar (lambda (f) `(,f (&rest args) (declare (ignore args)) (error "can't use ~A in trivial method" ',f))) '(slot-boundp slot-value %set-slot-value call-next-method)) (flet (((setf slot-value) (&rest args) `(%set-slot-value ,@args))) - (declare (inline (setf slot-value))) + (declare (inline (setf slot-value)) (ignorable #'(setf slot-value))) (block ,name ,@forms)))) ;; Why is SOURCE-LOC needed? Lambdas should know their location. (sb-c:source-location)))) @@ -75,49 +86,48 @@ ;;; allowing exactly one primary method. Methods are sorted most-specific-first, ;;; so we can stop looking as soon as a match is found. ;;; Sorting is performed during genesis. -(defun !call-a-method (gf-name specialized-arg &rest rest) +(defun trivial-call-a-method (gf-name specialized-arg &rest rest) (let* ((methods (the simple-vector - (cdr (or (assoc gf-name *!trivial-methods*) - (error "No methods on ~S" gf-name))))) + (cdr (or (assoc gf-name *!trivial-methods*) + (error "No methods on ~S" gf-name))))) (applicable-method - ;; Find a method where the guard returns T. If that fails, find a method - ;; which exactly matches TYPE-OF the specialized-arg. - ;; It might be nice to rely only on the TYPE-OF test, but then we'd have to - ;; concern ourselves with type hierarchies. - ;; The "method" is a vector: - ;; #(# QUALIFIER SPECIALIZER # LAMBDA-LIST SOURCE-LOC) - (or (find-if (lambda (method &aux (guard (svref method 0))) - (and (or (functionp guard) (fboundp guard)) - (funcall guard specialized-arg))) - methods) - (find (type-of specialized-arg) methods - :key (lambda (x) (svref x 2)))))) - + ;; Each "method" is represented as a vector: + ;; #(# QUALIFIER SPECIALIZER # LAMBDA-LIST SOURCE-LOC) + ;; 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))))))))) + methods))) (if applicable-method ;; Call using no permutation-vector / no precomputed next method. (apply (svref applicable-method 3) nil nil specialized-arg rest) (error "No applicable method for ~S on ~S~%" gf-name (type-of specialized-arg))))) -;;; For any "trivial" PRINT-OBJECT method lacking a predicate to determine -;;; its applicability, try to install one now. -;;; (Question: could not genesis find a predicate for everything?) -(defun !fixup-print-object-method-guards () - ;; LAYOUT-OF has an ordinary definition appearing later, unless a vop translates - ;; it, in which case it has to be inlined because the stub isn't ready for use. - #-(vop-translates sb-kernel:layout-of) (declare (notinline layout-of)) - ;; Wouldn't you know, DOVECTOR is in early-extensions, - ;; and it would need to go in primordial-extensions to use it here. - (loop for method across (cdr (assoc 'print-object sb-pcl::*!trivial-methods*)) - unless (svref method 0) - do (let ((classoid (find-classoid (elt method 2)))) - (setf (svref method 0) - (lambda (x) (classoid-typep (layout-of x) classoid x)))))) - (defun make-load-form (object &optional environment) - (!call-a-method 'make-load-form object environment)) + (trivial-call-a-method 'make-load-form object environment)) (defun print-object (object stream) - (!call-a-method 'print-object object stream)) + (trivial-call-a-method 'print-object object stream)) + +(macrolet ((ensure-gfs (names) + `(progn ,@(mapcar (lambda (name) + `(defun ,name (x) (trivial-call-a-method ',name x))) + names)))) + (ensure-gfs (open-stream-p interactive-stream-p input-stream-p output-stream-p + stream-element-type))) +(defun close (x &key abort) (trivial-call-a-method 'close x :abort abort)) ;;; FIXME: this no longer holds methods, but it seems to have an effect ;;; on the caching of a discriminating function for PRINT-OBJECT diff -Nru sbcl-2.0.6/src/code/early-extensions.lisp sbcl-2.1.1/src/code/early-extensions.lisp --- sbcl-2.0.6/src/code/early-extensions.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-extensions.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -16,7 +16,7 @@ ;;; A number that can represent an index into a vector, including ;;; one-past-the-end (deftype array-range () - `(integer 0 ,sb-xc:array-dimension-limit)) + `(integer 0 ,array-dimension-limit)) ;;; a type used for indexing into sequences, and for related ;;; quantities like lengths of lists and other sequences. @@ -35,13 +35,13 @@ ;;; MOST-POSITIVE-FIXNUM lets the system know it can increment a value ;;; of type INDEX without having to worry about using a bignum to ;;; represent the result. -(def!type index () `(integer 0 (,sb-xc:array-dimension-limit))) +(def!type index () `(integer 0 (,array-dimension-limit))) ;;; like INDEX, but augmented with -1 (useful when using the index ;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with ;;; an implementation which terminates the loop by testing for the ;;; index leaving the loop range) -(def!type index-or-minus-1 () `(integer -1 (,sb-xc:array-dimension-limit))) +(def!type index-or-minus-1 () `(integer -1 (,array-dimension-limit))) ;;; The smallest power of two that is equal to or greater than X. (declaim (inline power-of-two-ceiling)) @@ -285,6 +285,7 @@ (defmacro doplist ((key val) plist &body body) (with-unique-names (tail) `(let ((,tail ,plist) ,key ,val) + (declare (ignorable ,key ,val)) (loop (when (null ,tail) (return nil)) (setq ,key (pop ,tail)) (when (null ,tail) @@ -1126,7 +1127,7 @@ ((or symbol cons) (%check-deprecated-type type-specifier)) (class - (let ((name (class-name type-specifier))) + (let ((name (cl:class-name type-specifier))) (when (and name (symbolp name) (eq type-specifier (find-class name nil))) (%check-deprecated-type name)))))) @@ -1216,7 +1217,9 @@ ((or (listp id) ; must be a type-specifier (memq id '(special ignorable ignore dynamic-extent - truly-dynamic-extent)) + truly-dynamic-extent + sb-c::constant-value + sb-c::no-constraints)) (info :type :kind id)) (cdr decl)))))) (partition (spec) diff -Nru sbcl-2.0.6/src/code/early-float.lisp sbcl-2.1.1/src/code/early-float.lisp --- sbcl-2.0.6/src/code/early-float.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-float.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -49,58 +49,58 @@ ) ; EVAL-WHEN ;;;; float parameters -(defconstant sb-xc:most-positive-single-float #.sb-xc:most-positive-single-float) -(defconstant sb-xc:most-negative-single-float #.sb-xc:most-negative-single-float) -(defconstant sb-xc:most-positive-double-float #.sb-xc:most-positive-double-float) -(defconstant sb-xc:most-negative-double-float #.sb-xc:most-negative-double-float) -(defconstant sb-xc:pi #.sb-xc:pi) +(defconstant most-positive-single-float #.most-positive-single-float) +(defconstant most-negative-single-float #.most-negative-single-float) +(defconstant most-positive-double-float #.most-positive-double-float) +(defconstant most-negative-double-float #.most-negative-double-float) +(defconstant pi #.pi) -(defconstant sb-xc:least-positive-single-float (single-from-bits 0 0 1)) -(defconstant sb-xc:least-positive-short-float (single-from-bits 0 0 1)) -(defconstant sb-xc:least-negative-single-float (single-from-bits 1 0 1)) -(defconstant sb-xc:least-negative-short-float (single-from-bits 1 0 1)) -(defconstant sb-xc:least-positive-double-float (double-from-bits 0 0 1)) +(defconstant least-positive-single-float (single-from-bits 0 0 1)) +(defconstant least-positive-short-float (single-from-bits 0 0 1)) +(defconstant least-negative-single-float (single-from-bits 1 0 1)) +(defconstant least-negative-short-float (single-from-bits 1 0 1)) +(defconstant least-positive-double-float (double-from-bits 0 0 1)) #-long-float -(defconstant sb-xc:least-positive-long-float (double-from-bits 0 0 1)) +(defconstant least-positive-long-float (double-from-bits 0 0 1)) #+(and long-float x86) -(defconstant sb-xc:least-positive-long-float (long-from-bits 0 0 1)) -(defconstant sb-xc:least-negative-double-float (double-from-bits 1 0 1)) +(defconstant least-positive-long-float (long-from-bits 0 0 1)) +(defconstant least-negative-double-float (double-from-bits 1 0 1)) #-long-float -(defconstant sb-xc:least-negative-long-float (double-from-bits 1 0 1)) +(defconstant least-negative-long-float (double-from-bits 1 0 1)) #+(and long-float x86) -(defconstant sb-xc:least-negative-long-float (long-from-bits 1 0 1)) +(defconstant least-negative-long-float (long-from-bits 1 0 1)) -(defconstant sb-xc:least-positive-normalized-single-float +(defconstant least-positive-normalized-single-float (single-from-bits 0 sb-vm:single-float-normal-exponent-min 0)) -(defconstant sb-xc:least-positive-normalized-short-float - sb-xc:least-positive-normalized-single-float) -(defconstant sb-xc:least-negative-normalized-single-float +(defconstant least-positive-normalized-short-float + least-positive-normalized-single-float) +(defconstant least-negative-normalized-single-float (single-from-bits 1 sb-vm:single-float-normal-exponent-min 0)) -(defconstant sb-xc:least-negative-normalized-short-float - sb-xc:least-negative-normalized-single-float) -(defconstant sb-xc:least-positive-normalized-double-float +(defconstant least-negative-normalized-short-float + least-negative-normalized-single-float) +(defconstant least-positive-normalized-double-float (double-from-bits 0 sb-vm:double-float-normal-exponent-min 0)) #-long-float -(defconstant sb-xc:least-positive-normalized-long-float - sb-xc:least-positive-normalized-double-float) +(defconstant least-positive-normalized-long-float + least-positive-normalized-double-float) #+(and long-float x86) -(defconstant sb-xc:least-positive-normalized-long-float +(defconstant least-positive-normalized-long-float (long-from-bits 0 sb-vm:long-float-normal-exponent-min (ash sb-vm:long-float-hidden-bit 32))) -(defconstant sb-xc:least-negative-normalized-double-float +(defconstant least-negative-normalized-double-float (double-from-bits 1 sb-vm:double-float-normal-exponent-min 0)) #-long-float -(defconstant sb-xc:least-negative-normalized-long-float - sb-xc:least-negative-normalized-double-float) +(defconstant least-negative-normalized-long-float + least-negative-normalized-double-float) #+(and long-float x86) -(defconstant sb-xc:least-negative-normalized-long-float +(defconstant least-negative-normalized-long-float (long-from-bits 1 sb-vm:long-float-normal-exponent-min (ash sb-vm:long-float-hidden-bit 32))) -(defconstant sb-xc:most-positive-short-float sb-xc:most-positive-single-float) -(defconstant sb-xc:most-negative-short-float sb-xc:most-negative-single-float) -(defconstant sb-xc:most-positive-long-float sb-xc:most-positive-double-float) -(defconstant sb-xc:most-negative-long-float sb-xc:most-negative-double-float) +(defconstant most-positive-short-float most-positive-single-float) +(defconstant most-negative-short-float most-negative-single-float) +(defconstant most-positive-long-float most-positive-double-float) +(defconstant most-negative-long-float most-negative-double-float) (defconstant single-float-positive-infinity #.(sb-impl::make-flonum :+infinity 'single-float)) (defconstant single-float-negative-infinity #.(sb-impl::make-flonum :-infinity 'single-float)) @@ -124,28 +124,28 @@ (long-from-bits 1 (1+ sb-vm:long-float-normal-exponent-max) (ash sb-vm:long-float-hidden-bit 32))) -(defconstant sb-xc:single-float-epsilon +(defconstant single-float-epsilon (single-from-bits 0 (- sb-vm:single-float-bias (1- sb-vm:single-float-digits)) 1)) -(defconstant sb-xc:short-float-epsilon sb-xc:single-float-epsilon) -(defconstant sb-xc:single-float-negative-epsilon +(defconstant short-float-epsilon single-float-epsilon) +(defconstant single-float-negative-epsilon (single-from-bits 0 (- sb-vm:single-float-bias sb-vm:single-float-digits) 1)) -(defconstant sb-xc:short-float-negative-epsilon sb-xc:single-float-negative-epsilon) -(defconstant sb-xc:double-float-epsilon +(defconstant short-float-negative-epsilon single-float-negative-epsilon) +(defconstant double-float-epsilon (double-from-bits 0 (- sb-vm:double-float-bias (1- sb-vm:double-float-digits)) 1)) #-long-float -(defconstant sb-xc:long-float-epsilon sb-xc:double-float-epsilon) +(defconstant long-float-epsilon double-float-epsilon) #+(and long-float x86) -(defconstant sb-xc:long-float-epsilon +(defconstant long-float-epsilon (long-from-bits 0 (- sb-vm:long-float-bias (1- sb-vm:long-float-digits)) (+ 1 (ash sb-vm:long-float-hidden-bit 32)))) -(defconstant sb-xc:double-float-negative-epsilon +(defconstant double-float-negative-epsilon (double-from-bits 0 (- sb-vm:double-float-bias sb-vm:double-float-digits) 1)) #-long-float -(defconstant sb-xc:long-float-negative-epsilon sb-xc:double-float-negative-epsilon) +(defconstant long-float-negative-epsilon double-float-negative-epsilon) #+(and long-float x86) -(defconstant sb-xc:long-float-negative-epsilon +(defconstant long-float-negative-epsilon (long-from-bits 0 (- sb-vm:long-float-bias sb-vm:long-float-digits) (+ 1 (ash sb-vm:long-float-hidden-bit 32)))) diff -Nru sbcl-2.0.6/src/code/early-format.lisp sbcl-2.1.1/src/code/early-format.lisp --- sbcl-2.0.6/src/code/early-format.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-format.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -13,8 +13,9 @@ *format-directive-expanders* *format-directive-interpreters*)) (defglobal *format-directive-expanders* (make-array 128 :initial-element nil)) -(define-load-time-global *format-directive-interpreters* - (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) diff -Nru sbcl-2.0.6/src/code/early-impl.lisp sbcl-2.1.1/src/code/early-impl.lisp --- sbcl-2.0.6/src/code/early-impl.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-impl.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -23,7 +23,6 @@ sb-vm:*control-stack-start* sb-vm:*control-stack-end* sb-vm:*binding-stack-start* - #+(or hpux) sb-vm::*c-lra* *allow-with-interrupts* sb-unix::*unblock-deferrables-on-enabling-interrupts-p* *interrupts-enabled* @@ -36,7 +35,7 @@ sb-vm::*binding-stack-pointer* sb-pcl::*cache-miss-values-stack* sb-pcl::*dfun-miss-gfs-on-stack*)) -(defvar sb-vm:*alloc-signal*) ; initialized by create_thread_struct() + ;;; This is a slot of 'struct thread' if multithreaded, ;;; and the symbol-global-value should never be used. ;;; (And in any case it is not really a special var) diff -Nru sbcl-2.0.6/src/code/early-print.lisp sbcl-2.1.1/src/code/early-print.lisp --- sbcl-2.0.6/src/code/early-print.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-print.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -189,6 +189,8 @@ (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 () @@ -204,7 +206,7 @@ (,body-name)))) (t (let ((*circularity-hash-table* (make-hash-table :test 'eq))) - (output-object ,object (make-broadcast-stream)) + (output-object ,object *null-broadcast-stream*) (let ((*circularity-counter* 0)) (let ((,marker (check-for-circularity ,object t :logical-block))) diff -Nru sbcl-2.0.6/src/code/early-raw-slots.lisp sbcl-2.1.1/src/code/early-raw-slots.lisp --- sbcl-2.0.6/src/code/early-raw-slots.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-raw-slots.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -45,7 +45,7 @@ ;; 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)) -(defconstant +layout-all-tagged+ -1) +(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 (defstruct (raw-slot-data @@ -74,7 +74,7 @@ (defun raw-slot-data-accessor-name (rsd) (%simple-fun-name (raw-slot-data-accessor-fun rsd)))) -#-sb-fluid (declaim (freeze-type raw-slot-data)) +(declaim (freeze-type raw-slot-data)) ;; Simulate DEFINE-LOAD-TIME-GLOBAL - always bound in the image ;; but not eval'd in the compiler. @@ -171,15 +171,13 @@ ;; [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] -;; -(defmacro do-instance-tagged-slot ((index-var thing &key layout - ((:bitmap bitmap-expr)) (pad t)) +;; 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)) &body body) - (with-unique-names (instance bitmap limit) + (with-unique-names (instance layout limit) `(let* ((,instance ,thing) - (,bitmap ,(or bitmap-expr - `(layout-bitmap - ,(or layout `(%instance-layout ,instance))))) + (,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) @@ -187,5 +185,9 @@ (do ((,index-var sb-vm:instance-data-start (1+ ,index-var))) ((>= ,index-var ,limit)) (declare (type index ,index-var)) - (when (logbitp ,index-var ,bitmap) + (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))))) diff -Nru sbcl-2.0.6/src/code/early-source-location.lisp sbcl-2.1.1/src/code/early-source-location.lisp --- sbcl-2.0.6/src/code/early-source-location.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-source-location.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -39,7 +39,7 @@ #-sb-xc-host (eval-when (:compile-toplevel :load-toplevel :execute) - (dolist (entry '#.sb-vm::!per-thread-c-interface-symbols) + (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, diff -Nru sbcl-2.0.6/src/code/early-time.lisp sbcl-2.1.1/src/code/early-time.lisp --- sbcl-2.0.6/src/code/early-time.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-time.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -12,6 +12,14 @@ (in-package "SB-IMPL") -(defconstant sb-xc:internal-time-units-per-second 1000 +(defconstant internal-time-units-per-second + #+64-bit 1000000 ; microseconds + ;; 1 week in milliseconds is: (* 1000 60 60 24 7) = 604800000 which is + ;; a 30-bit number, but there are only 29 bits in a positive fixnum. + ;; It is left as an exercise to change the 32-bit code to use hundredths + ;; instead of thousands of a second. The upside of so doing is that + ;; GET-INTERNAL-REAL-TIME would be able to express more range without consing. + ;; The downside is of course decreased resolution. + #-64-bit 1000 ; milliseconds "The number of internal time units that fit into a second. See GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.") diff -Nru sbcl-2.0.6/src/code/early-type.lisp sbcl-2.1.1/src/code/early-type.lisp --- sbcl-2.0.6/src/code/early-type.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/early-type.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -314,13 +314,13 @@ (rational (rational thing)) ((float single-float) (cond #-sb-xc-host - ((<= sb-xc:most-negative-single-float thing sb-xc:most-positive-single-float) + ((<= 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 - ((<= sb-xc:most-negative-double-float thing sb-xc:most-positive-double-float) + ((<= most-negative-double-float thing most-positive-double-float) (coerce thing 'double-float)) (t (return-from coerce-numeric-bound))))))) @@ -350,17 +350,21 @@ (defun make-numeric-type (&key class format (complexp :real) low high enumerable) (declare (type (member integer rational float nil) class)) - (macrolet ((unionize (types classes initargs) + (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 - ,@initargs + :format format :class class - :complexp complexp :low low :high high :enumerable enumerable) + :complexp complexp + :low low + :high high + :enumerable enumerable) types))) (apply #'type-union types)))) (when (and (null class) (member complexp '(:real :complex))) @@ -371,7 +375,7 @@ (specifier-type 'real)) (unionize (rational single-float double-float) (rational float float) - (:format format))))) + (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) @@ -380,7 +384,7 @@ (specifier-type 'real)) (unionize (single-float double-float #+long-float (error "long-float")) (float float) - (:format thing)))))) + (single-float double-float)))))) (multiple-value-bind (low high) (case class (integer @@ -428,14 +432,14 @@ :enumerable (if (and ,low ,high) t nil)) (integer ,(or low '*) ,(or high '*))))) (cond ((neq complexp :real) nil) - ((and (eql low 0) (eql high (1- sb-xc:array-dimension-limit))) - (int-type 0 #.(1- sb-xc:array-dimension-limit))) ; INDEX type + ((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+ sb-xc:most-positive-fixnum)) + ((eql low (1+ most-positive-fixnum)) ;; positive bignum - (int-type #.(1+ sb-xc:most-positive-fixnum) nil)))) + (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)))) @@ -445,9 +449,9 @@ ((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- sb-xc:most-negative-fixnum))) + ((and (not low) (eql high (1- most-negative-fixnum))) ;; negative bignum - (int-type nil #.(1- sb-xc:most-negative-fixnum)))))) + (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) @@ -497,10 +501,10 @@ (setf pairs (cdr pairs))) else do (return nil)) (cond - ((>= low sb-xc:char-code-limit)) + ((>= low char-code-limit)) ((< high 0)) (t (push (cons (max 0 low) - (min high (1- sb-xc:char-code-limit))) + (min high (1- char-code-limit))) result)))))))) (unless pairs (return-from make-character-set-type *empty-type*)) @@ -514,14 +518,14 @@ (let* ((pair (car pairs)) (low (car pair)) (high (cdr pair))) - (cond ((eql high (1- sb-xc:char-code-limit)) + (cond ((eql high (1- char-code-limit)) (cond ((eql low 0) - (range 0 #.(1- sb-xc:char-code-limit) + (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- sb-xc: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) @@ -576,15 +580,15 @@ ;; 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 sb-xc:most-negative-fixnum - sb-xc:most-positive-fixnum)) + (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- sb-xc:char-code-limit))))) + (make-character-set-type `((0 . ,(1- char-code-limit))))) #+sb-unicode ((eql base-char) (make-character-set-type `((0 . ,(1- base-char-code-limit))))) @@ -928,7 +932,7 @@ (with-system-mutex ((hash-table-lock table)) (or (gethash spec table) (progn #+sb-xc-host - (when *compile-print* + (when cl:*compile-print* (format t "~&; NEW UNKNOWN-TYPE ~S~%" spec)) (setf (gethash spec table) (make-unknown-type :specifier spec)))))) @@ -1130,7 +1134,7 @@ ;;; #+sb-xc-host (labels ((xform (type-spec env parser) - (if (not (sb-xc:constantp type-spec env)) + (if (not (constantp type-spec env)) (values nil t) (let* ((expr (constant-form-value type-spec env)) (parse (funcall parser expr))) diff -Nru sbcl-2.0.6/src/code/error.lisp sbcl-2.1.1/src/code/error.lisp --- sbcl-2.0.6/src/code/error.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/error.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -182,7 +182,7 @@ ;; Should be (THE (FUNCTION-DESIGNATOR (CONDITION))) ;; but the cast kills DX allocation. `(lambda (c) (funcall ,handler c))))) - (name (let ((sb-xc:*gensym-counter* + (name (let ((*gensym-counter* (length (cluster-entries)))) (sb-xc:gensym "H")))) (local-functions `(,name ,@(rest lexpr))) diff -Nru sbcl-2.0.6/src/code/external-formats/enc-basic.lisp sbcl-2.1.1/src/code/external-formats/enc-basic.lisp --- sbcl-2.0.6/src/code/external-formats/enc-basic.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/external-formats/enc-basic.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -118,7 +118,7 @@ (declaim (inline char-len-as-utf8)) (defun char-len-as-utf8 (code) (declare (optimize speed (safety 0)) - (type (integer 0 (#.sb-xc:char-code-limit)) code)) + (type (integer 0 (#.char-code-limit)) code)) (cond ((< code 0) (bug "can't happen")) ((< code #x80) 1) ((< code #x800) 2) @@ -204,12 +204,7 @@ ;; so we can take a fast path -- and get benefit of the element ;; type information. On non-unicode build BASE-CHAR == ;; CHARACTER, handled above. - (ascii-bash)) - ((simple-array nil (*)) - (if (= send sstart) - (make-array null-padding :element-type '(unsigned-byte 8)) - ;; Just get the error... - (aref string sstart)))))) + (ascii-bash))))) ;;; from UTF-8 @@ -218,7 +213,7 @@ `(progn ;;(declaim (inline ,name)) (let ((lexically-max - (string->utf8 (string (code-char ,(1- sb-xc:char-code-limit))) + (string->utf8 (string (code-char ,(1- char-code-limit))) 0 1 0))) (declare (type (simple-array (unsigned-byte 8) (#+sb-unicode 4 #-sb-unicode 2)) lexically-max)) (defun ,name (array pos end) diff -Nru sbcl-2.0.6/src/code/external-formats/enc-ucs.lisp sbcl-2.1.1/src/code/external-formats/enc-ucs.lisp --- sbcl-2.0.6/src/code/external-formats/enc-ucs.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/external-formats/enc-ucs.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -347,7 +347,7 @@ (dpb (cref 3) (byte 8 24) (dpb (cref 2) (byte 8 16) (dpb (cref 1) (byte 8 8) (cref 0)))))))) - (if (< code sb-xc:char-code-limit) + (if (< code char-code-limit) (code-char code) (decoding-error array pos (+ pos bytes) :ucs-4le 'octet-decoding-error pos)))) @@ -366,7 +366,7 @@ (dpb (cref 0) (byte 8 24) (dpb (cref 1) (byte 8 16) (dpb (cref 2) (byte 8 8) (cref 3)))))))) - (if (< code sb-xc:char-code-limit) + (if (< code char-code-limit) (code-char code) (decoding-error array pos (+ pos bytes) :ucs-4be 'octet-decoding-error pos))))))) @@ -424,7 +424,7 @@ (setf (sap-ref-32le sap tail) bits) 4 (let ((code (sap-ref-32le sap head))) - (if (< code sb-xc:char-code-limit) + (if (< code char-code-limit) (code-char code) (return-from decode-break-reason 4))) ucs-4le->string-aref @@ -436,7 +436,7 @@ (setf (sap-ref-32be sap tail) bits) 4 (let ((code (sap-ref-32be sap head))) - (if (< code sb-xc:char-code-limit) + (if (< code char-code-limit) (code-char code) (return-from decode-break-reason 4))) ucs-4be->string-aref diff -Nru sbcl-2.0.6/src/code/fdefinition.lisp sbcl-2.1.1/src/code/fdefinition.lisp --- sbcl-2.0.6/src/code/fdefinition.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/fdefinition.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -509,7 +509,7 @@ (or (let ((result (lookup (car *fdefns*)))) (when (fdefn-p result) result)) (when constructor ; double-check w/lock before inserting - (sb-thread::with-system-mutex (*fdefns-lock*) + (with-system-mutex (*fdefns-lock*) (let* ((fdefns *fdefns*) (vector (car fdefns)) (result (lookup vector))) diff -Nru sbcl-2.0.6/src/code/fd-stream.lisp sbcl-2.1.1/src/code/fd-stream.lisp --- sbcl-2.0.6/src/code/fd-stream.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/fd-stream.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -96,6 +96,8 @@ (:conc-name fd-stream-) (:predicate fd-stream-p) (:include ansi-stream + ;; FIXME: would a type constraint on IN-BUFFER + ;; and/or CIN-BUFFER improve anything? (misc #'fd-stream-misc-routine)) (:copier nil)) @@ -462,16 +464,16 @@ (defun file-perror (pathname errno &optional datum &rest arguments) (declare (optimize allow-non-returning-tail-call)) - (multiple-value-bind (condition-type arguments) - (typecase datum - (format-control - (values 'simple-file-error - (list :format-control "~@<~?~@[: ~2I~_~A~]~:>" - :format-arguments (list datum arguments - (when errno (strerror errno)))))) - (t - (values datum arguments))) - (apply #'error condition-type :pathname pathname arguments))) + (let ((message (when errno (strerror errno)))) + (multiple-value-bind (condition-type arguments) + (typecase datum + (format-control + (values 'simple-file-error (list :format-control datum + :format-arguments arguments))) + (t + (values datum arguments))) + (apply #'error condition-type :pathname pathname :message message + arguments)))) (defun c-string-encoding-error (external-format code) (declare (optimize allow-non-returning-tail-call)) @@ -964,7 +966,7 @@ ;;; further assurance than "may" versus "will definitely not". (defun sysread-may-block-p (stream) #+win32 - ;; This answers T at EOF on win32, I think. + ;; This answers T at EOF on win32. (not (sb-win32:handle-listen (fd-stream-fd stream))) #-win32 (not (sb-unix:unix-simple-poll (fd-stream-fd stream) :input 0))) @@ -1468,6 +1470,7 @@ (let* ((byte (aref string start)) (bits (char-code byte)) (size ,out-size-expr)) + (declare (ignorable byte bits)) ,out-expr (incf tail size) (setf (buffer-tail obuf) tail) @@ -1606,7 +1609,7 @@ (let* ((stream ,name) (size 0) (head 0) (byte 0) (char nil) (decode-break-reason nil) - (length (dotimes (count (1- sb-xc:array-dimension-limit) count) + (length (dotimes (count (1- array-dimension-limit) count) (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) @@ -1628,7 +1631,7 @@ (make-string length :element-type 'character)) (t (make-string length :element-type element-type))))) - (declare (ignorable stream) + (declare (ignorable stream byte) (type index head length) ;; size (type (unsigned-byte 8) byte) (type (or null character) char) @@ -1942,17 +1945,13 @@ t)) ;;; Handle miscellaneous operations on FD-STREAM. -(defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2) - (declare (ignore arg2)) - (case operation +(defun fd-stream-misc-routine (fd-stream operation arg1) + (stream-misc-case (operation :default nil) (:listen (labels ((do-listen () (let ((ibuf (fd-stream-ibuf fd-stream))) (or (not (eql (buffer-head ibuf) (buffer-tail ibuf))) (fd-stream-listen fd-stream) - #+win32 - (sb-win32:handle-listen (fd-stream-fd fd-stream)) - #-win32 ;; If the read can block, LISTEN will certainly return NIL. (if (sysread-may-block-p fd-stream) nil @@ -2102,10 +2101,8 @@ (etypecase arg1 (character (fd-stream-character-size fd-stream arg1)) (string (fd-stream-string-size fd-stream arg1)))) - (:file-position - (if arg1 - (fd-stream-set-file-position fd-stream arg1) - (fd-stream-get-file-position fd-stream))))) + (:get-file-position (fd-stream-get-file-position fd-stream)) + (:set-file-position (fd-stream-set-file-position fd-stream arg1)))) ;; FIXME: Think about this. ;; @@ -2312,10 +2309,8 @@ "~@" namestring original)))) (defun %open-error (pathname errno if-exists if-does-not-exist) - (flet ((signal-it (&optional (condition 'simple-file-error)) - (file-perror pathname errno condition - :format-control "Error opening ~S" - :format-arguments (list pathname)))) + (flet ((signal-it (&rest arguments) + (apply #'file-perror pathname errno arguments))) (restart-case (case errno (#-win32 #.sb-unix:enoent @@ -2351,14 +2346,14 @@ :report "Reopen with :if-exists :append" '(:new-if-exists :append))))) (t - (signal-it))) + (signal-it "Error opening ~S" pathname))) (continue () :report "Retry opening." '()) (use-value (value) :report "Try opening a different file." :interactive read-evaluated-form - (list :filename (the pathname-designator value)))))) + (list :new-filename (the pathname-designator value)))))) (defun open (filename &key @@ -2396,16 +2391,17 @@ (declare (type index mask)) (let* (;; PATHNAME is the pathname we associate with the stream. (pathname (merge-pathnames filename)) - (physical (physicalize-pathname pathname)) - (truename (probe-file physical)) - ;; NAMESTRING is the native namestring we open the file with. - (namestring (cond (truename - (native-namestring truename :as-file t)) - ((or (not input) - (and input (eq if-does-not-exist :create)) - (and (eq direction :io) - (not if-does-not-exist-given))) - (native-namestring physical :as-file t))))) + (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)) + ;; Leave NAMESTRING as NIL if nonexistent and not creating a file. + (namestring (when (or existsp + (or (not input) + (and input (eq if-does-not-exist :create)) + (and (eq direction :io) + (not if-does-not-exist-given)))) + physical))) ;; Process if-exists argument if we are doing any output. (cond (output (unless if-exists-given @@ -2435,9 +2431,7 @@ nil) (t :create)))) - (cond ((and if-exists-given - truename - (eq if-exists :new-version)) + (cond ((and existsp if-exists-given (eq if-exists :new-version)) (sb-kernel::%file-error pathname "OPEN :IF-EXISTS :NEW-VERSION is not supported ~ when a new version must be created.")) @@ -2454,7 +2448,7 @@ pathname "OPEN :IF-DOES-NOT-EXIST ~s ~ :IF-EXISTS ~s will always signal an error." if-does-not-exist if-exists)) - (truename + (existsp (if if-exists (sb-kernel::%file-error pathname 'file-exists) (return))) @@ -2486,15 +2480,16 @@ (when (and output (= (logand orig-mode #o170000) #o40000)) (file-perror - pathname - "can't open ~A for output: is a directory" pathname)) + pathname nil + "Can't open ~S for output: is a directory" + pathname)) (setf mode (logand orig-mode #o777)) t) ((eql err/dev sb-unix:enoent) nil) (t - (file-perror - namestring err/dev "can't find ~S" namestring))))))) + (file-perror namestring err/dev + "Can't find ~S" namestring))))))) (unless (and exists (rename-the-old-one namestring original)) (setf original nil) @@ -2699,7 +2694,10 @@ ;;; ;;; FIXME: misleading name, screwy interface (defun file-name (stream &optional new-name) - (when (typep stream 'fd-stream) + (stream-api-dispatch (stream) + :gray (declare (ignore stream)) + :native + (when (typep stream 'fd-stream) (cond (new-name (setf (fd-stream-pathname stream) new-name) (setf (fd-stream-file stream) @@ -2707,7 +2705,8 @@ :as-file t)) t) (t - (fd-stream-pathname stream))))) + (fd-stream-pathname stream)))) + :simple (s-%file-name stream new-name))) ;; Fix the INPUT-CHAR-POS slot of STREAM after having consumed characters ;; from the CIN-BUFFER. This operation is done upon exit from a FAST-READ-CHAR @@ -2726,17 +2725,14 @@ (setf (form-tracking-stream-last-newline stream) pos)) (incf pos)))) -(defun tracking-stream-misc (stream operation &optional arg1 arg2) +(defun tracking-stream-misc (stream operation arg1) ;; The :UNREAD operation will never be invoked because STREAM has a buffer, ;; so unreading is implemented entirely within ANSI-STREAM-UNREAD-CHAR. ;; But we do need to prevent attempts to change the absolute position. - (case operation - (:file-position - (if arg1 - (simple-stream-perror "~S is not positionable" stream) - (fd-stream-get-file-position stream))) + (stream-misc-case (operation) + (:set-file-position (simple-stream-perror "~S is not positionable" stream)) (t ; call next method - (fd-stream-misc-routine stream operation arg1 arg2)))) + (fd-stream-misc-routine stream operation arg1)))) (!define-load-time-global *!cold-stderr-buf* " ") (declaim (type (simple-base-string 1) *!cold-stderr-buf*)) @@ -2763,8 +2759,8 @@ ;; will croak if there is any non-BASE-CHAR in the string (out (replace (make-array n :element-type 'base-char) string :start2 start) 0 n))))) - :misc (lambda (stream operation &optional arg1 arg2) - (declare (ignore stream arg1 arg2)) - (case operation + :misc (lambda (stream operation arg1) + (declare (ignore stream arg1)) + (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))))))) diff -Nru sbcl-2.0.6/src/code/filesys.lisp sbcl-2.1.1/src/code/filesys.lisp --- sbcl-2.0.6/src/code/filesys.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/filesys.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -360,13 +360,13 @@ :as-directory (eq :directory kind)))) (errorp (file-perror filename (sb-win32:get-last-error) - "Failed to find the ~a of ~A" query-for filename))))) + "Failed to find the ~A of ~S" query-for filename))))) (:write-date (cond ((sb-win32::native-file-write-date filename)) (errorp (file-perror filename (sb-win32:get-last-error) - "Failed to find the ~a of ~A" query-for filename))))))) + "Failed to find the ~A of ~S" query-for filename))))))) #-win32 (defun %query-file-system (pathname query-for errorp) @@ -404,7 +404,7 @@ (realpath (parse realpath :as-directory t)) (errorp - (file-perror filename errno "couldn't resolve ~A"))))) + (file-perror filename errno "Couldn't resolve ~S" filename))))) (resolve-problematic-symlink (filename errno realpath-failed) ;; SBCL has for many years had a policy that a pathname ;; that names an existing, dangling or self-referential @@ -442,7 +442,8 @@ ;; The file doesn't exist; maybe error. (errorp (file-perror - pathname errno "Failed to find the ~A of ~A" query-for pathname)))))) + pathname errno + "Failed to find the ~A of ~A" query-for pathname)))))) (binding* ((filename (native-namestring pathname :as-file t)) ((existsp errno nil mode nil uid nil nil nil nil mtime) (sb-unix:unix-stat filename))) @@ -543,9 +544,7 @@ (values nil (sb-win32:get-last-error))) (unless res (with-simple-restart (continue "Return T") - (file-perror namestring err 'delete-file-error - :format-control "Couldn't delete ~A" - :format-arguments (list namestring)))))) + (file-perror namestring err 'delete-file-error))))) t) (defun directorize-pathname (pathname) @@ -619,9 +618,8 @@ (get-errno)) (if res dir - (file-perror - namestring errno - "Could not delete directory ~A" namestring)))))) + (file-perror namestring errno + "Could not delete directory ~S" namestring)))))) (let ((physical (directorize-pathname (physicalize-pathname (merge-pathnames diff -Nru sbcl-2.0.6/src/code/final.lisp sbcl-2.1.1/src/code/final.lisp --- sbcl-2.0.6/src/code/final.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/final.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -43,7 +43,8 @@ (declaim (simple-vector **finalizer-store**)) (defun finalize (object function &key dont-save - &aux (item (if dont-save (list function) function))) + &aux (function (%coerce-callable-to-fun function)) + (item (if dont-save (list function) function))) "Arrange for the designated FUNCTION to be called when there are no more references to OBJECT, including references in FUNCTION itself. @@ -158,7 +159,9 @@ ;; finalizers can in practice almost never be run, as pseudo-static objects ;; don't die, making this more-or-less an exercise in futility. (with-finalizer-store (old-store) - (without-gcing + ;; This doesn't need WITHOUT-GCING. MAPHASH will never present its funarg + ;; with a culled entry. GC during the MAPHASH could remove some items + ;; before we get to them, and that's fantastic. (let ((new-store (make-finalizer-store (max (1+ (finalizer-max-id old-store)) +finalizers-initial-size+))) @@ -181,7 +184,7 @@ old-objects) (clrhash old-objects) (fill old-store 0) - (setq **finalizer-store** new-store))))) + (setq **finalizer-store** new-store)))) ;;; Replace the finalizer store with a copy. Tenured (gen6 = pseudo-static) ;;; vectors are problematic in many ways for gencgc, unless immutable. @@ -231,15 +234,23 @@ object)) ;;; Drain the queue of finalizers and return when empty. -;;; Concurrent invocations of this function are ok. -(defun scan-finalizers () +;;; Concurrent invocations of this function in different threads are ok. +;;; Nested invocations (from a GC forced by a finalizer) are not ok. +;;; See the trace at the bottom of this file. +(defvar *in-a-finalizer* nil) +#+sb-thread (define-alien-variable finalizer-thread-runflag int) +(defun run-pending-finalizers () ;; This never acquires the finalizer store lock. Code accordingly. (let ((hashtable (finalizer-id-map **finalizer-store**))) (loop + ;; Perform no further work if trying to stop the thread, even if there is work. + #+sb-thread (when (zerop finalizer-thread-runflag) (return)) (let ((cell (hash-table-culled-values hashtable))) ;; This is like atomic-pop, but its obtains the first cons cell ;; in the list, not the car of the first cons. - (loop (unless cell (return-from scan-finalizers)) + ;; Possible TODO: when no other work remains, free the *JOINABLE-THREADS*, + ;; though MAKE-THREAD and JOIN-THREAD do that also, so there's no memory leak. + (loop (unless cell (return-from run-pending-finalizers)) (let ((actual (cas (hash-table-culled-values hashtable) cell (cdr cell)))) (if (eq actual cell) (return) (setq cell actual)))) @@ -250,7 +261,7 @@ ;; so always load the vector again before dereferencing. (store **finalizer-store**) ;; I don't think we need a barrier; this has a data dependency - ;; on (CAR CELL) and STORE. (Alpha with threads, anyone?) + ;; on (CAR CELL) and STORE. (finalizers (svref store id))) ; [1] load (setf (svref store id) 0) ; [2] store ;; The ID can be reused right away. Link it into the recycle list, @@ -263,7 +274,7 @@ ;; Now call the function(s) (flet ((call (finalizer) (let ((fun (if (consp finalizer) (car finalizer) finalizer))) - (handler-case (funcall fun) + (handler-case (let ((*in-a-finalizer* t)) (funcall fun)) (error (c) (warn "Error calling finalizer ~S:~% ~S" fun c)))))) (if (simple-vector-p finalizers) @@ -288,83 +299,175 @@ (cond ((simple-vector-p finalizers) (fill finalizers 0)) ((consp finalizers) (rplaca finalizers 0)))))))) +(define-load-time-global *finalizer-thread* nil) +(declaim (type (or sb-thread:thread (eql :start) null) *finalizer-thread*)) #+sb-thread (progn - ;; *FINALIZER-THREAD* is either a boolean value indicating whether to start a - ;; thread, or a thread object (which is created no sooner than needed). - ;; Saving a core sets the flag to NIL so that finalizers which execute - ;; between stopping the thread and writing to disk will be synchronous. - ;; Restarting a saved core resets the flag to T. - (define-load-time-global *finalizer-thread* t) - (declaim (type (or sb-thread:thread boolean) *finalizer-thread*)) - (define-load-time-global *finalizer-queue-lock* - (sb-thread:make-mutex :name "finalizer")) - (define-load-time-global *finalizer-queue* - (sb-thread:make-waitqueue :name "finalizer"))) - -(defun run-pending-finalizers () - (when (hash-table-culled-values (finalizer-id-map **finalizer-store**)) - (cond #+sb-thread - ((%instancep *finalizer-thread*) - (with-system-mutex (*finalizer-queue-lock*) - (sb-thread:condition-notify *finalizer-queue*))) - #+sb-thread - ((eq *finalizer-thread* t) ; Create a new thread +(defun finalizer-thread-notify () + (alien-funcall (extern-alien "finalizer_thread_wake" (function void))) + nil) + +;;; The following operations are synchronized by *MAKE-THREAD-LOCK* - +;;; FINALIZER-THREAD-{START,STOP}, S-L-A-D, SB-POSIX:FORK +(defun finalizer-thread-start () + (with-system-mutex (sb-thread::*make-thread-lock*) + (aver (not *finalizer-thread*)) + (setf finalizer-thread-runflag 1) + (setq *finalizer-thread* :start) + (let ((thread (sb-thread::make-ephemeral-thread "finalizer" (lambda () - ;; If we already called FINALIZER-THREAD-STOP, then - ;; *FINALIZER-THREAD* is NIL, and this WHEN test is false. - (when (eq t (cas *finalizer-thread* t - sb-thread:*current-thread*)) - ;; Don't enter the loop if this thread lost the - ;; competition to become a finalizer thread. - (loop - (scan-finalizers) - ;; Wait for a notification - (with-system-mutex (*finalizer-queue-lock*) - ;; Don't go to sleep if *FINALIZER-THREAD* became NIL - (unless *finalizer-thread* - (return)) - ;; The return value of CONDITION-WAIT is irrelevant - ;; since it is always legal to call SCAN-FINALIZERS - ;; even when it has nothing to do. - ;; Spurious wakeup is of no concern to us here. - (sb-thread:condition-wait - *finalizer-queue* *finalizer-queue-lock*))))) - nil)) - (t - (scan-finalizers))))) - -;;; If a finalizer thread was started, stop it and wait for it to finish. -;;; Make no attempt to drain the queue of pending finalizers. -;;; (When called from EXIT, the user must invoke a final GC if there is -;;; an expectation that GC-based things run. Similarly when saving a core) + (setf *finalizer-thread* sb-thread:*current-thread*) + (loop (run-pending-finalizers) + (alien-funcall (extern-alien "finalizer_thread_wait" (function void))) + (when (zerop finalizer-thread-runflag) (return))) + (setq *finalizer-thread* 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)))) + +;;; 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 () - #+sb-thread (let ((thread *finalizer-thread*)) - ;; valid state transitions: - ;; T to a # - ;; # to NIL - ;; T to NIL - ;; If it was NIL, it is latched at that state, so we can ignore it. - (when (null thread) - (return-from finalizer-thread-stop)) - (let ((oldval (cas *finalizer-thread* thread nil))) - ;; If GC had started the thread, and it got to its main body only after - ;; we observed *FINALIZER-THREAD* = T, then we could see a transition - ;; from T to # now. That is unlikely, but we must try once - ;; again to CAS the value to NIL. - (unless (eq oldval thread) - (setq thread oldval) - ;; Also, we could be racing with someone else trying to stop the - ;; thread, so we could see T | # -> NIL. - (when (null thread) - (return-from finalizer-thread-stop)) - (aver (eq (cas *finalizer-thread* thread nil) thread)))) - (when (%instancep thread) - ;; The finalizer thread will exit when we wake it up - ;; and it sees that *FINALIZER-THREAD* is NIL. - (with-system-mutex (*finalizer-queue-lock*) - (sb-thread:condition-notify *finalizer-queue*)) - (sb-thread:join-thread thread)))) ; wait for it + (aver (sb-thread::thread-p thread)) + (alien-funcall (extern-alien "finalizer_thread_stop" (function void))) + (sb-thread:join-thread thread))) +) + +#| +;;; This is a display produced by annotating parts of gc-common.c and +;;; interrupt.c with each thread's output in its own column. +;;; The main thread is on the right. + +;;; This output shows that if the finalizer thread calls a function that +;;; triggers a GC, the interrupt nesting depth can grow without limit. +;;; The finalizer thread does not have to be a memory hog - it just has +;;; to be unlucky enough to be the thread that triggers the collection. +;;; _Any_ thread can bring the GC trigger up to the threshold, +;;; and as long as the finalizer thread is the one to cross the +;;; the threshold, it is tasked with triggering the next scan +;;; of finalizers, but it MUST NOT do so recursively. +;;; +;;; The same thing can happen without using a finalizer thread, +;;; but it's actually easier to understand the output this way. + +Thread 2 Main +-------- -------- +| Enter SB-EXT:GC 0 +| Stopping world +| Stopped world +| SUB-GC calling gc(0) +| set auto_gc_trig=4858833 +| completed GC +| Restarted world +| SB-EXT:GC calling POST-GC +| ENTER run-pending-finalizers +| Enter SB-EXT:GC 0 +| Stopping world +| Stopped world +| SUB-GC calling gc(6) +| set auto_gc_trig=5075473 +| completed GC +| Restarted world +| SB-EXT:GC calling POST-GC +| ENTER run-pending-finalizers +| Trying to start finalizer thread +| starting +| Enter SB-EXT:GC 0 +| Stopping world +| Caught SIGUSR2, pc=52a946bd +| STOP_FOR_GC PA=1 inh=N sigmask=0 +| Caught SIGILL, pc=52a946cc code 0x9 +| evt 1 >handle_pending +| STOP_FOR_GC PA=0 inh=N sigmask=0 +| fake ffcall "stop_for_gc" +| bind(free_ICI, 1) +| Stopped world +| SUB-GC calling gc(6) +| set auto_gc_trig=520eeb3 +| completed GC +| Restarted world +| SB-EXT:GC calling POST-GC +| ENTER run-pending-finalizers +| Notify finalizer thread +| unbind free_ICI -> 0 +| leave STOP_FOR_GC +| evt 1 handle_pending +| ENTER maybe_gc (pc was 52a946ce) +| fake ffcall "maybe_gc" +| bind(free_ICI, 1) +| maybe_gc calling SUB-GC +| Stopping world +| Caught SIGUSR2, pc=7ff010deef47 +| STOP_FOR_GC PA=0 inh=N sigmask=0 +| fake ffcall "stop_for_gc" +| bind(free_ICI, 1) +| Stopped world +| SUB-GC calling gc(0) +| set auto_gc_trig=552b033 +| completed GC +| Restarted world +| maybe_gc calling POST-GC +| ENTER run-pending-finalizers +| unbind free_ICI -> 0 +| leave STOP_FOR_GC +| gc_trig=55d9110, setting PA-int +| Caught SIGILL, pc=52a946cc code 0x9 +| evt 3 >handle_pending +| ENTER maybe_gc (pc was 52a946ce) +| fake ffcall "maybe_gc" +| bind(free_ICI, 2) +| maybe_gc calling SUB-GC +| Stopping world +| Caught SIGUSR2, pc=7ff010deef47 +| STOP_FOR_GC PA=0 inh=N sigmask=0 +| fake ffcall "stop_for_gc" +| bind(free_ICI, 1) +| Stopped world +| SUB-GC calling gc(0) +| set auto_gc_trig=56c0423 +| completed GC +| Restarted world +| maybe_gc calling POST-GC +| ENTER run-pending-finalizers +| unbind free_ICI -> 0 +| leave STOP_FOR_GC +| gc_trig=576e500, setting PA-int +| Caught SIGILL, pc=52a946cc code 0x9 +| evt 4 >handle_pending +| ENTER maybe_gc (pc was 52a946ce) +| fake ffcall "maybe_gc" +| bind(free_ICI, 3) +| maybe_gc calling SUB-GC +| Stopping world +| Caught SIGUSR2, pc=7ff010deef47 +| STOP_FOR_GC PA=0 inh=N sigmask=0 +| fake ffcall "stop_for_gc" +| bind(free_ICI, 1) +| Stopped world +| SUB-GC calling gc(0) +| set auto_gc_trig=59dc213 +| completed GC +| Restarted world +| maybe_gc calling POST-GC +| ENTER run-pending-finalizers +| unbind free_ICI -> 0 +| leave STOP_FOR_GC +| gc_trig=5a8a2f0, setting PA-int +| Caught SIGILL, pc=52a946cc code 0x9 +| evt 5 >handle_pending +| ENTER maybe_gc (pc was 52a946ce) +| fake ffcall "maybe_gc" +| bind(free_ICI, 4) +| maybe_gc calling SUB-GC +| Stopping world +| +;;; This pattern of binding FREE_INTERRUPT_CONTEXT_INDEX to successively +;;; higher values will continue forever until reaching the limit and crashing. +|# diff -Nru sbcl-2.0.6/src/code/float-inf-nan.lisp sbcl-2.1.1/src/code/float-inf-nan.lisp --- sbcl-2.0.6/src/code/float-inf-nan.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/code/float-inf-nan.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,118 @@ +;;;; This file contains the definitions of float-specific number +;;;; support (other than irrational stuff, which is in irrat.) There is +;;;; code in here that assumes there are only two float formats: IEEE +;;;; single and double. (LONG-FLOAT support has been added, but bugs +;;;; may still remain due to old code which assumes this dichotomy.) + +;;;; 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") + +(declaim (maybe-inline float-denormalized-p float-infinity-p float-nan-p + float-trapping-nan-p)) + +(defun float-denormalized-p (x) + "Return true if the float X is denormalized." + (number-dispatch ((x float)) + ((single-float) + (and (zerop (ldb sb-vm:single-float-exponent-byte (single-float-bits x))) + (not (zerop x)))) + ((double-float) + (and (zerop (ldb sb-vm:double-float-exponent-byte + (double-float-high-bits x))) + (not (zerop x)))) + #+(and long-float x86) + ((long-float) + (and (zerop (ldb sb-vm:long-float-exponent-byte (long-float-exp-bits x))) + (not (zerop x)))))) + +(defmacro define-float-inf-or-nan-test + (name doc single double #+(and long-float x86) long) + `(defun ,name (x) ,doc + (number-dispatch ((x float)) + ((single-float) + (let ((bits (single-float-bits x))) + (and (> (ldb sb-vm:single-float-exponent-byte bits) + sb-vm:single-float-normal-exponent-max) + ,single))) + ((double-float) + #+64-bit + ;; With 64-bit words, all the FOO-float-byte constants need to be reworked + ;; to refer to a byte position in the whole word. I think we can reasonably + ;; get away with writing the well-known values here. + (let ((bits (double-float-bits x))) + (and (> (ldb (byte 11 52) bits) sb-vm:double-float-normal-exponent-max) + ,double)) + #-64-bit + (let ((hi (double-float-high-bits x)) + (lo (double-float-low-bits x))) + (declare (ignorable lo)) + (and (> (ldb sb-vm:double-float-exponent-byte hi) + sb-vm:double-float-normal-exponent-max) + ,double))) + #+(and long-float x86) + ((long-float) + (let ((exp (long-float-exp-bits x)) + (hi (long-float-high-bits x)) + (lo (long-float-low-bits x))) + (declare (ignorable lo)) + (and (> (ldb sb-vm:long-float-exponent-byte exp) + sb-vm:long-float-normal-exponent-max) + ,long)))))) + +;; Infinities and NANs have the maximum exponent +(define-float-inf-or-nan-test float-infinity-or-nan-p nil + t t #+(and long-float x86) t) + +;; Infinity has 0 for the significand +(define-float-inf-or-nan-test float-infinity-p + "Return true if the float X is an infinity (+ or -)." + (zerop (ldb sb-vm:single-float-significand-byte bits)) + + #+64-bit (zerop (ldb (byte 52 0) bits)) + #-64-bit (zerop (logior (ldb sb-vm:double-float-significand-byte hi) lo)) + + #+(and long-float x86) + (and (zerop (ldb sb-vm:long-float-significand-byte hi)) + (zerop lo))) + +;; NaNs have nonzero for the significand +(define-float-inf-or-nan-test float-nan-p + "Return true if the float X is a NaN (Not a Number)." + (not (zerop (ldb sb-vm:single-float-significand-byte bits))) + + #+64-bit (not (zerop (ldb (byte 52 0) bits))) + #-64-bit (not (zerop (logior (ldb sb-vm:double-float-significand-byte hi) lo))) + + #+(and long-float x86) + (or (not (zerop (ldb sb-vm:long-float-significand-byte hi))) + (not (zerop lo)))) + +(define-float-inf-or-nan-test float-trapping-nan-p + "Return true if the float X is a trapping NaN (Not a Number)." + ;; MIPS has trapping NaNs (SNaNs) with the trapping-nan-bit SET. + ;; All the others have trapping NaNs (SNaNs) with the + ;; trapping-nan-bit CLEAR. Note that the given implementation + ;; considers infinities to be FLOAT-TRAPPING-NAN-P on most + ;; architectures. + + ;; SINGLE-FLOAT + #+mips (logbitp 22 bits) + #-mips (not (logbitp 22 bits)) + + ;; DOUBLE-FLOAT + #+mips (logbitp 19 hi) + #+(and (not mips) 64-bit) (not (logbitp 51 bits)) + #+(and (not mips) (not 64-bit)) (not (logbitp 19 hi)) + + ;; LONG-FLOAT (this code is dead anyway) + #+(and long-float x86) + (zerop (logand (ldb sb-vm:long-float-significand-byte hi) + (ash 1 30)))) diff -Nru sbcl-2.0.6/src/code/float.lisp sbcl-2.1.1/src/code/float.lisp --- sbcl-2.0.6/src/code/float.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/float.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -17,114 +17,10 @@ ;;;; float predicates and environment query -#-sb-fluid -(declaim (maybe-inline float-denormalized-p float-infinity-p float-nan-p - float-trapping-nan-p)) - -(defun float-denormalized-p (x) - "Return true if the float X is denormalized." - (number-dispatch ((x float)) - ((single-float) - (and (zerop (ldb sb-vm:single-float-exponent-byte (single-float-bits x))) - (not (zerop x)))) - ((double-float) - (and (zerop (ldb sb-vm:double-float-exponent-byte - (double-float-high-bits x))) - (not (zerop x)))) - #+(and long-float x86) - ((long-float) - (and (zerop (ldb sb-vm:long-float-exponent-byte (long-float-exp-bits x))) - (not (zerop x)))))) - -(defmacro define-float-inf-or-nan-test - (name doc single double #+(and long-float x86) long) - `(defun ,name (x) ,doc - (number-dispatch ((x float)) - ((single-float) - (let ((bits (single-float-bits x))) - (and (> (ldb sb-vm:single-float-exponent-byte bits) - sb-vm:single-float-normal-exponent-max) - ,single))) - ((double-float) - #+64-bit - ;; With 64-bit words, all the FOO-float-byte constants need to be reworked - ;; to refer to a byte position in the whole word. I think we can reasonably - ;; get away with writing the well-known values here. - (let ((bits (double-float-bits x))) - (and (> (ldb (byte 11 52) bits) sb-vm:double-float-normal-exponent-max) - ,double)) - #-64-bit - (let ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x))) - (declare (ignorable lo)) - (and (> (ldb sb-vm:double-float-exponent-byte hi) - sb-vm:double-float-normal-exponent-max) - ,double))) - #+(and long-float x86) - ((long-float) - (let ((exp (long-float-exp-bits x)) - (hi (long-float-high-bits x)) - (lo (long-float-low-bits x))) - (declare (ignorable lo)) - (and (> (ldb sb-vm:long-float-exponent-byte exp) - sb-vm:long-float-normal-exponent-max) - ,long)))))) - -;; Infinities and NANs have the maximum exponent -(define-float-inf-or-nan-test float-infinity-or-nan-p nil - t t #+(and long-float x86) t) - -;; Infinity has 0 for the significand -(define-float-inf-or-nan-test float-infinity-p - "Return true if the float X is an infinity (+ or -)." - (zerop (ldb sb-vm:single-float-significand-byte bits)) - - #+64-bit (zerop (ldb (byte 52 0) bits)) - #-64-bit (zerop (logior (ldb sb-vm:double-float-significand-byte hi) lo)) - - #+(and long-float x86) - (and (zerop (ldb sb-vm:long-float-significand-byte hi)) - (zerop lo))) - -;; NaNs have nonzero for the significand -(define-float-inf-or-nan-test float-nan-p - "Return true if the float X is a NaN (Not a Number)." - (not (zerop (ldb sb-vm:single-float-significand-byte bits))) - - #+64-bit (not (zerop (ldb (byte 52 0) bits))) - #-64-bit (not (zerop (logior (ldb sb-vm:double-float-significand-byte hi) lo))) - - #+(and long-float x86) - (or (not (zerop (ldb sb-vm:long-float-significand-byte hi))) - (not (zerop lo)))) - -(define-float-inf-or-nan-test float-trapping-nan-p - "Return true if the float X is a trapping NaN (Not a Number)." - ;; HPPA (and apparently MIPS) have trapping NaNs (SNaNs) with the - ;; trapping-nan-bit SET. PPC, SPARC, Alpha, and x86 (and presumably - ;; x86-64, ARM, and ARM64) have trapping NaNs (SNaNs) with the - ;; trapping-nan-bit CLEAR. Note that the given implementation - ;; considers infinities to be FLOAT-TRAPPING-NAN-P on most - ;; architectures. - - ;; SINGLE-FLOAT - #+(or mips hppa) (logbitp 22 bits) - #-(or mips hppa) (not (logbitp 22 bits)) - - ;; DOUBLE-FLOAT - #+(or mips hppa) (logbitp 19 hi) - #+(and (not (or mips hppa)) 64-bit) (not (logbitp 51 bits)) - #+(and (not (or mips hppa)) (not 64-bit)) (not (logbitp 19 hi)) - - ;; LONG-FLOAT (this code is dead anyway) - #+(and long-float x86) - (zerop (logand (ldb sb-vm:long-float-significand-byte hi) - (ash 1 30)))) - ;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the ;;; actual exponent (and hence how denormalized it is), otherwise we just ;;; return the number of digits or 0. -#-sb-fluid (declaim (maybe-inline float-precision)) +(declaim (maybe-inline float-precision)) (defun float-precision (f) "Return a non-negative number of significant digits in its float argument. Will be less than FLOAT-DIGITS if denormalized or zero." @@ -189,7 +85,7 @@ #+long-float (long-float sb-vm:long-float-digits))) -#-sb-fluid (declaim (inline float-digits float-radix)) +(declaim (inline float-digits float-radix)) (defun float-digits (f) (declare (explicit-check)) @@ -209,7 +105,6 @@ (defconstant-eqx float-decoding-error "Can't decode NaN or infinity: ~S." #'string=) -#-sb-fluid (declaim (maybe-inline integer-decode-single-float integer-decode-double-float)) @@ -395,7 +290,7 @@ ((long-float) (integer-decode-long-float x)))) -#-sb-fluid (declaim (maybe-inline decode-single-float decode-double-float)) +(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. @@ -517,7 +412,7 @@ ;;;; SCALE-FLOAT -#-sb-fluid (declaim (maybe-inline scale-single-float scale-double-float)) +(declaim (maybe-inline scale-single-float scale-double-float)) ;;; Handle float scaling where the X is denormalized or the result is ;;; denormalized or underflows to 0. @@ -816,8 +711,8 @@ ((integer) number) ((ratio) (values (truncate (numerator number) (denominator number)))) (((foreach single-float double-float #+long-float long-float)) - (if (and (<= (float sb-xc:most-negative-fixnum number) number) - (< number (float sb-xc:most-positive-fixnum number))) + (if (and (<= (float most-negative-fixnum number) number) + (< number (float most-positive-fixnum number))) (truly-the fixnum (%unary-truncate number)) (multiple-value-bind (bits exp) (integer-decode-float number) (let ((res (ash bits exp))) @@ -828,8 +723,8 @@ ;;; Specialized versions for floats. (macrolet ((def (type name) `(defun ,name (number) - (if (and (<= ,(coerce sb-xc:most-negative-fixnum type) number) - (< number ,(coerce sb-xc:most-positive-fixnum type))) + (if (and (<= ,(coerce most-negative-fixnum type) number) + (< number ,(coerce most-positive-fixnum type))) (truly-the fixnum (,name number)) ;; General -- slow -- case. (multiple-value-bind (bits exp) (integer-decode-float number) @@ -853,9 +748,9 @@ ((integer) number) ((ratio) (values (round (numerator number) (denominator number)))) (((foreach single-float double-float #+long-float long-float)) - (if (< (float sb-xc:most-negative-fixnum number) + (if (< (float most-negative-fixnum number) number - (float sb-xc:most-positive-fixnum number)) + (float most-positive-fixnum number)) (truly-the fixnum (%unary-round number)) (multiple-value-bind (bits exp) (integer-decode-float number) (let* ((shifted (ash bits exp)) @@ -871,6 +766,7 @@ (- rounded) rounded))))))) +#-round-float (defun %unary-ftruncate (number) (number-dispatch ((number real)) ((integer) (float number)) @@ -878,6 +774,14 @@ (((foreach single-float double-float #+long-float long-float)) (%unary-ftruncate number)))) +(declaim (inline first-bit-set)) +(defun first-bit-set (x) + #+x86-64 + (truly-the (values (mod #.sb-vm:n-word-bits) &optional) + (%primitive sb-vm::unsigned-word-find-first-bit (the word x))) + #-x86-64 + (1- (integer-length (logand x (- x))))) + (defun rational (x) "RATIONAL produces a rational number for any real numeric argument. This is more efficient than RATIONALIZE, but it assumes that floating-point is @@ -890,10 +794,85 @@ 0 (let ((int (if (minusp x) (- bits) bits))) (if (minusp exp) - (integer-/-integer int (ash 1 (- exp))) + ;; Instead of division (which also involves GCD) + ;; find the first set bit of the numerator and shift accordingly, + ;; as the denominator is a power of two. + (let* ((pexp (- exp)) + (set (first-bit-set bits)) + (shifted (ash int (- set)))) + (if (> pexp set) + (%make-ratio shifted + (let ((shift (- pexp set))) + (if (< shift sb-vm:n-fixnum-bits) + (ash 1 shift) + (bignum-ashift-left-fixnum 1 shift)))) + (ash int exp))) (ash int exp)))))) ((rational) x))) +#+64-bit +(defun float-bignum-= (float bignum) + (declare (optimize speed)) + (number-dispatch ((float)) + (((foreach single-float double-float)) + (multiple-value-bind (bits exp) (integer-decode-float float) + (if (or (eql bits 0) + (minusp exp)) + nil + (let ((int (if (minusp float) (- bits) bits))) + (and (= (truly-the bignum-length (bignum-integer-length bignum)) + (+ (integer-length bits) exp)) + (sb-bignum::bignum-lower-bits-zero-p bignum exp) + (= int + (truly-the fixnum + (sb-bignum::last-bignum-part=>fixnum exp bignum)))))))))) + +#+64-bit +(defun float-bignum-< (float bignum) + (declare (optimize speed)) + (number-dispatch ((float)) + (((foreach single-float double-float)) + (multiple-value-bind (bits exp) (integer-decode-float float) + (if (or (eql bits 0) + (minusp exp)) + (bignum-plus-p bignum) + (let ((int (if (minusp float) (- bits) bits)) + (length-diff (- (truly-the bignum-length (bignum-integer-length bignum)) + (+ (integer-length bits) exp)))) + (cond + ((plusp length-diff) (bignum-plus-p bignum)) + ((minusp length-diff) (minusp float)) + (t + (let ((diff (- (truly-the fixnum + (sb-bignum::last-bignum-part=>fixnum exp bignum)) + int))) + (cond ((plusp diff) t) + ((minusp diff) nil) + (t + (not (sb-bignum::bignum-lower-bits-zero-p bignum exp))))))))))))) + +#+64-bit +(defun float-bignum-> (float bignum) + (declare (optimize speed)) + (number-dispatch ((float)) + (((foreach single-float double-float)) + (multiple-value-bind (bits exp) (integer-decode-float float) + (if (or (eql bits 0) + (minusp exp)) + (not (bignum-plus-p bignum)) + (let ((int (if (minusp float) (- bits) bits)) + (length-diff (- (truly-the bignum-length (bignum-integer-length bignum)) + (+ (integer-length bits) exp)))) + (cond + ((plusp length-diff) (not (bignum-plus-p bignum))) + ((minusp length-diff) (not (minusp float))) + (t + (let ((diff (- (truly-the fixnum + (sb-bignum::last-bignum-part=>fixnum exp bignum)) + int))) + (cond ((plusp diff) nil) + ((minusp diff) t))))))))))) + ;;; This algorithm for RATIONALIZE, due to Bruno Haible, is included ;;; with permission. ;;; diff -Nru sbcl-2.0.6/src/code/float-trap.lisp sbcl-2.1.1/src/code/float-trap.lisp --- sbcl-2.0.6/src/code/float-trap.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/float-trap.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -48,10 +48,10 @@ names))) ) ; EVAL-WHEN -;;; interpreter stubs for floating point modes get/setters for the -;;; alpha have been removed to alpha-vm.lisp, as they are implemented -;;; in C rather than as VOPs. Likewise for x86-64 and mips. -#-(or alpha x86-64 mips) +;;; interpreter stubs for floating point modes get/setters for +;;; some architectures have been removed, as they are implemented +;;; in C rather than as VOPs. +#-(or x86-64 mips) (progn (defun floating-point-modes () (floating-point-modes)) @@ -201,8 +201,7 @@ (with-interrupts ;; Reset the accumulated exceptions, may be needed on other ;; platforms too, at least Linux doesn't seem to require it. - #+(or sunos (and hppa linux)) - (setf (ldb sb-vm:float-sticky-bits (floating-point-modes)) 0) + #+sunos (setf (ldb sb-vm:float-sticky-bits (floating-point-modes)) 0) (error (or (cdr (assoc code +sigfpe-code-error-alist+)) 'floating-point-exception) :operation op diff -Nru sbcl-2.0.6/src/code/fop.lisp sbcl-2.1.1/src/code/fop.lisp --- sbcl-2.0.6/src/code/fop.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/fop.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -127,7 +127,7 @@ (flet ((read-varint () (loop for shift :of-type (integer 0 28) from 0 by 7 ; position in integer for octet = (fast-read-byte) - for accum :of-type (mod #.sb-xc:char-code-limit) + for accum :of-type (mod #.char-code-limit) = (logand octet #x7F) then (logior (ash (logand octet #x7F) shift) accum) unless (logbitp 7 octet) return accum))) @@ -183,7 +183,7 @@ (define-fop 45 :not-host (fop-layout ((:operands depthoid flags length) name bitmap inherits)) (decf depthoid) ; was bumped by 1 since non-stack args can't encode negatives - (find-and-init-or-check-layout name depthoid flags length bitmap inherits)) + (sb-kernel::load-layout name depthoid inherits length bitmap flags)) ;; Allocate a CLOS object. This is used when the compiler detects that ;; MAKE-LOAD-FORM returned a simple use of MAKE-LOAD-FORM-SAVING-SLOTS, @@ -317,6 +317,10 @@ (define-fop 36 (fop-integer ((:operands n-bytes))) (number-to-core (load-s-integer n-bytes (fasl-input-stream)))) +(define-fop 33 :not-host (fop-word-pointer) + (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream)) + (int-sap (fast-read-u-integer #.sb-vm:n-word-bytes)))) + (define-fop 34 (fop-word-integer) (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream)) (number-to-core (fast-read-s-integer #.sb-vm:n-word-bytes)))) @@ -536,6 +540,9 @@ ;; For a full explanation, refer to the comment above MAKE-CORE-COMPONENT ;; concerning the corresponding use therein of WITH-PINNED-OBJECTS etc. (read-n-bytes (fasl-input-stream) (code-instructions code) 0 n-code-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. + (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(). @@ -656,7 +663,7 @@ `(define-fop ,(car spec) (,(symbolicate "FOP-LAYOUT-OF-" (cadr spec))) - (find-layout ',(cadr spec)))) + ,(find-layout (cadr spec)))) specs)))) (frob (#x68 t) (#x69 structure-object) diff -Nru sbcl-2.0.6/src/code/foreign.lisp sbcl-2.1.1/src/code/foreign.lisp --- sbcl-2.0.6/src/code/foreign.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/foreign.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -14,9 +14,7 @@ (defun find-foreign-symbol-address (name) "Returns the address of the foreign symbol NAME, or NIL. Does not enter the symbol in the linkage table, and never returns an address in the linkage-table." - (or #-linkage-table - (find-foreign-symbol-in-table name *static-foreign-symbols*) - (find-dynamic-foreign-symbol-address name))) + (find-dynamic-foreign-symbol-address name)) ;;; Note that much conditionalization is for nothing at this point, because all ;;; platforms that we care about implement dlopen(). But if one did not, only @@ -28,23 +26,13 @@ ;;; flexibility of recompiling C without recompiling Lisp. (defun foreign-symbol-address (name &optional datap) "Returns the address of the foreign symbol NAME. DATAP must be true if the -symbol designates a variable (used only on linkage-table platforms). -Returns a secondary value T if the symbol is a dynamic foreign symbol. +symbol designates a variable. +Returns a secondary value T for historical reasons. -On linkage-table ports the returned address is always static: either direct -address of a static symbol, or the linkage-table address of a dynamic one. -Dynamic symbols are entered into the linkage-table if they aren't there already. - -On non-linkage-table ports signals an error if the symbol isn't found." +The returned address is always a linkage-table address. +Symbols are entered into the linkage-table if they aren't there already." (declare (ignorable datap)) - #+linkage-table - (values (ensure-foreign-symbol-linkage name datap) t) - #-linkage-table - (let ((static (find-foreign-symbol-in-table name *static-foreign-symbols*))) - (if static - (values static nil) - #+os-provides-dlopen (values (ensure-dynamic-foreign-symbol-address name) t) - #-os-provides-dlopen (error 'undefined-alien-error :name name)))) + (values (ensure-foreign-symbol-linkage name datap) t)) (defun foreign-symbol-sap (symbol &optional datap) "Returns a SAP corresponding to the foreign symbol. DATAP must be true if the @@ -52,9 +40,6 @@ the symbol into the linkage-table. On non-linkage-table ports signals an error if the symbol isn't found." (declare (ignorable datap)) - #-linkage-table - (int-sap (foreign-symbol-address symbol)) - #+linkage-table (multiple-value-bind (addr sharedp) (foreign-symbol-address symbol datap) ;; If the address is from linkage-table and refers to data @@ -66,21 +51,12 @@ (defun foreign-reinit () #+os-provides-dlopen (reopen-shared-objects) - #+linkage-table (update-linkage-table t)) + (update-linkage-table t)) ;;; Cleanups before saving a core (defun foreign-deinit () - #+(and os-provides-dlopen (not linkage-table)) ; at most HPPA and Alpha now - (when (dynamic-foreign-symbols-p) - (warn "~@" (list-dynamic-foreign-symbols))) ;; Clobber list of undefineds. Reinit will figure it all out again. - #+linkage-table (setf (cdr *linkage-info*) nil) + (setf (cdr *linkage-info*) nil) #+os-provides-dlopen (close-shared-objects)) @@ -89,7 +65,6 @@ (declare (ignorable sap)) (let ((addr (sap-int sap))) (declare (ignorable addr)) - #+linkage-table (when (<= sb-vm:linkage-table-space-start addr sb-vm:linkage-table-space-end) @@ -119,15 +94,8 @@ ;; static foreign symbols (and *linkage-info*, for that matter). )) -;;; How we learn about foreign symbols and dlhandles initially -(defvar *!initial-foreign-symbols*) - (defun !foreign-cold-init () (declare (special *runtime-dlhandle* *shared-objects*)) - #-linkage-table - (dovector (symbol *!initial-foreign-symbols*) - (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol))) - #+linkage-table (loop for table-offset from 0 and reference across (symbol-value 'sb-vm::+required-foreign-symbols+) do (setf (gethash reference (car *linkage-info*)) table-offset)) diff -Nru sbcl-2.0.6/src/code/foreign-load.lisp sbcl-2.1.1/src/code/foreign-load.lisp --- sbcl-2.0.6/src/code/foreign-load.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/foreign-load.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -88,16 +88,6 @@ (dlopen-or-lose obj)) (setf *shared-objects* (append (remove obj *shared-objects*) (list obj))) - ;; FIXME: Why doesn't the linkage table work on Windows? (Or maybe it - ;; does and this can be just #+linkage-table?) Note: remember to change - ;; FOREIGN-DEINIT as well then! - ;; - ;; Kovalenko 2010-11-24: I think so. Alien _data_ references - ;; are the only thing on win32 that is even slightly - ;; problematic. Handle function references in the same way as - ;; other linkage-table platforms is easy. - ;; - #+linkage-table (when (or old (cdr *linkage-info*)) ;; If OLD is non-NIL, then we're passing "true" which causes all foreign ;; symbols to get looked up again. Otherwise we're passing "false" @@ -116,9 +106,8 @@ :key #'shared-object-pathname :test #'equal))) (when old - #-hpux (dlclose-or-lose old) + (dlclose-or-lose old) (setf *shared-objects* (remove old *shared-objects*)) - #+linkage-table (update-linkage-table t) ;; Return T for unloaded, vs whatever update-linkage-info returns t))))) @@ -168,32 +157,8 @@ (defun close-shared-objects () (let (saved) (dolist (obj (reverse *shared-objects*)) - #-hpux (dlclose-or-lose obj) + (dlclose-or-lose obj) (unless (shared-object-dont-save obj) (push obj saved))) (setf *shared-objects* saved)) - #-hpux (dlclose-or-lose)) - -;;; This table is unsynchronized, but the only platforms that use it -;;; lack thread support, and they don't work anyway. -#-linkage-table -(let ((symbols (make-hash-table :test #'equal))) - (defun ensure-dynamic-foreign-symbol-address (symbol &optional datap) - "Returns the address of the foreign symbol as an integer. On linkage-table -ports if the symbols isn't found a special guard address is returned instead, -accesses to which will result in an UNDEFINED-ALIEN-ERROR. On other ports an -error is immediately signalled if the symbol isn't found. The returned address -is never in the linkage-table." - (declare (ignorable datap)) - (let ((addr (find-dynamic-foreign-symbol-address symbol))) - (cond ((not addr) - (error 'undefined-alien-error :name symbol)) - (t - (setf (gethash symbol symbols) t) - addr)))) - (defun dynamic-foreign-symbols-p () - (plusp (hash-table-count symbols))) - (defun list-dynamic-foreign-symbols () - (loop for symbol being each hash-key in symbols - collect symbol))) diff -Nru sbcl-2.0.6/src/code/gc.lisp sbcl-2.1.1/src/code/gc.lisp --- sbcl-2.0.6/src/code/gc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/gc.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -15,7 +15,6 @@ #+gencgc (define-alien-variable ("DYNAMIC_SPACE_START" sb-vm:dynamic-space-start) os-vm-size-t) -#-sb-fluid (declaim (inline current-dynamic-space-start)) (defun current-dynamic-space-start () #+gencgc sb-vm:dynamic-space-start @@ -27,7 +26,6 @@ (defun dynamic-space-free-pointer () (extern-alien "dynamic_space_free_pointer" system-area-pointer))) -#-sb-fluid (declaim (inline dynamic-usage)) #+gencgc (defun dynamic-usage () @@ -149,7 +147,13 @@ ;;; For GENCGC all generations < GEN will be GC'ed. -(define-load-time-global *already-in-gc* (sb-thread:make-mutex :name "GC lock")) +(defmacro try-acquire-gc-lock (&rest forms) + #-sb-thread `(progn ,@forms t) + #+sb-thread + `(when (eql (alien-funcall (extern-alien "try_acquire_gc_lock" (function int))) 1) + ,@forms + (alien-funcall (extern-alien "release_gc_lock" (function void))) + t)) (defun sub-gc (gen) (cond (*gc-inhibit* @@ -195,8 +199,6 @@ ;; Let's make sure we're not interrupted and that none of ;; the deadline or deadlock detection stuff triggers. (without-interrupts - (sb-thread::without-thread-waiting-for - (:already-without-interrupts t) (let ((sb-impl::*deadline* nil) (epoch *gc-epoch*)) (loop @@ -210,10 +212,9 @@ ;; execute the remainder of the GC: stopping the ;; world with interrupts disabled is the mother of ;; all critical sections. - (cond ((sb-thread:with-mutex (*already-in-gc* :wait-p nil) + (cond ((try-acquire-gc-lock (unsafe-clear-roots gen) - (gc-stop-the-world) - t) + (gc-stop-the-world)) ;; Success! GC. (perform-gc) ;; Return, but leave *gc-pending* as is: we @@ -240,8 +241,19 @@ ;; runtime. (when (and (eql gen 0) (neq epoch *gc-pending*)) - (return 0)))))))))) + (return 0))))))))) +#+sb-thread +(defun post-gc () + (sb-impl::finalizer-thread-notify) + (alien-funcall (extern-alien "empty_thread_recyclebin" (function void))) + ;; Post-GC actions are invoked synchronously by the GCing thread, + ;; which is an arbitrary one. If those actions aquire any locks, or are sensitive + ;; to the state of *ALLOW-WITH-INTERRUPTS*, any deadlocks of what-have-you + ;; are user error. Hooks need to be sufficiently uncomplicated as to be harmless. + (call-hooks "after-GC" *after-gc-hooks* :on-error :warn)) + +#-sb-thread (defun post-gc () ;; Outside the mutex, interrupts may be enabled: these may cause ;; another GC. FIXME: it can potentially exceed maximum interrupt @@ -253,33 +265,48 @@ ;; ;; KLUDGE: Don't run the hooks in GC's if: ;; - ;; A) this thread is dying, so that user-code never runs with - ;; (thread-alive-p *current-thread*) => nil + ;; A) this thread is dying or just born, so that user-code never runs with + ;; (thread-alive-p *current-thread*) => nil. + ;; The just-born case can happen with foreign threads that are unlucky + ;; enough to be elected to perform GC just as they begin executing + ;; ENTER-FOREIGN-CALLBACK. This definitely seems to happen with sb-safepoint. + ;; I'm not sure whether it can happen without sb-safepoint. ;; ;; B) interrupts are disabled somewhere up the call chain since we ;; don't want to run user code in such a case. ;; + ;; Condition (A) is tested in the C runtime at can_invoke_post_gc(). + ;; Condition (B) is tested here. ;; The long-term solution will be to keep a separate thread for ;; after-gc hooks. ;; Finalizers are in a separate thread (usually), ;; but it's not permissible to invoke CONDITION-NOTIFY from a ;; dying thread, so we still need the guard for that, but not ;; the guard for whether interupts are enabled. - (when (sb-thread:thread-alive-p sb-thread:*current-thread*) - (let ((threadp #+sb-thread (%instancep sb-impl::*finalizer-thread*))) - (when threadp - ;; It's OK to frob a condition variable regardless of - ;; *allow-with-interrupts*, and probably OK to start a thread. - ;; For consistency with the previous behavior, we delay finalization - ;; if there is no finalizer thread and interrupts are disabled. - ;; That's my excuse anyway, not having looked more in-depth. - (run-pending-finalizers)) - (when *allow-with-interrupts* - (sb-thread::without-thread-waiting-for () - (with-interrupts - (unless threadp - (run-pending-finalizers)) - (call-hooks "after-GC" *after-gc-hooks* :on-error :warn))))))) + + ;; Here's one reason that MAX_INTERRUPTS is as high as it is. + ;; If the thread that performed GC runs post-GC hooks which cons enough to + ;; cause another GC while in the hooks, then as soon as interrupts are allowed + ;; again, a GC can be invoked "recursively" - while there is a maybe_gc() on + ;; the C call stack. It's not even true that _this_ thread had to cons a ton - + ;; any thread could have, causing this thread to hit the GC trigger which sets the + ;; P-A interrupted bit which causes the interrupt instruction at the end of a + ;; pseudo-atomic sequence to take a signal hit. So with interrupts eanbled, + ;; we get back into the GC, which calls post-GC, which might cons ... + ;; See the example at the bottom of src/code/final for a clear picture. + ;; Logically, the finalizer existence test belongs in src/code/final, + ;; but the flaw in that is we're not going to call that code until unmasking + ;; interrupts, which is precisely the thing we need to NOT do if already + ;; in post-GC code of any kind (be it finalizer or other). + (when (and *allow-with-interrupts* + (or (and (sb-impl::hash-table-culled-values + (sb-impl::finalizer-id-map sb-impl::**finalizer-store**)) + (not sb-impl::*in-a-finalizer*)) + *after-gc-hooks*)) + (sb-thread::without-thread-waiting-for () + (with-interrupts + (run-pending-finalizers) + (call-hooks "after-GC" *after-gc-hooks* :on-error :warn))))) ;;; This is the user-advertised garbage collection function. (defun gc (&key (full nil) (gen 0) &allow-other-keys) diff -Nru sbcl-2.0.6/src/code/globals.lisp sbcl-2.1.1/src/code/globals.lisp --- sbcl-2.0.6/src/code/globals.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/globals.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -19,7 +19,7 @@ ;;; to running into any errors, or else you've got twice the trouble. ;;; ;;; There are other thread-locals which are used by C code, and those are all -;;; defined in !PER-THREAD-C-INTERFACE-SYMBOLS. Those other symbols must have +;;; defined in PER-THREAD-C-INTERFACE-SYMBOLS. Those other symbols must have ;;; initial values of either a fixnum or a static symbol (typically T or NIL). ;;; ;;; In contrast, DEFINE-THREAD-LOCAL allows more-or-less an arbitrary form, @@ -73,7 +73,7 @@ (find (car (ensure-list x)) (sb-vm:primitive-object-slots thread-struct) :key #'sb-vm:slot-special)) - sb-vm::!per-thread-c-interface-symbols))) + sb-vm::per-thread-c-interface-symbols))) (tls-slot (+ n-fixed (length (cdr list))))) (nconc list (list (list symbol initform))) (setf (info :variable :wired-tls symbol) (ash tls-slot sb-vm:word-shift)) @@ -84,7 +84,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**) @@ -95,7 +95,6 @@ *posix-argv*)) ;;; This constant is assigned by Genesis and never read by Lisp code. ;;; (To prove that it isn't used, it's not a toplevel form) -#+linkage-table (let () (defconstant sb-vm::+required-foreign-symbols+ (symbol-value 'sb-vm::+required-foreign-symbols+))) diff -Nru sbcl-2.0.6/src/code/host-alieneval.lisp sbcl-2.1.1/src/code/host-alieneval.lisp --- sbcl-2.0.6/src/code/host-alieneval.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/host-alieneval.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1182 +0,0 @@ -;;;; the part of the Alien implementation which is needed at -;;;; cross-compilation 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-ALIEN") - -(/show0 "host-alieneval.lisp 15") - -;;;; utility functions - -(defun align-offset (offset alignment) - (let ((extra (rem offset alignment))) - (if (zerop extra) offset (+ offset (- alignment extra))))) - -(defun guess-alignment (bits) - (cond ((null bits) nil) - #-(or (and x86 (not win32)) (and ppc darwin)) ((> bits 32) 64) - ((> bits 16) 32) - ((> bits 8) 16) - ((> bits 1) 8) - (t 1))) - -;;;; ALIEN-TYPE-INFO stuff - -;;; We define a keyword "BOA" constructor so that we can reference the -;;; slot names in init forms. -(defmacro define-alien-type-class ((name &key include include-args) &rest slots) - (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE"))) - (multiple-value-bind (include include-defstruct overrides) - (etypecase include - (null - (values nil 'alien-type nil)) - (symbol - (values - include - (alien-type-class-defstruct-name - (alien-type-class-or-lose include)) - nil)) - (list - (values - (car include) - (alien-type-class-defstruct-name - (alien-type-class-or-lose (car include))) - (cdr include)))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (create-alien-type-class-if-necessary ',name ',defstruct-name - ',(or include 'root))) - (setf (info :source-location :alien-type ',name) - (sb-c:source-location)) - (def!struct (,defstruct-name - (:include ,include-defstruct - (class ',name) - ,@overrides) - (:copier nil) - (:constructor - ,(symbolicate "MAKE-" defstruct-name) - (&key class bits alignment - ,@(mapcar (lambda (x) - (if (atom x) x (car x))) - slots) - ,@include-args - ;; KLUDGE - &aux (alignment (or alignment (guess-alignment bits)))))) - ,@slots))))) - -(defmacro define-alien-type-method ((class method) lambda-list &rest body) - (let ((defun-name (symbolicate class "-" method "-METHOD"))) - `(progn - (defun ,defun-name ,lambda-list - ,@body) - (setf (,(method-slot method) (alien-type-class-or-lose ',class)) - #',defun-name)))) - -;;;; type parsing and unparsing - -;;; CMU CL used COMPILER-LET to bind *AUXILIARY-TYPE-DEFINITIONS*, and -;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we -;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve -;;; a similar effect. -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - (defun auxiliary-type-definitions (env) - (multiple-value-bind (result expanded-p) - (%macroexpand '&auxiliary-type-definitions& env) - (if expanded-p - result - ;; This is like having the global symbol-macro definition be - ;; NIL, but global symbol-macros make me vaguely queasy, so - ;; I do it this way instead. - nil)))) - -;;; Parse TYPE as an alien type specifier and return the resultant -;;; ALIEN-TYPE structure. -(defun parse-alien-type (type env) - (declare (type sb-kernel:lexenv-designator env)) - (if (consp type) - (let ((translator (info :alien-type :translator (car type)))) - (unless translator - (error "unknown alien type: ~/sb-impl:print-type-specifier/" - type)) - (funcall translator type env)) - (ecase (info :alien-type :kind type) - (:primitive - (let ((translator (info :alien-type :translator type))) - (unless translator - (error "no translator for primitive alien type ~ - ~/sb-impl:print-type-specifier/" - type)) - (funcall translator (list type) env))) - (:defined - (or (info :alien-type :definition type) - (error "no definition for alien type ~/sb-impl:print-type-specifier/" - type))) - (:unknown - (error "unknown alien type: ~/sb-impl:print-type-specifier/" - type))))) - -(defun auxiliary-alien-type (kind name env) - (declare (type sb-kernel:lexenv-designator env)) - (flet ((aux-defn-matches (x) - (and (eq (first x) kind) (eq (second x) name)))) - (let ((in-auxiliaries - (or (find-if #'aux-defn-matches *new-auxiliary-types*) - (find-if #'aux-defn-matches (auxiliary-type-definitions env))))) - (if in-auxiliaries - (values (third in-auxiliaries) t) - (info :alien-type kind name))))) - -(defun (setf auxiliary-alien-type) (new-value kind name env) - (declare (type sb-kernel:lexenv-designator env)) - (flet ((aux-defn-matches (x) - (and (eq (first x) kind) (eq (second x) name)))) - (when (find-if #'aux-defn-matches *new-auxiliary-types*) - (error "attempt to multiply define ~A ~S" kind name)) - (when (find-if #'aux-defn-matches (auxiliary-type-definitions env)) - (error "attempt to shadow definition of ~A ~S" kind name))) - (push (list kind name new-value) *new-auxiliary-types*) - new-value) - -(defun verify-local-auxiliaries-okay () - (dolist (info *new-auxiliary-types*) - (destructuring-bind (kind name defn) info - (declare (ignore defn)) - (when (info :alien-type kind name) - (error "attempt to shadow definition of ~A ~S" kind name))))) - -(defun unparse-alien-type (type) - "Convert the alien-type structure TYPE back into a list specification of - the type." - (declare (type alien-type type)) - (let ((*record-types-already-unparsed* nil)) - (%unparse-alien-type type))) - -;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we -;;; need to recurse inside the binding of -;;; *RECORD-TYPES-ALREADY-UNPARSED*. -(defun %unparse-alien-type (type) - (invoke-alien-type-method :unparse type)) - -;;;; alien type defining stuff - -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - (defun %define-alien-type-translator (name translator) - (setf (info :alien-type :kind name) :primitive) - (setf (info :alien-type :translator name) translator) - (clear-info :alien-type :definition name) - name)) - -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - (defun %def-auxiliary-alien-types (types source-location) - (dolist (info types) - ;; Clear up the type we're about to define from the toplevel - ;; *new-auxiliary-types* (local scopes take care of themselves). - ;; Unless this is done we never actually get back the full type - ;; from INFO, since the *new-auxiliary-types* have precendence. - (setf *new-auxiliary-types* - (remove info *new-auxiliary-types* - :test (lambda (a b) - (and (eq (first a) (first b)) - (eq (second a) (second b)))))) - (destructuring-bind (kind name defn) info - (let ((old (info :alien-type kind name))) - (unless (or (null old) (alien-type-= old defn)) - (warn "redefining ~A ~S to be:~% ~S,~%was:~% ~S" - kind name defn old))) - (setf (info :alien-type kind name) defn - (info :source-location :alien-type name) source-location)))) - - (defun %define-alien-type (name new source-location) - (ecase (info :alien-type :kind name) - (:primitive - (error "~/sb-impl:print-type-specifier/ is a built-in alien type." - name)) - (:defined - (let ((old (info :alien-type :definition name))) - (unless (or (null old) (alien-type-= new old)) - (warn "redefining ~S to be:~% ~ - ~/sb-impl:print-type-specifier/,~%was~% ~ - ~/sb-impl:print-type-specifier/" - name - (unparse-alien-type new) - (unparse-alien-type old))))) - (:unknown)) - (setf (info :alien-type :definition name) new) - (setf (info :alien-type :kind name) :defined) - (setf (info :source-location :alien-type name) source-location) - name)) - -;;;; the root alien type - -(eval-when (:compile-toplevel :load-toplevel :execute) - (create-alien-type-class-if-necessary 'root 'alien-type nil)) - -(defmethod print-object ((type alien-type) stream) - (print-unreadable-object (type stream :type t) - (sb-impl:print-type-specifier stream (unparse-alien-type type)))) - -;;;; the SAP type - -(define-alien-type-class (system-area-pointer)) - -(define-alien-type-translator system-area-pointer () - (make-alien-system-area-pointer-type - :bits sb-vm:n-machine-word-bits)) - -(define-alien-type-method (system-area-pointer :unparse) (type) - (declare (ignore type)) - 'system-area-pointer) - -(define-alien-type-method (system-area-pointer :lisp-rep) (type) - (declare (ignore type)) - 'system-area-pointer) - -(define-alien-type-method (system-area-pointer :alien-rep) (type context) - (declare (ignore type context)) - 'system-area-pointer) - -(define-alien-type-method (system-area-pointer :naturalize-gen) (type alien) - (declare (ignore type)) - alien) - -(define-alien-type-method (system-area-pointer :deport-gen) (type object) - (declare (ignore type)) - (/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object) - object) - -(define-alien-type-method (system-area-pointer :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-sap ,sap (/ ,offset sb-vm:n-byte-bits))) - -;;;; the ALIEN-VALUE type - -(define-alien-type-class (alien-value :include system-area-pointer)) - -(define-alien-type-method (alien-value :lisp-rep) (type) - (declare (ignore type)) - nil) - -(define-alien-type-method (alien-value :naturalize-gen) (type alien) - `(%sap-alien ,alien ',type)) - -(define-alien-type-method (alien-value :deport-gen) (type value) - (declare (ignore type)) - (/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value) - `(alien-sap ,value)) - -;;; HEAP-ALIEN-INFO -- defstruct. -;;; -(defmethod print-object ((info heap-alien-info) stream) - (print-unreadable-object (info stream :type t) - (format stream "~S ~S~@[ (data)~]" - (heap-alien-info-alien-name info) - (unparse-alien-type (heap-alien-info-type info)) - (heap-alien-info-datap info)))) - -;;; The form to evaluate to produce the SAP pointing to where in the heap -;;; it is. -(defun heap-alien-info-sap-form (info) - `(foreign-symbol-sap ,(heap-alien-info-alien-name info) - ,(heap-alien-info-datap info))) - -#-sb-xc-host ; No FOREIGN-SYMBOL-SAP -(defun heap-alien-info-sap (info) - (foreign-symbol-sap (heap-alien-info-alien-name info) - (heap-alien-info-datap info))) - -;;;; Interfaces to the different methods - -(defun alien-type-= (type1 type2) - "Return T iff TYPE1 and TYPE2 describe equivalent alien types." - (or (eq type1 type2) - (and (eq (alien-type-class type1) - (alien-type-class type2)) - (invoke-alien-type-method :type= type1 type2)))) - -(defun alien-subtype-p (type1 type2) - "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the - only supported subtype relationships are is that any pointer type is a - subtype of (* t), and any array type first dimension will match - (array nil ...). Otherwise, the two types have to be - ALIEN-TYPE-=." - (or (eq type1 type2) - (invoke-alien-type-method :subtypep type1 type2))) - -(defun compute-naturalize-lambda (type) - `(lambda (alien ignore) - (declare (ignore ignore)) - ,(invoke-alien-type-method :naturalize-gen type 'alien))) - -(defun compute-deport-lambda (type) - (declare (type alien-type type)) - (/noshow "entering COMPUTE-DEPORT-LAMBDA" type) - (multiple-value-bind (form value-type) - (invoke-alien-type-method :deport-gen type 'value) - `(lambda (value ignore) - (declare (type ,(or value-type - (compute-lisp-rep-type type) - `(alien ,type)) - value) - (ignore ignore)) - ,form))) - -(defun compute-deport-alloc-lambda (type) - `(lambda (value ignore) - (declare (ignore ignore)) - ,(invoke-alien-type-method :deport-alloc-gen type 'value))) - -(defun compute-extract-lambda (type) - (let ((extract (invoke-alien-type-method :extract-gen type 'sap 'offset))) - `(lambda (sap offset ignore) - (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (ignore ignore)) - ,(if (eq (alien-type-class type) 'integer) - extract - `(naturalize ,extract ',type))))) - -(defun compute-deposit-lambda (type) - (declare (type alien-type type)) - `(lambda (value sap offset ignore) - (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (ignore ignore)) - (let ((alloc-tmp (deport-alloc value ',type))) - (maybe-with-pinned-objects (alloc-tmp) (,type) - (let ((value (deport alloc-tmp ',type))) - ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value) - ;; Note: the reason we don't just return the pre-deported value - ;; is because that would inhibit any (deport (naturalize ...)) - ;; optimizations that might have otherwise happen. Re-naturalizing - ;; the value might cause extra consing, but is flushable, so probably - ;; results in better code. - (naturalize value ',type)))))) - -(defun compute-lisp-rep-type (type) - (invoke-alien-type-method :lisp-rep type)) - -;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function -;;; return values). See the :ALIEN-REP method for INTEGER for -;;; details. -(defun compute-alien-rep-type (type &optional (context :normal)) - (invoke-alien-type-method :alien-rep type context)) - -;;;; default methods - -(defun missing-alien-operation-error (type operation) - (error "Cannot ~A aliens of type ~/sb-impl:print-type-specifier/." - operation type)) - -(define-alien-type-method (root :unparse) (type) - `( ,(type-of type))) - -(define-alien-type-method (root :type=) (type1 type2) - (declare (ignore type1 type2)) - t) - -(define-alien-type-method (root :subtypep) (type1 type2) - (alien-type-= type1 type2)) - -(define-alien-type-method (root :lisp-rep) (type) - (declare (ignore type)) - nil) - -(define-alien-type-method (root :alien-rep) (type context) - (declare (ignore type context)) - '*) - -(define-alien-type-method (root :naturalize-gen) (type alien) - (declare (ignore alien)) - (missing-alien-operation-error "represent" type)) - -(define-alien-type-method (root :deport-gen) (type object) - (declare (ignore object)) - (missing-alien-operation-error "represent" type)) - -(define-alien-type-method (root :deport-alloc-gen) (type object) - (declare (ignore type)) - object) - -(define-alien-type-method (root :deport-pin-p) (type) - (declare (ignore type)) - ;; Override this method to return T for classes which take a SAP to a - ;; GCable lisp object when deporting. - nil) - -(define-alien-type-method (root :extract-gen) (type sap offset) - (declare (ignore sap offset)) - (missing-alien-operation-error "represent" type)) - -(define-alien-type-method (root :deposit-gen) (type sap offset value) - `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value)) - -(define-alien-type-method (root :arg-tn) (type state) - (declare (ignore state)) - (missing-alien-operation-error "pass as argument to CALL-OUT" - (unparse-alien-type type))) - -(define-alien-type-method (root :result-tn) (type state) - (declare (ignore state)) - (missing-alien-operation-error "return from CALL-OUT" - (unparse-alien-type type))) - -;;;; the INTEGER type - -(define-alien-type-class (integer) - (signed t :type (member t nil))) - -(define-alien-type-translator signed (&optional (bits sb-vm:n-word-bits)) - (make-alien-integer-type :bits bits)) - -(define-alien-type-translator integer (&optional (bits sb-vm:n-word-bits)) - (make-alien-integer-type :bits bits)) - -(define-alien-type-translator unsigned (&optional (bits sb-vm:n-word-bits)) - (make-alien-integer-type :bits bits :signed nil)) - -(define-alien-type-method (integer :unparse) (type) - (list (if (alien-integer-type-signed type) 'signed 'unsigned) - (alien-integer-type-bits type))) - -(define-alien-type-method (integer :type=) (type1 type2) - (and (eq (alien-integer-type-signed type1) - (alien-integer-type-signed type2)) - (= (alien-integer-type-bits type1) - (alien-integer-type-bits type2)))) - -(define-alien-type-method (integer :lisp-rep) (type) - (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) - (alien-integer-type-bits type))) - -(define-alien-type-method (integer :alien-rep) (type context) - ;; When returning integer values that are narrower than a machine - ;; register from a function, some platforms leave the higher bits of - ;; 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). - (ecase context - ((:normal #-(or alpha x86 x86-64) :result) - (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) - (alien-integer-type-bits type))) - #+(or alpha x86 x86-64) - (:result - (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) - (max (alien-integer-type-bits type) - sb-vm:n-machine-word-bits))))) - -;;; As per the comment in the :ALIEN-REP method above, this is defined -;;; elsewhere for alpha and x86oids. -#-(or alpha x86 x86-64) -(define-alien-type-method (integer :naturalize-gen) (type alien) - (declare (ignore type)) - alien) - -(define-alien-type-method (integer :deport-gen) (type value) - (declare (ignore type)) - value) - -(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))))) - (if ref-fun - `(,ref-fun ,sap (/ ,offset sb-vm:n-byte-bits)) - (error "cannot extract ~W-bit integers" - (alien-integer-type-bits type))))) - -;;;; the BOOLEAN type - -(define-alien-type-class (boolean :include integer :include-args (signed))) - -;;; FIXME: Check to make sure that we aren't attaching user-readable -;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance. -(define-alien-type-translator boolean (&optional (bits sb-vm:n-word-bits)) - (make-alien-boolean-type :bits bits :signed nil)) - -(define-alien-type-method (boolean :unparse) (type) - `(boolean ,(alien-boolean-type-bits type))) - -(define-alien-type-method (boolean :lisp-rep) (type) - (declare (ignore type)) - `(member t nil)) - -(define-alien-type-method (boolean :naturalize-gen) (type alien) - (let ((bits (alien-boolean-type-bits type))) - (if (= bits sb-vm:n-word-bits) - `(not (zerop ,alien)) - `(logtest ,alien ,(ldb (byte bits 0) -1))))) - -(define-alien-type-method (boolean :deport-gen) (type value) - (declare (ignore type)) - `(if ,value 1 0)) - -;;;; the ENUM type - -(define-alien-type-class (enum :include (integer (bits 32)) - :include-args (signed)) - name ; name of this enum (if any) - from ; alist from symbols to integers - to ; alist or vector from integers to symbols - kind ; kind of from mapping, :VECTOR or :ALIST - offset) ; offset to add to value for :VECTOR from mapping - -(define-alien-type-translator enum (&whole - type name - &rest mappings - &environment env) - (cond (mappings - (let ((result (parse-enum name mappings))) - (when name - (multiple-value-bind (old old-p) - (auxiliary-alien-type :enum name env) - (when old-p - (unless (alien-type-= result old) - (cerror "Continue, clobbering the old definition" - "Incompatible alien enum type definition: ~S" name) - (setf (alien-enum-type-from old) (alien-enum-type-from result) - (alien-enum-type-to old) (alien-enum-type-to result) - (alien-enum-type-kind old) (alien-enum-type-kind result) - (alien-enum-type-offset old) (alien-enum-type-offset result) - (alien-enum-type-signed old) (alien-enum-type-signed result))) - (setf result old)) - (unless old-p - (setf (auxiliary-alien-type :enum name env) result)))) - result)) - (name - (multiple-value-bind (result found) - (auxiliary-alien-type :enum name env) - (unless found - (error "unknown enum type: ~S" name)) - result)) - (t - (error "empty enum type: ~S" type)))) - -(defun parse-enum (name elements) - (when (null elements) - (error "An enumeration must contain at least one element.")) - (let ((min nil) - (max nil) - (from-alist ()) - (prev -1)) - (declare (list from-alist)) - (dolist (el elements) - (multiple-value-bind (sym val) - (if (listp el) - (values (first el) (second el)) - (values el (1+ prev))) - (setf prev val) - (unless (symbolp sym) - (error "The enumeration element ~S is not a symbol." sym)) - (unless (integerp val) - (error "The element value ~S is not an integer." val)) - (unless (and max (> max val)) (setq max val)) - (unless (and min (< min val)) (setq min val)) - (when (rassoc val from-alist) - (style-warn "The element value ~S is used more than once." val)) - (when (assoc sym from-alist :test #'eq) - (error "The enumeration element ~S is used more than once." sym)) - (push (cons sym val) from-alist))) - (let* ((signed (minusp min)) - (min-bits (if signed - (1+ (max (integer-length min) - (integer-length max))) - (integer-length max)))) - (when (> min-bits 32) - (error "can't represent enums needing more than 32 bits")) - (setf from-alist (sort from-alist #'< :key #'cdr)) - (cond - ;; If range is at least 20% dense, use vector mapping. Crossover - ;; point solely on basis of space would be 25%. Vector mapping - ;; is always faster, so give the benefit of the doubt. - ((>= (/ (length from-alist) (1+ (- max min))) 2/10) - ;; If offset is small and ignorable, ignore it to save time. - (when (< 0 min 10) (setq min 0)) - (let ((to (make-array (1+ (- max min))))) - (dolist (el from-alist) - (setf (svref to (- (cdr el) min)) (car el))) - (make-alien-enum-type :name name :signed signed - :from from-alist :to to :kind - :vector :offset (- min)))) - (t - (make-alien-enum-type :name name :signed signed - :from from-alist - :to (mapcar (lambda (x) (cons (cdr x) (car x))) - from-alist) - :kind :alist)))))) - -(define-alien-type-method (enum :unparse) (type) - `(enum ,(alien-enum-type-name type) - ,@(let ((prev -1)) - (mapcar (lambda (mapping) - (let ((sym (car mapping)) - (value (cdr mapping))) - (prog1 - (if (= (1+ prev) value) - sym - `(,sym ,value)) - (setf prev value)))) - (alien-enum-type-from type))))) - -(define-alien-type-method (enum :type=) (type1 type2) - (and (eq (alien-enum-type-name type1) - (alien-enum-type-name type2)) - (equal (alien-enum-type-from type1) - (alien-enum-type-from type2)))) - -(define-alien-type-method (enum :lisp-rep) (type) - `(member ,@(mapcar #'car (alien-enum-type-from type)))) - -(define-alien-type-method (enum :naturalize-gen) (type alien) - (ecase (alien-enum-type-kind type) - (:vector - `(svref ',(alien-enum-type-to type) - (+ ,alien ,(alien-enum-type-offset type)))) - (:alist - `(ecase ,alien - ,@(mapcar (lambda (mapping) - `(,(car mapping) ',(cdr mapping))) - (alien-enum-type-to type)))))) - -(define-alien-type-method (enum :deport-gen) (type value) - `(ecase ,value - ,@(mapcar (lambda (mapping) - `(,(car mapping) ,(cdr mapping))) - (alien-enum-type-from type)))) - -;;;; the FLOAT types - -(define-alien-type-class (float) - (type (missing-arg) :type symbol)) - -(define-alien-type-method (float :unparse) (type) - (alien-float-type-type type)) - -(define-alien-type-method (float :lisp-rep) (type) - (alien-float-type-type type)) - -(define-alien-type-method (float :alien-rep) (type context) - (declare (ignore context)) - (alien-float-type-type type)) - -(define-alien-type-method (float :naturalize-gen) (type alien) - (declare (ignore type)) - alien) - -(define-alien-type-method (float :deport-gen) (type value) - (declare (ignore type)) - value) - -(define-alien-type-class (single-float :include (float (bits 32)) - :include-args (type))) - -(define-alien-type-translator single-float () - (make-alien-single-float-type :type 'single-float)) - -(define-alien-type-method (single-float :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-single ,sap (/ ,offset sb-vm:n-byte-bits))) - -(define-alien-type-class (double-float :include (float (bits 64)) - :include-args (type))) - -(define-alien-type-translator double-float () - (make-alien-double-float-type :type 'double-float)) - -(define-alien-type-method (double-float :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-double ,sap (/ ,offset sb-vm:n-byte-bits))) - - -;;;; the POINTER type - -(define-alien-type-class (pointer :include (alien-value (bits - sb-vm:n-machine-word-bits))) - (to nil :type (or alien-type null))) - -(define-alien-type-translator * (to &environment env) - (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env)))) - -(define-alien-type-method (pointer :unparse) (type) - (let ((to (alien-pointer-type-to type))) - `(* ,(if to - (%unparse-alien-type to) - t)))) - -(define-alien-type-method (pointer :type=) (type1 type2) - (let ((to1 (alien-pointer-type-to type1)) - (to2 (alien-pointer-type-to type2))) - (if to1 - (if to2 - (alien-type-= to1 to2) - nil) - (null to2)))) - -(define-alien-type-method (pointer :subtypep) (type1 type2) - (and (alien-pointer-type-p type2) - (let ((to1 (alien-pointer-type-to type1)) - (to2 (alien-pointer-type-to type2))) - (if to1 - (if to2 - (alien-subtype-p to1 to2) - t) - (null to2))))) - -(define-alien-type-method (pointer :deport-gen) (type value) - (/noshow "doing alien type method POINTER :DEPORT-GEN" type value) - (values - ;; FIXME: old version, highlighted a bug in xc optimization - `(etypecase ,value - (null - (int-sap 0)) - (system-area-pointer - ,value) - ((alien ,type) - (alien-sap ,value))) - ;; new version, works around bug in xc optimization - #+nil - `(etypecase ,value - (system-area-pointer - ,value) - ((alien ,type) - (alien-sap ,value)) - (null - (int-sap 0))) - `(or null system-area-pointer (alien ,type)))) - -;;;; the MEM-BLOCK type - -(define-alien-type-class (mem-block :include alien-value)) - -(define-alien-type-method (mem-block :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap+ ,sap (truncate ,offset sb-vm:n-byte-bits))) - -(define-alien-type-method (mem-block :deposit-gen) (type sap offset value) - (let ((bits (alien-mem-block-type-bits type))) - (unless bits - (error "can't deposit aliens of type ~S (unknown size)" type)) - `(sb-kernel:system-area-ub8-copy ,value 0 ,sap - (truncate ,offset sb-vm:n-byte-bits) - ',(truncate bits sb-vm:n-byte-bits)))) - -;;;; the ARRAY type - -(define-alien-type-class (array :include mem-block) - (element-type (missing-arg) :type alien-type) - (dimensions (missing-arg) :type list)) - -(define-alien-type-translator array (ele-type &rest dims &environment env) - - (when dims - (unless (typep (first dims) '(or index null)) - (error "The first dimension is not a non-negative fixnum or NIL: ~S" - (first dims))) - (let ((loser (find-if-not (lambda (x) (typep x 'index)) - (rest dims)))) - (when loser - (error "A dimension is not a non-negative fixnum: ~S" loser)))) - - (let ((parsed-ele-type (parse-alien-type ele-type env))) - (make-alien-array-type - :element-type parsed-ele-type - :dimensions dims - :alignment (alien-type-alignment parsed-ele-type) - :bits (if (and (alien-type-bits parsed-ele-type) - (every #'integerp dims)) - (* (align-offset (alien-type-bits parsed-ele-type) - (alien-type-alignment parsed-ele-type)) - (reduce #'* dims)))))) - -(define-alien-type-method (array :unparse) (type) - `(array ,(%unparse-alien-type (alien-array-type-element-type type)) - ,@(alien-array-type-dimensions type))) - -(define-alien-type-method (array :type=) (type1 type2) - (and (equal (alien-array-type-dimensions type1) - (alien-array-type-dimensions type2)) - (alien-type-= (alien-array-type-element-type type1) - (alien-array-type-element-type type2)))) - -(define-alien-type-method (array :subtypep) (type1 type2) - (and (alien-array-type-p type2) - (let ((dim1 (alien-array-type-dimensions type1)) - (dim2 (alien-array-type-dimensions type2))) - (and (= (length dim1) (length dim2)) - (or (and dim2 - (null (car dim2)) - (equal (cdr dim1) (cdr dim2))) - (equal dim1 dim2)) - (alien-subtype-p (alien-array-type-element-type type1) - (alien-array-type-element-type type2)))))) - -;;;; the RECORD type - -(def!struct (alien-record-field (:copier nil)) - (name (missing-arg) :type symbol) - (type (missing-arg) :type alien-type) - (bits nil :type (or unsigned-byte null)) - (offset 0 :type unsigned-byte)) -(defmethod print-object ((field alien-record-field) stream) - (print-unreadable-object (field stream :type t) - (format stream - "~S ~S~@[:~D~]" - (alien-record-field-type field) - (alien-record-field-name field) - (alien-record-field-bits field)))) -(!set-load-form-method alien-record-field (:xc :target)) - -(define-alien-type-class (record :include mem-block) - (kind :struct :type (member :struct :union)) - (name nil :type (or symbol null)) - (fields nil :type list)) - -(define-alien-type-translator struct (name &rest fields &environment env) - (parse-alien-record-type :struct name fields env)) - -(define-alien-type-translator union (name &rest fields &environment env) - (parse-alien-record-type :union name fields env)) - -;;; FIXME: This is really pretty horrible: we avoid creating new -;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the -;;; system already. This way forward-references sans fields get -;;; "updated" for free to contain the field info. Maybe rename -;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use -;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729 -(defun parse-alien-record-type (kind name fields env) - (declare (type sb-kernel:lexenv-designator env)) - (flet ((frob-type (type new-fields alignment bits) - (setf (alien-record-type-fields type) new-fields - (alien-record-type-alignment type) alignment - (alien-record-type-bits type) bits))) - (cond (fields - (multiple-value-bind (new-fields alignment bits) - (parse-alien-record-fields kind fields env) - (let* ((old (and name (auxiliary-alien-type kind name env))) - (old-fields (and old (alien-record-type-fields old)))) - (when (and old-fields - (notevery #'record-fields-match-p old-fields new-fields)) - (cerror "Continue, clobbering the old definition." - "Incompatible alien record type definition~%Old: ~S~%New: ~S" - (unparse-alien-type old) - `(,(unparse-alien-record-kind kind) - ,name - ,@(let ((*record-types-already-unparsed* '())) - (mapcar #'unparse-alien-record-field new-fields)))) - (frob-type old new-fields alignment bits)) - (if old-fields - old - (let ((type (or old (make-alien-record-type :name name :kind kind)))) - (when (and name (not old)) - (setf (auxiliary-alien-type kind name env) type)) - (frob-type type new-fields alignment bits) - type))))) - (name - (or (auxiliary-alien-type kind name env) - (setf (auxiliary-alien-type kind name env) - (make-alien-record-type :name name :kind kind)))) - (t - (make-alien-record-type :kind kind))))) - -;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union -;;; types. KIND is the kind we are paring the fields of, and FIELDS is the -;;; list of field specifications. -;;; -;;; Result is a list of field objects, overall alignment, and number of bits -(defun parse-alien-record-fields (kind fields env) - (declare (type list fields)) - (let ((total-bits 0) - (overall-alignment 1) - (parsed-fields nil)) - (dolist (field fields) - (destructuring-bind (var type &key alignment bits offset) field - (declare (ignore bits)) - (let* ((field-type (parse-alien-type type env)) - (bits (alien-type-bits field-type)) - (parsed-field - (make-alien-record-field :type field-type - :name var))) - (unless alignment - (setf alignment (alien-type-alignment field-type))) - (push parsed-field parsed-fields) - (when (null bits) - (error "unknown size: ~S" (unparse-alien-type field-type))) - (when (null alignment) - (error "unknown alignment: ~S" (unparse-alien-type field-type))) - (setf overall-alignment (max overall-alignment alignment)) - (ecase kind - (:struct - (let ((offset (or offset (align-offset total-bits alignment)))) - (setf (alien-record-field-offset parsed-field) offset) - (setf total-bits (+ offset bits)))) - (:union - (setf total-bits (max total-bits bits))))))) - (values (nreverse parsed-fields) - overall-alignment - (align-offset total-bits overall-alignment)))) - -(define-alien-type-method (record :unparse) (type) - `(,(unparse-alien-record-kind (alien-record-type-kind type)) - ,(alien-record-type-name type) - ,@(unless (member type *record-types-already-unparsed* :test #'eq) - (push type *record-types-already-unparsed*) - (mapcar #'unparse-alien-record-field - (alien-record-type-fields type))))) - -(defun unparse-alien-record-kind (kind) - (case kind - (:struct 'struct) - (:union 'union) - (t '???))) - -(defun unparse-alien-record-field (field) - `(,(alien-record-field-name field) - ,(%unparse-alien-type (alien-record-field-type field)) - ,@(when (alien-record-field-bits field) - (list :bits (alien-record-field-bits field))) - ,@(when (alien-record-field-offset field) - (list :offset (alien-record-field-offset field))))) - -;;; Test the record fields. Keep a hashtable table of already compared -;;; types to detect cycles. -(defun record-fields-match-p (field1 field2) - (and (eq (alien-record-field-name field1) - (alien-record-field-name field2)) - (eql (alien-record-field-bits field1) - (alien-record-field-bits field2)) - (eql (alien-record-field-offset field1) - (alien-record-field-offset field2)) - (alien-type-= (alien-record-field-type field1) - (alien-record-field-type field2)))) - -(defvar *alien-type-matches* nil - "A hashtable used to detect cycles while comparing record types.") - -(define-alien-type-method (record :type=) (type1 type2) - (and (eq (alien-record-type-name type1) - (alien-record-type-name type2)) - (eq (alien-record-type-kind type1) - (alien-record-type-kind type2)) - (eql (alien-type-bits type1) - (alien-type-bits type2)) - (eql (alien-type-alignment type1) - (alien-type-alignment type2)) - (flet ((match-fields (&optional old) - (setf (gethash type1 *alien-type-matches*) (cons type2 old)) - (every #'record-fields-match-p - (alien-record-type-fields type1) - (alien-record-type-fields type2)))) - (if *alien-type-matches* - (let ((types (gethash type1 *alien-type-matches*))) - (or (memq type2 types) (match-fields types))) - (let ((*alien-type-matches* (make-hash-table :test #'eq))) - (match-fields)))))) - -;;;; the FUNCTION and VALUES alien types - -;;; Calling-convention spec, typically one of predefined keywords. -;;; Add or remove as needed for target platform. It makes sense to -;;; support :cdecl everywhere. -;;; -;;; Null convention is supposed to be platform-specific most-universal -;;; callout convention. For x86, SBCL calls foreign functions in a way -;;; allowing them to be either stdcall or cdecl; null convention is -;;; appropriate here, as it is for specifying callbacks that could be -;;; accepted by foreign code both in cdecl and stdcall form. -(def!type calling-convention () `(or null (member :stdcall :cdecl))) - -;;; Convention could be a values type class, stored at result-type. -;;; However, it seems appropriate only for epilogue-related -;;; conventions, those not influencing incoming arg passing. -;;; -;;; As of x86's :stdcall and :cdecl, supported by now, both are -;;; epilogue-related, but future extensions (like :fastcall and -;;; miscellaneous non-x86 stuff) might affect incoming argument -;;; translation as well. - -(define-alien-type-class (fun :include mem-block) - (result-type (missing-arg) :type alien-type) - (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))) - (stub nil :type (or null function)) - (convention nil :type calling-convention)) -;;; The safe default is to assume that everything is varargs. -;;; On x86-64 we have to emit a spurious instruction because of it. -;;; So until all users fix their lambda lists to be explicit about &REST -;;; (which is never gonna happen), be backward-compatible, unless -;;; locally toggled to get rid of noise instructions if so inclined. -(defglobal *alien-fun-type-varargs-default* :unspecified) - -;;; KLUDGE: non-intrusive, backward-compatible way to allow calling -;;; convention specification for function types is unobvious. -;;; -;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list -;;; starting with a convention keyword; its second item is a real -;;; 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) - (typecase result-type - ((cons calling-convention *) - (values (second result-type) (first result-type))) - (t result-type))) - (varargs (eq (car (last arg-types)) '&rest))) - (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))))) - -(define-alien-type-method (fun :unparse) (type) - `(function ,(let ((result-type - (%unparse-alien-type (alien-fun-type-result-type type))) - (convention (alien-fun-type-convention type))) - (if convention (list convention result-type) - result-type)) - ,@(mapcar #'%unparse-alien-type - (alien-fun-type-arg-types type)) - ,@(when (alien-fun-type-varargs type) - '(&rest)))) - -(define-alien-type-method (fun :type=) (type1 type2) - (and (alien-type-= (alien-fun-type-result-type type1) - (alien-fun-type-result-type type2)) - (eq (alien-fun-type-convention type1) - (alien-fun-type-convention type2)) - (= (length (alien-fun-type-arg-types type1)) - (length (alien-fun-type-arg-types type2))) - (every #'alien-type-= - (alien-fun-type-arg-types type1) - (alien-fun-type-arg-types type2)))) - -(define-alien-type-class (values) - (values (missing-arg) :type list)) - -(define-alien-type-translator values (&rest values &environment env) - (unless *values-type-okay* - (error "cannot use values types here")) - (let ((*values-type-okay* nil)) - (make-alien-values-type - :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env)) - values)))) - -(define-alien-type-method (values :unparse) (type) - `(values ,@(mapcar #'%unparse-alien-type - (alien-values-type-values type)))) - -(define-alien-type-method (values :type=) (type1 type2) - (and (= (length (alien-values-type-values type1)) - (length (alien-values-type-values type2))) - (every #'alien-type-= - (alien-values-type-values type1) - (alien-values-type-values type2)))) - -;;;; a structure definition needed both in the target and in the -;;;; cross-compilation host - -;;; information about local aliens. The WITH-ALIEN macro builds one of -;;; these structures and LOCAL-ALIEN and friends communicate -;;; information about how that local alien is represented. -(def!struct (local-alien-info - (:copier nil) - (:constructor make-local-alien-info - (&key type force-to-memory-p - &aux (force-to-memory-p (or force-to-memory-p - (alien-array-type-p type) - (alien-record-type-p type)))))) - ;; the type of the local alien - (type (missing-arg) :type alien-type) - ;; Must this local alien be forced into memory? Using the ADDR macro - ;; on a local alien will set this. - (force-to-memory-p nil :type (member t nil))) -(!set-load-form-method local-alien-info (:xc :target)) -(defmethod print-object ((info local-alien-info) stream) - (print-unreadable-object (info stream :type t) - (format stream - "~:[~;(forced to stack) ~]~S" - (local-alien-info-force-to-memory-p info) - (unparse-alien-type (local-alien-info-type info))))) - -;;;; the ADDR macro - -(sb-xc:defmacro addr (expr &environment env) - "Return an Alien pointer to the data addressed by Expr, which must be a call - to SLOT or DEREF, or a reference to an Alien variable." - (let ((form (%macroexpand expr env))) - (or (typecase form - (cons - (case (car form) - (slot - (cons '%slot-addr (cdr form))) - (deref - (cons '%deref-addr (cdr form))) - (%heap-alien - (cons '%heap-alien-addr (cdr form))) - (local-alien - (let ((info (let ((info-arg (second form))) - (and (consp info-arg) - (eq (car info-arg) 'quote) - (second info-arg))))) - (unless (local-alien-info-p info) - (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S" - form)) - (setf (local-alien-info-force-to-memory-p info) t)) - (cons '%local-alien-addr (cdr form))))) - (symbol - (let ((kind (info :variable :kind form))) - (when (eq kind :alien) - `(%heap-alien-addr ',(info :variable :alien-info form)))))) - (error "~S is not a valid L-value." form)))) - -(push '("SB-ALIEN" define-alien-type-class define-alien-type-method) - *!removable-symbols*) - -(in-package "SB-IMPL") - -(defun extern-alien-name (name) - (handler-case (cl:coerce name 'base-string) - (error () - (error "invalid external alien name: ~S" name)))) - -(declaim (ftype (sfunction (string hash-table) (or integer null)) - find-foreign-symbol-in-table)) -(defun find-foreign-symbol-in-table (name table) - (let ((extern (extern-alien-name name))) - (values - (or (gethash extern table) - (gethash (concatenate 'base-string "ldso_stub__" extern) table))))) - -;;; *STATIC-FOREIGN-SYMBOLS* are static as opposed to "dynamic" (not -;;; as opposed to C's "extern"). The table contains symbols known at -;;; the time that the program was built, but not symbols defined in -;;; object files which have been loaded dynamically since then. -#-linkage-table -(progn - (declaim (type hash-table *static-foreign-symbols*)) - (defvar *static-foreign-symbols* (make-hash-table :test 'equal))) - -(/show0 "host-alieneval.lisp end of file") diff -Nru sbcl-2.0.6/src/code/hppa-vm.lisp sbcl-2.1.1/src/code/hppa-vm.lisp --- sbcl-2.0.6/src/code/hppa-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/hppa-vm.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ -(in-package "SB-VM") - -#-sb-xc-host -(defun machine-type () - "Returns a string describing the type of the local machine." - "HPPA") - -;;;; FIXUP-CODE-OBJECT -(defconstant-eqx +fixup-kinds+ - #(:absolute :load :load11u :load-short :hi :branch) - #'equalp) -(!with-bigvec-or-sap -(defun fixup-code-object (code offset value kind flavor) - (declare (ignore flavor)) - (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) - (error "Unaligned instruction? offset=#x~X." offset)) - (let* ((sap (code-instructions code)) - (inst (sap-ref-32 sap offset))) - (setf (sap-ref-32 sap offset) - (ecase kind - (:absolute - value) - (:load - (logior (mask-field (byte 18 14) value) - (if (< value 0) - (1+ (ash (ldb (byte 13 0) value) 1)) - (ash (ldb (byte 13 0) value) 1)))) - (:load11u - (logior (if (< value 0) - (1+ (ash (ldb (byte 10 0) value) 1)) - (ash (ldb (byte 11 0) value) 1)) - (mask-field (byte 18 14) inst))) - (:load-short - (let ((low-bits (ldb (byte 11 0) value))) - (aver (<= 0 low-bits (1- (ash 1 4)))) - (logior (ash (dpb (ldb (byte 4 0) value) - (byte 4 1) - (ldb (byte 1 4) value)) 17) - (logand inst #xffe0ffff)))) - (:hi - (logior (ash (ldb (byte 5 13) value) 16) - (ash (ldb (byte 2 18) value) 14) - (ash (ldb (byte 2 11) value) 12) - (ash (ldb (byte 11 20) value) 1) - (ldb (byte 1 31) value) - (logand inst #xffe00000))) - (:branch - (let ((bits (ldb (byte 9 2) value))) - (aver (zerop (ldb (byte 2 0) value))) - (logior (ash bits 3) - (mask-field (byte 1 1) inst) - (mask-field (byte 3 13) inst) - (mask-field (byte 11 21) inst))))))) - nil)) - -#-sb-xc-host (progn - -;;; For now. -(defun context-floating-point-modes (context) - (declare (ignore context)) - (warn "stub CONTEXT-FLOATING-POINT-MODES") - 0) - -;;;; Internal-error-arguments. - -;;; INTERNAL-ERROR-ARGUMENTS -- interface. -;;; -;;; Given the sigcontext, extract the internal error arguments from the -;;; instruction stream. -;;; -(defun internal-error-args (context) - (declare (type (alien (* os-context-t)) context)) - (let* ((pc (context-pc context)) - (trap-number (logand (sap-ref-8 pc 3) #x1f))) - (declare (type system-area-pointer pc)) - (sb-kernel::decode-internal-error-args (sap+ pc 5) trap-number - (sap-ref-8 pc 4)))) -) ; end PROGN diff -Nru sbcl-2.0.6/src/code/hpux-os.lisp sbcl-2.1.1/src/code/hpux-os.lisp --- sbcl-2.0.6/src/code/hpux-os.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/hpux-os.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -;;;; OS interface functions for SBCL under HPUX - -;;;; 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-SYS") - -;;; Check that target machine features are set up consistently with -;;; this file. -#-hpux (error "missing :HPUX feature") - -(defun software-type () - "Return a string describing the supporting software." - (values "HPUX")) - -;;; Return system time, user time and number of page faults. -(defun get-system-info () - (multiple-value-bind - (err? utime stime maxrss ixrss idrss isrss minflt majflt) - (sb-unix:unix-getrusage sb-unix:rusage_self) - (declare (ignore maxrss ixrss idrss isrss minflt)) - (unless err? ; FIXME: nonmnemonic (reversed) name for ERR? - (error "Unix system call getrusage failed: ~A." (strerror utime))) - (values utime stime majflt))) - -;;; support for CL:MACHINE-VERSION defined OAOO elsewhere -(defun get-machine-version () - nil) diff -Nru sbcl-2.0.6/src/code/icf.lisp sbcl-2.1.1/src/code/icf.lisp --- sbcl-2.0.6/src/code/icf.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/icf.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -89,7 +89,7 @@ (do-referenced-object (object rewrite) (simple-vector :extend - (when (and (logtest (get-header-data object) vector-addr-hashing-subtype) + (when (and (logtest (get-header-data object) vector-addr-hashing-flag) touchedp) (setf (svref object 1) 1))) (code-component @@ -385,6 +385,7 @@ (name (and entry (sb-kernel:%fun-name entry)))) (and (symbolp name) + (symbol-package name) (eq (nth-value 1 (find-symbol (symbol-name name) (symbol-package name))) :external)))) diff -Nru sbcl-2.0.6/src/code/immobile-space.lisp sbcl-2.1.1/src/code/immobile-space.lisp --- sbcl-2.0.6/src/code/immobile-space.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/immobile-space.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -151,7 +151,7 @@ ;;; current jump address, which means we need to fix them *all* before anyone ;;; else gets an opportunity to change the fdefn-fun of this same fdefn again. (defun sb-vm::remove-static-links (fdefn) - (sb-thread::with-system-mutex (sb-c::*static-linker-lock*) + (sb-int:with-system-mutex (sb-c::*static-linker-lock*) (let ((fun-entry (sb-vm::fdefn-raw-addr fdefn)) (fdefn-entry (sb-vm::fdefn-entry-address fdefn))) (flet ((code-statically-links-fdefn-p (code) diff -Nru sbcl-2.0.6/src/code/inspect.lisp sbcl-2.1.1/src/code/inspect.lisp --- sbcl-2.0.6/src/code/inspect.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/inspect.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -178,6 +178,11 @@ t (inspected-structure-elements object))) +(defmethod inspected-parts ((object pathname)) + (values (format nil "The object is a ~S.~%" (type-of object)) + t + (inspected-structure-elements object))) + (defun inspected-standard-object-elements (object) (let ((reversed-elements nil) (class-slots (sb-pcl::class-slots (class-of object)))) diff -Nru sbcl-2.0.6/src/code/interr.lisp sbcl-2.1.1/src/code/interr.lisp --- sbcl-2.0.6/src/code/interr.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/interr.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -326,6 +326,9 @@ (invalid-array-error object) (error (if (and (%instancep object) (layout-invalid (%instance-layout 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. 'layout-invalid 'type-error) :datum object @@ -338,11 +341,6 @@ type)) :context (sb-di:error-context)))) -(deferr layout-invalid-error (object layout) - (error 'layout-invalid - :datum object - :expected-type (layout-classoid layout))) - (deferr odd-key-args-error () (%program-error "odd number of &KEY arguments")) diff -Nru sbcl-2.0.6/src/code/irrat.lisp sbcl-2.1.1/src/code/irrat.lisp --- sbcl-2.0.6/src/code/irrat.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/irrat.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -76,6 +76,7 @@ #-x86 (def-math-rtn "atan" 1) #-x86 (def-math-rtn "atan2" 2) +;;; See src/runtime/wrap.c for the definitions of the "sb_"-prefixed things. (def-math-rtn "acos" 1 #+win32 t) (def-math-rtn "asin" 1 #+win32 t) (def-math-rtn "cosh" 1 #+win32 t) @@ -119,6 +120,12 @@ (if (evenp power) 1 base)) + ((eql base 0) + (cond ((= power 0) 1) + ((> power 0) 0) + (t (error 'division-by-zero + :operands (list 0 power) + :operation 'expt)))) ((ratiop base) (let ((den (denominator base)) (num (numerator base))) @@ -253,7 +260,7 @@ (when (< x-hi 0) (cond ((and (= x-ihi #x3ff00000) (zerop yisint)) ;; (-1)**non-int - (let ((y*pi (* y sb-xc:pi))) + (let ((y*pi (* y pi))) (declare (double-float y*pi)) (return-from real-expt (complex @@ -276,7 +283,7 @@ (2 ; even (coerce pow rtype)) (t ; non-integer - (let ((y*pi (* y sb-xc:pi))) + (let ((y*pi (* y pi))) (declare (double-float y*pi)) (complex (coerce (* pow (%cos y*pi)) @@ -375,11 +382,11 @@ (number-dispatch ((number number)) (((foreach fixnum bignum)) (if (minusp number) - (complex (log (- number)) (coerce sb-xc:pi 'single-float)) + (complex (log (- number)) (coerce pi 'single-float)) (coerce (/ (log2 number) (log (exp $1.0d0) $2.0d0)) 'single-float))) ((ratio) (if (minusp number) - (complex (log (- number)) (coerce sb-xc:pi 'single-float)) + (complex (log (- number)) (coerce pi 'single-float)) (let ((numerator (numerator number)) (denominator (denominator number))) (if (= (integer-length numerator) @@ -394,7 +401,7 @@ ;; Since this doesn't seem to be an implementation issue ;; I (pw) take the Kahan result. (if (= (float-sign-bit number) 1) ; MINUSP - (complex (log (- number)) (coerce sb-xc:pi '(dispatch-type number))) + (complex (log (- number)) (coerce pi '(dispatch-type number))) (coerce (%log (coerce number 'double-float)) '(dispatch-type number)))) ((complex) @@ -449,15 +456,15 @@ (number-dispatch ((number number)) ((rational) (if (minusp number) - (coerce sb-xc:pi 'single-float) + (coerce pi 'single-float) $0.0f0)) ((single-float) (if (minusp (float-sign number)) - (coerce sb-xc:pi 'single-float) + (coerce pi 'single-float) $0.0f0)) ((double-float) (if (minusp (float-sign number)) - (coerce sb-xc:pi 'double-float) + (coerce pi 'double-float) $0.0d0)) (handle-complex (atan (imagpart number) (realpart number))))) @@ -548,8 +555,8 @@ (if (zerop y) (if (= (float-sign-bit x) 0) ; PLUSP y - (float-sign y sb-xc:pi)) - (float-sign y (sb-xc:/ sb-xc:pi 2))) + (float-sign y pi)) + (float-sign y (sb-xc:/ pi 2))) (%atan2 y x)))) (number-dispatch ((y real) (x real)) ((double-float @@ -909,9 +916,9 @@ (declare (muffle-conditions compiler-note)) (declare (type (or rational complex) z)) (let* (;; constants - (theta (sb-xc:/ (sb-xc:sqrt sb-xc:most-positive-double-float) $4.0d0)) - (rho (sb-xc:/ $4.0d0 (sb-xc:sqrt sb-xc:most-positive-double-float))) - (half-pi (sb-xc:/ sb-xc:pi $2.0d0)) + (theta (sb-xc:/ (sb-xc:sqrt most-positive-double-float) $4.0d0)) + (rho (sb-xc:/ $4.0d0 (sb-xc:sqrt most-positive-double-float))) + (half-pi (sb-xc:/ pi $2.0d0)) (rp (float (realpart z) $1.0d0)) (beta (float-sign rp $1.0d0)) (x (* beta rp)) diff -Nru sbcl-2.0.6/src/code/last-file.lisp sbcl-2.1.1/src/code/last-file.lisp --- sbcl-2.0.6/src/code/last-file.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/last-file.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -29,7 +29,7 @@ (defun check-compile-time-sxhashes () (loop for (object . hash) across sb-c::*sxhash-crosscheck* unless (= (sxhash object) hash) - do (error "SB-XC:SXHASH computed wrong answer for ~S. Got ~x should be ~x" + do (error "SXHASH computed wrong answer for ~S. Got ~x should be ~x" object hash (sxhash object)))) (check-compile-time-sxhashes) diff -Nru sbcl-2.0.6/src/code/late-cas.lisp sbcl-2.1.1/src/code/late-cas.lisp --- sbcl-2.0.6/src/code/late-cas.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/late-cas.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,144 +0,0 @@ -(in-package "SB-IMPL") - -(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) - -;;; Out-of-line definitions for various primitive cas functions. -(macrolet ((def (name lambda-list ref &optional set) - #+compare-and-swap-vops - (declare (ignore ref set)) - `(defun ,name (,@lambda-list old new) - #+compare-and-swap-vops - (,name ,@lambda-list old new) - #-compare-and-swap-vops - (progn - #+sb-thread - ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?") - #-sb-thread - (let ((current (,ref ,@lambda-list))) - ;; Shouldn't this be inside a WITHOUT-INTERRUPTS ? - (when (eq current old) - ,(if set - `(,set ,@lambda-list new) - `(setf (,ref ,@lambda-list) new))) - current))))) - (def %compare-and-swap-car (cons) car) - (def %compare-and-swap-cdr (cons) cdr) - (def %instance-cas (instance index) %instance-ref %instance-set) - #+(or x86-64 x86 riscv) - (def %raw-instance-cas/word (instance index) - %raw-instance-ref/word - %raw-instance-set/word) - #+riscv - (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)) - -;; Atomic increment/decrement ops on tagged storage cells (as contrasted with -;; specialized arrays and raw structure slots) are defined in terms of CAS. - -;; This code would be more concise if workable versions -;; of +-MODFX, --MODFX were defined generically. -(macrolet ((modular (fun a b) - #+(or x86 x86-64) - `(,(package-symbolicate "SB-VM" fun "-MODFX") ,a ,b) - #-(or x86 x86-64) - ;; algorithm of https://graphics.stanford.edu/~seander/bithacks - `(let ((res (logand (,fun ,a ,b) - (ash sb-ext:most-positive-word - (- sb-vm:n-fixnum-tag-bits)))) - (m (ash 1 (1- sb-vm:n-fixnum-bits)))) - (- (logxor res m) m)))) - - ;; Atomically frob the CAR or CDR of a cons, or a symbol-value. - ;; The latter will be a global value because the ATOMIC-INCF/DECF - ;; macros work on a symbol only if it is known global. - (macrolet ((def-frob (name op type slot) - `(defun ,name (place delta) - (declare (type ,type place) (type fixnum delta)) - (loop (let ((old (the fixnum (,slot place)))) - (when (eq (cas (,slot place) old - (modular ,op old delta)) old) - (return old))))))) - (def-frob %atomic-inc-symbol-global-value + symbol symbol-value) - (def-frob %atomic-dec-symbol-global-value - symbol symbol-value) - (def-frob %atomic-inc-car + cons car) - (def-frob %atomic-dec-car - cons car) - (def-frob %atomic-inc-cdr + cons cdr) - (def-frob %atomic-dec-cdr - cons cdr))) - -;;; ATOMIC-MUMBLE functions are not used when self-building. - -(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.0.6/src/code/late-extensions.lisp sbcl-2.1.1/src/code/late-extensions.lisp --- sbcl-2.0.6/src/code/late-extensions.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/late-extensions.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -58,7 +58,7 @@ "Read the content of STREAM into a buffer in order to count lines and columns." (unless (and old-position position - (< position sb-xc:array-dimension-limit)) + (< position array-dimension-limit)) (return-from read-content)) (let ((content (make-string position :element-type (stream-element-type stream)))) diff -Nru sbcl-2.0.6/src/code/late-format.lisp sbcl-2.1.1/src/code/late-format.lisp --- sbcl-2.0.6/src/code/late-format.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/late-format.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1075,9 +1075,9 @@ ;;;; format directives and support functions for justification (defconstant-eqx !illegal-inside-justification - (mapcar (lambda (x) (directive-bits (parse-directive x 0 nil))) - '("~:>" "~:@>" - "~:T" "~:@T")) + '#.(mapcar (lambda (x) (directive-bits (parse-directive x 0 nil))) + '("~:>" "~:@>" + "~:T" "~:@T")) #'equal) ;;; Reject ~W, ~_, ~I and certain other specific values of modifier+character. @@ -1436,7 +1436,7 @@ ((not (directive-colonp close)) (values 0 0 directives)) ((directive-atsignp justification) - (values 0 sb-xc:call-arguments-limit directives)) + (values 0 call-arguments-limit directives)) ;; FIXME: here we could assert that the ;; corresponding argument was a list. (t (values 1 1 remaining)))))) @@ -1472,7 +1472,7 @@ ;; a format control (either a function or a string). (if (directive-atsignp iteration) (values (if (zerop posn) 1 0) - sb-xc:call-arguments-limit + call-arguments-limit remaining) ;; FIXME: the argument corresponding to this ;; directive must be a list. @@ -1483,7 +1483,7 @@ (loop (let ((directive (pop directives))) (when (null directive) - (return (values min (min max sb-xc:call-arguments-limit)))) + (return (values min (min max call-arguments-limit)))) (when (format-directive-p directive) (incf-both (count :arg (directive-params directive) :key #'cdr)) @@ -1508,7 +1508,7 @@ (cond ((directive-atsignp directive) (incf min) - (setq max sb-xc:call-arguments-limit)) + (setq max call-arguments-limit)) (t (incf-both 2)))) (t (throw 'give-up-format-string-walk nil)))))))))) (catch 'give-up-format-string-walk diff -Nru sbcl-2.0.6/src/code/late-type.lisp sbcl-2.1.1/src/code/late-type.lisp --- sbcl-2.0.6/src/code/late-type.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/late-type.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -305,9 +305,6 @@ ;;; 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 -;;; A flag to prevent TYPE-OF calls by user applications from returning -;;; (NOT x). TYPE-SPECIFIER usually allows it to preserve information. -(defparameter *unparse-allow-negation* t) ; initialized by genesis (define-type-method (function :negate) (type) (make-negation-type type)) @@ -581,11 +578,11 @@ (etypecase type (named-type (ecase (named-type-name type) - ((t *) sb-xc:call-arguments-limit) + ((t *) call-arguments-limit) ((nil) 0))) (values-type (if (values-type-rest type) - sb-xc:call-arguments-limit + call-arguments-limit (+ (length (values-type-optional type)) (length (values-type-required type))))))) @@ -603,7 +600,7 @@ ;;; 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. -#-sb-fluid (declaim (freeze-type values-type)) +(declaim (freeze-type values-type)) ; (inline single-value-type)) (defun single-value-type (type) (declare (type ctype type)) @@ -975,7 +972,7 @@ ;;; 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 sb-xc:subtypep (type1 type2 &optional environment) +(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. @@ -1412,6 +1409,34 @@ ;; 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*) @@ -1432,17 +1457,13 @@ ((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 - ((classoid-non-instance-p type1) - (values nil t)) - ((classoid-inherits-from type1 'function) - (values nil t)) - ((eq type1 (find-classoid 'function)) - (values nil t)) - ((or (structure-classoid-p type1) - (condition-classoid-p type1)) - (values t t)) - (t (values nil nil)))) + (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)) @@ -1479,22 +1500,21 @@ (cond ((eq type2 *extended-sequence-type*) (typecase type1 - ((or structure-classoid condition-classoid) *empty-type*) + ((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 - ((or structure-classoid condition-classoid) type1) + ((satisfies classoid-definitely-instancep) type1) (classoid (when (or (classoid-non-instance-p type1) - (eq type1 (find-classoid 'function)) - (classoid-inherits-from type1 'function)) + (classoid-is-or-inherits type1 'function)) *empty-type*)) (t (empty-unless-hairy type1)))) ((eq type2 *funcallable-instance-type*) (typecase type1 - ((or structure-classoid condition-classoid) *empty-type*) + ((satisfies classoid-definitely-instancep) *empty-type*) (classoid (cond ((classoid-non-instance-p type1) *empty-type*) @@ -1625,6 +1645,43 @@ (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) @@ -1638,7 +1695,10 @@ (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 (%make-hairy-type whole)))) + (t (let ((type (info :function :predicate-for predicate-name))) + (if type + (specifier-type type) + (%make-hairy-type whole)))))) ;;;; negation types @@ -1885,8 +1945,8 @@ `(unsigned-byte ,high-length)) (t `(mod ,(1+ high))))) - ((and (= low sb-xc:most-negative-fixnum) - (= high sb-xc:most-positive-fixnum)) + ((and (= low most-negative-fixnum) + (= high most-positive-fixnum)) 'fixnum) ((and (= low (lognot high)) (= high-count high-length) @@ -2276,8 +2336,8 @@ (if (listp bound) (list coerced) coerced)))) (defun inner-coerce-real-bound (bound type upperp) - (let ((nl sb-xc:most-negative-long-float) - (pl sb-xc:most-positive-long-float)) + (let ((nl most-negative-long-float) + (pl most-positive-long-float)) (let ((nbound (if (listp bound) (car bound) bound))) (ecase type (rational @@ -2297,10 +2357,10 @@ (make-bound (coerce nbound 'long-float))))))))) (defun inner-coerce-float-bound (bound type upperp) - (let ((nd sb-xc:most-negative-double-float) - (pd sb-xc:most-positive-double-float) - (ns sb-xc:most-negative-single-float) - (ps sb-xc:most-positive-single-float)) + (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 @@ -2421,11 +2481,11 @@ (let ((res (cond ((and format (subtypep format 'double-float)) - (if (sb-xc:<= sb-xc:most-negative-double-float cx sb-xc:most-positive-double-float) + (if (sb-xc:<= most-negative-double-float cx most-positive-double-float) (coerce cx format) nil)) (t - (if (sb-xc:<= sb-xc:most-negative-single-float cx sb-xc:most-positive-single-float) + (if (sb-xc:<= most-negative-single-float cx most-positive-single-float) ;; FIXME: bug #389 (coerce cx (or format 'single-float)) nil))))) @@ -2600,8 +2660,6 @@ dtype stype))) (complexp (array-type-complexp type))) - (if (and (eq complexp t) (not *unparse-allow-negation*)) - (setq complexp :maybe)) (cond ((eq dims '*) (if (eq eltype '*) (ecase complexp @@ -2897,17 +2955,17 @@ (integer (when (minusp dims) (error "Arrays can't have a negative number of dimensions: ~S" dims)) - (when (>= dims sb-xc:array-rank-limit) + (when (>= dims array-rank-limit) (error "array type with too many dimensions: ~S" dims)) (make-list dims :initial-element '*)) (list - (when (>= (length dims) sb-xc:array-rank-limit) + (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 sb-xc:array-dimension-limit)) + (< dim array-dimension-limit)) (error "bad dimension in array type: ~S" dim)))) dims) (t @@ -3314,8 +3372,9 @@ ((type= type (specifier-type 'bignum)) 'bignum) ((type= type (specifier-type 'simple-string)) 'simple-string) ((type= type (specifier-type 'string)) 'string) - ((unparse-string-type type 'simple-string)) - ((unparse-string-type type '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 @@ -3623,19 +3682,19 @@ ;;;; CHARACTER-SET types (def-type-translator character-set - (&optional (pairs `((0 . ,(1- sb-xc:char-code-limit))))) + (&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- sb-xc:char-code-limit))) + (= (cdar pairs) (1- char-code-limit))) (make-negation-type type) (let ((not-character (make-negation-type (make-character-set-type - `((0 . ,(1- sb-xc:char-code-limit))))))) + `((0 . ,(1- char-code-limit))))))) (type-union not-character (make-character-set-type @@ -3646,9 +3705,9 @@ (high1 (cdar tail) (cdar tail)) (low2 (caadr tail) (caadr tail))) ((null (cdr tail)) - (when (< (cdar tail) (1- sb-xc:char-code-limit)) + (when (< (cdar tail) (1- char-code-limit)) (push (cons (1+ (cdar tail)) - (1- sb-xc:char-code-limit)) + (1- char-code-limit)) not-pairs)) (nreverse not-pairs)) (push (cons (1+ high1) (1- low2)) not-pairs))))))))) @@ -3954,13 +4013,21 @@ ;;; 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) - (if (complexp x) - (let ((imag (imagpart x))) - (values :complex (sb-xc:min num imag) (sb-xc:max num imag))) - (values :real num num)) + (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)) diff -Nru sbcl-2.0.6/src/code/list.lisp sbcl-2.1.1/src/code/list.lisp --- sbcl-2.0.6/src/code/list.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/list.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -175,7 +175,7 @@ (endp object)) (defun list-length (list) - "Return the length of the given List, or Nil if the List is circular." + "Return the length of LIST, or NIL if LIST is circular." (do ((n 0 (+ n 2)) (y list (cddr y)) (z list (cdr z))) @@ -343,7 +343,7 @@ (lastn-macro unsigned-byte))))))) (define-compiler-macro last (&whole form list &optional (n 1) &environment env) - (if (sb-xc:constantp n env) + (if (constantp n env) (case (constant-form-value n env) (0 `(%last0 ,list)) (1 `(%last1 ,list)) @@ -351,7 +351,7 @@ form)) (defun list (&rest args) - "Return constructs and returns a list of its arguments." + "Construct and return a list containing the objects ARGS." args) ;;; LIST* is done the same as LIST, except that the last cons is made @@ -380,7 +380,7 @@ result))))) (defun make-list (size &key initial-element) - "Constructs a list with size elements each set to value" + "Construct and return a list with SIZE elements each set to INITIAL-ELEMENT." (declare (explicit-check)) (%make-list size initial-element)) ;;; This entry point is to be preferred, irrespective of @@ -393,7 +393,7 @@ (declare (type index count)))) (defun append (&rest lists) - "Construct a new list by concatenating the list arguments" + "Construct and return a list by concatenating LISTS." (let* ((result (list nil)) (tail result) (index 0) diff -Nru sbcl-2.0.6/src/code/load.lisp sbcl-2.1.1/src/code/load.lisp --- sbcl-2.0.6/src/code/load.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/load.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -43,8 +43,6 @@ ;;;; utilities for reading from fasl files -#-sb-fluid (declaim (inline read-byte)) - ;;; This expands into code to read an N-byte unsigned integer using ;;; FAST-READ-BYTE. (defmacro fast-read-u-integer (n) @@ -99,13 +97,7 @@ `(with-fast-read-byte ((unsigned-byte 8) ,fasl-input-stream) (fast-read-u-integer ,n)))) -;; FIXME: on x86-64, these functions exceed 600, 900, and 1200 bytes of code -;; respectively. Either don't inline them, or make a "really" fast inline case -;; that punts if inapplicable. e.g. if the fast-read-byte buffer will not be -;; refilled, then SAP-REF-WORD could work to read 8 bytes. -;; But this would only be feasible on machines that are little-endian -;; and that allow unaligned reads. (like x86) -(declaim (inline read-byte-arg read-word-arg)) +(declaim (inline read-byte-arg)) (defun read-byte-arg (stream) (declare (optimize (speed 0))) (read-arg 1 stream)) @@ -333,7 +325,12 @@ (result (make-string length))) (read-string-as-bytes stream result) (push result results) - result))) + result)) + (unsuffix (s) + (if (and (> (length s) 4) + (string= s "-WIP" :start1 (- (length s) 4))) + (subseq s 0 (- (length s) 4)) + s))) ;; Read and validate implementation and version. (let ((implementation (string-from-stream)) (expected-implementation +backend-fasl-file-implementation+)) @@ -349,9 +346,9 @@ (sbcl-version (if (<= fasl-version 76) "1.0.11.18" (string-from-stream))) - (expected-version (sb-xc:lisp-implementation-version))) + (expected-version (lisp-implementation-version))) (push fasl-version results) - (unless (string= expected-version sbcl-version) + (unless (string= (unsuffix expected-version) (unsuffix sbcl-version)) (restart-case (error 'invalid-fasl-version :stream stream @@ -498,7 +495,6 @@ (nuke-fop-vector (%fasl-input-stack fasl-input)))) t) -(declaim (notinline read-byte)) ; Why is it even *declaimed* inline above? ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?) diff -Nru sbcl-2.0.6/src/code/loop.lisp sbcl-2.1.1/src/code/loop.lisp --- sbcl-2.0.6/src/code/loop.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/loop.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -177,7 +177,7 @@ (declaim (sb-ext:freeze-type loop-minimax)) (defconstant-eqx +loop-minimax-type-infinities-alist+ - '((fixnum sb-xc:most-positive-fixnum sb-xc:most-negative-fixnum) + '((fixnum most-positive-fixnum most-negative-fixnum) (single-float sb-ext:single-float-positive-infinity sb-ext:single-float-negative-infinity) (double-float sb-ext:double-float-positive-infinity sb-ext:double-float-negative-infinity)) #'equal) @@ -185,7 +185,7 @@ (defun make-loop-minimax (answer-variable type) (let ((infinity-data (cdr (assoc type +loop-minimax-type-infinities-alist+ - :test #'sb-xc:subtypep)))) + :test #'subtypep)))) (make-loop-minimax-internal :answer-variable answer-variable :type type @@ -521,7 +521,7 @@ ;;;; code analysis stuff (defun loop-constant-fold-if-possible (form &optional expected-type) - (let* ((constantp (sb-xc:constantp form)) + (let* ((constantp (constantp form)) (value (and constantp (constant-form-value form)))) (when (and constantp expected-type) (unless (sb-xc:typep value expected-type) @@ -576,7 +576,7 @@ &optional (default-type required-type)) (if (null specified-type) default-type - (multiple-value-bind (a b) (sb-xc:subtypep specified-type required-type) + (multiple-value-bind (a b) (subtypep specified-type required-type) (cond ((not b) (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." specified-type required-type)) @@ -905,6 +905,12 @@ (check-var-name name) (loop-declare-var name dtype :step-var-p step-var-p :initialization initialization) + ;; IGNORABLEize every variable because neither binding nor assignment constitutes + ;; a "use". Unfortunately there is no syntax for declaring what to ignore in LOOP. + ;; The idiom is to use NIL as a variable, but sometimes users don't, because they + ;; want variables names as information within a destructuring operation, + ;; e.g. (for (this . that-not-used) in stuff do (frob this)) + (push `(ignorable ,name) (declarations loop)) ;; We use ASSOC on this list to check for duplications (above), ;; so don't optimize out this list: (push (list name (or initialization (loop-typed-init dtype step-var-p))) @@ -958,7 +964,7 @@ desetq &aux (loop *loop*)) (cond ((or (null name) (null dtype) (eq dtype t)) nil) ((symbolp name) - (unless (or (sb-xc:subtypep t dtype) + (unless (or (subtypep t dtype) (and (eq (sb-xc:symbol-package name) *cl-package*) (eq :special (info :variable :kind name)))) (let ((dtype `(type ,(if initialization @@ -1399,15 +1405,17 @@ (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) - (loop-make-var var list data-type)) + (loop-make-var var + ;; Don't want to assert the type, as ENDP will do that + `(the* (list :use-annotations t :source-form ,list) ,list) + data-type)) (t (loop-make-var (setq listvar (gensym)) list 't) (loop-make-var var nil data-type))) (let ((list-step (loop-list-step listvar))) (let* ((first-endtest - ;; mysterious comment from original CMU CL sources: - ;; the following should use `atom' instead of `endp', - ;; per [bug2428] + ;; the following should use `atom' instead of `endp', + ;; per 6.1.2.1.3 `(atom ,listvar)) (other-endtest first-endtest)) (when (and constantp (listp list-value)) @@ -1428,7 +1436,10 @@ (loop-constant-fold-if-possible val) (let ((listvar (gensym "LOOP-LIST-"))) (loop-make-var var nil data-type) - (loop-make-var listvar list t) + (loop-make-var listvar + ;; Don't want to assert the type, as ENDP will do that + `(the* (list :use-annotations t :source-form ,list) ,list) + t) (let ((list-step (loop-list-step listvar))) (let* ((first-endtest `(endp ,listvar)) (other-endtest first-endtest) diff -Nru sbcl-2.0.6/src/code/macroexpand.lisp sbcl-2.1.1/src/code/macroexpand.lisp --- sbcl-2.0.6/src/code/macroexpand.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/macroexpand.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -13,7 +13,7 @@ ;;;; syntactic environment access -(defun sb-xc:special-operator-p (symbol) +(defun special-operator-p (symbol) "If the symbol globally names a special form, return T, otherwise NIL." (declare (symbol symbol)) (eq (info :function :kind symbol) :special-form)) @@ -105,7 +105,7 @@ (values form nil)))) ((and (listp form) (let ((fn (car form))) - (and (symbolp fn) (sb-xc:macro-function fn env)))) + (and (symbolp fn) (macro-function fn env)))) (perform-expansion it)) (t (values form nil))))) @@ -117,7 +117,7 @@ environment." (labels ((frob (form expanded) (multiple-value-bind (new-form newly-expanded-p) - (sb-xc:macroexpand-1 form env) + (macroexpand-1 form env) (if newly-expanded-p (frob new-form t) (values new-form expanded))))) @@ -127,8 +127,8 @@ (defun %macroexpand-1 (form &optional env) (if (or (atom form) (let ((op (car form))) - (not (and (symbolp op) (sb-xc:special-operator-p op))))) - (sb-xc:macroexpand-1 form env) + (not (and (symbolp op) (special-operator-p op))))) + (macroexpand-1 form env) (values form nil))) ;;; Like MACROEXPAND, but takes care not to expand special forms. diff -Nru sbcl-2.0.6/src/code/macros.lisp sbcl-2.1.1/src/code/macros.lisp --- sbcl-2.0.6/src/code/macros.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/macros.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -10,6 +10,18 @@ ;;;; files for more information. (in-package "SB-IMPL") + + +;;;; Destructing-bind + +(sb-xc:defmacro destructuring-bind (lambda-list expression &body body + &environment env) + (declare (ignore env)) ; could be policy-sensitive (but isn't) + "Bind the variables in LAMBDA-LIST to the corresponding values in the +tree structure resulting from the evaluation of EXPRESSION." + `(binding* ,(sb-c::expand-ds-bind lambda-list expression t nil) + ,@body)) + ;;;; DEFUN @@ -346,7 +358,7 @@ (prog-expansion-from-let varlist body-decls 'let*))) (sb-xc:defmacro prog1 (result &body body) - (let ((n-result (gensym))) + (let ((n-result (sb-xc:gensym))) `(let ((,n-result ,result)) (progn ,@body @@ -386,7 +398,7 @@ ;; Preserve non-toplevelness of the form! (let ((car (car forms))) (if nested car `(the t ,car)))) (t - (let ((n-result (gensym))) + (let ((n-result (sb-xc:gensym))) `(let ((,n-result ,(first forms))) (if ,n-result ,n-result @@ -440,7 +452,7 @@ ;; form will take longer than can be described as adequate, as the ;; optional dispatch mechanism for the M-V-B gets increasingly ;; hairy. - (let ((val (and (sb-xc:constantp n env) (constant-form-value n env)))) + (let ((val (and (constantp n env) (constant-form-value n env)))) (if (and (integerp val) (<= 0 val (or #+(or x86-64 arm64 riscv) ;; better DEFAULT-UNKNOWN-VALUES 1000 10))) ; Arbitrary limit. @@ -491,13 +503,13 @@ (let* ((func (if (listp test-form) (car test-form))) (new-test (if (and (typep func '(and symbol (not null))) - (not (sb-xc:macro-function func env)) - (not (sb-xc:special-operator-p func)) + (not (macro-function func env)) + (not (special-operator-p func)) (proper-list-p (cdr test-form))) ;; TEST-FORM is a function call. We do not attempt this ;; if TEST-FORM is a macro invocation or special form. `(,func ,@(mapcar (lambda (place) - (if (sb-xc:constantp place env) + (if (constantp place env) place (with-unique-names (temp) (bindings `(,temp ,place)) @@ -574,7 +586,7 @@ (setf ,place (check-type-error ',place ,place ',type ,@(and type-string `(,type-string))))) - (let ((value (gensym))) + (let ((value (sb-xc:gensym))) `(do ((,value ,place ,place)) ((typep ,value ',type)) (setf ,place @@ -636,7 +648,7 @@ (sb-c::warn-if-compiler-macro-dependency-problem name) ;; FIXME: warn about incompatible lambda list with ;; respect to parent function? - (setf (sb-xc:compiler-macro-function name) definition) + (setf (compiler-macro-function name) definition) name)) ;;;; CASE, TYPECASE, and friends @@ -824,8 +836,8 @@ (flet ((try-one-byte () (let ((best-answer nil) ;; "best" means smallest - (best-max-bin-count sb-xc:most-positive-fixnum) ; sentinel value - (best-average sb-xc:most-positive-fixnum)) + (best-max-bin-count most-positive-fixnum) ; sentinel value + (best-average most-positive-fixnum)) (loop named try for nbits from smallest-nbits to largest-nbits do (let ((bin-counts (make-array (ash 1 nbits) :initial-element 0))) @@ -834,8 +846,8 @@ finally (return-from try (values best-max-bin-count best-answer))))) (try-two-bytes () (let ((best-answer nil) - (best-max-bin-count sb-xc:most-positive-fixnum) - (best-average sb-xc:most-positive-fixnum)) + (best-max-bin-count most-positive-fixnum) + (best-average most-positive-fixnum)) (loop named try for nbits from smallest-nbits to largest-nbits do (let ((bin-counts (make-array (ash 1 nbits) :initial-element 0))) @@ -1467,9 +1479,9 @@ (setq clauses (if default (cons default new-clauses) new-clauses) keys (new-keys) implement-as 'case)) - #+(vop-named sb-c:multiway-branch-if-eq) - ((expand-struct-typecase keyform keyform-value normal-clauses keys - default errorp) + ((and (sb-c::vop-existsp :named sb-c:multiway-branch-if-eq) + (expand-struct-typecase keyform keyform-value normal-clauses keys + default errorp)) (return-from case-body-aux it)))))) ;; Efficiently expanding CASE over symbols depends on CASE over integers being @@ -1555,7 +1567,7 @@ (sb-xc:defmacro with-open-file ((stream filespec &rest options) &body body) (multiple-value-bind (forms decls) (parse-body body nil) - (let ((abortp (gensym))) + (let ((abortp (sb-xc:gensym))) `(let ((,stream (open ,filespec ,@options)) (,abortp t)) ,@decls @@ -1586,7 +1598,7 @@ (with-current-source-form (varlist) (mapcar (lambda (var) (with-current-source-form (var) - (or (cond ((symbolp var) var) + (or (cond ((symbolp var) (list var)) ((listp var) (unless (symbolp (first var)) (error "~S step variable is not a symbol: ~S" @@ -1603,6 +1615,7 @@ `(block ,block (,bind ,inits ,@decls + (declare (ignorable ,@(mapcar #'car inits))) (tagbody (go ,label-2) ,label-1 @@ -1658,12 +1671,12 @@ ;; since we don't want to use IGNORABLE on what might be a special ;; var. (binding* (((forms decls) (parse-body body nil)) - (n-list (gensym "N-LIST")) - (start (gensym "START")) + (n-list (sb-xc:gensym "LIST")) + (start (sb-xc:gensym "START")) ((clist members clist-ok) (with-current-source-form (list) (cond - ((sb-xc:constantp list env) + ((constantp list env) (binding* ((value (constant-form-value list env)) ((all dot) (list-members value :max-length 20))) (when (eql dot t) @@ -1674,19 +1687,26 @@ (values value nil nil) (values value all t)))) ((and (consp list) (eq 'list (car list)) - (every (lambda (arg) (sb-xc:constantp arg env)) (cdr list))) + (every (lambda (arg) (constantp arg env)) (cdr list))) (let ((values (mapcar (lambda (arg) (constant-form-value arg env)) (cdr list)))) (values values values t))) (t (values nil nil nil)))))) `(block nil - (let ((,n-list ,(if clist-ok (list 'quote clist) list))) + (let ((,n-list ,(if clist-ok + (list 'quote clist) + ;; Don't want to use a cast because + ;; the type will actually be checked by ENDP first. + ;; But it doesn't detect the mismatch because the SETF + ;; mixes in T with the initial type. + `(the* (list :use-annotations t :source-form ,list) ,list)))) (tagbody ,start (unless (endp ,n-list) (let ((,var ,(if clist-ok `(truly-the (member ,@members) (car ,n-list)) `(car ,n-list)))) + (declare (ignorable ,var)) ,@decls (setq ,n-list (cdr ,n-list)) (tagbody ,@forms)) @@ -1721,9 +1741,6 @@ `(sb-c::%proclaim ',spec (sb-c:source-location))) specs))) -;; Avoid unknown return values in emitted code for PRINT-UNREADABLE-OBJECT -(sb-xc:proclaim '(ftype (sfunction (t t t &optional t) null) - %print-unreadable-object)) (sb-xc:defmacro print-unreadable-object ((object stream &key type identity) &body body) "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally @@ -1787,7 +1804,8 @@ (let ((ctype (sb-c::careful-specifier-type (constant-form-value element-type)))) (and ctype - (csubtypep ctype (specifier-type 'character))))) + (csubtypep ctype (specifier-type 'character)) + (neq ctype *empty-type*)))) ;; Using MAKE-ARRAY avoids a style-warning if et is 'STANDARD-CHAR: ;; "The default initial element #\Nul is not a STANDARD-CHAR." 'make-array ; hooray! it's known be a valid string type diff -Nru sbcl-2.0.6/src/code/maphash.lisp sbcl-2.1.1/src/code/maphash.lisp --- sbcl-2.0.6/src/code/maphash.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/maphash.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -22,7 +22,7 @@ ;;; like INDEX, but only up to half the maximum. Used by hash-table ;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))). -(deftype index/2 () `(integer 0 (,(floor sb-xc:array-dimension-limit 2)))) +(deftype index/2 () `(integer 0 (,(floor array-dimension-limit 2)))) ;;; The high water mark is an element of the pairs vector, and not ;;; a slot in the table. @@ -97,25 +97,32 @@ hash-tables. If the table may be mutated by another thread during iteration, use eg. SB-EXT:WITH-LOCKED-HASH-TABLE to protect the WITH-HASH-TABLE-ITERATOR for." - (let ((function (gensymify* name "-FUN"))) - `(let ((,function - (let* ((kv-vector (hash-table-pairs ,hash-table)) - (limit (1+ (* 2 (kv-vector-high-water-mark kv-vector)))) - (index 3)) - (declare (fixnum index)) - (flet ((,name () - (loop - (when (> index limit) (return nil)) - (let ((i index)) - (incf (truly-the index index) 2) - (let ((key (data-vector-ref kv-vector (1- i))) - (value (data-vector-ref kv-vector i))) - (unless (or (empty-ht-slot-p key) - (empty-ht-slot-p value)) - (return (values t key value)))))))) - #',name)))) - (macrolet ((,name () '(funcall ,function))) - ,@body)))) + ;; If within the BODY code the stepping function is used exactly once, then + ;; it gets let-converted and so it should make no difference whether it returns + ;; one or more than one value (it would never need RETURN-MULTIPLE). + ;; However if the iterator is not let-converted then it is best to return + ;; a fixed number of values on success or failure. + (let ((kvv (make-symbol "KVV")) + (lim (make-symbol "LIMIT")) + (ind (make-symbol "INDEX")) + (step (make-symbol "THUNK"))) + `(let* ((,kvv (hash-table-pairs ,hash-table)) + (,lim (1+ (* 2 (kv-vector-high-water-mark ,kvv)))) + (,ind 3)) + (declare (fixnum ,ind)) + (dx-flet ((,step () + (loop + (when (> ,ind ,lim) (return (values t nil nil))) + (let ((i ,ind)) + (incf (truly-the index ,ind) 2) + (let ((k (data-vector-ref ,kvv (1- i))) + (v (data-vector-ref ,kvv i))) + (unless (or (empty-ht-slot-p k) (empty-ht-slot-p v)) + (return (values nil k v)))))))) + (macrolet ((,name () + '(multiple-value-bind (endp k v) (,step) + (unless endp (values t k v))))) + ,@body))))) (define-compiler-macro make-hash-table (&whole form &rest keywords) (let ((kind diff -Nru sbcl-2.0.6/src/code/mips-vm.lisp sbcl-2.1.1/src/code/mips-vm.lisp --- sbcl-2.0.6/src/code/mips-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/mips-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -2,39 +2,9 @@ ;;; (in-package "SB-VM") - -#-sb-xc-host (defun machine-type () "Returns a string describing the type of the local machine." "MIPS") - -;;;; FIXUP-CODE-OBJECT - -(defconstant-eqx +fixup-kinds+ #(:absolute :jmp :lui :addi) #'equalp) -(!with-bigvec-or-sap -(defun fixup-code-object (code offset value kind flavor) - (declare (type index offset)) - (declare (ignore flavor)) - (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) - (error "Unaligned instruction? offset=#x~X." offset)) - (let ((sap (code-instructions code))) - (ecase kind - (:absolute - (setf (sap-ref-32 sap offset) value)) - (:jump - (aver (zerop (ash value -28))) - (setf (ldb (byte 26 0) (sap-ref-32 sap offset)) - (ash value -2))) - (:lui - (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) - (ash (1+ (ash value -15)) -1))) - (:addi - (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) - (ldb (byte 16 0) value))))) - nil)) - - -#-sb-xc-host (progn (define-alien-routine ("os_context_bd_cause" context-bd-cause-int) unsigned-int @@ -86,4 +56,3 @@ (trap-number (ldb (byte 8 6) (sap-ref-32 pc offset)))) (declare (type system-area-pointer pc)) (sb-kernel::decode-internal-error-args (sap+ pc (+ offset 4)) trap-number))) -) ; end PROGN diff -Nru sbcl-2.0.6/src/code/misc.lisp sbcl-2.1.1/src/code/misc.lisp --- sbcl-2.0.6/src/code/misc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/misc.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -12,11 +12,11 @@ (in-package "SB-IMPL") -(defun sb-xc:lisp-implementation-type () +(defun lisp-implementation-type () "SBCL") -(defun sb-xc:lisp-implementation-version () +(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-xc:lisp-implementation-version)) + #-sb-xc-host #.(lisp-implementation-version)) diff -Nru sbcl-2.0.6/src/code/number-dispatch.lisp sbcl-2.1.1/src/code/number-dispatch.lisp --- sbcl-2.0.6/src/code/number-dispatch.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/code/number-dispatch.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,227 @@ +;;;; This file contains the the NUMBER-DISPATCH macro + +;;;; 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") + +(eval-when (:compile-toplevel :load-toplevel :execute) + +;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT +;;; with the type dispatches and bodies. Result is a tree built of +;;; alists representing the dispatching off each arg (in order). The +;;; leaf is the body to be executed in that case. + (defun parse-number-dispatch (vars result types var-types body) + ;; Shouldn't be necessary, but avoids a warning in certain lisps that + ;; seem to like to warn about self-calls in :COMPILE-TOPLEVEL situation. + (named-let parse-number-dispatch ((vars vars) (result result) (types types) + (var-types var-types) (body body)) + (cond ((null vars) + (unless (null types) (error "More types than vars.")) + (when (cdr result) + (error "Duplicate case: ~S." body)) + (setf (cdr result) + (sublis var-types body :test #'equal))) + ((null types) + (error "More vars than types.")) + (t + (flet ((frob (var type) + (parse-number-dispatch + (rest vars) + (or (assoc type (cdr result) :test #'equal) + (car (setf (cdr result) + (acons type nil (cdr result))))) + (rest types) + (acons `(dispatch-type ,var) type var-types) + body))) + (let ((type (first types)) + (var (first vars))) + (if (and (consp type) (eq (first type) 'foreach)) + (dolist (type (rest type)) + (frob var type)) + (frob var type)))))))) + +;;; our guess for the preferred order in which to do type tests +;;; (cheaper and/or more probable first.) + (defconstant-eqx +type-test-ordering+ + '(fixnum single-float double-float integer #+long-float long-float + sb-vm:signed-word word bignum + complex ratio) + #'equal) + +;;; Should TYPE1 be tested before TYPE2? + (defun type-test-order (type1 type2) + (let ((o1 (position type1 +type-test-ordering+)) + (o2 (position type2 +type-test-ordering+))) + (cond ((not o1) nil) + ((not o2) t) + (t + (< o1 o2))))) + +;;; Return an ETYPECASE form that does the type dispatch, ordering the +;;; cases for efficiency. +;;; Check for some simple to detect problematic cases where the caller +;;; used types that are not disjoint and where this may lead to +;;; unexpected behaviour of the generated form, for example making +;;; a clause unreachable, and throw an error if such a case is found. +;;; An example: +;;; (number-dispatch ((var1 integer) (var2 float)) +;;; ((fixnum single-float) a) +;;; ((integer float) b)) +;;; Even though the types are not reordered here, the generated form, +;;; basically +;;; (etypecase var1 +;;; (fixnum (etypecase var2 +;;; (single-float a))) +;;; (integer (etypecase var2 +;;; (float b)))) +;;; would fail at runtime if given var1 fixnum and var2 double-float, +;;; even though the second clause matches this signature. To catch +;;; this earlier than runtime we throw an error already here. + (defun generate-number-dispatch (vars error-tags cases) + ;; Shouldn't be necessary, but avoids a warning in certain lisps that + ;; seem to like to warn about self-calls in :COMPILE-TOPLEVEL situation. + (named-let generate-number-dispatch ((vars vars) (error-tags error-tags) (cases cases)) + (if vars + (let ((var (first vars)) + (cases (sort cases #'type-test-order :key #'car))) + (flet ((error-if-sub-or-supertype (type1 type2) + (when (or (subtypep type1 type2) + (subtypep type2 type1)) + (error "Types not disjoint: ~S ~S." type1 type2))) + (error-if-supertype (type1 type2) + (when (subtypep type2 type1) + (error "Type ~S ordered before subtype ~S." + type1 type2))) + (test-type-pairs (fun) + ;; Apply FUN to all (ordered) pairs of types from the + ;; cases. + (mapl (lambda (cases) + (when (cdr cases) + (let ((type1 (caar cases))) + (dolist (case (cdr cases)) + (funcall fun type1 (car case)))))) + cases))) + ;; For the last variable throw an error if a type is followed + ;; by a subtype, for all other variables additionally if a + ;; type is followed by a supertype. + (test-type-pairs (if (cdr vars) + #'error-if-sub-or-supertype + #'error-if-supertype))) + `((typecase ,var + ,@(mapcar (lambda (case) + `(,(first case) + ,@(generate-number-dispatch (rest vars) + (rest error-tags) + (cdr case)))) + cases) + (t (go ,(first error-tags)))))) + cases))) + + ) ; EVAL-WHEN + +;;; This is a vaguely case-like macro that does number cross-product +;;; dispatches. The Vars are the variables we are dispatching off of. +;;; The Type paired with each Var is used in the error message when no +;;; case matches. Each case specifies a Type for each var, and is +;;; executed when that signature holds. A type may be a list +;;; (FOREACH Each-Type*), causing that case to be repeatedly +;;; instantiated for every Each-Type. In the body of each case, any +;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the +;;; type of that var in that instance of the case. +;;; +;;; [Though it says "_any_ list", it's still an example of how not to perform +;;; incomplete lexical analysis within a macro imho. Let's say that the body +;;; code passes a lambda that happens name its args DISPATCH-TYPE and X. +;;; What happens? +;;; (macroexpand-1 '(number-dispatch ((x number)) +;;; ((float) (f x (lambda (dispatch-type x) (wat)))))) +;;; -> [stuff elided] +;;; (TYPECASE X (FLOAT (F X (LAMBDA FLOAT (WAT)))) +;;; +;;; So the NUMBER-DISPATCH macro indeed substituted for *any* appearance +;;; just like it says. I wonder if we could define DISPATCH-TYPE as macrolet +;;; that expands to the type for the current branch, so that it _must_ +;;; be in a for-evaluation position; but maybe I'm missing something?] +;;; +;;; As an alternate to a case spec, there may be a form whose CAR is a +;;; symbol. In this case, we apply the CAR of the form to the CDR and +;;; treat the result of the call as a list of cases. This process is +;;; not applied recursively. +;;; +;;; Be careful when using non-disjoint types in different cases for the +;;; same variable. Some uses will behave as intended, others not, as the +;;; variables are dispatched off sequentially and clauses are reordered +;;; for efficiency. Some, but not all, problematic cases are detected +;;; and lead to a compile time error; see GENERATE-NUMBER-DISPATCH above +;;; for an example. +(defmacro number-dispatch (var-specs &body cases) + (let ((res (list nil)) + (vars (mapcar #'car var-specs)) + (block (gensym))) + (dolist (case cases) + (if (symbolp (first case)) + (let ((cases (apply (symbol-function (first case)) (rest case)))) + (dolist (case cases) + (parse-number-dispatch vars res (first case) nil (rest case)))) + (parse-number-dispatch vars res (first case) nil (rest case)))) + + (collect ((errors) + (error-tags)) + (dolist (spec var-specs) + (let ((var (first spec)) + (type (second spec)) + (tag (gensym))) + (error-tags tag) + (errors tag) + (errors + (sb-c::internal-type-error-call var type)))) + + `(block ,block + (tagbody + (return-from ,block + ,@(generate-number-dispatch vars (error-tags) + (cdr res))) + ,@(errors)))))) + +;;;; binary operation dispatching utilities + +(eval-when (:compile-toplevel :execute) + +;;; Return NUMBER-DISPATCH forms for rational X float. +(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio))) + `(((single-float single-float) (,op ,x ,y)) + (((foreach ,@rat-types) + (foreach single-float double-float #+long-float long-float)) + (,op (coerce ,x '(dispatch-type ,y)) ,y)) + (((foreach single-float double-float #+long-float long-float) + (foreach ,@rat-types)) + (,op ,x (coerce ,y '(dispatch-type ,x)))) + #+long-float + (((foreach single-float double-float long-float) long-float) + (,op (coerce ,x 'long-float) ,y)) + #+long-float + ((long-float (foreach single-float double-float)) + (,op ,x (coerce ,y 'long-float))) + (((foreach single-float double-float) double-float) + (,op (coerce ,x 'double-float) ,y)) + ((double-float single-float) + (,op ,x (coerce ,y 'double-float))))) + +;;; Return NUMBER-DISPATCH forms for bignum X fixnum. +(defun bignum-cross-fixnum (fix-op big-op) + `(((fixnum fixnum) (,fix-op x y)) + ((fixnum bignum) + (,big-op (make-small-bignum x) y)) + ((bignum fixnum) + (,big-op x (make-small-bignum y))) + ((bignum bignum) + (,big-op x y)))) + +) ; EVAL-WHEN diff -Nru sbcl-2.0.6/src/code/numbers.lisp sbcl-2.1.1/src/code/numbers.lisp --- sbcl-2.0.6/src/code/numbers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/numbers.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -10,230 +10,13 @@ ;;;; files for more information. (in-package "SB-KERNEL") - -;;;; the NUMBER-DISPATCH macro - -(eval-when (:compile-toplevel :load-toplevel :execute) - -;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT -;;; with the type dispatches and bodies. Result is a tree built of -;;; alists representing the dispatching off each arg (in order). The -;;; leaf is the body to be executed in that case. -(defun parse-number-dispatch (vars result types var-types body) - ;; Shouldn't be necessary, but avoids a warning in certain lisps that - ;; seem to like to warn about self-calls in :COMPILE-TOPLEVEL situation. - (named-let parse-number-dispatch ((vars vars) (result result) (types types) - (var-types var-types) (body body)) - (cond ((null vars) - (unless (null types) (error "More types than vars.")) - (when (cdr result) - (error "Duplicate case: ~S." body)) - (setf (cdr result) - (sublis var-types body :test #'equal))) - ((null types) - (error "More vars than types.")) - (t - (flet ((frob (var type) - (parse-number-dispatch - (rest vars) - (or (assoc type (cdr result) :test #'equal) - (car (setf (cdr result) - (acons type nil (cdr result))))) - (rest types) - (acons `(dispatch-type ,var) type var-types) - body))) - (let ((type (first types)) - (var (first vars))) - (if (and (consp type) (eq (first type) 'foreach)) - (dolist (type (rest type)) - (frob var type)) - (frob var type)))))))) - -;;; our guess for the preferred order in which to do type tests -;;; (cheaper and/or more probable first.) -(defconstant-eqx +type-test-ordering+ - '(fixnum single-float double-float integer #+long-float long-float - sb-vm:signed-word word bignum - complex ratio) - #'equal) - -;;; Should TYPE1 be tested before TYPE2? -(defun type-test-order (type1 type2) - (let ((o1 (position type1 +type-test-ordering+)) - (o2 (position type2 +type-test-ordering+))) - (cond ((not o1) nil) - ((not o2) t) - (t - (< o1 o2))))) - -;;; Return an ETYPECASE form that does the type dispatch, ordering the -;;; cases for efficiency. -;;; Check for some simple to detect problematic cases where the caller -;;; used types that are not disjoint and where this may lead to -;;; unexpected behaviour of the generated form, for example making -;;; a clause unreachable, and throw an error if such a case is found. -;;; An example: -;;; (number-dispatch ((var1 integer) (var2 float)) -;;; ((fixnum single-float) a) -;;; ((integer float) b)) -;;; Even though the types are not reordered here, the generated form, -;;; basically -;;; (etypecase var1 -;;; (fixnum (etypecase var2 -;;; (single-float a))) -;;; (integer (etypecase var2 -;;; (float b)))) -;;; would fail at runtime if given var1 fixnum and var2 double-float, -;;; even though the second clause matches this signature. To catch -;;; this earlier than runtime we throw an error already here. -(defun generate-number-dispatch (vars error-tags cases) - ;; Shouldn't be necessary, but avoids a warning in certain lisps that - ;; seem to like to warn about self-calls in :COMPILE-TOPLEVEL situation. - (named-let generate-number-dispatch ((vars vars) (error-tags error-tags) (cases cases)) - (if vars - (let ((var (first vars)) - (cases (sort cases #'type-test-order :key #'car))) - (flet ((error-if-sub-or-supertype (type1 type2) - (when (or (sb-xc:subtypep type1 type2) - (sb-xc:subtypep type2 type1)) - (error "Types not disjoint: ~S ~S." type1 type2))) - (error-if-supertype (type1 type2) - (when (sb-xc:subtypep type2 type1) - (error "Type ~S ordered before subtype ~S." - type1 type2))) - (test-type-pairs (fun) - ;; Apply FUN to all (ordered) pairs of types from the - ;; cases. - (mapl (lambda (cases) - (when (cdr cases) - (let ((type1 (caar cases))) - (dolist (case (cdr cases)) - (funcall fun type1 (car case)))))) - cases))) - ;; For the last variable throw an error if a type is followed - ;; by a subtype, for all other variables additionally if a - ;; type is followed by a supertype. - (test-type-pairs (if (cdr vars) - #'error-if-sub-or-supertype - #'error-if-supertype))) - `((typecase ,var - ,@(mapcar (lambda (case) - `(,(first case) - ,@(generate-number-dispatch (rest vars) - (rest error-tags) - (cdr case)))) - cases) - (t (go ,(first error-tags)))))) - cases))) - -) ; EVAL-WHEN - -;;; This is a vaguely case-like macro that does number cross-product -;;; dispatches. The Vars are the variables we are dispatching off of. -;;; The Type paired with each Var is used in the error message when no -;;; case matches. Each case specifies a Type for each var, and is -;;; executed when that signature holds. A type may be a list -;;; (FOREACH Each-Type*), causing that case to be repeatedly -;;; instantiated for every Each-Type. In the body of each case, any -;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the -;;; type of that var in that instance of the case. -;;; -;;; [Though it says "_any_ list", it's still an example of how not to perform -;;; incomplete lexical analysis within a macro imho. Let's say that the body -;;; code passes a lambda that happens name its args DISPATCH-TYPE and X. -;;; What happens? -;;; (macroexpand-1 '(number-dispatch ((x number)) -;;; ((float) (f x (lambda (dispatch-type x) (wat)))))) -;;; -> [stuff elided] -;;; (TYPECASE X (FLOAT (F X (LAMBDA FLOAT (WAT)))) -;;; -;;; So the NUMBER-DISPATCH macro indeed substituted for *any* appearance -;;; just like it says. I wonder if we could define DISPATCH-TYPE as macrolet -;;; that expands to the type for the current branch, so that it _must_ -;;; be in a for-evaluation position; but maybe I'm missing something?] -;;; -;;; As an alternate to a case spec, there may be a form whose CAR is a -;;; symbol. In this case, we apply the CAR of the form to the CDR and -;;; treat the result of the call as a list of cases. This process is -;;; not applied recursively. -;;; -;;; Be careful when using non-disjoint types in different cases for the -;;; same variable. Some uses will behave as intended, others not, as the -;;; variables are dispatched off sequentially and clauses are reordered -;;; for efficiency. Some, but not all, problematic cases are detected -;;; and lead to a compile time error; see GENERATE-NUMBER-DISPATCH above -;;; for an example. -(defmacro number-dispatch (var-specs &body cases) - (let ((res (list nil)) - (vars (mapcar #'car var-specs)) - (block (gensym))) - (dolist (case cases) - (if (symbolp (first case)) - (let ((cases (apply (symbol-function (first case)) (rest case)))) - (dolist (case cases) - (parse-number-dispatch vars res (first case) nil (rest case)))) - (parse-number-dispatch vars res (first case) nil (rest case)))) - - (collect ((errors) - (error-tags)) - (dolist (spec var-specs) - (let ((var (first spec)) - (type (second spec)) - (tag (gensym))) - (error-tags tag) - (errors tag) - (errors - (sb-c::internal-type-error-call var type)))) - - `(block ,block - (tagbody - (return-from ,block - ,@(generate-number-dispatch vars (error-tags) - (cdr res))) - ,@(errors)))))) - -;;;; binary operation dispatching utilities - -(eval-when (:compile-toplevel :execute) - -;;; Return NUMBER-DISPATCH forms for rational X float. -(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio))) - `(((single-float single-float) (,op ,x ,y)) - (((foreach ,@rat-types) - (foreach single-float double-float #+long-float long-float)) - (,op (coerce ,x '(dispatch-type ,y)) ,y)) - (((foreach single-float double-float #+long-float long-float) - (foreach ,@rat-types)) - (,op ,x (coerce ,y '(dispatch-type ,x)))) - #+long-float - (((foreach single-float double-float long-float) long-float) - (,op (coerce ,x 'long-float) ,y)) - #+long-float - ((long-float (foreach single-float double-float)) - (,op ,x (coerce ,y 'long-float))) - (((foreach single-float double-float) double-float) - (,op (coerce ,x 'double-float) ,y)) - ((double-float single-float) - (,op ,x (coerce ,y 'double-float))))) - -;;; Return NUMBER-DISPATCH forms for bignum X fixnum. -(defun bignum-cross-fixnum (fix-op big-op) - `(((fixnum fixnum) (,fix-op x y)) - ((fixnum bignum) - (,big-op (make-small-bignum x) y)) - ((bignum fixnum) - (,big-op x (make-small-bignum y))) - ((bignum bignum) - (,big-op x y)))) -) ; EVAL-WHEN - ;;;; canonicalization utilities ;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is ;;; used when we know that REALPART and IMAGPART are the same type, but ;;; rational canonicalization might still need to be done. -#-sb-fluid (declaim (inline canonical-complex)) +(declaim (inline canonical-complex)) (defun canonical-complex (realpart imagpart) (if (eql imagpart 0) realpart @@ -253,7 +36,7 @@ ;;; Given a numerator and denominator with the GCD already divided ;;; out, make a canonical rational. We make the denominator positive, ;;; and check whether it is 1. -#-sb-fluid (declaim (inline build-ratio)) +(declaim (inline build-ratio)) (defun build-ratio (num den) (multiple-value-bind (num den) (if (minusp den) @@ -268,7 +51,7 @@ (t (%make-ratio num den))))) ;;; Truncate X and Y, but bum the case where Y is 1. -#-sb-fluid (declaim (inline maybe-truncate)) +(declaim (inline maybe-truncate)) (defun maybe-truncate (x y) (if (eql y 1) x @@ -635,71 +418,134 @@ ;;; ROUND and FROUND are not declared inline since they seem too ;;; obscure and too big to inline-expand by default. Also, this gives ;;; the compiler a chance to pick off the unary float case. -#-sb-fluid (declaim (inline fceiling ffloor ftruncate)) -(defun ftruncate (number &optional (divisor 1)) - "Same as TRUNCATE, but returns first value as a float." - (declare (explicit-check)) - (macrolet ((ftruncate-float (rtype) - `(let* ((float-div (coerce divisor ',rtype)) - (res (%unary-ftruncate (/ number float-div)))) - (values res - (- number - (* (coerce res ',rtype) float-div)))))) - (number-dispatch ((number real) (divisor real)) - (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) - (multiple-value-bind (q r) - (truncate number divisor) - (values (float q) r))) - (((foreach single-float double-float #+long-float long-float) - (or rational single-float)) - (if (eql divisor 1) - (let ((res (%unary-ftruncate number))) - (values res (- number (coerce res '(dispatch-type number))))) - (ftruncate-float (dispatch-type number)))) - #+long-float - ((long-float (or single-float double-float long-float)) - (ftruncate-float long-float)) - #+long-float - (((foreach double-float single-float) long-float) - (ftruncate-float long-float)) - ((double-float (or single-float double-float)) - (ftruncate-float double-float)) - ((single-float double-float) - (ftruncate-float double-float)) - (((foreach fixnum bignum ratio) - (foreach single-float double-float #+long-float long-float)) - (ftruncate-float (dispatch-type divisor)))))) +(declaim (inline fceiling ffloor ftruncate)) -(defun ffloor (number &optional (divisor 1)) - "Same as FLOOR, but returns first value as a float." - (declare (explicit-check)) - (multiple-value-bind (tru rem) (ftruncate number divisor) - (if (and (not (zerop rem)) - (if (minusp divisor) - (plusp number) - (minusp number))) - (values (1- tru) (+ rem divisor)) - (values tru rem)))) - -(defun fceiling (number &optional (divisor 1)) - "Same as CEILING, but returns first value as a float." - (declare (explicit-check)) - (multiple-value-bind (tru rem) (ftruncate number divisor) - (if (and (not (zerop rem)) - (if (minusp divisor) - (minusp number) - (plusp number))) - (values (+ tru 1) (- rem divisor)) - (values tru rem)))) +#-round-float +(progn + (defun ftruncate (number &optional (divisor 1)) + "Same as TRUNCATE, but returns first value as a float." + (declare (explicit-check)) + (macrolet ((ftruncate-float (rtype) + `(let* ((float-div (coerce divisor ',rtype)) + (res (%unary-ftruncate (/ number float-div)))) + (values res + (- number + (* (coerce res ',rtype) float-div)))))) + (number-dispatch ((number real) (divisor real)) + (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) + (multiple-value-bind (q r) + (truncate number divisor) + (values (float q) r))) + (((foreach single-float double-float #+long-float long-float) + (or rational single-float)) + (if (eql divisor 1) + (let ((res (%unary-ftruncate number))) + (values res (- number (coerce res '(dispatch-type number))))) + (ftruncate-float (dispatch-type number)))) + #+long-float + ((long-float (or single-float double-float long-float)) + (ftruncate-float long-float)) + #+long-float + (((foreach double-float single-float) long-float) + (ftruncate-float long-float)) + ((double-float (or single-float double-float)) + (ftruncate-float double-float)) + ((single-float double-float) + (ftruncate-float double-float)) + (((foreach fixnum bignum ratio) + (foreach single-float double-float #+long-float long-float)) + (ftruncate-float (dispatch-type divisor)))))) + + (defun ffloor (number &optional (divisor 1)) + "Same as FLOOR, but returns first value as a float." + (declare (explicit-check)) + (multiple-value-bind (tru rem) (ftruncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (values (1- tru) (+ rem divisor)) + (values tru rem)))) + + (defun fceiling (number &optional (divisor 1)) + "Same as CEILING, but returns first value as a float." + (declare (explicit-check)) + (multiple-value-bind (tru rem) (ftruncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (minusp number) + (plusp number))) + (values (+ tru 1) (- rem divisor)) + (values tru rem)))) ;;; FIXME: this probably needs treatment similar to the use of ;;; %UNARY-FTRUNCATE for FTRUNCATE. -(defun fround (number &optional (divisor 1)) - "Same as ROUND, but returns first value as a float." - (declare (explicit-check)) - (multiple-value-bind (res rem) - (round number divisor) - (values (float res (if (floatp rem) rem $1.0)) rem))) + (defun fround (number &optional (divisor 1)) + "Same as ROUND, but returns first value as a float." + (declare (explicit-check)) + (multiple-value-bind (res rem) + (round number divisor) + (values (float res (if (floatp rem) rem $1.0)) rem)))) + +#+round-float +(macrolet ((def (name mode docstring) + `(defun ,name (number &optional (divisor 1)) + ,docstring + (declare (explicit-check)) + (macrolet ((ftruncate-float (rtype) + `(let* ((float-div (coerce divisor ',rtype)) + (res (,(case rtype + (double-float 'sb-kernel:round-double) + (single-float 'sb-kernel:round-single)) + (/ number float-div) + ,,mode))) + (values res + (- number + (* (coerce res ',rtype) float-div))))) + (unary-ftruncate-float (rtype) + `(let* ((res (,(case rtype + (double-float 'sb-kernel:round-double) + (single-float 'sb-kernel:round-single)) + number + ,,mode))) + (values res (- number res))))) + (number-dispatch ((number real) (divisor real)) + (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) + (multiple-value-bind (q r) + (,(find-symbol (string mode) :cl) number divisor) + (values (float q) r))) + (((foreach single-float double-float) + (or rational single-float)) + (if (eql divisor 1) + (unary-ftruncate-float (dispatch-type number)) + (ftruncate-float (dispatch-type number)))) + ((double-float (or single-float double-float)) + (ftruncate-float double-float)) + ((single-float double-float) + (ftruncate-float double-float)) + (((foreach fixnum bignum ratio) + (foreach single-float double-float)) + (ftruncate-float (dispatch-type divisor)))))))) + (def ftruncate :truncate + "Same as TRUNCATE, but returns first value as a float.") + + (def ffloor :floor + "Same as FLOOR, but returns first value as a float.") + + (def fceiling :ceiling + "Same as CEILING, but returns first value as a float.") + (def fround :round + "Same as ROUND, but returns first value as a float.") + + (macrolet ((def (name) + `(defun ,name (x mode) + (ecase mode + ,@(loop for m in '(:round :floor :ceiling :truncate) + collect `(,m (,name x ,m))))))) + + + (def round-single) + (def round-double))) ;;;; comparisons @@ -794,7 +640,7 @@ ((>= ,integer 0) (< (float quot ,float) ,float)))))))))) -(eval-when (:compile-toplevel :execute) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how ;;; to handle the case when X or Y is a floating-point infinity and ;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec @@ -820,7 +666,6 @@ (,op x (coerce 0 '(dispatch-type x))) (if (float-infinity-p x) ,infinite-x-finite-y - ;; Likewise (make-fixnum-float-comparer ,(case op (> '<) (< '>) @@ -830,41 +675,78 @@ (,op (coerce x 'double-float) y)) ((double-float single-float) (,op x (coerce y 'double-float))) - (((foreach single-float double-float #+long-float long-float) rational) - (if (eql y 0) - (,op x (coerce 0 '(dispatch-type x))) - (if (float-infinity-p x) - ,infinite-x-finite-y - (,op (rational x) y)))) - (((foreach bignum fixnum ratio) float) + (((foreach single-float double-float #+long-float long-float) ratio) + (if (float-infinity-p x) + ,infinite-x-finite-y + ;; Avoid converting the float into a rational, since it + ;; will be taken apart later anyway. + (multiple-value-bind (bits exp) (integer-decode-float x) + (if (eql bits 0) + (,op 0 y) + (let ((int (if (minusp x) (- bits) bits))) + (if (minusp exp) + (,op (* int (denominator y)) + (ash (numerator y) (- exp))) + (,op (ash int exp) y))))))) + ((ratio (foreach single-float double-float)) + (if (float-infinity-p y) + ,infinite-y-finite-x + (multiple-value-bind (bits exp) (integer-decode-float y) + (if (eql bits 0) + (,op x 0) + (let ((int (if (minusp y) (- bits) bits))) + (if (minusp exp) + (,op (ash (numerator x) (- exp)) + (* int (denominator x))) + (,op x (ash int exp)))))))) + (((foreach single-float double-float) bignum) + (if (float-infinity-p x) + ,infinite-x-finite-y + #+64-bit + (,(case op + (> 'float-bignum->) + (< 'float-bignum-<) + (= 'float-bignum-=)) + x y) + #-64-bit + (,op (rational x) y))) + ((bignum float) (if (float-infinity-p y) ,infinite-y-finite-x + #+64-bit + (,(case op + (> 'float-bignum-<) + (< 'float-bignum->) + (= 'float-bignum-=)) + y x) + #-64-bit (,op x (rational y)))))) ) ; EVAL-WHEN (macrolet ((def-two-arg- (name op ratio-arg1 ratio-arg2 &rest cases) `(defun ,name (x y) + (declare (inline float-infinity-p)) (number-dispatch ((x real) (y real)) - (basic-compare - ,op - :infinite-x-finite-y - (,op x (coerce 0 '(dispatch-type x))) - :infinite-y-finite-x - (,op (coerce 0 '(dispatch-type y)) y)) - (((foreach fixnum bignum) ratio) - (,op x (,ratio-arg2 (numerator y) - (denominator y)))) - ((ratio integer) - (,op (,ratio-arg1 (numerator x) - (denominator x)) - y)) - ((ratio ratio) - (,op (* (numerator (truly-the ratio x)) - (denominator (truly-the ratio y))) - (* (numerator (truly-the ratio y)) - (denominator (truly-the ratio x))))) - ,@cases)))) + (basic-compare + ,op + :infinite-x-finite-y + (,op x (coerce 0 '(dispatch-type x))) + :infinite-y-finite-x + (,op (coerce 0 '(dispatch-type y)) y)) + (((foreach fixnum bignum) ratio) + (,op x (,ratio-arg2 (numerator y) + (denominator y)))) + ((ratio integer) + (,op (,ratio-arg1 (numerator x) + (denominator x)) + y)) + ((ratio ratio) + (,op (* (numerator (truly-the ratio x)) + (denominator (truly-the ratio y))) + (* (numerator (truly-the ratio y)) + (denominator (truly-the ratio x))))) + ,@cases)))) (def-two-arg- two-arg-< < floor ceiling ((fixnum bignum) (bignum-plus-p y)) @@ -881,6 +763,7 @@ (plusp (bignum-compare x y))))) (defun two-arg-= (x y) + (declare (inline float-infinity-p)) (number-dispatch ((x number) (y number)) (basic-compare = ;; An infinite value is never equal to a finite value. @@ -976,8 +859,8 @@ (fixnum (logcount #-x86-64 (truly-the (integer 0 - #.(max sb-xc:most-positive-fixnum - (lognot sb-xc:most-negative-fixnum))) + #.(max most-positive-fixnum + (lognot most-negative-fixnum))) (if (minusp (truly-the fixnum integer)) (lognot (truly-the fixnum integer)) integer)) @@ -1238,7 +1121,7 @@ (setq v (- temp))) (setq temp (- u v)) (when (zerop temp) - (return (the (integer 0 #.(1+ sb-xc:most-positive-fixnum)) (ash u k))))))) + (return (the (integer 0 #.(1+ most-positive-fixnum)) (ash u k))))))) (declare (type (mod #.sb-vm:n-word-bits) k) (type sb-vm:signed-word u v))))) @@ -1378,7 +1261,7 @@ (significant-half (ash ,arg (- (ash fourth-size 1)))) (significant-half-isqrt (if-fixnum-p-truly-the - (integer 1 #.(isqrt sb-xc:most-positive-fixnum)) + (integer 1 #.(isqrt most-positive-fixnum)) (,recurse significant-half))) (zeroth-iteration (ash significant-half-isqrt fourth-size))) diff -Nru sbcl-2.0.6/src/code/pathname.lisp sbcl-2.1.1/src/code/pathname.lisp --- sbcl-2.0.6/src/code/pathname.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/pathname.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -16,12 +16,11 @@ ;;; The HOST structure holds the functions that both parse the ;;; pathname information into structure slot entries, and after ;;; translation the inverse (unparse) functions. -(sb-xc:defstruct (host (:constructor nil) - (:copier nil) - (:print-object - (lambda (host stream) - (print-unreadable-object - (host stream :type t :identity t))))) +(defstruct (host (:constructor nil) + (:copier nil) + (:print-object + (lambda (host stream) + (print-unreadable-object (host stream :type t :identity t))))) (parse (missing-arg) :type function :read-only t) (parse-native (missing-arg) :type function :read-only t) (unparse (missing-arg) :type function :read-only t) @@ -36,36 +35,36 @@ ;;; A PATTERN is a list of entries and wildcards used for pattern ;;; matches of translations. -(sb-xc:defstruct (pattern (:constructor make-pattern (pieces)) (:copier nil)) - (pieces nil :type list)) +(defstruct (pattern (:constructor %make-pattern (hash pieces)) + (:copier nil)) + (hash 0 :type fixnum :read-only t) + (pieces nil :type list :read-only t)) ;;;; PATHNAME structures ;;; the various magic tokens that are allowed to appear in pretty much ;;; all pathname components -(sb-xc:deftype pathname-component-tokens () +(deftype pathname-component-tokens () '(member nil :unspecific :wild :unc)) -(sb-xc:defstruct (pathname (:conc-name %pathname-) - (:copier nil) - (:constructor %%make-pathname - (host device directory name type version - &aux (dir-hash (pathname-dir-hash directory)) - (stem-hash (mix (sxhash name) (sxhash type))))) - (:predicate pathnamep)) +;;; This definition relies on compiler magic to turn the metclass +;;; into BUILT-IN-CLASSOID. Same for LOGICAL-PATHNAME. +(defstruct (pathname (:conc-name %pathname-) + (:copier nil) + (:constructor !allocate-pathname + (host device dir+hash name type version)) + (:predicate pathnamep)) (namestring nil) ; computed on demand - ;; support for pathname interning and hashing. - ;; Host and device might be reducible to small integers if we keep tables (vectors) - ;; of the values seen. - ;; We might even be able to pack DIR-HASH, STEM-HASH, and HOST, DEVICE into one slot. - (dir-hash nil :type hash-code :read-only t) - (stem-hash nil :type hash-code :read-only t) ; name hash and type hash mixed ;; the host (at present either a UNIX or logical host) + ;; Host and device could be reduced to small integers and packed in one slot + ;; by keeping tables of the observed values. (host nil :type (or host null) :read-only t) ;; the name of a logical or physical device holding files (device nil :type (or simple-string pathname-component-tokens) :read-only t) - ;; a list of strings that are the component subdirectory components - (directory nil :type list :read-only t) + ;; an interned list of strings headed by :ABSOLUTE or :RELATIVE + ;; comprising the path, or NIL. + ;; if the list is non-NIL, it's a cons of the list and a numeric hash. + (dir+hash nil :type list :read-only t) ;; the filename (name nil :type (or simple-string pattern pathname-component-tokens) :read-only t) ;; the type extension of the file @@ -75,3 +74,9 @@ (version nil :type (or integer pathname-component-tokens (member :newest)) :read-only t)) +(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))) +(declaim (inline logical-pathname-p)) +(defun logical-pathname-p (x) (typep x 'logical-pathname)) diff -Nru sbcl-2.0.6/src/code/ppc-vm.lisp sbcl-2.1.1/src/code/ppc-vm.lisp --- sbcl-2.0.6/src/code/ppc-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/ppc-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -2,55 +2,15 @@ ;;; (in-package "SB-VM") -#-sb-xc-host (defun machine-type () "Returns a string describing the type of the local machine." #-64-bit "PowerPC" #+64-bit "PowerPC64") -;;;; FIXUP-CODE-OBJECT - -(defconstant-eqx +fixup-kinds+ #(:absolute :absolute64 :b :ba :ha :l) #'equalp) -(!with-bigvec-or-sap -(defun fixup-code-object (code offset fixup kind flavor) - (declare (type index offset)) - (declare (ignore flavor)) - (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) - (error "Unaligned instruction? offset=#x~X." offset)) - (let ((sap (code-instructions code))) - (ecase kind - (:absolute - ;; There is an implicit addend currently stored in the fixup location. - (incf (sap-ref-32 sap offset) fixup)) - (:absolute64 - (incf (sap-ref-64 sap offset) fixup)) - (:b - (error "Can't deal with CALL fixups, yet.")) - (:ba - (setf (ldb (byte 24 2) (sap-ref-32 sap offset)) - (ash fixup -2))) - (:ha - (let* ((h (ldb (byte 16 16) fixup)) - (l (ldb (byte 16 0) fixup))) - ; Compensate for possible sign-extension when the low half - ; is added to the high. We could avoid this by ORI-ing - ; the low half in 32-bit absolute loads, but it'd be - ; nice to be able to do: - ; lis rX,foo@ha - ; lwz rY,foo@l(rX) - ; and lwz/stw and friends all use a signed 16-bit offset. - (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) - (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) - (:l - (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) - (ldb (byte 16 0) fixup))))) - nil)) - ;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then ;;;; hacked for types. -#-sb-xc-host (progn (define-alien-routine ("os_context_lr_addr" context-lr-addr) (* unsigned-long) (context (* os-context-t))) @@ -130,4 +90,3 @@ '(#.arg-count-sc))))) (t (values #.(error-number-or-lose 'unknown-error) nil))))) -) ; end PROGN diff -Nru sbcl-2.0.6/src/code/pprint.lisp sbcl-2.1.1/src/code/pprint.lisp --- sbcl-2.0.6/src/code/pprint.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/pprint.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -31,7 +31,7 @@ (declaim (freeze-type newline) (end-block)) -#-sb-fluid (declaim (inline index-posn posn-index posn-column)) +(declaim (inline index-posn posn-index posn-column)) (defun index-posn (index stream) (declare (type index index) (type pretty-stream stream) (values posn)) @@ -121,8 +121,8 @@ (return)) (incf start count))))))))))) -(defun pretty-misc (stream op &optional arg1 arg2) - (declare (ignore stream op arg1 arg2))) +(defun pretty-misc (stream op arg) + (declare (ignore stream op arg))) ;;;; logical blocks @@ -934,24 +934,22 @@ ;;;; standard pretty-printing routines (defun pprint-array (stream array) - (cond ((and (null *print-array*) (null *print-readably*)) - (output-ugly-object stream array)) + (cond ((or (null (array-element-type array)) + (and (null *print-array*) (null *print-readably*))) + (print-object array stream)) ((and *print-readably* (not (array-readably-printable-p array))) (sb-impl::output-unreadable-array-readably array stream)) ((vectorp array) - (pprint-vector stream array)) + (pprint-logical-block (stream nil :prefix "#(" :suffix ")") + (dotimes (i (length array)) + (unless (zerop i) + (format stream " ~:_")) + (pprint-pop) + (output-object (aref array i) stream)))) (t (pprint-multi-dim-array stream array)))) -(defun pprint-vector (stream vector) - (pprint-logical-block (stream nil :prefix "#(" :suffix ")") - (dotimes (i (length vector)) - (unless (zerop i) - (format stream " ~:_")) - (pprint-pop) - (output-object (aref vector i) stream)))) - (defun pprint-multi-dim-array (stream array) (funcall (formatter "#~DA") stream (array-rank array)) (with-array-data ((data array) (start) (end)) diff -Nru sbcl-2.0.6/src/code/pred.lisp sbcl-2.1.1/src/code/pred.lisp --- sbcl-2.0.6/src/code/pred.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/pred.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -13,7 +13,7 @@ ;;;; miscellaneous non-primitive predicates -#-sb-fluid (declaim (inline streamp)) +(declaim (inline streamp)) (defun streamp (stream) (typep stream 'stream)) @@ -138,8 +138,7 @@ (def-type-predicate-wrapper simple-rank-1-array-*-p) (def-type-predicate-wrapper simple-string-p) (def-type-predicate-wrapper stringp) - (def-type-predicate-wrapper vectorp) - (def-type-predicate-wrapper vector-nil-p)) + (def-type-predicate-wrapper vectorp)) #+(or x86 x86-64 arm arm64) (defun fixnum-mod-p (x limit) @@ -215,10 +214,10 @@ (cond ((<= 0 object 1) 'bit) ((< object 0) 'fixnum) - (t `(integer 0 ,sb-xc:most-positive-fixnum)))) + (t `(integer 0 ,most-positive-fixnum)))) (integer (if (>= object 0) - `(integer ,(1+ sb-xc:most-positive-fixnum)) + `(integer ,(1+ most-positive-fixnum)) 'bignum)) (character (typecase object @@ -234,25 +233,37 @@ ((eq object nil) 'null) ((eq (sb-xc:symbol-package object) *keyword-package*) 'keyword) (t 'symbol))) - ((or array complex #+sb-simd-pack simd-pack #+sb-simd-pack-256 simd-pack-256) - (let ((sb-kernel::*unparse-allow-negation* nil)) - (declare (special sb-kernel::*unparse-allow-negation*)) ; forward ref - (type-specifier (ctype-of object)))) + (array + (let ((etype (specifier-type (array-element-type 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 + (make-array-type (array-dimensions object) + :complexp (if (typep object 'simple-array) nil :maybe) + :element-type etype + :specialized-element-type etype)))) + ((or complex #+sb-simd-pack simd-pack #+sb-simd-pack-256 simd-pack-256) + (type-specifier (ctype-of object))) + (simple-fun 'compiled-function) (t - (let* ((classoid (classoid-of object)) - (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))))) + (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))))))) ;;;; equality predicates @@ -482,7 +493,8 @@ ((%instancep x) (and (%instancep y) (let ((layout (%instance-layout x))) - (and (logtest +structure-layout-flag+ (layout-flags layout)) + (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)) diff -Nru sbcl-2.0.6/src/code/primordial-extensions.lisp sbcl-2.1.1/src/code/primordial-extensions.lisp --- sbcl-2.0.6/src/code/primordial-extensions.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/primordial-extensions.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -322,20 +322,19 @@ ;;; 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. -;;; The extra magic is that we need to discern between constants simple enough -;;; to assigned during genesis (cold-load) from those assigned in cold-init. -;;; This choice informs the compiler how to emit references to the symbol. -(defvar sb-c::*!const-value-deferred* '()) +;;; 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 +;;; in genesis because the target representation of the value will be available. +;;; It would not be available if the form were computable only by target code. #-sb-xc-host (eval-when (:compile-toplevel) (sb-xc:defmacro defconstant-eqx (symbol expr eqx &optional doc) - (let ((constp (sb-xc:constantp expr))) - `(progn - (eval-when (:compile-toplevel) - (sb-xc:defconstant ,symbol (%defconstant-eqx-value ',symbol ,expr ,eqx)) - ,@(unless constp - `((push ',symbol sb-c::*!const-value-deferred*)))) - (eval-when (:load-toplevel) - (sb-c::%defconstant ',symbol - ,(if constp `',(constant-form-value expr) expr) - (sb-c:source-location) ,@(when doc (list 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))))))) diff -Nru sbcl-2.0.6/src/code/print.lisp sbcl-2.1.1/src/code/print.lisp --- sbcl-2.0.6/src/code/print.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/print.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -218,7 +218,7 @@ ;; This is exact for bases which are exactly a power-of-2, or an overestimate ;; otherwise, as mandated by the finite output stream. (let ((bits-per-char - (aref #.(sb-xc:coerce + (aref #.(coerce ;; base 2 or base 3 = 1 bit per character ;; base 4 .. base 7 = 2 bits per character ;; base 8 .. base 15 = 3 bits per character, etc @@ -342,7 +342,7 @@ (if (eq initiate :initiate) (let ((*circularity-hash-table* (make-hash-table :test 'eq))) - (check-it (make-broadcast-stream)) + (check-it *null-broadcast-stream*) (let ((*circularity-counter* 0)) (check-it stream))) ;; otherwise @@ -379,11 +379,13 @@ (print-unreadable-object (object stream :identity t) (prin1 'instance stream)))) (let ((classoid (layout-classoid layout))) - ;; Additionally, if the object is an obsolete CONDITION, don't crash. - ;; (There is no update-instance protocol for conditions) + ;; 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) - (logtest (layout-flags layout) +condition-layout-flag+))) + (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))))))) @@ -839,7 +841,8 @@ (write-char #\" stream)) (t (write-string vector stream)))) - ((not (or *print-array* readably)) + ((or (null (array-element-type vector)) + (not (or *print-array* readably))) (output-terse-array vector stream)) ((bit-vector-p vector) (cond ((cut-length)) @@ -890,7 +893,7 @@ ;;; Output the printed representation of any array in either the #< or #A ;;; form. (defmethod print-object ((array array) stream) - (if (or *print-array* *print-readably*) + (if (and (or *print-array* *print-readably*) (array-element-type array)) (output-array-guts array stream) (output-terse-array array stream))) @@ -898,7 +901,10 @@ (defun output-terse-array (array stream) (let ((*print-level* nil) (*print-length* nil)) - (print-unreadable-object (array stream :type t :identity t)))) + (if (and (not (array-element-type array)) *print-readably* *read-eval*) + (format stream "#.(~S '~D :ELEMENT-TYPE ~S)" + 'make-array (array-dimensions array) nil) + (print-unreadable-object (array stream :type t :identity t))))) ;;; Convert an array into a list that can be used with MAKE-ARRAY's ;;; :INITIAL-CONTENTS keyword argument. @@ -1802,9 +1808,9 @@ ;; ":TYPE T" is no good, since CLOSURE doesn't have full-fledged status. (print-unreadable-object (object stream :identity (not proper-name-p)) (format stream "~A~@[ ~S~]" - ;; TYPE-OF is so that GFs print as # - ;; and not # before SRC;PCL;PRINT-OBJECT is loaded. - (if (closurep object) 'closure (type-of object)) + ;; CLOSURE and SIMPLE-FUN should print as # + ;; but anything else prints as its exact type. + (if (funcallable-instance-p object) (type-of object) 'function) name)))) ;;;; catch-all for unknown things diff -Nru sbcl-2.0.6/src/code/profile.lisp sbcl-2.1.1/src/code/profile.lisp --- sbcl-2.0.6/src/code/profile.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/profile.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -68,9 +68,6 @@ ;;;; High resolution timer -;;; FIXME: High resolution this is not. Build a microsecond-accuracy version -;;; on top of unix-getrusage, maybe. - (defconstant +ticks-per-second+ internal-time-units-per-second) (declaim (inline get-internal-ticks)) diff -Nru sbcl-2.0.6/src/code/quantifiers.lisp sbcl-2.1.1/src/code/quantifiers.lisp --- sbcl-2.0.6/src/code/quantifiers.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/quantifiers.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -15,7 +15,7 @@ ;;; arbitrary sequence arguments, both in the full call case and in ;;; the open code case. (flet ((expand (pred sequences test found-result unfound-result) - (unless (proper-list-of-length-p sequences 1 sb-xc:call-arguments-limit) + (unless (proper-list-of-length-p sequences 1 call-arguments-limit) (return-from expand (values nil t))) ; give up (binding* ((elements (make-gensym-list (length sequences))) ((bind-fun call-it) (funarg-bind/call-forms pred elements)) diff -Nru sbcl-2.0.6/src/code/reader.lisp sbcl-2.1.1/src/code/reader.lisp --- sbcl-2.0.6/src/code/reader.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/reader.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -32,7 +32,8 @@ (list `(%instance-ref table ,(dsd-index dsd)) (case (dsd-name dsd) (gethash-impl '#'gethash-return-default) - (pairs (make-array kv-pairs-overhead-slots)) + (pairs (make-array kv-pairs-overhead-slots + :initial-element 0)) (lock nil) (t (dsd-default dsd))))) (dd-slots @@ -172,12 +173,10 @@ ;;; predicates for testing character attributes -#-sb-fluid -(progn - (declaim (inline whitespace[1]p whitespace[2]p)) - (declaim (inline constituentp terminating-macrop)) - (declaim (inline single-escape-p multiple-escape-p)) - (declaim (inline token-delimiterp))) +(declaim (inline whitespace[1]p whitespace[2]p)) +(declaim (inline constituentp terminating-macrop)) +(declaim (inline single-escape-p multiple-escape-p)) +(declaim (inline token-delimiterp)) ;;; the [1] and [2] here refer to ANSI glossary entries for ;;; "whitespace". @@ -493,8 +492,7 @@ (defun flush-whitespace (stream) ;; This flushes whitespace chars, returning the last char it read (a ;; non-white one). It always gets an error on end-of-file. - (let* ((stream (in-stream-from-designator stream)) - (rt *readtable*) + (let* ((rt *readtable*) (base (base-char-syntax-array rt)) (extended (extended-char-table rt))) (macrolet ((done-p () @@ -770,8 +768,9 @@ "Read from STREAM and return the value read, preserving any whitespace that followed the object." (declare (explicit-check)) - (check-for-recursive-read stream recursive-p 'read-preserving-whitespace) - (%read-preserving-whitespace stream eof-error-p eof-value recursive-p)) + (let ((stream (in-stream-from-designator stream))) + (check-for-recursive-read stream recursive-p 'read-preserving-whitespace) + (%read-preserving-whitespace stream eof-error-p eof-value recursive-p))) ;;; Read from STREAM given starting CHAR, returning 1 and the resulting ;;; object, unless CHAR is a macro yielding no value, then 0 and NIL, @@ -798,7 +797,8 @@ (defun read (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) - (recursive-p nil)) + (recursive-p nil) + &aux (stream (in-stream-from-designator stream))) "Read the next Lisp value from STREAM, and return it." (declare (explicit-check)) (check-for-recursive-read stream recursive-p 'read) @@ -835,16 +835,15 @@ 'sb-kernel::character-decoding-error-in-macro-char-comment :position (file-position stream) :stream stream) (invoke-restart 'attempt-resync)))) - (let ((stream (in-stream-from-designator stream))) - (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream + (if (ansi-stream-p stream) + (prepare-for-fast-read-char stream (loop (let ((char (fast-read-char nil +EOF+))) (when (or (eq char +EOF+) (char= char #\newline)) (return (done-with-fast-read-char)))))) ;; CLOS stream - (loop (let ((char (read-char stream nil +EOF+))) + (loop (let ((char (read-char stream nil +EOF+))) (when (or (eq char +EOF+) (char= char #\newline)) - (return))))))) + (return)))))) ;; Don't return anything. (values)) @@ -904,7 +903,9 @@ ;;; (This is a COMMON-LISP exported symbol.) (defun read-delimited-list (endchar &optional (input-stream *standard-input*) - recursive-p) + recursive-p + &aux (input-stream + (in-stream-from-designator input-stream))) "Read Lisp values from INPUT-STREAM until the next character after a value's representation is ENDCHAR, and return the objects as a list." (declare (explicit-check)) @@ -914,7 +915,8 @@ (read-list-item input-stream)))) (if recursive-p (%read-delimited-list) - (with-read-buffer () (%read-delimited-list)))))) ; end MACROLET + (let ((*sharp-equal* nil)) + (with-read-buffer () (%read-delimited-list))))))) ; end MACROLET (defun read-after-dot (stream firstchar collectp) ;; FIRSTCHAR is non-whitespace! @@ -971,7 +973,6 @@ (let* ((token-buf *read-buffer*) (buf (token-buf-string token-buf)) (rt *readtable*) - (stream (in-stream-from-designator stream)) (suppress *read-suppress*) (lim (length buf)) (ptr 0) @@ -1482,8 +1483,7 @@ (#.+char-attr-package-delimiter+ (go COLON)) (t (go SYMBOL))) SYMBOL ; not a dot, dots, or number - (let ((stream (in-stream-from-designator stream))) - (macrolet + (macrolet ((scan (read-a-char &optional finish) `(prog () SYMBOL-LOOP @@ -1502,7 +1502,7 @@ (prepare-for-fast-read-char stream (scan (fast-read-char nil +EOF+) (done-with-fast-read-char))) ;; CLOS stream - (scan (read-char stream nil +EOF+))))) + (scan (read-char stream nil +EOF+)))) SINGLE-ESCAPE ; saw a single-escape ;; Don't put the escape character in the read buffer. ;; READ-NEXT CHAR, put in buffer (no case conversion). @@ -1594,6 +1594,9 @@ (multiple-value-bind (symbol accessibility) (%find-symbol (token-buf-string buf) (token-buf-fill-ptr buf) pkg) (when (eq accessibility :external) (return symbol)) + (when (and accessibility + (check-deprecated-export pkg symbol)) + (return symbol)) (with-simple-restart (continue "Use symbol anyway.") (error 'simple-reader-package-error :package pkg @@ -1678,8 +1681,8 @@ (inline token-buf-getchar)) ; makes for smaller code (let* ((fixnum-max-digits (macrolet ((maxdigits () - (sb-xc:coerce (integer-reader-safe-digits) - '(vector (unsigned-byte 8))))) + (coerce (integer-reader-safe-digits) + '(vector (unsigned-byte 8))))) (aref (maxdigits) (- base 2)))) (base-power (macrolet ((base-powers () diff -Nru sbcl-2.0.6/src/code/redblack.lisp sbcl-2.1.1/src/code/redblack.lisp --- sbcl-2.0.6/src/code/redblack.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/redblack.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -180,9 +180,20 @@ ((< (node-key tree) key) (setq tree (right tree))) (t (return tree))))) +;;; Find a node with key less than or equal to KEY and as near it as possible. (defun find<= (key tree) (named-let recurse ((node tree) (best nil)) (cond ((null node) best) ((< key (node-key node)) (recurse (left node) best)) ((< (node-key node) key) (recurse (right node) node)) (t node)))) + +;;; Find a node with key greater than or equal to KEY and as near it as possible. +(defun find>= (key tree) + (named-let recurse ((node tree) (best nil)) + (cond ((null node) best) + ((< key (node-key node)) (recurse (left node) node)) + ((< (node-key node) key) (recurse (right node) best)) + (t node)))) + +(export '(find>= find<=)) diff -Nru sbcl-2.0.6/src/code/restart.lisp sbcl-2.1.1/src/code/restart.lisp --- sbcl-2.0.6/src/code/restart.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/restart.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -31,7 +31,7 @@ ;; extent. (associated-conditions '() :type list)) -#-sb-fluid (declaim (freeze-type restart)) +(declaim (freeze-type restart)) (defmacro with-condition-restarts (condition-form restarts-form &body body) diff -Nru sbcl-2.0.6/src/code/riscv-vm.lisp sbcl-2.1.1/src/code/riscv-vm.lisp --- sbcl-2.0.6/src/code/riscv-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/riscv-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1,56 +1,12 @@ ;;; This file contains the RISC-V-specific runtime stuff. (in-package "SB-VM") - -#-sb-xc-host + (defun machine-type () "Return a string describing the type of the local machine." #-64-bit "RV32G" #+64-bit "RV64G") - -;;; FIXUP-CODE-OBJECT -(defconstant-eqx +fixup-kinds+ #(:absolute :i-type :s-type :u-type) #'equalp) - -(defun u-and-i-inst-immediate (value) - (let ((hi (ash (+ value (expt 2 11)) -12))) - (values hi (- value (ash hi 12))))) - -(def!type short-immediate () `(signed-byte 12)) -(def!type short-immediate-fixnum () `(signed-byte ,(- 12 n-fixnum-tag-bits))) - -(def!type u+i-immediate () - #-64-bit `(or (signed-byte 32) (unsigned-byte 32)) - #+64-bit `(or (integer #x-80000800 #x7ffff7ff) - (integer ,(+ (ash 1 64) #x-80000800) - ,(1- (ash 1 64))))) - -(!with-bigvec-or-sap - (defun fixup-code-object (code offset fixup kind flavor) - (declare (type index offset)) - (declare (ignore flavor)) - (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) - (error "Unaligned instruction? offset=#x~X." offset)) - #+64-bit - (unless (typep fixup 'u+i-immediate) - (error "Tried to fixup with ~a." fixup)) - (let ((sap (code-instructions code))) - (multiple-value-bind (u i) (u-and-i-inst-immediate fixup) - (ecase kind - (:absolute - (setf (sap-ref-32 sap offset) fixup)) - (:i-type - (setf (ldb (byte 12 20) (sap-ref-32 sap offset)) i)) - (:s-type - (setf (ldb (byte 5 7) (sap-ref-32 sap offset)) - (ldb (byte 5 0) i)) - (setf (ldb (byte 7 25) (sap-ref-32 sap offset)) - (ldb (byte 7 5) i))) - (:u-type - (setf (ldb (byte 20 12) (sap-ref-32 sap offset)) u))))) - nil)) - ;;; CONTEXT-FLOAT-REGISTER -#-sb-xc-host (progn (define-alien-routine ("os_context_float_register_addr" context-float-register-addr) (* unsigned) (context (* os-context-t)) (index int)) @@ -84,13 +40,12 @@ (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))))))) ;;; INTERNAL-ERROR-ARGS ;;; Given a (POSIX) signal context, extract the internal error ;;; arguments from the instruction stream. -#-sb-xc-host (defun internal-error-args (context) (declare (type (alien (* os-context-t)) context)) (let* ((pc (context-pc context)) @@ -105,7 +60,6 @@ ;;; Undo the effects of XEP-ALLOCATE-FRAME ;;; and point PC to FUNCTION -#-sb-xc-host (defun context-call-function (context function &optional arg-count) (declare (ignore context function arg-count)) (style-warn "Unimplemented.")) diff -Nru sbcl-2.0.6/src/code/room.lisp sbcl-2.1.1/src/code/room.lisp --- sbcl-2.0.6/src/code/room.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/room.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,8 +11,6 @@ (in-package "SB-VM") -(eval-when (:compile-toplevel :load-toplevel :execute) - (export 'sb-sys::get-page-size "SB-SYS")) ;;;; type format database @@ -34,7 +32,7 @@ (room-info-name info))) (defconstant tiny-boxed-size-mask #xFF) -(defun !compute-room-infos () +(defun compute-room-infos () (let ((infos (make-array 256 :initial-element nil)) (default-size-mask (mask-field (byte 23 0) -1))) (dolist (obj *primitive-objects*) @@ -49,11 +47,11 @@ (symbol (make-room-info tiny-boxed-size-mask name :other)) (t (make-room-info default-size-mask name :other))))))) - (let ((info (make-room-info default-size-mask 'array-header :other))) + (let ((info (make-room-info tiny-boxed-size-mask 'array-header :other))) (dolist (code (list #+sb-unicode complex-character-string-widetag complex-base-string-widetag simple-array-widetag complex-bit-vector-widetag complex-vector-widetag - complex-array-widetag complex-vector-nil-widetag)) + complex-array-widetag)) (setf (svref infos code) info))) (setf (svref infos bignum-widetag) @@ -61,6 +59,9 @@ ;; not that this is expected to work concurrently with gc. (make-room-info (ash most-positive-word (- (1+ n-widetag-bits))) 'bignum :other)) + (setf (svref infos filler-widetag) + (make-room-info (ash most-positive-word (- (1+ n-widetag-bits))) + 'filler :other)) (setf (svref infos closure-widetag) (make-room-info short-header-max-words 'closure :closure)) @@ -70,6 +71,7 @@ (when (saetp-specifier saetp) ;; SIMPLE-ARRAY-NIL is a special case. (setf (svref infos (saetp-typecode saetp)) saetp)))) + ;; This one is here for completeness only- LENGTH does not imply size. (setf (svref infos simple-array-nil-widetag) (make-room-info 0 'simple-array-nil :other)) @@ -109,7 +111,8 @@ infos)) -(define-load-time-global *room-info* (!compute-room-infos)) +(define-load-time-global *room-info* (compute-room-infos)) +(declaim (type (simple-vector 256) *room-info*)) (defconstant-eqx +heap-spaces+ '((:dynamic "Dynamic space" dynamic-usage) @@ -169,13 +172,6 @@ (multiple-value-bind (start end) (%space-bounds space) (ash (- end start) n-fixnum-tag-bits)))) -;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword -;;; is eight bytes on platforms with 32-bit word size and 16 bytes on -;;; platforms with 64-bit word size. -#-sb-fluid (declaim (inline round-to-dualword)) -(defun round-to-dualword (size) - (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask))) - (defun instance-length (instance) ; excluding header, not aligned to even ;; Add 1 if expressed length PLUS header (total number of words) would be ;; an even number, and the hash state bits indicate hashed-and-moved. @@ -192,25 +188,6 @@ (ash header-word (- hash-slot-present-flag)) 1)))) -;;; Return the vector OBJ, its WIDETAG, and the number of octets -;;; required for its storage (including padding and alignment). -(defun reconstitute-vector (obj saetp) - (declare (type (simple-array * (*)) obj) - (type specialized-array-element-type-properties saetp)) - (let* ((length (+ (length obj) - (saetp-n-pad-elements saetp))) - (n-bits (saetp-n-bits saetp)) - (alignment-pad (floor 7 n-bits)) - (n-data-octets (if (>= n-bits 8) - (* length (ash n-bits -3)) - (ash (* (+ length alignment-pad) - n-bits) - -3)))) - (values obj - (saetp-typecode saetp) - (round-to-dualword (+ (* vector-data-offset n-word-bytes) - n-data-octets))))) - ;;; * 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. @@ -222,101 +199,69 @@ ;;; 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" - (if (is-lisp-pointer (get-lisp-obj-address object)) - (let ((words - (typecase object - (cons 2) - (instance (1+ (instance-length object))) - (function - (when (= (fun-subtype object) simple-fun-widetag) - (return-from primitive-object-size - (primitive-object-size (fun-code-header object)))) - (1+ (get-closure-length object))) - (null sizeof-nil-in-words) - (code-component - (return-from primitive-object-size (code-object-size object))) - (fdefn 4) ; no length stored in the header - ;; Anything else is an OTHER pointer. - (t - (let ((room-info - (aref *room-info* (%other-pointer-widetag object)))) - (if (arrayp object) - (cond ((array-header-p object) - (+ array-dimensions-offset (array-rank object))) - ((simple-array-nil-p object) 2) - (t - (return-from primitive-object-size - (nth-value 2 (reconstitute-vector object room-info))))) - ;; Other things (symbol, value-cell, etc) - ;; don't have a sizer, so use GET-HEADER-DATA - (1+ (logand (get-header-data object) - (room-info-mask room-info))))))))) - (* (align-up words 2) n-word-bytes)) - 0)) - -;;; Given the address (untagged, aligned, and interpreted as a FIXNUM) -;;; of a lisp object, return the object, its "type code" (either -;;; LIST-POINTER-LOWTAG or a header widetag), and the number of octets -;;; required for its storage (including padding and alignment). Note -;;; that this function is designed to NOT CONS, even if called -;;; out-of-line. -;;; FIXME: size calculation should be via PRIMITIVE-OBJECT-SIZE, not reinvented + (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))) + +(defmacro widetag@baseptr (sap) + #+big-endian `(sap-ref-8 ,sap ,(1- n-word-bytes)) + #+little-endian `(sap-ref-8 ,sap 0)) + +(defmacro lispobj@baseptr (sap widetag) + `(%make-lisp-obj + (logior (sap-int ,sap) + (logand (deref (extern-alien "widetag_lowtag" (array char 256)) ,widetag) + 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? +;;; DO NOT USE THIS! It is soon to be removed (defun reconstitute-object (address) - (let* ((object-sap (int-sap (get-lisp-obj-address address))) - (header (sap-ref-word object-sap 0)) - (widetag (logand header widetag-mask)) - (header-value (ash header (- n-widetag-bits))) - (info (svref *room-info* widetag))) - (macrolet - ((boxed-size (header-value) - `(round-to-dualword (ash (1+ ,header-value) word-shift))) - (tagged-object (tag) - `(%make-lisp-obj (logior ,tag (get-lisp-obj-address address))))) - (cond - ;; Pick off arrays, as they're the only plausible cause for - ;; a non-nil, non-ROOM-INFO object as INFO. - ((specialized-array-element-type-properties-p info) - (reconstitute-vector (tagged-object other-pointer-lowtag) info)) - ((= widetag filler-widetag) - (values nil filler-widetag (boxed-size header-value))) - ((null info) - (error "Unrecognized widetag #x~2,'0X in reconstitute-object" - widetag)) - - (t - (case (room-info-kind info) - (:list - (values (tagged-object list-pointer-lowtag) - list-pointer-lowtag - (* 2 n-word-bytes))) - - (:instance - (let ((instance (tagged-object instance-pointer-lowtag))) - (values instance - widetag - (boxed-size (instance-length instance))))) - - (:closure ; also funcallable-instance - (values (tagged-object fun-pointer-lowtag) - widetag - (boxed-size (logand header-value short-header-max-words)))) - - (:code - (let ((c (tagged-object other-pointer-lowtag))) - (values c - code-header-widetag - (code-object-size c)))) - - (:fdefn - (values (tagged-object other-pointer-lowtag) widetag - (* fdefn-size n-word-bytes))) - - (:other - (values (tagged-object other-pointer-lowtag) - widetag - (boxed-size (logand header-value (room-info-mask info))))))))))) + (let ((sap (descriptor-sap address))) + (lispobj@baseptr sap (widetag@baseptr sap)))) ;;; Iterate over all the objects in the contiguous block of memory ;;; with the low address at START and the high address just before @@ -327,26 +272,54 @@ (defun map-objects-in-range (fun start end &optional (strict-bound t)) (declare (type function fun)) (declare (dynamic-extent fun)) - (named-let iter ((start start)) - (cond - ((< (get-lisp-obj-address start) (get-lisp-obj-address end)) - (multiple-value-bind (obj typecode size) (reconstitute-object start) - ;; SIZE is almost surely a fixnum. Non-fixnum would mean at least - ;; a 512MB object if 32-bit words, and is inconceivable if 64-bit. - (aver (not (logtest (the word size) lowtag-mask))) + (let ((start (descriptor-sap start)) + (end (descriptor-sap end))) + (loop + (if (sap>= start end) (return)) + (binding* ((widetag (widetag@baseptr start)) + (obj (lispobj@baseptr start widetag)) + ((typecode size) + ;; PRIMITIVE-OBJECT-SIZE works on conses, but they're exceptions already + ;; because of absence of a widetag, so may as well not call the sizer. + (if (listp obj) + (values list-pointer-lowtag (* 2 n-word-bytes)) + (values widetag (primitive-object-size obj))))) + ;; SIZE is surely a fixnum. Non-fixnum would imply at least + ;; a 512MB object if 32-bit words, and is inconceivable if 64-bit. + ;; But check to be sure. + (aver (not (logtest (the fixnum size) lowtag-mask))) (unless (= typecode filler-widetag) (funcall fun obj typecode size)) - ;; This special little dance is to add a number of octets - ;; (and it had best be a number evenly divisible by our - ;; allocation granularity) to an unboxed, aligned address - ;; masquerading as a fixnum. Without consing. - (iter (%make-lisp-obj - (mask-field (byte #.n-word-bits 0) - (+ (get-lisp-obj-address start) - size)))))) - (strict-bound + (setq start (sap+ start size)))) + (when strict-bound ;; If START is not eq to END, then we have blown past our endpoint. - (aver (eq start end)))))) + #+sb-devel + (unless (sap= start end) + ;; don't make things go more wrong than they already are. + (alien-funcall (extern-alien "printf" (function void system-area-pointer)) + (vector-sap #.(format nil "map-objects-in-range failure~%"))) + (alien-funcall (extern-alien "ldb_monitor" (function void)))) + #-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 @@ -359,7 +332,6 @@ ;; of word size. This is fine for 32-bit address space, ;; but if 64-bit then we have to scale the value. Additionally ;; there is a fallback for when even the scaled value is too big. - ;; (None of this matters to Lisp code for the most part) (start #+64-bit (unsigned 32) #-64-bit signed) ;; On platforms with small enough GC pages, this field ;; will be a short. On platforms with larger ones, it'll @@ -458,41 +430,59 @@ ;; You can't specify :ALL and also a list of spaces. Check that up front. (do-rest-arg ((space) spaces) (the spaces space)) (flet ((do-1-space (space) - (ecase space - (:static - ;; Static space starts with NIL, which requires special - ;; handling, as the header and alignment are slightly off. - (multiple-value-bind (start end) (%space-bounds space) - (declare (ignore start)) - (funcall fun nil symbol-widetag (* sizeof-nil-in-words n-word-bytes)) - (let ((start (+ (logandc2 sb-vm:nil-value sb-vm:lowtag-mask) - (ash (- sizeof-nil-in-words 2) sb-vm:word-shift)))) - (map-objects-in-range fun - (ash start (- sb-vm:n-fixnum-tag-bits)) - end)))) - - ((:read-only #-gencgc :dynamic) - ;; Read-only space (and dynamic space on cheneygc) is a block - ;; of contiguous allocations. - (multiple-value-bind (start end) (%space-bounds space) - (map-objects-in-range fun start end))) - #+immobile-space - (:immobile - ;; Filter out filler objects. These either look like cons cells - ;; in fixedobj subspace, or code without enough header words - ;; in varyobj subspace. (cf 'filler_obj_p' in gc-internal.h) - (dx-flet ((filter (obj type size) - (unless (= type list-pointer-lowtag) - (funcall fun obj type size)))) - (map-immobile-objects #'filter :fixed)) - (dx-flet ((filter (obj type size) - (unless (and (code-component-p obj) - (code-obj-is-filler-p obj)) - (funcall fun obj type size)))) - (map-immobile-objects #'filter :variable))) - - #+gencgc - (:dynamic + (ecase space + (:static + ;; Static space starts with NIL, which requires special + ;; handling, as the header and alignment are slightly off. + (multiple-value-bind (start end) (%space-bounds space) + (declare (ignore start)) + (funcall fun nil symbol-widetag (* sizeof-nil-in-words n-word-bytes)) + (let ((start (+ (logandc2 sb-vm:nil-value sb-vm:lowtag-mask) + (ash (- sizeof-nil-in-words 2) sb-vm:word-shift)))) + (map-objects-in-range fun + (ash start (- sb-vm:n-fixnum-tag-bits)) + end)))) + + ((:read-only #-gencgc :dynamic) + ;; Read-only space (and dynamic space on cheneygc) is a block + ;; of contiguous allocations. + (multiple-value-bind (start end) (%space-bounds space) + (map-objects-in-range fun start end))) + #+immobile-space + (:immobile + ;; Filter out filler objects. These either look like cons cells + ;; in fixedobj subspace, or code without enough header words + ;; in varyobj subspace. (cf 'filler_obj_p' in gc-internal.h) + (dx-flet ((filter (obj type size) + (unless (= type list-pointer-lowtag) + (funcall fun obj type size)))) + (map-immobile-objects #'filter :fixed)) + (dx-flet ((filter (obj type size) + (unless (and (code-component-p obj) + (code-obj-is-filler-p obj)) + (funcall fun obj type size)))) + (map-immobile-objects #'filter :variable)))))) + (do-rest-arg ((space) spaces) + (if (eq space :dynamic) + (without-gcing #+cheneygc (do-1-space space) + #+gencgc (walk-dynamic-space fun #b1111111 0 0)) + (do-1-space space))))) + +;;; Using the mask bits you can make many different match conditions resulting +;;; from a product of {boxed,unboxed,code,any} x {large,non-large,both} +;;; e.g. mask = #b10011" constraint = "#b10010" +;;; matches "large & (unboxed | code)" +;;; +;;; I think, when iterating over only code, that if we grab the code_allocator_lock +;;; and free_pages_lock, that this can be made reliable (both crash-free and +;;; guaranteed to visit all chosen objects) despite other threads running. +;;; As things are it is only "maybe" reliable, regardless of the parameters. +#+gencgc +(defun walk-dynamic-space (fun generation-mask + page-type-mask page-type-constraint) + (declare (function fun) + (type (unsigned-byte 7) generation-mask) + (type (unsigned-byte 5) page-type-mask page-type-constraint)) ;; Dynamic space on gencgc requires walking the GC page tables ;; in order to determine what regions contain objects. @@ -508,87 +498,57 @@ ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach ;; NEXT-FREE-PAGE. We then MAP-OBJECTS-IN-RANGE if the range ;; is not empty, and proceed to the next page (unless we've hit - ;; NEXT-FREE-PAGE). We happily take advantage of the fact that - ;; MAP-OBJECTS-IN-RANGE will simply return if passed two - ;; coincident pointers for the range. + ;; NEXT-FREE-PAGE). ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent ;; closing allocation regions and opening new ones. This may ;; prove to be an issue with concurrent systems, or with ;; spectacularly poor timing for closing an allocation region ;; in a single-threaded system. - (close-current-gc-region) - (do ((initial-next-free-page next-free-page) - ;; This is a "funny" fixnum - essentially the bit cast of a pointer - (start (the fixnum (%make-lisp-obj (current-dynamic-space-start)))) - (page-index 0 (1+ page-index)) - ;; SPAN is a page count, for which an unsigned fixnum is adequate. - (span 0)) - ;; We can safely iterate up to and including next_free_page - ;; even if next_free_page is the total number of pages in the space, - ;; because there is one extra page table entry as a sentinel. - ;; The extra page always has 0 bytes used, so we'll observe the end - ;; of a contiguous block without needing a termination clause to - ;; handle a final sequence of totally full pages that exactly abut - ;; the heap end. [Also note that for our purposes, contiguous blocks - ;; can span different GC generations and page types, whereas within - ;; GC, a page ends a block if the next differs in those aspects] - ((> page-index initial-next-free-page)) - ;; The type constraint on PAGE-INDEX is probably too generous, + (close-current-gc-region) + (do ((initial-next-free-page next-free-page) + (base (int-sap (current-dynamic-space-start))) + (start-page 0) + (end-page 0) + (end-page-bytes-used 0)) + ((> start-page initial-next-free-page)) + ;; The type constraint on page indices is probably too generous, ;; but it does its job of producing efficient code. - (declare (type (integer 0 (#.(/ (ash 1 n-machine-word-bits) gencgc-card-bytes))) - page-index) - (type (and fixnum unsigned-byte) span)) - (let ((page-bytes-used ; The low bit of bytes-used is the need-to-zero flag. - (logandc1 1 (slot (deref page-table page-index) 'bytes-used)))) - (if (= page-bytes-used gencgc-card-bytes) - (incf span) - ;; RANGE-END forces funny increment of START by the extent in bytes, - ;; returning a negative fixum when the word's high bit flips. - ;; The proper way to add "funny" fixnums is via +-MODFX which for - ;; reasons unknown isn't defined on all backends. - (macrolet - ((range-end (extra) - `(truly-the fixnum - (%make-lisp-obj - (logand most-positive-word - ;; The first and third addends are known good - ;; The second needs help to avoid an expensive ASH - (+ (get-lisp-obj-address start) - (logand (* span gencgc-card-bytes) most-positive-word) - ,extra)))))) - (map-objects-in-range fun start (range-end page-bytes-used) - (< page-index initial-next-free-page)) - ;; In a certain rare situation, we must restart the next loop iteration - ;; at exactly PAGE-INDEX instead of 1+ PAGE-INDEX. - ;; Normally the contents of PAGE-INDEX are always included in the - ;; current range. But what if it contributed 0 bytes to the range? - ;; - ;; N : #x8000 bytes used - ;; N+1 : #x8000 bytes used - ;; N+2 : 0 bytes used <- PAGE-INDEX now points here - ;; N+3 : initially 0 bytes, then gets some bytes - ;; - ;; We invoked the map function with page_address(N) for #x10000 bytes. - ;; Suppose that function consed a partly unboxed object starting on - ;; page N+2 extending to page N+3, and that NEXT-FREE-PAGE was greater - ;; than both to begin with, so the termination condition isn't in play. - ;; In the best case scenario, resuming the scan at page N+3 (mid-object) - ;; would read valid widetags, but in the worst case scenario, we get - ;; random bits. Page N+2 needs a fighting chance to be the start of - ;; a range, so go back 1 page if the current page had zero bytes used - ;; and the span exceeded 1. That is, always make forward progress. - (setq start (range-end (cond ((and (zerop page-bytes-used) (plusp span)) - (decf page-index) - 0) - (t - gencgc-card-bytes))) - span 0))))))))) - - (do-rest-arg ((space) spaces) - (if (eq space :dynamic) - (without-gcing (do-1-space space)) - (do-1-space space))))) + (declare (type (integer 0 (#.(/ (ash 1 n-machine-word-bits) gencgc-card-bytes))) + start-page end-page)) + (setq end-page start-page) + (loop (setq end-page-bytes-used + ;; The low bit of bytes-used is the need-to-zero flag. + (logandc1 1 (slot (deref page-table end-page) 'bytes-used))) + ;; See 'page_ends_contiguous_block_p' in gencgc.c + (when (or (< end-page-bytes-used gencgc-card-bytes) + (= (slot (deref page-table (1+ end-page)) 'start) 0)) + (return)) + (incf end-page)) + (let ((start (sap+ base (truly-the sb-vm:signed-word + (logand (* start-page gencgc-card-bytes) + most-positive-word)))) + (end (sap+ base (truly-the sb-vm:signed-word + (logand (+ (* end-page gencgc-card-bytes) + end-page-bytes-used) + most-positive-word))))) + (when (sap> end start) + ;; The bits in the 5-bit flag field have fixed positions, + ;; but the position of the field itself depends on endianness. + (let ((flags (ldb #+little-endian (byte 5 0) #+big-endian (byte 5 3) + (slot (deref page-table start-page) 'flags)))) + ;; The GEN slot is declared as (SIGNED 8) which does not satisfy the + ;; type restriction on the first argument to LOGBITP. + ;; Masking it to 3 bits fixes that, and allows using the other 5 bits + ;; for something potentially. + (when (and (logbitp (logand (slot (deref page-table start-page) 'gen) 7) + generation-mask) + (= (logand flags page-type-mask) page-type-constraint)) + (map-objects-in-range fun + (%make-lisp-obj (sap-int start)) + (%make-lisp-obj (sap-int end)) + (< start-page initial-next-free-page)))))) + (setq start-page (1+ end-page)))) ;; Start with a Lisp rendition of ensure_region_closed() on the active ;; thread's region, since users are often surprised to learn that a @@ -874,11 +834,6 @@ ;;;; PRINT-ALLOCATED-OBJECTS -;;; This notion of page-size is completely arbitrary - it affects 2 things: -;;; (1) how much output to print "per page" in print-allocated-objects -;;; (2) sb-sprof deciding how many regions [sic] were made if #+cheneygc -(defun get-page-size () sb-c:+backend-page-bytes+) - ;;; This function is sheer madness. You're better off using ;;; LIST-ALLOCATED-OBJECTS and then iterating over that, to avoid ;;; seeing all the junk created while doing this thing. @@ -892,7 +847,7 @@ (let* ((space-start (ash start n-fixnum-tag-bits)) (space-end (ash end n-fixnum-tag-bits)) (space-size (- space-end space-start)) - (pagesize (get-page-size)) + (pagesize sb-c:+backend-page-bytes+) (start (+ space-start (round (* space-size percent) 100))) (printed-conses (make-hash-table :test 'eq)) (pages-so-far 0) @@ -1115,19 +1070,35 @@ ;; As for INSTANCE, allow the functoid to see the access form (,functoid (%fun-layout ,obj) ,@more) (,functoid (%funcallable-instance-fun ,obj) ,@more) + ;; Unfortunately for FUNCALLABLE-INSTANCEs, the relation + ;; between layout bitmap indices and indices as given to + ;; FUNCALLABLE-INSTANCE-INFO is not so obvious, and it's + ;; both tricky and unnecessary to generalize iteration. + ;; So just hardcode the few cases that exist. + #+compact-instance-header (ecase (layout-bitmap .l.) - (#.sb-kernel:+layout-all-tagged+ - (loop for .i. from instance-data-start ; exclude layout + (-1 ; external trampoline, all slots are tagged + ;; In this case, the trampoline word is scanned, with no ill effect. + (loop for .i. from 0 to (- (get-closure-length ,obj) funcallable-instance-info-offset) do (,functoid (%funcallable-instance-info ,obj .i.) ,@more))) - (#b0110 - ;; A pedantically correct kludge which shall remain unless need arises - ;; for more general partially unboxed FINs. - ;; payload word 0 is raw (but looks like a fixnum, by design) - ;; word 1 is the fin-fun which we already accounted for above - ;; word 2 (info slot 0) is the only one that hasn't been processed. - ;; words 3 and 4 are raw but looks like fixnums by accident. - (,functoid (%funcallable-instance-info ,obj 0) ,@more))))) + (#b0110 ; internal trampoline, 2 raw slots, 1 tagged slot + ;; ^ ---- trampoline + ;; ^------ implementation function + ;; ^------- (FUNCALLABLE-INSTANCE-INFO 0) + ;; and the rest of the words are raw. + (,functoid (%funcallable-instance-info ,obj 0) ,@more))) + #-compact-instance-header + (progn + (aver (eql (layout-bitmap .l.) -4)) + ;; v ----trampoline + ;; = #b1...1100 + ;; ^----- layout + ;; ^------ implementation function + ;; ^------- (FUNCALLABLE-INSTANCE-INFO 0) + (loop for .i. from 0 + to (- (get-closure-length ,obj) funcallable-instance-info-offset) + do (,functoid (%funcallable-instance-info ,obj .i.) ,@more))))) .,(make-case 'function))) ; in case there was code provided for it (t ;; TODO: the generated code is pretty horrible. OTHER-POINTER-LOWTAG @@ -1309,9 +1280,10 @@ (let ((where (+ dynamic-space-start (* page-num gencgc-card-bytes))) (seen-filler nil)) (loop - (multiple-value-bind (obj type size) - (reconstitute-object (ash where (- n-fixnum-tag-bits))) - (when (= type code-header-widetag) + (let* ((obj (let ((sap (int-sap where))) + (lispobj@baseptr sap (widetag@baseptr sap)))) + (size (primitive-object-size obj))) + (when (code-component-p obj) (incf n-code-bytes size)) (when (if (and (consp obj) (eq (car obj) 0) (eq (cdr obj) 0)) (if seen-filler @@ -1347,7 +1319,7 @@ (defun show-immobile-spaces (which) (flet ((show (obj type size) (declare (ignore type size)) - (let ((*print-pretty* nil)) + (let ((*print-pretty* nil) (*print-length* 3)) (format t "~x: ~s~%" (get-lisp-obj-address obj) obj)))) (when (or (eq which :fixed) (eq which :both)) (format t "Fixedobj space~%==============~%") @@ -1479,6 +1451,79 @@ (format t "~5d = ~s~%" n x) (setq prev n))))) +#+gencgc +(flet ((print-it (obj type size) + (declare (ignore type size)) + (let ((*print-level* 2) (*print-lines* 1)) + (format t "~x ~s~%" (get-lisp-obj-address obj) obj)))) +(defun print-all-code () + (walk-dynamic-space #'print-it #x7f #b11 #b11)) +(defun print-large-code () + (walk-dynamic-space #'print-it #x7f #b10011 #b10011)) +(defun print-large-unboxed () + (walk-dynamic-space #'print-it #x7f #b10011 #b10010)) +;;; Use this only if you know what you're doing. It can fail because a page +;;; that needs to continue onto the next page will cause the "overrun" check +;;; to fail. +(defun print-page-contents (page) + (let* ((start + (+ (current-dynamic-space-start) (* sb-vm:gencgc-card-bytes page))) + (end + (+ 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) + (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) + #+gencgc + (progn + #+immobile-code + (map-objects-in-range #'visit + (ash varyobj-space-start (- n-fixnum-tag-bits)) + (%make-lisp-obj (sap-int *varyobj-space-free-pointer*))) + (walk-dynamic-space #'visit + #b1111111 ; all generations + 3 3)))) + +(defun show-all-layouts () + (let ((l (sb-vm::list-allocated-objects :all :test #'sb-kernel::layout-p)) + zero trailing-raw trailing-tagged vanilla) + (dolist (x l) + (let ((m (sb-kernel::layout-bitmap x))) + (cond ((eql m +layout-all-tagged+) (push x vanilla)) + ((eql m 0) (push x zero)) + ((minusp m) (push x trailing-tagged)) + (t (push x trailing-raw))))) + (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)))) + (when zero + (legend nil "Zero bitmap (~d):" zero) + (dolist (x zero) (format t "~a~%" (name x)))) + (when trailing-raw + (legend t "Trailing raw (~d):" trailing-raw) + (dolist (x trailing-raw) + (let ((m (sb-kernel::layout-bitmap x))) + (format t "~30a 0...~v,'0b~%" + (name x) + (acond ((layout-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))) + (format t "~30a 1...~b~%" + (name x) + (acond ((layout-info x) (ldb (byte (dd-length it) 0) m)) + (t (ldb (byte 32 0) m))))))) + (legend t "Default: (~d) [not shown]" vanilla)))) + (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. diff -Nru sbcl-2.0.6/src/code/run-program.lisp sbcl-2.1.1/src/code/run-program.lisp --- sbcl-2.0.6/src/code/run-program.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/run-program.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -165,7 +165,7 @@ ;;; mutex is needed. More importantly the sigchld signal handler also ;;; accesses it, that's why we need without-interrupts. (defmacro with-active-processes-lock (() &body body) - `(sb-thread::with-system-mutex (*active-processes-lock*) + `(with-system-mutex (*active-processes-lock*) ,@body)) (deftype process-status () @@ -589,7 +589,8 @@ (envp (* c-string)) (pty-name c-string) (channel (array int 2)) - (dir c-string)) + (dir c-string) + (preserve-fds (* int))) #-win32 (define-alien-routine wait-for-exec @@ -649,6 +650,11 @@ (loop for arg in args collect (coerce arg 'simple-string)))) +(defmacro coerce-or-copy (object type) + `(if (typep ,object ,type) + (copy-seq ,object) + (coerce ,object ,type))) + ;;; FIXME: There shouldn't be two semiredundant versions of the ;;; documentation. Since this is a public extension function, the ;;; documentation should be in the doc string. So all information from @@ -694,26 +700,34 @@ ;;; the fork worked, and NIL if it did not. (defun run-program (program args &key - (env nil env-p) - (environment - (when env-p - (unix-environment-sbcl-from-cmucl env)) - environment-p) - (wait t) - search - #-win32 pty - input - if-input-does-not-exist - output - (if-output-exists :error) - (error :output) - (if-error-exists :error) - status-hook - (external-format :default) - directory - #+win32 (escape-arguments t)) + (env nil env-p) + (environment + (when env-p + (unix-environment-sbcl-from-cmucl env)) + environment-p) + (wait t) + search + #-win32 pty + input + if-input-does-not-exist + output + (if-output-exists :error) + (error :output) + (if-error-exists :error) + status-hook + (external-format :default) + directory + preserve-fds + #+win32 (escape-arguments t) + #+win32 (window nil)) "RUN-PROGRAM creates a new process specified by PROGRAM. -ARGS are passed as the arguments to the program. +ARGS is a list of strings to be passed literally to the new program. +In POSIX environments, this list becomes the array supplied as the second +parameter to the execv() or execvp() system call, each list element becoming +one array element. The strings should not contain shell escaping, as there is +no shell involvement. Further note that while conventionally the process +receives its own pathname in argv[0], that is automatic, and the 0th string +should not be present in ARGS. The program arguments and the environment are encoded using the default external format for streams. @@ -799,9 +813,22 @@ Specifies the directory in which the program should be run. NIL (the default) means the directory is unchanged. + :PRESERVE-FDS + A sequence of file descriptors which should remain open in the child + process. + Windows specific options: :ESCAPE-ARGUMENTS (default T) - Controls escaping of the arguments passed to CreateProcess." + Controls escaping of the arguments passed to CreateProcess. + :WINDOW (default NIL) + When NIL, the subprocess decides how it will display its window. The + following options control how the subprocess window should be displayed: + :HIDE, :SHOW-NORMAL, :SHOW-MAXIMIZED, :SHOW-MINIMIZED, :SHOW-NO-ACTIVATE, + :SHOW-MIN-NO-ACTIVE, :SHOW-NA. + Note: console application subprocesses may or may not display a console + window depending on whether the SBCL runtime is itself a console or GUI + application. Invoke CMD /C START to consistently display a console window + or use the :WINDOW :HIDE option to consistently hide the console window." (when (and env-p environment-p) (error "can't specify :ENV and :ENVIRONMENT simultaneously")) (let* (;; Clear various specials used by GET-DESCRIPTOR-FOR to @@ -871,21 +898,32 @@ (with-open-pty ((pty-name pty-stream) (pty cookie)) (setf (values child #+win32 handle) #+win32 - (sb-thread::with-system-mutex (*spawn-lock*) + (with-system-mutex (*spawn-lock*) (sb-win32::mswin-spawn progname args stdin stdout stderr - search environment-vec directory)) + search environment-vec directory + window + preserve-fds)) #-win32 - (with-args (args-vec args) - (sb-thread::with-system-mutex (*spawn-lock*) - (spawn progname args-vec - stdin stdout stderr - (if search 1 0) - environment-vec pty-name - channel - directory)))) + (let ((preserve-fds + (and preserve-fds + (sort (coerce-or-copy preserve-fds + '(simple-array (signed-byte #.(alien-size int)) (*))) + #'<)))) + (with-pinned-objects (preserve-fds) + (with-args (args-vec args) + (with-system-mutex (*spawn-lock*) + (spawn progname args-vec + stdin stdout stderr + (if search 1 0) + environment-vec pty-name + channel + directory + (if preserve-fds + (vector-sap preserve-fds) + (int-sap 0)))))))) (unless (minusp child) #-win32 (setf child (wait-for-exec child channel)) @@ -1279,7 +1317,7 @@ (t (fail "invalid option: ~S" object)))))) -#+(or linux sunos hpux haiku) +#+(or linux sunos haiku) (defun software-version () "Return a string describing version of the supporting software, or NIL if not available." diff -Nru sbcl-2.0.6/src/code/save.lisp sbcl-2.1.1/src/code/save.lisp --- sbcl-2.0.6/src/code/save.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/save.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -66,17 +66,26 @@ ;;; This variable is accessed by C code when saving. Export it to survive tree-shaker. ;;; The symbols in this set are clobbered just in time to avoid saving them to the core -;;; but not so early that we kill the running image. (Though in fact if SAVE-ERROR -;;; and hence REINIT is reached, we reassign them all anyway) +;;; but not so early that we kill the running image. (export 'sb-kernel::*save-lisp-clobbered-globals* 'sb-kernel) (define-load-time-global sb-kernel::*save-lisp-clobbered-globals* '#(sb-impl::*exit-lock* sb-thread::*make-thread-lock* sb-thread::*initial-thread* + ;; Saving *JOINABLE-THREADS* could cause catastophic failure on restart. + ;; SAVE-LISP-AND-DIE should have cleaned up, but there's a timing problem + ;; with the finalizer thread, and I'm loathe to put in a SLEEP delay. + sb-thread::*joinable-threads* sb-thread::*all-threads* sb-thread::*session* sb-kernel::*gc-epoch*)) +(defun start-lisp (toplevel) + (named-lambda start-lisp () + (handling-end-of-the-world + (reinit t) + (funcall toplevel)))) + (defun save-lisp-and-die (core-file-name &key (toplevel #'toplevel-init) (executable nil) @@ -204,20 +213,11 @@ (return-from save-lisp-and-die)))) (when (eql t compression) (setf compression -1)) - (labels ((restart-lisp () - (handling-end-of-the-world - (reinit) - ;; REINIT can not discern between a restarted image and a - ;; failure to save. It doesn't make a lot of sense to start - ;; a finalizer thread in the failed case, so we set the flag - ;; here, not in REINIT which would do it for both cases. - #+sb-thread (setq *finalizer-thread* t) - #+hpux (%primitive sb-vm::setup-return-from-lisp-stub) - (funcall toplevel))) - (foreign-bool (value) - (if value 1 0))) + (flet ((foreign-bool (value) + (if value 1 0))) (let ((name (native-namestring (physicalize-pathname core-file-name) - :as-file t))) + :as-file t)) + (startfun (start-lisp toplevel))) (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 @@ -237,8 +237,8 @@ sb-disassem::*disassem-inst-space* nil) ;; Save the restart function. Logically a passed argument, but can't be, ;; as it would require pinning around the whole save operation. - (with-pinned-objects (#'restart-lisp) - (setf lisp-init-function (get-lisp-obj-address #'restart-lisp))) + (with-pinned-objects (startfun) + (setf lisp-init-function (get-lisp-obj-address startfun))) ;; Do a destructive non-conservative GC, and then save a core. ;; A normal GC will leave huge amounts of storage unreclaimed ;; (over 50% on x86). This needs to be done by a single function @@ -260,7 +260,7 @@ (if purify (purify :root-structures root-structures) (gc)) (without-gcing (save name - (get-lisp-obj-address #'restart-lisp) + (get-lisp-obj-address startfun) (foreign-bool executable) (foreign-bool save-runtime-options) (foreign-bool compression) @@ -271,7 +271,7 @@ ;; Something went very wrong -- reinitialize to have a prayer ;; of being able to report the error. (restore-fd-streams) - (reinit) + (reinit nil) (error 'save-error))) (defun tune-image-for-dump () @@ -301,42 +301,31 @@ #+sb-wtimer (itimer-emulation-deinit) #+sb-thread - (progn - ;; Terminate finalizer thread now, especially given that the thread runs - ;; user-supplied code that might not even work in later steps of deinit. - ;; See also the comment at definition of THREAD-EPHEMERAL-P. - (finalizer-thread-stop) - (let ((threads (sb-thread:list-all-threads))) - (when (cdr threads) - ;; Despite calling FINALIZER-THREAD-STOP, an unlucky thread schedule - ;; courtesy of the OS might notionally start the finalizer thread but not - ;; run it until now. Suppose it barely got to its lisp trampoline, - ;; at which point we see it in *ALL-THREADS* not having observed it - ;; in *FINALIZER-THREAD*. FINALIZER-THREAD-STOP didn't know to stop it. - ;; Without adding significantly more synchronization, the best recourse - ;; is to consider it as nonexistent whenever it was "stopped". - ;; A newly started finalizer thread can do nothing but exit immediately - ;; whenever *FINALIZER-THREAD* is NIL so we don't actually care - ;; what that thread is doing at this point. - (let ((finalizer (find-if (lambda (x) - (and (sb-thread::thread-%ephemeral-p x) - (string= (sb-thread:thread-name x) "finalizer"))) - threads))) - (when finalizer - (sb-thread:join-thread finalizer))) - ;; Regardless of what happened above, grab the all-threads list again. - (setq threads (sb-thread:list-all-threads))) - (when (cdr threads) - (let* ((interactive (sb-thread::interactive-threads)) - (other (set-difference threads interactive))) - (error 'save-with-multiple-threads-error - :interactive-threads interactive - :other-threads other))))) + (let (err) + (with-system-mutex (sb-thread::*make-thread-lock*) + (finalizer-thread-stop) + #+pauseless-threadstart (sb-thread::join-pthread-joinables #'identity) + (let ((threads (sb-thread:list-all-threads)) + (starting + (setq sb-thread::*starting-threads* ; ordinarily pruned in MAKE-THREAD + (delete 0 sb-thread::*starting-threads*))) + (joinable sb-thread::*joinable-threads*)) + (when (or (cdr threads) starting joinable) + (let* ((interactive (sb-thread::interactive-threads)) + (other (union (set-difference threads interactive) + (union starting joinable)))) + (make-condition 'save-with-multiple-threads-error + :interactive-threads interactive + :other-threads other))))) + (when err (error err))) (tune-image-for-dump) (float-deinit) (profile-deinit) (foreign-deinit) - (fill *pathnames* nil) + ;; To have any hope of making pathname interning actually work, + ;; this CLRHASH would need to be removed. But removing it causes excess + ;; garbage retention because weakness doesn't work. It's a catch-22. + (clrhash *pathnames*) ;; Clean up the simulated weak list of covered code components. (rplacd sb-c:*code-coverage-info* (delete-if-not #'weak-pointer-value (cdr sb-c:*code-coverage-info*))) @@ -468,7 +457,7 @@ (sb-vm:do-referenced-object (obj examine) (simple-vector :extend - (when (and written (logtest sb-vm:vector-addr-hashing-subtype + (when (and written (logtest sb-vm:vector-addr-hashing-flag (get-header-data obj))) (setf (svref obj 1) 1)))))))))) ; set need-to-rehash @@ -494,8 +483,10 @@ (#.sb-vm:code-header-widetag (let ((di (sb-vm::%%code-debug-info obj))) ;; Discard memoized debugger's debug info - (when (and (consp di) (neq obj sb-fasl:*assembler-routines*)) - (setf (%code-debug-info obj) (car di)))) + (when (typep di 'sb-c::compiled-debug-info) + (let ((thing (sb-c::compiled-debug-info-tlf-num+offset di))) + (when (consp thing) + (setf (sb-c::compiled-debug-info-tlf-num+offset di) (car thing)))))) (dotimes (i (sb-kernel:code-n-entries obj)) (let* ((fun (sb-kernel:%code-entry-point obj i)) (arglist (%simple-fun-arglist fun)) diff -Nru sbcl-2.0.6/src/code/sc-offset.lisp sbcl-2.1.1/src/code/sc-offset.lisp --- sbcl-2.0.6/src/code/sc-offset.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/sc-offset.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -19,7 +19,9 @@ ;;;; +SC+OFFSET-OFFSET-BYTES+ and exported to sc-offset.h during ;;;; genesis for use by the runtime. -(deftype sc+offset () +;;; This has to be DEF!TYPE because it appears in COMPILED-DEBUG-FUN +;;; which is DEF!STRUCT. +(def!type sc+offset () `(unsigned-byte ,(+ sb-vm:sc-number-bits sb-vm:sc-offset-bits))) (defconstant-eqx +sc+offset-scn-bytes+ diff -Nru sbcl-2.0.6/src/code/seq.lisp sbcl-2.1.1/src/code/seq.lisp --- sbcl-2.0.6/src/code/seq.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/seq.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -32,12 +32,12 @@ `((count nil nil (etypecase count - (null (1- sb-xc:most-positive-fixnum)) + (null (1- most-positive-fixnum)) (fixnum (max 0 count)) (integer (if (minusp count) 0 - (1- sb-xc:most-positive-fixnum)))) - (mod #.sb-xc:most-positive-fixnum)) + (1- most-positive-fixnum)))) + (mod #.most-positive-fixnum)) ;; Entries for {start,end}{,1,2} ,@(mapcan (lambda (names) (destructuring-bind (start end length sequence) names @@ -958,6 +958,7 @@ ((atom 2nd) 3rd) (rplacd 2nd 3rd))) +(declaim (inline nreverse-word-specialized-vector)) (defun nreverse-word-specialized-vector (vector start end) (do ((left-index start (1+ left-index)) (right-index (1- end) (1- right-index))) @@ -1422,17 +1423,15 @@ (setf (car node) (apply really-fun args)) (setf node (cdr node))))) (sequence - (multiple-value-bind (iter limit from-end) + (multiple-value-bind (iter limit from-end step endp elt set) (sb-sequence:make-sequence-iterator result-sequence) + (declare (ignore elt) (type function step endp set)) (map-into-lambda sequences (&rest args) (declare (truly-dynamic-extent args) (optimize speed)) - (when (sb-sequence:iterator-endp result-sequence - iter limit from-end) + (when (funcall endp result-sequence iter limit from-end) (return-from map-into result-sequence)) - (setf (sb-sequence:iterator-element result-sequence iter) - (apply really-fun args)) - (setf iter (sb-sequence:iterator-step result-sequence - iter from-end))))))) + (funcall set (apply really-fun args) result-sequence iter) + (setf iter (funcall step result-sequence iter from-end))))))) result-sequence) ;;;; REDUCE diff -Nru sbcl-2.0.6/src/code/setf-funs.lisp sbcl-2.1.1/src/code/setf-funs.lisp --- sbcl-2.0.6/src/code/setf-funs.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/setf-funs.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -57,7 +57,7 @@ (let ((type (type-specifier (global-ftype sym)))) (aver (consp type)) (list - #-sb-fluid `(declaim (inline (setf ,sym))) + `(declaim (inline (setf ,sym))) (compute-one-setter sym type)))) (sort (res) #'string<))))) diff -Nru sbcl-2.0.6/src/code/setf.lisp sbcl-2.1.1/src/code/setf.lisp --- sbcl-2.0.6/src/code/setf.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/setf.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -46,14 +46,14 @@ ;;; of value forms, a list of the single store-value form, a storing function, ;;; and an accessing function. (declaim (ftype (function (t &optional lexenv-designator)) - sb-xc:get-setf-expansion)) -(defun sb-xc:get-setf-expansion (form &optional environment) + get-setf-expansion)) +(defun get-setf-expansion (form &optional environment) "Return five values needed by the SETF machinery: a list of temporary variables, a list of values with which to fill them, a list of temporaries for the new values, the setting function, and the accessing function." (named-let retry ((form form)) (labels ((newvals (count) - (let ((sb-xc:*gensym-counter* 1)) + (let ((*gensym-counter* 1)) (make-gensym-list count "NEW"))) ;; Produce the expansion of a SETF form that calls either ;; #'(SETF name) or an inverse given by short form DEFSETF. @@ -68,7 +68,7 @@ (multiple-value-bind (expansion expanded) ;; Previously this called %MACROEXPAND, but the two operations ;; are equivalent on atoms, so do the one that is "less". - (sb-xc:macroexpand-1 form environment) + (macroexpand-1 form environment) (if expanded (retry expansion) (let ((vals (newvals 1))) @@ -186,7 +186,7 @@ :setf (list (cadr place) value-form) it))))) (multiple-value-bind (temps vals newval setter) - (sb-xc:get-setf-expansion place env) + (get-setf-expansion place env) (car (gen-let* (mapcar #'list temps vals) (gen-mv-bind newval value-form (forms-list setter))))))) @@ -202,7 +202,7 @@ (collect ((let*-bindings) (mv-bindings) (setters) (getters)) (dolist (arg (butlast args)) (multiple-value-bind (temps subforms store-vars setter getter) - (sb-xc:get-setf-expansion arg env) + (get-setf-expansion arg env) (let*-bindings (mapcar #'list temps subforms)) (mv-bindings store-vars) (setters setter) @@ -239,7 +239,7 @@ (when (and (not (symbolp place)) (eq operator 'psetq)) (%program-error "Place ~S in PSETQ is not a SYMBOL" place)) (multiple-value-bind (temps vals stores setter) - (sb-xc:get-setf-expansion place env) + (get-setf-expansion place env) (let*-bindings (mapcar #'list temps vals)) (mv-bindings (cons stores value-form)) (setters setter)))) @@ -276,7 +276,7 @@ (collect ((let*-bindings) (mv-bindings) (setters) (getters)) (dolist (arg args) (multiple-value-bind (temps subforms store-vars setter getter) - (sb-xc:get-setf-expansion arg env) + (get-setf-expansion arg env) (let*-bindings (mapcar #'list temps subforms)) (mv-bindings store-vars) (setters setter) @@ -321,7 +321,7 @@ (if (symbolp (setq place (macroexpand-for-setf place env))) `(prog1 (car ,place) (setq ,place (cdr ,place))) (multiple-value-bind (temps vals stores setter getter) - (sb-xc:get-setf-expansion place env) + (get-setf-expansion place env) (let ((list (copy-symbol 'list)) (ret (copy-symbol 'car))) `(let* (,@(mapcar #'list temps vals) @@ -338,7 +338,7 @@ remove the property specified by the indicator. Returns T if such a property was present, NIL if not." (multiple-value-bind (temps vals newval setter getter) - (sb-xc:get-setf-expansion place env) + (get-setf-expansion place env) (let* ((flag (make-symbol "FLAG")) (body `(multiple-value-bind (,(car newval) ,flag) ;; See ANSI 5.1.3 for why we do out-of-order evaluation @@ -380,7 +380,7 @@ (if (symbolp (setq place (macroexpand-for-setf place env))) `(setq ,place (,operator ,delta ,place)) (multiple-value-bind (dummies vals newval setter getter) - (sb-xc:get-setf-expansion place env) + (get-setf-expansion place env) `(let* (,@(mapcar #'list dummies vals) (,(car newval) (,operator ,delta ,getter)) ,@(cdr newval)) @@ -519,7 +519,7 @@ (let ((mask 0) (bit 1)) (dolist (form sexprs (values (temp-vars) (temp-vals) (call-arguments) mask)) - (call-arguments (if (sb-xc:constantp form environment) + (call-arguments (if (constantp form environment) (progn (next-name-hint) form) ; Skip one hint. (let ((temp (nice-tempname form))) (setq mask (logior mask bit)) @@ -541,7 +541,7 @@ (binding* (((before-temps before-vals before-args) (collect-setf-temps before-arg-forms environment name-hints)) ((place-temps place-subforms stores setter getter) - (sb-xc:get-setf-expansion place environment)) + (get-setf-expansion place environment)) ((after-temps after-vals after-args) (if after-args-bindp (collect-setf-temps after-arg-forms environment name-hints) @@ -558,7 +558,7 @@ (every (lambda (x) (or (member x place-temps) (eq x newval-temp) - (sb-xc:constantp x environment))) + (constantp x environment))) (cdr setter))))) (setq newval-binding nil setter (substitute compute newval-temp setter))) @@ -582,7 +582,7 @@ ;; 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 - 'sb-xc:define-setf-expander access-fn + '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) diff -Nru sbcl-2.0.6/src/code/share-vm.lisp sbcl-2.1.1/src/code/share-vm.lisp --- sbcl-2.0.6/src/code/share-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/share-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -19,7 +19,7 @@ #+(or x86 x86-64) `(progn ,@body) #-(or x86 x86-64) - `(with-pinned-objects ((without-gcing + `(with-pinned-objects ((with-code-pages-pinned (:dynamic) (sb-di::code-object-from-context ,context))) ,@body)) diff -Nru sbcl-2.0.6/src/code/sharpm.lisp sbcl-2.1.1/src/code/sharpm.lisp --- sbcl-2.0.6/src/code/sharpm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/sharpm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -236,6 +236,9 @@ ;; though the docs say this is undefined behavior, so it's ok, ;; other than it being something we should complain about ;; for portability reasons. + ;; Some other things that shouldn't work: + ;; * (read-from-string "#x a") => 10 + ;; * (read-from-string "#x #+foo a b") => 11 (let ((res (let ((*read-base* radix)) (read stream t nil t)))) (unless (typep res 'rational) @@ -295,7 +298,7 @@ ;; 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-info (%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)))))) @@ -303,16 +306,12 @@ (i sb-vm:instance-data-start (1+ i))) ((>= i len)) (process (%instance-ref tree i))))) - ;; It is not safe to iterate over %FUNCALLABLE-INSTANCE-INFO without knowing - ;; where the raw slots are, if any. We can safely process FSC-INSTANCE-SLOTS - ;; though, and that's the *only* slot to look at. - ;; No other funcallable structure (%METHOD-FUNCTION, INTERPRETED-FUNCTION, etc) - ;; has a reader syntax. - ;; ASSUMPTION: all funcallable structures have at least 1 slot beyond - ;; %FUNCALLABLE-INSTANCE-FUN (overlapping with FSC-INSTANCE-SLOTS) - ;; and that slot is never a raw slot. + ;; ASSUMPTION: all funcallable instances have at least 1 slot + ;; accessible via FUNCALLABLE-INSTANCE-INFO. + ;; The only such objects with reader syntax are CLOS objects, + ;; and those have exactly 1 slot in the primitive object. (funcallable-instance - (process (sb-pcl::%fsc-instance-slots tree)))))) + (process (%funcallable-instance-info tree 0)))))) tree))) ;;; Sharp-equal works as follows. @@ -434,7 +433,6 @@ 'sb-kernel::character-decoding-error-in-dispatch-macro-char-comment :sub-char sub-char :position (file-position stream) :stream stream) (invoke-restart 'attempt-resync)))) - (let ((stream (in-stream-from-designator stream))) (macrolet ((munch (get-char &optional finish) `(do ((level 1) (prev ,get-char char) @@ -453,7 +451,7 @@ (prepare-for-fast-read-char stream (munch (fast-read-char) (done-with-fast-read-char))) ;; fundamental-stream - (munch (read-char stream t))))))) + (munch (read-char stream t)))))) ;;;; a grab bag of other sharp readmacros: #', #:, and #. diff -Nru sbcl-2.0.6/src/code/simple-fun.lisp sbcl-2.1.1/src/code/simple-fun.lisp --- sbcl-2.0.6/src/code/simple-fun.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/simple-fun.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -383,16 +383,13 @@ ;; return it unchanged in all other cases info))) -(defun %code-entry-points (code-obj) ; DO NOT USE IN NEW CODE - (%code-entry-point code-obj 0)) - (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) ;; and filler_obj_p() in the C code (eql (sb-vm::%code-boxed-size code-obj) 0)) -#+(or sparc alpha hppa ppc64) +#+(or sparc ppc64) (defun code-trailer-ref (code offset) (with-pinned-objects (code) (sap-ref-32 (int-sap (get-lisp-obj-address code)) @@ -473,11 +470,6 @@ (values (%primitive sb-c:compute-fun code-obj (%code-fun-offset code-obj fun-index)))))) -(defun code-entry-points (code-obj) ; FIXME: obsolete - (let ((a (make-array (code-n-entries code-obj)))) - (dotimes (i (length a) a) - (setf (aref a i) (%code-entry-point code-obj i))))) - ;;; Return the 0-based index of SIMPLE-FUN within its code component. ;;; Computed via binary search. (defun %simple-fun-index (simple-fun) @@ -633,8 +625,15 @@ (in-package "SB-C") +;;; Decode the packed TLF-NUM+OFFSET slot, which might have ancillary +;;; data for the debugger pushed in. So if it's a cons, take the CDR. ;;; This is target-only code, so doesn't belong in 'debug-info.lisp' -(flet ((unpack-tlf-num+offset (integer &aux (bytepos 0)) +(flet ((unpack-tlf-num+offset (cdi &aux (tlf-num+offset + (compiled-debug-info-tlf-num+offset cdi)) + (integer (if (consp tlf-num+offset) + (car tlf-num+offset) + tlf-num+offset)) + (bytepos 0)) (flet ((unpack-1 () (let ((shift 0) (acc 0)) (declare (notinline sb-kernel:%ldb)) ; lp#1573398 @@ -650,9 +649,6 @@ (values (if (eql v1 0) nil (1- v1)) (if (eql v2 0) nil (1- v2))))))) (defun compiled-debug-info-tlf-number (cdi) - (nth-value 0 (unpack-tlf-num+offset - (compiled-debug-info-tlf-num+offset cdi)))) - + (nth-value 0 (unpack-tlf-num+offset cdi))) (defun compiled-debug-info-char-offset (cdi) - (nth-value 1 (unpack-tlf-num+offset - (compiled-debug-info-tlf-num+offset cdi))))) + (nth-value 1 (unpack-tlf-num+offset cdi)))) diff -Nru sbcl-2.0.6/src/code/source-location.lisp sbcl-2.1.1/src/code/source-location.lisp --- sbcl-2.0.6/src/code/source-location.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/source-location.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -84,7 +84,7 @@ (or *source-namestring* (when source-info (make-file-info-namestring - *compile-file-pathname* + cl:*compile-file-pathname* (get-toplevelish-file-info source-info))))) tlf-number form-number) diff -Nru sbcl-2.0.6/src/code/sparc-vm.lisp sbcl-2.1.1/src/code/sparc-vm.lisp --- sbcl-2.0.6/src/code/sparc-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/sparc-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,39 +11,15 @@ (in-package "SB-VM") ;;; See x86-vm.lisp for a description of this. -#-sb-xc-host (defun machine-type () "Returns a string describing the type of the local machine." "SPARC") - -(defconstant-eqx +fixup-kinds+ #(:call :sethi :add :absolute) #'equalp) -(!with-bigvec-or-sap -(defun fixup-code-object (code offset fixup kind flavor) - (declare (type index offset)) - (declare (ignore flavor)) - (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) - (error "Unaligned instruction? offset=#x~X." offset)) - (let ((sap (code-instructions code))) - (ecase kind - (:call - (error "Can't deal with CALL fixups, yet.")) - (:sethi - (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) - (ldb (byte 22 10) fixup))) - (:add - (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) - (ldb (byte 10 0) fixup))) - (:absolute - (setf (sap-ref-32 sap offset) - fixup)))) - nil)) ;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp. ;;;; ;;;; See also x86-vm for commentary on signed vs unsigned. -#-sb-xc-host (progn ;;; This is like CONTEXT-REGISTER, but returns the value of a float ;;; register. FORMAT is the type of float to return. @@ -87,4 +63,3 @@ (trap-number (sap-ref-8 pc 3))) (declare (type system-area-pointer pc)) (sb-kernel::decode-internal-error-args (sap+ pc 4) trap-number))) -) ; end PROGN diff -Nru sbcl-2.0.6/src/code/stream.lisp sbcl-2.1.1/src/code/stream.lisp --- sbcl-2.0.6/src/code/stream.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/stream.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -117,8 +117,7 @@ (maybe-resolve-synonym-stream result) result))) -(defun ansi-stream-input-stream-p (stream) - (declare (type ansi-stream stream)) +(defmethod input-stream-p ((stream ansi-stream)) (if (synonym-stream-p stream) (input-stream-p (resolve-synonym-stream stream)) (and (not (eq (ansi-stream-in stream) #'closed-flame)) @@ -129,60 +128,34 @@ (or (not (eq (ansi-stream-in stream) #'ill-in)) (not (eq (ansi-stream-bin stream) #'ill-bin)))))) -;;; Temporary definition that gets overwritten by pcl/gray-streams -(defun input-stream-p (stream) - (declare (type stream stream)) - (and (ansi-stream-p stream) - (ansi-stream-input-stream-p stream))) - -(defun ansi-stream-output-stream-p (stream) - (declare (type ansi-stream stream)) +(defmethod output-stream-p ((stream ansi-stream)) (if (synonym-stream-p stream) (output-stream-p (resolve-synonym-stream stream)) (and (not (eq (ansi-stream-in stream) #'closed-flame)) (or (not (eq (ansi-stream-out stream) #'ill-out)) (not (eq (ansi-stream-bout stream) #'ill-bout)))))) -;;; Temporary definition that gets overwritten by pcl/gray-streams -(defun output-stream-p (stream) - (declare (type stream stream)) - (and (ansi-stream-p stream) - (ansi-stream-output-stream-p stream))) - -(declaim (inline ansi-stream-open-stream-p)) -(defun ansi-stream-open-stream-p (stream) - (declare (type ansi-stream stream)) - ;; CLHS 22.1.4 lets us not worry about synonym streams here. +(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))) -(defun open-stream-p (stream) - (ansi-stream-open-stream-p stream)) - -(declaim (inline ansi-stream-element-type)) -(defun ansi-stream-element-type (stream) - (declare (type ansi-stream stream)) - (funcall (ansi-stream-misc stream) stream :element-type)) - -(defun stream-element-type (stream) - (ansi-stream-element-type stream)) +(defmethod stream-element-type ((stream ansi-stream)) + (call-ansi-stream-misc stream :element-type)) (defun stream-external-format (stream) - (funcall (ansi-stream-misc stream) stream :external-format)) - -(defun interactive-stream-p (stream) - (declare (type stream stream)) - (funcall (ansi-stream-misc stream) stream :interactive-p)) - -(declaim (inline ansi-stream-close)) -(defun ansi-stream-close (stream abort) - (declare (type ansi-stream stream)) - (when (ansi-stream-open-stream-p stream) - (funcall (ansi-stream-misc stream) stream :close abort)) + (stream-api-dispatch (stream) + :simple (s-%stream-external-format stream) + :gray (error "~S is not defined for ~S" 'stream-external-format stream) + :native (call-ansi-stream-misc stream :external-format))) + +(defmethod interactive-stream-p ((stream ansi-stream)) + (call-ansi-stream-misc stream :interactive-p)) + +(defmethod close ((stream ansi-stream) &key abort) + (unless (eq (ansi-stream-in stream) #'closed-flame) + (call-ansi-stream-misc stream :close abort)) t) -(defun close (stream &key abort) - (ansi-stream-close stream abort)) - (defun set-closed-flame (stream) (setf (ansi-stream-in stream) #'closed-flame) (setf (ansi-stream-bin stream) #'closed-flame) @@ -205,25 +178,20 @@ (defun external-format-char-size (external-format) (ef-char-size (get-external-format external-format))) -;;; Call the MISC method with the :FILE-POSITION operation. -#-sb-fluid (declaim (inline ansi-stream-file-position)) -(defun ansi-stream-file-position (stream position) +;;; Call the MISC method with the :GET-FILE-POSITION operation. +(declaim (inline !ansi-stream-ftell)) ; named for the stdio inquiry function +(defun !ansi-stream-ftell (stream) (declare (type stream stream)) - (declare (type (or index (alien sb-unix:unix-offset) (member nil :start :end)) - position)) ;; FIXME: It would be good to comment on the stuff that is done here... ;; FIXME: This doesn't look interrupt safe. - (cond - (position - (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc stream) stream :file-position position)) - (t - (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil))) - (when res + (let ((res (call-ansi-stream-misc stream :get-file-position)) + (delta (- +ansi-stream-in-buffer-length+ + (ansi-stream-in-index stream)))) + (if (eql delta 0) + res + (when res #-sb-unicode - (- res - (- +ansi-stream-in-buffer-length+ - (ansi-stream-in-index stream))) + (- res delta) #+sb-unicode (let ((char-size (if (fd-stream-p stream) (fd-stream-char-size stream) @@ -236,17 +204,54 @@ for i from start below +ansi-stream-in-buffer-length+ sum (funcall char-size (aref buffer i)))) (fixnum - (* char-size - (- +ansi-stream-in-buffer-length+ - (ansi-stream-in-index stream)))))))))))) + (* char-size delta))))))))) -(defun file-position (stream &optional position) - (if (ansi-stream-p stream) - (ansi-stream-file-position stream position) - (let ((result (stream-file-position stream position))) - (if (numberp result) - result - (and result t))))) +;;; You're not allowed to specify NIL for the position but we were permitting +;;; it, which made it impossible to test for a bad call that tries to assign +;;; the position, versus a inquiry for the current position. +;;; CLHS specifies: file-position stream position-spec => success-p +;;; and position-spec is a "file position designator" which precludes NIL +;;; but the implementation methods can't detect supplied vs unsupplied. +;;; What a fubar API at the CL: layer. Was #'(SETF FILE-POSITION) not invented? +(defun file-position (stream &optional (position 0 suppliedp)) + (if suppliedp + ;; Setter + (let ((arg (the (or index (alien sb-unix:unix-offset) (member :start :end)) + position))) + (stream-api-dispatch (stream) + :native (progn + (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) + (call-ansi-stream-misc stream :set-file-position arg)) + ;; The impl method is expected to return a success indication as + ;; a generalized boolean. + :simple (s-%file-position stream arg) + ;; I think our fndb entry is overconstrained - it says that this returns + ;; either unsigned-byte or strict boolean, however CLHS says that setting + ;; FILE-POSITION returns a /generalized boolean/. + ;; A stream-specific method should be allowed to convey more information + ;; than T/NIL yet we are forced to discard that information, + ;; lest the return value constraint on this be violated. + :gray (let ((result (stream-file-position stream arg))) + (if (numberp result) result (and result t))))) + ;; Getter + (let ((result (stream-api-dispatch (stream) + :native (!ansi-stream-ftell stream) + :simple (s-%file-position stream nil) + :gray (stream-file-position stream)))) + (the (or unsigned-byte null) result)))) + +(defmethod stream-file-position ((stream ansi-stream) &optional position) + ;; Excuse me for asking, but why is this even a thing? + ;; Users are not supposed to call the stream implementation directly, + ;; they're supposed to call the function in the CL: package + ;; which indirects to this. But if they do ... make it work. + ;; And note that inlining of !ansi-stream-file-position would be pointless, + ;; it's nearly 1K of code. + ;; Oh, this is srsly wtf now. If POSITION is NIL, + ;; then you must not call FILE-POSITION with both arguments. + (if position + (file-position stream position) + (file-position stream))) ;;; This is a literal translation of the ANSI glossary entry "stream ;;; associated with a file". @@ -289,7 +294,10 @@ stream))) (defun file-string-length (stream object) - (funcall (ansi-stream-misc stream) stream :file-string-length object)) + (stream-api-dispatch (stream) + :gray (declare (ignore stream)) + :simple (s-%file-string-length stream object) + :native (call-ansi-stream-misc stream :file-string-length object))) ;;;; input functions @@ -334,60 +342,72 @@ (progn (done-with-fast-read-char) (eof-or-lose stream eof-error-p (values eof-value t)))))))) -#-sb-fluid (declaim (inline ansi-stream-read-line)) -(defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p) - (declare (ignore recursive-p)) +;; to potentially avoid consing a bufer on sucessive calls to read-line +;; (just consing the result string) +(define-load-time-global *read-line-buffers* nil) +(declaim (list *read-line-buffers*)) + +(declaim (inline ansi-stream-read-line)) +(defun ansi-stream-read-line (stream eof-error-p eof-value) (if (ansi-stream-cin-buffer stream) ;; Stream has a fast-read-char buffer. Copy large chunks directly ;; out of the buffer. (ansi-stream-read-line-from-frc-buffer stream eof-error-p eof-value) ;; Slow path, character by character. - (prepare-for-fast-read-char stream - (let ((res (make-string 80)) - (len 80) - (index 0)) - (loop - (let ((ch (fast-read-char nil nil))) - (cond (ch - (when (char= ch #\newline) - (done-with-fast-read-char) - (return (values (%shrink-vector res index) nil))) + ;; There is no need to use PREPARE-FOR-FAST-READ-CHAR + ;; because the CIN-BUFER is known to be NIL. + (let ((ch (funcall (ansi-stream-in stream) stream nil 0))) + (case ch + (#\newline (values "" nil)) + (0 (values (eof-or-lose stream eof-error-p eof-value) t)) + (t + (let* ((buffer (or (atomic-pop *read-line-buffers*) + (make-string 128))) + (res buffer) + (len (length res)) + (eof) + (index 0)) + (declare (type (simple-array character (*)) buffer)) + (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (index index)) + (setf (schar res index) (truly-the character ch)) + (incf index) + (loop (case (setq ch (funcall (ansi-stream-in stream) stream nil 0)) + (#\newline (return)) + (0 (return (setq eof t))) + (t (when (= index len) (setq len (* len 2)) (let ((new (make-string len))) (replace new res) (setq res new))) - (setf (schar res index) ch) - (incf index)) - ((zerop index) - (done-with-fast-read-char) - (return (values (eof-or-lose stream - eof-error-p - eof-value) - t))) - ;; Since FAST-READ-CHAR already hit the eof char, we - ;; shouldn't do another READ-CHAR. - (t - (done-with-fast-read-char) - (return (values (%shrink-vector res index) t)))))))))) + (setf (schar res index) (truly-the character ch)) + (incf index)))) + (if (eq res buffer) + (setq res (subseq buffer 0 index)) + (%shrink-vector res index)) + ;; Do not push an enlarged buffer, only the original one. + (atomic-push buffer *read-line-buffers*) + (values res eof))))))) (defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p) (declare (explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (if (ansi-stream-p stream) - (ansi-stream-read-line stream eof-error-p eof-value recursive-p) - ;; must be Gray streams FUNDAMENTAL-STREAM + (declare (ignore recursive-p)) + (stream-api-dispatch (stream (in-stream-from-designator stream)) + :simple (s-%read-line stream eof-error-p eof-value) + :native (ansi-stream-read-line stream eof-error-p eof-value) + :gray (multiple-value-bind (string eof) (stream-read-line stream) (if (and eof (zerop (length string))) (values (eof-or-lose stream eof-error-p eof-value) t) - (values string eof)))))) + (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. -#-sb-fluid (declaim (inline read-char unread-char read-byte listen)) +(declaim (inline read-char unread-char read-byte)) -#-sb-fluid (declaim (inline ansi-stream-read-char)) +(declaim (inline ansi-stream-read-char)) (defun ansi-stream-read-char (stream eof-error-p eof-value recursive-p) (declare (ignore recursive-p)) (prepare-for-fast-read-char stream @@ -400,16 +420,20 @@ eof-value recursive-p) (declare (explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (if (ansi-stream-p stream) - (ansi-stream-read-char stream eof-error-p eof-value recursive-p) - ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-api-dispatch (stream (in-stream-from-designator stream)) + :native (ansi-stream-read-char stream eof-error-p eof-value recursive-p) + ;; The final T is BLOCKING-P. I removed the ignored recursive-p arg. + :simple (let ((char (s-%read-char stream eof-error-p eof-value t))) + (if (eq char eof-value) + char + (the character char))) + :gray (let ((char (stream-read-char stream))) (if (eq char :eof) (eof-or-lose stream eof-error-p eof-value) - (the character char)))))) + (the character char))))) -#-sb-fluid (declaim (inline ansi-stream-unread-char)) +(declaim (inline ansi-stream-unread-char)) (defun ansi-stream-unread-char (character stream) (let ((index (1- (ansi-stream-in-index stream))) (buffer (ansi-stream-cin-buffer stream))) @@ -423,39 +447,39 @@ (when (ansi-stream-input-char-pos stream) (decf (ansi-stream-input-char-pos stream)))) (t - (funcall (ansi-stream-misc stream) stream - :unread character))))) + (call-ansi-stream-misc stream :unread character))))) (defun unread-char (character &optional (stream *standard-input*)) (declare (explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (if (ansi-stream-p stream) - (ansi-stream-unread-char character stream) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-unread-char stream character))) + (stream-api-dispatch (stream (in-stream-from-designator stream)) + :simple (s-%unread-char stream character) + :native (ansi-stream-unread-char character stream) + :gray (stream-unread-char stream character)) nil) -#-sb-fluid (declaim (inline ansi-stream-listen)) -(defun ansi-stream-listen (stream) +(declaim (inline %ansi-stream-listen)) +(defun %ansi-stream-listen (stream) (or (/= (the fixnum (ansi-stream-in-index stream)) +ansi-stream-in-buffer-length+) - ;; Handle :EOF return from misc methods specially - (let ((result (funcall (ansi-stream-misc stream) stream :listen))) - (if (eq result :eof) - nil - result)))) + (call-ansi-stream-misc stream :listen))) + +(declaim (inline ansi-stream-listen)) +(defun ansi-stream-listen (stream) + (let ((result (%ansi-stream-listen stream))) + (if (eq result :eof) + nil + result))) (defun listen (&optional (stream *standard-input*)) (declare (explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (if (ansi-stream-p stream) - (ansi-stream-listen stream) - ;; Fall through to Gray streams FUNDAMENTAL-STREAM case. - (stream-listen stream)))) + (stream-api-dispatch (stream (in-stream-from-designator stream)) + :simple (error "Unimplemented") ; gets redefined + :native (ansi-stream-listen stream) + :gray (stream-listen stream))) -#-sb-fluid (declaim (inline ansi-stream-read-char-no-hang)) +(declaim (inline ansi-stream-read-char-no-hang)) (defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p) - (if (funcall (ansi-stream-misc stream) stream :listen) + (if (%ansi-stream-listen stream) ;; On T or :EOF get READ-CHAR to do the work. (ansi-stream-read-char stream eof-error-p eof-value recursive-p) nil)) @@ -465,31 +489,33 @@ eof-value recursive-p) (declare (explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (if (ansi-stream-p stream) + (stream-api-dispatch (stream (in-stream-from-designator stream)) + :native (ansi-stream-read-char-no-hang stream eof-error-p eof-value recursive-p) - ;; must be Gray streams FUNDAMENTAL-STREAM + ;; Absence of EOF-OR-LOSE here looks a little suspicious + ;; considering that the impl function didn't use recursive-p + :simple (s-%read-char-no-hang stream eof-error-p eof-value) + :gray (let ((char (stream-read-char-no-hang stream))) (if (eq char :eof) (eof-or-lose stream eof-error-p eof-value) - (the (or character null) char)))))) + (the (or character null) char))))) -#-sb-fluid (declaim (inline ansi-stream-clear-input)) +(declaim (inline ansi-stream-clear-input)) (defun ansi-stream-clear-input (stream) (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc stream) stream :clear-input)) + (call-ansi-stream-misc stream :clear-input)) (defun clear-input (&optional (stream *standard-input*)) (declare (explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (if (ansi-stream-p stream) - (ansi-stream-clear-input stream) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-clear-input stream))) + (stream-api-dispatch (stream (in-stream-from-designator stream)) + :simple (error "Unimplemented") ; gets redefined + :native (ansi-stream-clear-input stream) + :gray (stream-clear-input stream)) nil) -#-sb-fluid (declaim (inline ansi-stream-read-byte)) +(declaim (inline ansi-stream-read-byte)) (defun ansi-stream-read-byte (stream eof-error-p eof-value recursive-p) ;; Why the "recursive-p" parameter? a-s-r-b is funcall'ed from ;; a-s-read-sequence and needs a lambda list that's congruent with @@ -500,9 +526,13 @@ (defun read-byte (stream &optional (eof-error-p t) eof-value) (declare (explicit-check)) - (if (ansi-stream-p stream) - (ansi-stream-read-byte stream eof-error-p eof-value nil) - ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-api-dispatch (stream) + :native (ansi-stream-read-byte stream eof-error-p eof-value nil) + :simple (let ((byte (s-%read-byte stream eof-error-p eof-value))) + (if (eq byte eof-value) + byte + (the integer byte))) + :gray (let ((byte (stream-read-byte stream))) (if (eq byte :eof) (eof-or-lose stream eof-error-p eof-value) @@ -518,7 +548,7 @@ ;;; some cases, but it wasn't being used in SBCL, so it was dropped. ;;; If we ever need it, it could be added later as a new variant N-BIN ;;; method (perhaps N-BIN-ASAP?) or something. -#-sb-fluid (declaim (inline read-n-bytes)) +(declaim (inline read-n-bytes)) (defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t)) (if (ansi-stream-p stream) (ansi-stream-read-n-bytes stream buffer start numbytes eof-error-p) @@ -672,153 +702,160 @@ (defun write-char (character &optional (stream *standard-output*)) (declare (explicit-check)) - (with-out-stream stream (ansi-stream-out character) - (stream-write-char character)) + (stream-api-dispatch (stream (out-stream-from-designator stream)) + :native (funcall (ansi-stream-out stream) stream character) + :simple (s-%write-char stream character) + :gray (stream-write-char stream character)) character) (defun terpri (&optional (stream *standard-output*)) (declare (explicit-check)) - (with-out-stream stream (ansi-stream-out #\newline) (stream-terpri)) + (stream-api-dispatch (stream (out-stream-from-designator stream)) + :native (funcall (ansi-stream-out stream) stream #\Newline) + :simple (s-%terpri stream) + :gray (stream-terpri stream)) nil) -#-sb-fluid (declaim (inline ansi-stream-fresh-line)) -(defun ansi-stream-fresh-line (stream) - (unless (eql (charpos stream) 0) - (funcall (ansi-stream-out stream) stream #\newline) - t)) - (defun fresh-line (&optional (stream *standard-output*)) (declare (explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (if (ansi-stream-p stream) - (ansi-stream-fresh-line stream) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-fresh-line stream)))) - -#-sb-fluid (declaim (inline ansi-stream-write-string)) -(defun ansi-stream-write-string (string stream start end) - (with-array-data ((data string) (offset-start start) - (offset-end end) - :check-fill-pointer t) - (funcall (ansi-stream-sout stream) - stream data offset-start offset-end))) - -(defun %write-string (string stream start end) - (let ((stream (out-stream-from-designator stream))) - (if (ansi-stream-p stream) - (ansi-stream-write-string string stream start end) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-write-string stream string start end))) - string) + (stream-api-dispatch (stream (out-stream-from-designator stream)) + :native (unless (eql (charpos stream) 0) + (funcall (ansi-stream-out stream) stream #\newline) + t) + :simple (s-%fresh-line stream) + :gray (stream-fresh-line stream))) + +(macrolet + ((define (name) + `(defun ,name (string stream start end) + (with-array-data ((data string) (start start) (end end) :check-fill-pointer t) + (stream-api-dispatch (stream) + :native (progn (funcall (ansi-stream-sout stream) stream data start end) + ,@(when (eq name '%write-line) + '((funcall (ansi-stream-out stream) stream #\newline)))) + :simple (,(symbolicate "S-" name) stream data start end) + :gray (progn (stream-write-string stream data start end) + ,@(when (eq name '%write-line) + '((stream-write-char stream #\newline)))))) + string))) + (define %write-line) + (define %write-string)) (defun write-string (string &optional (stream *standard-output*) &key (start 0) end) - (declare (type string string)) - (declare (type stream-designator stream)) (declare (explicit-check)) - (%write-string string stream start end)) + (%write-string string (out-stream-from-designator stream) start end)) (defun write-line (string &optional (stream *standard-output*) &key (start 0) end) - (declare (type string string)) - (declare (type stream-designator stream)) (declare (explicit-check)) - (let ((stream (out-stream-from-designator stream))) - (cond ((ansi-stream-p stream) - (ansi-stream-write-string string stream start end) - (funcall (ansi-stream-out stream) stream #\newline)) - (t - (stream-write-string stream string start end) - (stream-write-char stream #\newline)))) - string) + (%write-line string (out-stream-from-designator stream) start end)) (defun charpos (&optional (stream *standard-output*)) - (with-out-stream stream (ansi-stream-misc :charpos) (stream-line-column))) + (stream-api-dispatch (stream (out-stream-from-designator stream)) + :native (call-ansi-stream-misc stream :charpos) + :simple (s-%charpos stream) + :gray (stream-line-column stream))) (defun line-length (&optional (stream *standard-output*)) - (with-out-stream stream (ansi-stream-misc :line-length) - (stream-line-length))) + (stream-api-dispatch (stream (out-stream-from-designator stream)) + :native (call-ansi-stream-misc stream :line-length) + :simple (s-%line-length stream) + :gray (stream-line-length stream))) (defun finish-output (&optional (stream *standard-output*)) (declare (explicit-check)) - (with-out-stream stream (ansi-stream-misc :finish-output) - (stream-finish-output)) + (stream-api-dispatch (stream (out-stream-from-designator stream)) + :native (call-ansi-stream-misc stream :finish-output) + :simple (s-%finish-output stream) + :gray (stream-finish-output stream)) nil) (defun force-output (&optional (stream *standard-output*)) (declare (explicit-check)) - (with-out-stream stream (ansi-stream-misc :force-output) - (stream-force-output)) + (stream-api-dispatch (stream (out-stream-from-designator stream)) + :native (call-ansi-stream-misc stream :force-output) + :simple (s-%force-output stream) + :gray (stream-force-output stream)) nil) (defun clear-output (&optional (stream *standard-output*)) (declare (explicit-check)) - (with-out-stream stream (ansi-stream-misc :clear-output) - (stream-clear-output)) + (stream-api-dispatch (stream (out-stream-from-designator stream)) + :native (call-ansi-stream-misc stream :clear-output) + :simple (s-%clear-output stream) + :gray (stream-clear-output stream)) nil) (defun write-byte (integer stream) (declare (explicit-check)) ;; The STREAM argument is not allowed to be a designator. - (%with-out-stream stream (ansi-stream-bout integer) (stream-write-byte integer)) + (stream-api-dispatch (stream) + :native (funcall (ansi-stream-bout stream) stream integer) + :simple (s-%write-byte stream integer) + :gray (stream-write-byte stream integer)) integer) -;;; Meta: the following comment is mostly true, but gray stream support -;;; is already incorporated into the definitions within this file. -;;; But these need to redefinable, otherwise the relative order of -;;; loading sb-simple-streams and any user-defined code which executes -;;; (F #'read-char ...) is sensitive to the order in which those -;;; are loaded, though insensitive at compile-time. -;;; (These were inline throughout this file, but that's not appropriate -;;; globally. And we must not inline them in the rest of this file if -;;; dispatch to gray or simple streams is to work, since both redefine -;;; these functions later.) -(declaim (notinline read-char unread-char read-byte listen)) +(declaim (notinline 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 ;;; appropriate SIMPLE- or FUNDAMENTAL-STREAM functions. -(defun stream-misc-dispatch (stream operation &optional arg1 arg2) - (declare (type stream stream) (ignore arg2)) - (ecase operation - (:listen - ;; Return T if input available, :EOF for end-of-file, otherwise NIL. - (let ((char (read-char-no-hang stream nil :eof))) - (when (characterp char) - (unread-char char stream)) - char)) - (:unread - (unread-char arg1 stream)) - (:close - (close stream)) - (:clear-input - (clear-input stream)) - (:force-output - (force-output stream)) - (:finish-output - (finish-output stream)) - (:clear-output - (clear-output stream)) - (:element-type - (stream-element-type stream)) - (:element-mode - (stream-element-type-stream-element-mode - (stream-element-type stream))) - (:stream-external-format - (stream-external-format stream)) - (:interactive-p - (interactive-stream-p stream)) - (:line-length - (line-length stream)) - (:charpos - (charpos stream)) - (:file-length - (file-length stream)) - (:file-string-length - (file-string-length stream arg1)) - (:file-position - (file-position stream arg1)))) +(defun stream-misc-dispatch (stream operation arg) + (if (simple-stream-p stream) + + ;; Dispatch to a simple-stream implementation function + (stream-misc-case (operation) + (:listen (listen stream)) ; call the redefined LISTEN + (:unread (s-%unread-char stream arg)) + (:close (error "Attempted to close inner stream ~S" stream)) + (:clear-input (clear-input stream)) ; call the redefined CLEAR-INPUT + (:force-output (s-%force-output stream)) + (:finish-output (s-%finish-output stream)) + (:clear-output (s-%clear-output stream)) + ;; All simple-streams use (UNSIGNED-BYTE 8) - it's one of the + ;; salient distinctions between simple-streams and Gray streams. + ;; See (DEFMETHOD STREAM-ELEMENT-TYPE ((STREAM SIMPLE-STREAM)) ...) + (:element-type '(unsigned-byte 8)) + ;; FIXME: All simple-streams are actually bivalent. We historically have + ;; returned UNSIGNED-BYTE based on element-type. But this is wrong! + (:element-mode 'UNSIGNED-BYTE) + ;; This call returns an instance of the format structure defined + ;; by the SB-SIMPLE-STREAMS package, not the SB-IMPL:: structure. + ;; This also needs to be fixed. + (:external-format (s-%stream-external-format stream)) + (:interactive-p (interactive-stream-p stream)) + (:line-length (s-%line-length stream)) + (:charpos (s-%charpos stream)) + (:file-length (s-%file-length stream)) + (:file-string-length (s-%file-string-length stream arg)) + (:set-file-position (s-%file-position stream arg)) + ;; yeesh, this wants a _required_ NIL argument to mean "inquire". + (:get-file-position (s-%file-position stream nil))) + + ;; else call the generic function + (stream-misc-case (operation) + (:listen (stream-listen stream)) + (:unread (stream-unread-char stream arg)) ; specialized arg first + (:close (error "Attempted to close inner stream ~S" stream)) + (:clear-input (stream-clear-input stream)) + (:force-output (stream-force-output stream)) + (:finish-output (stream-finish-output stream)) + (:clear-output (stream-clear-output stream)) + (:element-type (stream-element-type stream)) + (:element-mode + (stream-element-type-stream-element-mode (stream-element-type stream))) + (:interactive-p (interactive-stream-p stream)) ; is generic + (:line-length (stream-line-length stream)) + (:charpos (stream-line-column stream)) + (:set-file-position (stream-file-position stream arg)) + (:get-file-position (stream-file-position stream)) + ;; This last bunch of pseudo-methods will probably just signal an error + ;; since they aren't generic and don't work on Gray streams. + (:external-format (stream-external-format stream)) + (:file-length (file-length stream)) + (:file-string-length (file-string-length stream arg))))) (declaim (inline stream-element-mode)) (defun stream-element-mode (stream) @@ -827,7 +864,7 @@ ((fd-stream-p stream) (fd-stream-element-mode stream)) ((and (ansi-stream-p stream) - (funcall (ansi-stream-misc stream) stream :element-mode))) + (call-ansi-stream-misc stream :element-mode))) (t (stream-element-type-stream-element-mode (stream-element-type stream))))) @@ -835,26 +872,23 @@ ;;;; broadcast streams (defun make-broadcast-stream (&rest streams) - (unless streams - (return-from make-broadcast-stream - (load-time-value (let ((out (lambda (stream arg) - (declare (ignore stream arg) - (optimize speed (safety 0))))) - (sout (lambda (stream string start end) - (declare (ignore stream string start end) - (optimize speed (safety 0))))) - (stream (%make-broadcast-stream nil))) - (setf (broadcast-stream-out stream) out - (broadcast-stream-bout stream) out - (broadcast-stream-sout stream) sout) - stream) - t))) (dolist (stream streams) (unless (output-stream-p stream) (error 'type-error :datum stream :expected-type '(satisfies output-stream-p)))) - (%make-broadcast-stream streams)) + (let ((stream (%make-broadcast-stream streams))) + (unless streams + (flet ((out (stream arg) + (declare (ignore stream arg) + (optimize speed (safety 0)))) + (sout (stream string start end) + (declare (ignore stream string start end) + (optimize speed (safety 0))))) + (setf (broadcast-stream-out stream) #'out + (broadcast-stream-bout stream) #'out + (broadcast-stream-sout stream) #'sout))) + stream)) (macrolet ((out-fun (name fun &rest args) `(defun ,name (stream ,@args) @@ -864,9 +898,9 @@ (out-fun broadcast-bout write-byte byte) (out-fun broadcast-sout %write-string string start end)) -(defun broadcast-misc (stream operation &optional arg1 arg2) +(defun broadcast-misc (stream operation arg1) (let ((streams (broadcast-stream-streams stream))) - (case operation + (stream-misc-case (operation) ;; FIXME: This may not be the best place to note this, but I ;; think the :CHARPOS protocol needs revision. Firstly, I think ;; this is the last place where a NULL return value was possible @@ -907,31 +941,32 @@ (if last (file-length (car last)) 0))) - (:file-position - (if arg1 + (:set-file-position (let ((res (or (eql arg1 :start) (eql arg1 0)))) (dolist (stream streams res) - (setq res (file-position stream arg1)))) + (setq res (file-position stream arg1))))) + (:get-file-position (let ((last (last streams))) (if last (file-position (car last)) - 0)))) + 0))) (:file-string-length (let ((last (last streams))) (if last (file-string-length (car last) arg1) 1))) (:close - (when (broadcast-stream-streams stream) - (set-closed-flame stream))) + ;; I don't know how something is trying to close the + ;; universal sink stream, but it is. Stop it from happening. + (unless (eq stream *null-broadcast-stream*) + (set-closed-flame stream))) (t (let ((res nil)) (dolist (stream streams res) (setq res (if (ansi-stream-p stream) - (funcall (ansi-stream-misc stream) stream operation - arg1 arg2) - (stream-misc-dispatch stream operation arg1 arg2))))))))) + (call-ansi-stream-misc stream operation arg1) + (stream-misc-dispatch stream operation arg1))))))))) ;;;; synonym streams @@ -962,22 +997,33 @@ (in-fun synonym-bin read-byte eof-error-p eof-value) (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p)) -(defun synonym-misc (stream operation &optional arg1 arg2) +(defun synonym-misc (stream operation arg1) (declare (optimize (safety 1))) - (let ((syn (symbol-value (synonym-stream-symbol stream)))) - (if (ansi-stream-p syn) + ;; CLHS 21.1.4 implies that CLOSE on a synonym stream closes the synonym stream in that + ;; "The consequences are undefined if the synonym stream symbol is not bound to an open + ;; stream from the time of the synonym stream's creation until the time it is closed." + ;; The antecent of this "it" is the synonym stream --------------^ + ;; which means that there exist a way to close synonym streams. + ;; We can presume that CLOSE is that way, despite some text seemingly to the contrary + ;; "Any operations on a synonym stream will be performed on the stream that is then + ;; the value of the dynamic variable named by the synonym stream symbol." + ;; so "any" in that sentence mean "almost any, with a notable exception". + (stream-misc-case (operation) + (:close + (set-closed-flame stream)) + (t + (let ((syn (symbol-value (synonym-stream-symbol stream)))) + (if (ansi-stream-p syn) ;; We have to special-case some operations which interact with ;; the in-buffer of the wrapped stream, since just calling ;; ANSI-STREAM-MISC on them - (case operation - (:listen (or (/= (the fixnum (ansi-stream-in-index syn)) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc syn) syn :listen))) + (stream-misc-case (operation) + (:listen (%ansi-stream-listen syn)) (:clear-input (clear-input syn)) (:unread (unread-char arg1 syn)) (t - (funcall (ansi-stream-misc syn) syn operation arg1 arg2))) - (stream-misc-dispatch syn operation arg1 arg2)))) + (call-ansi-stream-misc syn operation arg1))) + (stream-misc-dispatch syn operation arg1)))))) ;;;; two-way streams @@ -1026,22 +1072,20 @@ (in-fun two-way-bin read-byte eof-error-p eof-value) (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-error-p)) -(defun two-way-misc (stream operation &optional arg1 arg2) +(defun two-way-misc (stream operation arg1) (let* ((in (two-way-stream-input-stream stream)) (out (two-way-stream-output-stream stream)) (in-ansi-stream-p (ansi-stream-p in)) (out-ansi-stream-p (ansi-stream-p out))) - (case operation + (stream-misc-case (operation) (:listen (if in-ansi-stream-p - (or (/= (the fixnum (ansi-stream-in-index in)) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc in) in :listen)) + (%ansi-stream-listen in) (listen in))) ((:finish-output :force-output :clear-output) (if out-ansi-stream-p - (funcall (ansi-stream-misc out) out operation arg1 arg2) - (stream-misc-dispatch out operation arg1 arg2))) + (call-ansi-stream-misc out operation arg1) + (stream-misc-dispatch out operation arg1))) (:clear-input (clear-input in)) (:unread (unread-char arg1 in)) (:element-type @@ -1059,11 +1103,11 @@ (set-closed-flame stream)) (t (or (if in-ansi-stream-p - (funcall (ansi-stream-misc in) in operation arg1 arg2) - (stream-misc-dispatch in operation arg1 arg2)) + (call-ansi-stream-misc in operation arg1) + (stream-misc-dispatch in operation arg1)) (if out-ansi-stream-p - (funcall (ansi-stream-misc out) out operation arg1 arg2) - (stream-misc-dispatch out operation arg1 arg2))))))) + (call-ansi-stream-misc out operation arg1) + (stream-misc-dispatch out operation arg1))))))) ;;;; concatenated streams @@ -1126,18 +1170,17 @@ (when (zerop remaining-bytes) (return numbytes))) (setf (concatenated-stream-streams stream) (cdr streams)))) -(defun concatenated-misc (stream operation &optional arg1 arg2) +(defun concatenated-misc (stream operation arg1) (let* ((left (concatenated-stream-streams stream)) (current (car left))) - (case operation + (stream-misc-case (operation) (:listen (unless left (return-from concatenated-misc :eof)) (loop (let ((stuff (if (ansi-stream-p current) - (funcall (ansi-stream-misc current) current - :listen) - (stream-misc-dispatch current :listen)))) + (%ansi-stream-listen current) + (stream-misc-dispatch current operation arg1)))) (cond ((eq stuff :eof) ;; Advance STREAMS, and try again. (pop (concatenated-stream-streams stream)) @@ -1159,8 +1202,8 @@ (t (when left (if (ansi-stream-p current) - (funcall (ansi-stream-misc current) current operation arg1 arg2) - (stream-misc-dispatch current operation arg1 arg2))))))) + (call-ansi-stream-misc current operation arg1) + (stream-misc-dispatch current operation arg1))))))) ;;;; echo streams @@ -1236,16 +1279,16 @@ start numbytes nil)) (cond ((not eof-error-p) - (write-sequence buffer (echo-stream-output-stream stream) - :start start :end (+ start bytes-read)) + (write-seq-impl buffer (echo-stream-output-stream stream) + start (+ start bytes-read)) bytes-read) ((> numbytes bytes-read) - (write-sequence buffer (echo-stream-output-stream stream) - :start start :end (+ start bytes-read)) + (write-seq-impl buffer (echo-stream-output-stream stream) + start (+ start bytes-read)) (error 'end-of-file :stream stream)) (t - (write-sequence buffer (echo-stream-output-stream stream) - :start start :end (+ start bytes-read)) + (write-seq-impl buffer (echo-stream-output-stream stream) + start (+ start bytes-read)) (aver (= numbytes (+ start bytes-read))) numbytes)))) @@ -1266,21 +1309,20 @@ (declaim (freeze-type string-input-stream)) -(defun string-in-misc (stream operation &optional arg1 arg2) - (declare (type string-input-stream stream) - (ignore arg2)) - (case operation - (:file-position - (if arg1 +(defun string-in-misc (stream operation arg1) + (declare (type string-input-stream stream)) + (stream-misc-case (operation :default nil) + (:set-file-position (setf (string-input-stream-index stream) (case arg1 (:start (string-input-stream-start stream)) (:end (string-input-stream-limit stream)) ;; We allow moving position beyond EOF. Errors happen ;; on read, not move. - (t (+ (string-input-stream-start stream) arg1)))) + (t (+ (string-input-stream-start stream) arg1))))) + (:get-file-position (- (string-input-stream-index stream) - (string-input-stream-start stream)))) + (string-input-stream-start stream))) ;; According to ANSI: "Should signal an error of type type-error ;; if stream is not a stream associated with a file." ;; This is checked by FILE-LENGTH, so no need to do it here either. @@ -1433,7 +1475,7 @@ ;; in the source material is potentially advantageous versus checking the ;; buffer in GET-OUTPUT-STREAM-STRING, because if all source strings are ;; BASE-STRING, we needn't check anything. - ;; Bounds check was already performed by ANSI-STREAM-WRITE-STRING + ;; Bounds check was already performed `(let ((s (truly-the simple-character-string src))) (declare (optimize (sb-c::insert-array-bounds-checks 0))) (loop for i from start2 below end2 @@ -1459,16 +1501,18 @@ (reject (&rest args) (declare (ignore args)) (error "Stream can not accept characters")) - (misc (stream operation &optional arg1 arg2) + (misc (stream operation arg1) ;; Intercept the misc handler to reset the Unicode state ;; (since the char handlers are local functions). ;; Technically this should be among the actions performed on :CLEAR-OUTPUT, ;; which would also include *actually* clearing the output. But we don't. - (if (eq operation :reset) + (stream-misc-case (operation) + (:reset-unicode-p (setf (string-output-stream-unicode-p stream) nil ;; resume checking for Unicode characters - (ansi-stream-out stream) #'default-out) - (string-out-misc stream operation arg1 arg2)))) + (ansi-stream-out stream) #'default-out)) + (t + (string-out-misc stream operation arg1))))) (multiple-value-bind (element-type unicode-p out sout-aux) (case (%other-pointer-widetag buffer) #+sb-unicode @@ -1501,11 +1545,9 @@ ;; No point in optimizing for unsupplied ELEMENT-TYPE. ;; Compiler transforms into %MAKE-CHARACTER-STRING-OSTREAM. (let ((ctype (specifier-type element-type))) - (cond ((eq ctype *empty-type*) - (%init-string-output-stream (%allocate-string-ostream) - (make-array 0 :element-type nil) - nil)) - ((csubtypep ctype (specifier-type 'base-char)) + (cond ((and (csubtypep ctype (specifier-type 'base-char)) + ;; Let NIL mean "default", i.e. CHARACTER + (neq ctype *empty-type*)) (%make-base-string-ostream)) ((csubtypep ctype (specifier-type 'character)) (%make-character-string-ostream)) @@ -1584,11 +1626,6 @@ (defun string-sout (stream string start end) (declare (explicit-check string) (type index start end)) - (when (typep (truly-the simple-string string) '(simple-array nil (*))) - ;; Such garbage that we have to deal with in all these routines - ;; for b.s. strings. - (return-from string-sout ; fail if the span is nonempty - (if (> end start) (aref string start)))) (let* ((full-length (- end start)) (length full-length) (buffer (string-output-stream-buffer stream)) @@ -1670,10 +1707,9 @@ (setf (string-output-stream-pointer stream) (+ size diff) (string-output-stream-index stream) pos)))))))) -(defun string-out-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) +(defun string-out-misc (stream operation arg1) (declare (optimize speed)) - (case operation + (stream-misc-case (operation :default nil) (:charpos ;; Keeping this first is a silly micro-optimization: FRESH-LINE ;; makes this the most common one. @@ -1698,10 +1734,10 @@ pointer (length buffer)) (/noshow0 "/string-out-misc charpos next") (go :next)))) - (:file-position - (/noshow0 "/string-out-misc file-position") - (when arg1 - (set-string-output-stream-file-position stream arg1)) + (:set-file-position + (set-string-output-stream-file-position stream arg1) + t) ; just claim it worked, who cares (see lp#1839040) + (:get-file-position (string-output-stream-index stream)) (:close (/noshow0 "/string-out-misc close") @@ -1716,9 +1752,6 @@ ;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function. (defun get-output-stream-string (stream) (declare (type string-output-stream stream)) - (when (eq (string-output-stream-element-type stream) nil) - (return-from get-output-stream-string - (load-time-value (make-array 0 :element-type nil) t))) (let* ((length (max (string-output-stream-index stream) (string-output-stream-index-cache stream))) (prev (nreverse (string-output-stream-prev stream))) @@ -1746,7 +1779,7 @@ ;; Reset UNICODE-P unless it was :IGNORE or element-type is CHARACTER. (when (and (eq (string-output-stream-element-type stream) :default) (eq (string-output-stream-unicode-p stream) t)) - (funcall (ansi-stream-misc stream) stream :reset)) + (call-ansi-stream-misc stream :reset-unicode-p)) ;; There are exactly 3 cases that we have to deal with when copying: ;; CHARACTER-STRING into BASE-STRING (without type-checking per character) @@ -1828,8 +1861,8 @@ :start1 pointer :start2 start :end2 end))) (setf (finite-base-string-output-stream-pointer stream) new-pointer))) -(defun finite-base-string-out-misc (stream operation &optional arg1 arg2) - (declare (ignore stream operation arg1 arg2)) +(defun finite-base-string-out-misc (stream operation arg1) + (declare (ignore stream operation arg1)) (error "finite-base-string-out-misc needs an implementation")) ;;;; fill-pointer streams @@ -1955,12 +1988,10 @@ :start1 offset-current :start2 start :end2 end))) dst-end))) -(defun fill-pointer-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) - (case operation - (:file-position - (let ((buffer (fill-pointer-output-stream-string stream))) - (if arg1 +(defun fill-pointer-misc (stream operation arg1 + &aux (buffer (fill-pointer-output-stream-string stream))) + (stream-misc-case (operation :default nil) + (:set-file-position (setf (fill-pointer buffer) (case arg1 (:start 0) @@ -1975,11 +2006,11 @@ (error "Cannot move FILE-POSITION beyond the end ~ of WITH-OUTPUT-TO-STRING stream ~ constructed with non-adjustable string."))) - arg1))) - (fill-pointer buffer)))) + arg1)))) + (:get-file-position + (fill-pointer buffer)) (:charpos - (let* ((buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer))) + (let ((current (fill-pointer buffer))) (with-array-data ((string buffer) (start) (end current)) (declare (simple-string string)) (let ((found (position #\newline string :test #'char= @@ -2038,7 +2069,7 @@ #'case-frob-capitalize-first-sout))) (%make-case-frob-stream target out sout)))) -(defun case-frob-misc (stream op &optional arg1 arg2) +(defun case-frob-misc (stream op arg1) (declare (type case-frob-stream stream)) (case op (:close @@ -2047,9 +2078,13 @@ (t (let ((target (case-frob-stream-target stream))) (if (ansi-stream-p target) - (funcall (ansi-stream-misc target) target op arg1 arg2) - (stream-misc-dispatch target op arg1 arg2)))))) + (call-ansi-stream-misc target op arg1) + (stream-misc-dispatch target op arg1)))))) +;;; FIXME: formatted output into a simple-stream is currently hampered +;;; by the fact that case-frob streams assume that the stream is either ANSI +;;; or Gray. Probably the easiest fix would be to define STREAM-WRITE-CHAR +;;; and STREAM-WRITE-STRING on simple-stream. (defun case-frob-upcase-out (stream char) (declare (type case-frob-stream stream) (type character char)) @@ -2287,10 +2322,10 @@ (type index start) (type sequence-end end) (values index)) - (if (ansi-stream-p stream) - (ansi-stream-read-sequence seq stream start end) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-read-sequence stream seq start end))) + (stream-api-dispatch (stream) + :simple (error "Unimplemented") ; gets redefined + :native (ansi-stream-read-sequence seq stream start end) + :gray (stream-read-sequence stream seq start end))) (declaim (inline read-sequence/read-function)) (defun read-sequence/read-function (seq stream start %end @@ -2420,18 +2455,11 @@ (defun write-sequence (seq stream &key (start 0) (end nil)) "Write the elements of SEQ bounded by START and END to STREAM." - (cond ((typep stream 'broadcast-stream) - (let* ((length (length seq)) - (end (or end length))) - (unless (<= start end length) - (sequence-bounding-indices-bad-error seq start end)) - (dolist (s (broadcast-stream-streams stream) seq) - (write-sequence seq s :start start :end end)))) - ((ansi-stream-p stream) - (ansi-stream-write-sequence seq stream start end)) - (t - ;; must be Gray-streams FUNDAMENTAL-STREAM - (stream-write-sequence stream seq start end)))) + (let* ((length (length seq)) + (end (or end length))) + (unless (<= start end length) + (sequence-bounding-indices-bad-error seq start end))) + (write-seq-impl seq stream start end)) ;;; This macro allows sharing code between ;;; WRITE-SEQUENCE/WRITE-FUNCTION and SB-GRAY:STREAM-WRITE-STRING. @@ -2492,7 +2520,9 @@ (write-list (compute-write-function nil))) (string (if (ansi-stream-p stream) - (ansi-stream-write-string seq stream start end) + (with-array-data ((data seq) (start start) (end end) + :check-fill-pointer t) + (funcall (ansi-stream-sout stream) stream data start end)) (stream-write-string stream seq start end))) (vector (with-array-data ((data seq) (offset-start start) (offset-end end) @@ -2510,16 +2540,34 @@ (write-generic-sequence (compute-write-function nil))))))) (declaim (notinline write-sequence/write-function)) -(defun ansi-stream-write-sequence (seq stream start %end) +;;; 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. +(defun write-seq-impl (seq stream start %end) (declare (type sequence seq) - (type ansi-stream stream) + (type stream stream) (type index start) (type sequence-end %end) - (values sequence) (inline write-sequence/write-function)) - (write-sequence/write-function - seq stream start %end (stream-element-mode stream) - (ansi-stream-out stream) (ansi-stream-bout stream)) + (stream-api-dispatch (stream) + :simple (s-%write-sequence stream seq start (or %end (length seq))) + :gray (stream-write-sequence stream seq start %end) + :native + (typecase stream + ;; Don't merely extract one layer of composite stream, because a synonym stream + ;; may redirect to a broadcast stream which wraps a two-way-stream etc etc. + (synonym-stream + (write-seq-impl seq (symbol-value (synonym-stream-symbol stream)) start %end)) + (broadcast-stream + (dolist (s (broadcast-stream-streams stream) seq) + (write-seq-impl seq s start %end))) + (two-way-stream ; handles ECHO-STREAM also + (write-seq-impl seq (two-way-stream-output-stream stream) start %end)) + ;; file, string, pretty, and case-frob streams all fall through to the default, + ;; which has special logic for fd-stream. + (t + (write-sequence/write-function + seq stream start %end (stream-element-mode stream) + (ansi-stream-out stream) (ansi-stream-bout stream))))) seq) ;;; like FILE-POSITION, only using :FILE-LENGTH @@ -2529,9 +2577,14 @@ ;; aren't according to the glossary). However, the behaviour of ;; FILE-LENGTH for broadcast streams is explicitly described in the ;; BROADCAST-STREAM entry. - (unless (typep stream 'broadcast-stream) - (stream-file-stream-or-lose stream)) - (funcall (ansi-stream-misc stream) stream :file-length)) + (stream-api-dispatch (stream) + :simple (s-%file-length stream) + ;; Perhaps if there were a generic function to obtain the pathname? + :gray (error "~S is not defined for ~S" 'file-length stream) + :native (progn + (unless (typep stream 'broadcast-stream) + (stream-file-stream-or-lose stream)) + (call-ansi-stream-misc stream :file-length)))) ;; Placing this definition (formerly in "toplevel") after the important ;; stream types are known produces smaller+faster code than it did before. diff -Nru sbcl-2.0.6/src/code/string-hash.lisp sbcl-2.1.1/src/code/string-hash.lisp --- sbcl-2.0.6/src/code/string-hash.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/string-hash.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -53,7 +53,7 @@ (set-result (+ result (ash result 3))) (set-result (logxor result (ash result -11))) (set-result (logxor result (ash result 15))) - (logand result sb-xc:most-positive-fixnum)))) + (logand result most-positive-fixnum)))) ;;; test: ;;; (let ((ht (make-hash-table :test 'equal))) ;;; (do-all-symbols (symbol) @@ -122,10 +122,10 @@ ;; search starting from 2^60*pi. The multiplication should be ;; efficient no matter what the platform thanks to modular ;; arithmetic. - (let* ((mul (logand 3622009729038463111 sb-xc:most-positive-fixnum)) - (xor (logand 608948948376289905 sb-xc:most-positive-fixnum)) - (xy (logand (+ (* x mul) y) sb-xc:most-positive-fixnum))) - (logand (logxor xor xy (ash xy -5)) sb-xc:most-positive-fixnum))) + (let* ((mul (logand 3622009729038463111 most-positive-fixnum)) + (xor (logand 608948948376289905 most-positive-fixnum)) + (xy (logand (+ (* x mul) y) most-positive-fixnum))) + (logand (logxor xor xy (ash xy -5)) most-positive-fixnum))) ;;; Same as above, but don't mask computations to n-positive-fixnum-bits. (declaim (inline word-mix)) @@ -185,14 +185,14 @@ ;;; an extra right-shift to remove bits that lack any randomness. CACHE-MASK can be ;;; reworked to examine bits other than at the low end. (defun hash-layout-name (name) - (let ((limit (1+ (ash sb-xc:most-positive-fixnum -1)))) + (let ((limit (1+ (ash most-positive-fixnum -1)))) (declare (notinline random)) (logior (if (typep name '(and symbol (not null))) (flet ((improve-hash (x) (#+64-bit murmur3-fmix64 #-64-bit murmur3-fmix32 x))) (mix (logand (improve-hash (sb-impl::%sxhash-simple-string (symbol-name name))) - sb-xc:most-positive-fixnum) + most-positive-fixnum) (let ((package (sb-xc:symbol-package name))) (sb-impl::%sxhash-simple-string ;; Must specifically look for CL package when cross-compiling diff -Nru sbcl-2.0.6/src/code/stubs.lisp sbcl-2.1.1/src/code/stubs.lisp --- sbcl-2.0.6/src/code/stubs.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/stubs.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -149,6 +149,16 @@ "Hints the processor that the current thread is spin-looping." (spin-loop-hint)) +;;; 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. +(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))) + (and (> (length inherits) depthoid) + (eq (svref inherits depthoid) test-layout))))) (defun %other-pointer-subtype-p (x choices) (and (%other-pointer-p x) diff -Nru sbcl-2.0.6/src/code/sunos-os.lisp sbcl-2.1.1/src/code/sunos-os.lisp --- sbcl-2.0.6/src/code/sunos-os.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/sunos-os.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -32,3 +32,20 @@ ;;; support for CL:MACHINE-VERSION defined OAOO elsewhere (defun get-machine-version () nil) + +(in-package "SB-UNIX") + +;; SunOS defines CLOCK_PROCESS_CPUTIME_ID but you get EINVAL if you try to use it. +(defun system-internal-run-time () + (multiple-value-bind (utime-sec utime-usec stime-sec stime-usec) + (with-alien ((usage (struct sb-unix::rusage))) + (syscall* ("sb_getrusage" int (* (struct sb-unix::rusage))) + (values (slot (slot usage 'sb-unix::ru-utime) 'sb-unix::tv-sec) + (slot (slot usage 'sb-unix::ru-utime) 'sb-unix::tv-usec) + (slot (slot usage 'sb-unix::ru-stime) 'sb-unix::tv-sec) + (slot (slot usage 'sb-unix::ru-stime) 'sb-unix::tv-usec)) + rusage_self (addr usage))) + (+ (* (+ utime-sec stime-sec) internal-time-units-per-second) + (floor (+ utime-usec stime-usec + (floor microseconds-per-internal-time-unit 2)) + microseconds-per-internal-time-unit)))) diff -Nru sbcl-2.0.6/src/code/symbol.lisp sbcl-2.1.1/src/code/symbol.lisp --- sbcl-2.0.6/src/code/symbol.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/symbol.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -88,7 +88,7 @@ (return-from compute-symbol-hash (sxhash nil))) ;; And make a symbol's hash not the same as (sxhash name) in general. (let ((sxhash (logxor (%sxhash-simple-substring string 0 length) - sb-xc:most-positive-fixnum))) + most-positive-fixnum))) ;; The low 32 bits of the word in memory should have at least a 1 bit somewhere. ;; If not, OR in a constant value. (if (ldb-test (byte (- 32 sb-vm:n-fixnum-tag-bits) 0) sxhash) @@ -204,12 +204,11 @@ (defun symbol-plist (symbol) "Return SYMBOL's property list." - #+(vop-translates cl:symbol-plist) - (symbol-plist symbol) - #-(vop-translates cl:symbol-plist) - (let ((list (car (truly-the list (symbol-info symbol))))) ; a white lie - ;; Just ensure the result is not a fixnum, and we're done. - (if (fixnump list) nil 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)))) (declaim (ftype (sfunction (symbol t) cons) %ensure-plist-holder) (inline %ensure-plist-holder)) diff -Nru sbcl-2.0.6/src/code/sysmacs.lisp sbcl-2.1.1/src/code/sysmacs.lisp --- sbcl-2.0.6/src/code/sysmacs.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/sysmacs.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -15,6 +15,7 @@ (defvar *in-without-gcing*) (defvar *gc-inhibit*) +(defvar *gc-pin-code-pages*) ;;; When the dynamic usage increases beyond this amount, the system ;;; notes that a garbage collection needs to occur by setting @@ -63,7 +64,7 @@ (*interrupts-enabled* nil) (*gc-inhibit* t)) (,without-gcing-body)) - ;; This is not racy becuase maybe_defer_handler + ;; This is not racy because can_hande_now() ;; defers signals if *GC-INHIBIT* is NIL but there ;; is a pending gc or stop-for-gc. (when (or *interrupt-pending* @@ -123,35 +124,6 @@ :format-control "~S isn't an output stream." :format-arguments (list ,svar))) ,svar))))) - -;;; WITH-mumble-STREAM calls the function in the given SLOT of the -;;; STREAM with the ARGS for ANSI-STREAMs, or the FUNCTION with the -;;; ARGS for FUNDAMENTAL-STREAMs. -(defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch) - `(let ((stream (in-stream-from-designator ,stream))) - ,(if stream-dispatch - `(if (ansi-stream-p stream) - (funcall (,slot stream) stream ,@args) - ,@(when stream-dispatch - `(,(destructuring-bind (function &rest args) stream-dispatch - `(,function stream ,@args))))) - `(funcall (,slot stream) stream ,@args)))) - -(defmacro %with-out-stream (stream (slot &rest args) &optional stream-dispatch) - `(let ((stream ,stream)) - ,(if stream-dispatch - `(if (ansi-stream-p stream) - (funcall (,slot stream) stream ,@args) - ,@(when stream-dispatch - `(,(destructuring-bind (function &rest args) stream-dispatch - `(,function stream ,@args))))) - `(funcall (,slot stream) stream ,@args)))) - -(defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch) - `(%with-out-stream (out-stream-from-designator ,stream) - (,slot ,@args) - ,stream-dispatch)) - ;;;; These are hacks to make the reader win. diff -Nru sbcl-2.0.6/src/code/target-alieneval.lisp sbcl-2.1.1/src/code/target-alieneval.lisp --- sbcl-2.0.6/src/code/target-alieneval.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-alieneval.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1,4 +1,4 @@ -;;;; This file contains parts of the ALIEN implementation that +;;;; This file contains parts of the Alien implementation that ;;;; are not part of the compiler. ;;;; This software is part of the SBCL system. See the README file for @@ -198,7 +198,7 @@ :sap (sap-int (alien-value-sap value)) :type (unparse-alien-type (alien-value-type value))))) -#-sb-fluid (declaim (inline null-alien)) +(declaim (inline null-alien)) (defun null-alien (x) "Return true if X (which must be an ALIEN pointer) is null, false otherwise." (zerop (sap-int (alien-sap x)))) @@ -296,7 +296,7 @@ ;;; Allocate a block of memory at least BYTES bytes long and return a ;;; system area pointer to it. -#-sb-fluid (declaim (inline %make-alien)) +(declaim (inline %make-alien)) (defun %make-alien (bytes) (declare (type index bytes) (optimize (sb-c:alien-funcall-saves-fp-and-pc 0))) @@ -320,7 +320,7 @@ (let ((*saved-fp* (sb-c::current-fp-fixnum))) (funcall fn))) -#-sb-fluid (declaim (inline free-alien)) +(declaim (inline free-alien)) (defun free-alien (alien) "Dispose of the storage pointed to by ALIEN. The ALIEN must have been allocated by MAKE-ALIEN, MAKE-ALIEN-STRING or malloc(3)." @@ -570,6 +570,42 @@ (unless (local-alien-info-force-to-memory-p info) (error "~S isn't forced to memory. Something went wrong." alien)) alien) + + +;;;; the ADDR macro + +(defmacro addr (expr &environment env) + "Return an Alien pointer to the data addressed by Expr, which must be a call + to SLOT or DEREF, or a reference to an Alien variable." + (let ((form (%macroexpand expr env))) + (or (typecase form + (cons + (case (car form) + (slot + (cons '%slot-addr (cdr form))) + (deref + (cons '%deref-addr (cdr form))) + (%heap-alien + (cons '%heap-alien-addr (cdr form))) + (local-alien + (let ((info (let ((info-arg (second form))) + (and (consp info-arg) + (eq (car info-arg) 'quote) + (second info-arg))))) + (unless (local-alien-info-p info) + (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S" + form)) + (setf (local-alien-info-force-to-memory-p info) t)) + (cons '%local-alien-addr (cdr form))))) + (symbol + (let ((kind (info :variable :kind form))) + (when (eq kind :alien) + `(%heap-alien-addr ',(info :variable :alien-info form)))))) + (error "~S is not a valid L-value." form)))) + +(push '("SB-ALIEN" define-alien-type-class define-alien-type-method) + *!removable-symbols*) + ;;;; the CAST macro diff -Nru sbcl-2.0.6/src/code/target-allocate.lisp sbcl-2.1.1/src/code/target-allocate.lisp --- sbcl-2.0.6/src/code/target-allocate.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-allocate.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -;;;; system memory allocation - -;;;; 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") - -(define-alien-routine ("os_allocate" allocate-system-memory) - system-area-pointer - (bytes unsigned)) - -(define-alien-routine ("os_deallocate" deallocate-system-memory) - void - (addr system-area-pointer) - (bytes unsigned)) diff -Nru sbcl-2.0.6/src/code/target-char.lisp sbcl-2.1.1/src/code/target-char.lisp --- sbcl-2.0.6/src/code/target-char.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-char.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -12,14 +12,13 @@ (in-package "SB-IMPL") ;;; We compile some trivial character operations via inline expansion. -#-sb-fluid (declaim (inline standard-char-p graphic-char-p alpha-char-p alphanumericp)) (declaim (maybe-inline upper-case-p lower-case-p both-case-p digit-char-p)) (deftype char-code () - `(integer 0 (,sb-xc:char-code-limit))) + `(integer 0 (,char-code-limit))) (define-load-time-global **unicode-character-name-huffman-tree** ()) @@ -42,7 +41,7 @@ (macrolet ((frob () (flet ((coerce-it (array) - (sb-xc:coerce array '(simple-array (unsigned-byte 8) 1))) + (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)) diff -Nru sbcl-2.0.6/src/code/target-defstruct.lisp sbcl-2.1.1/src/code/target-defstruct.lisp --- sbcl-2.0.6/src/code/target-defstruct.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-defstruct.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -199,7 +199,7 @@ (write name :stream stream) (do ((index 0 (1+ index)) (limit (or (and (not *print-readably*) *print-length*) - sb-xc:most-positive-fixnum)) + most-positive-fixnum)) (remaining-slots (dd-slots dd) (cdr remaining-slots))) ((or (null remaining-slots) (>= index limit)) (write-string (if remaining-slots " ...)" ")") stream)) @@ -223,12 +223,16 @@ ;; of change f02bee325920166b69070e4735a8a3f295f8edfd which ;; stopped the badness is a stronger way. It should be the case ;; that absence of a DD can't happen unless the classoid is absent. - ;; KLUDGE: during PCL build debugging, we can sometimes - ;; attempt to print out a PCL object (with null LAYOUT-INFO). + ;; KLUDGE: during warm build, we may see a CONDITION or STANDARD-OBJECT + ;; here, and we need a way to get a handle on it (for SB-VM:HEXDUMP at least). + ;; I'm not sure why a condition-report function isn't called in the former + ;; case. Using the default structure printer won't solve anything, because + ;; the layout of a condition does not describe any slot of interest. (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (prin1 name stream) - (write-char #\space stream) - (write-string "(no LAYOUT-INFO)" stream))) + (prin1 name stream) + (write-char #\space stream) + (write-string "(no LAYOUT-INFO) " stream) + (write (get-lisp-obj-address structure) :base 16 :radix t :stream stream))) ((not (dd-slots dd)) ;; the structure type doesn't count as a component for *PRINT-LEVEL* ;; processing. We can likewise elide the logical block processing, diff -Nru sbcl-2.0.6/src/code/target-error.lisp sbcl-2.1.1/src/code/target-error.lisp --- sbcl-2.0.6/src/code/target-error.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-error.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -31,19 +31,6 @@ ;;; Lists to which *HANDLER-CLUSTERS* is bound generally have dynamic ;;; extent. -(defun !target-error-cold-init () - ;; Anonymous lambdas are too complicated to dump as constants in genesis. - ;; (that's sad, I wish we could do something about it) - (setq **initial-handler-clusters** - `(((,(find-classoid-cell 'warning :create t) - . - ,(named-lambda "MAYBE-MUFFLE" (warning) - (when (muffle-warning-p warning) - (muffle-warning warning)))) - (,(find-classoid-cell 'step-condition) - . - sb-impl::invoke-stepper))))) - (defmethod print-object ((restart restart) stream) (if *print-escape* (print-unreadable-object (restart stream :type t :identity t) diff -Nru sbcl-2.0.6/src/code/target-extensions.lisp sbcl-2.1.1/src/code/target-extensions.lisp --- sbcl-2.0.6/src/code/target-extensions.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-extensions.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -148,8 +148,8 @@ `(let* ((,size ,initial-size) (,string (make-array ,size :element-type ',element-type)) (,pointer 0)) - (declare (type (integer 0 ,sb-xc:array-dimension-limit) ,size) - (type (integer 0 ,(1- sb-xc:array-dimension-limit)) ,pointer) + (declare (type (integer 0 ,array-dimension-limit) ,size) + (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))) @@ -281,3 +281,20 @@ `(defvar ,name ,@(when valuep (list value)))) ((:final) `',name)))) + +(define-load-time-global *deprecated-exports* nil) + +(defun deprecate-export (package symbol state version) + (declare (type deprecation-state state) + (type string version) + (type symbol symbol)) + (setf (getf (getf *deprecated-exports* package) symbol) + (cons state version))) + +(defun check-deprecated-export (package symbol) + (let ((state (getf (getf *deprecated-exports* package) symbol))) + (when state + (deprecation-warn (car state) "SBCL" (cdr state) 'symbol + (format nil "~A:~A" (package-name package) symbol) + (list symbol)) + t))) diff -Nru sbcl-2.0.6/src/code/target-format.lisp sbcl-2.1.1/src/code/target-format.lisp --- sbcl-2.0.6/src/code/target-format.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-format.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -178,8 +178,11 @@ char))) (directive '.directive) ; expose this var to the lambda. it's easiest (directives (if lambda-list (car (last lambda-list)) (sb-xc:gensym "DIRECTIVES")))) - `(setf - (aref *format-directive-interpreters* (sb-xc:char-code (char-upcase ,char))) + `(%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)) (named-lambda ,defun-name (stream ,directive ,directives orig-args args) (declare (ignorable stream orig-args args)) ,@(if lambda-list diff -Nru sbcl-2.0.6/src/code/target-hash-table.lisp sbcl-2.1.1/src/code/target-hash-table.lisp --- sbcl-2.0.6/src/code/target-hash-table.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-hash-table.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -52,7 +52,7 @@ (and (hash-table-weak-p ht) (decode-hash-table-weakness (ht-flags-weakness (hash-table-flags ht))))) -#-sb-fluid (declaim (inline eq-hash)) +(declaim (inline eq-hash)) (defun eq-hash (key) (declare (values fixnum (member t nil))) ;; I think it would be ok to pick off SYMBOL here and use its hash slot @@ -105,7 +105,7 @@ ;; Consider picking off %INSTANCEP too before using EQ-HASH ? (eq-hash key))))) -#-sb-fluid (declaim (inline equal-hash)) +(declaim (inline equal-hash)) (defun equal-hash (key) (declare (values fixnum (member t nil))) (typecase key @@ -268,7 +268,9 @@ ;;; 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 +min-hash-table-rehash-threshold+ (float 1/16 $1.0)) +;;; 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)) ;; The GC will set this to 1 if it moves an address-sensitive key. This used ;; to be signaled by a bit in the header of the kv vector, but that @@ -310,7 +312,7 @@ ;; is set, so it needs to see a valid value in the 'supplement' slot. ;; Neither 0 nor +empty-ht-slot+ is a valid value. (setf (kv-vector-supplement v) nil) - (set-header-data v sb-vm:vector-hashing-subtype) + (set-header-data v sb-vm:vector-hashing-flag) v)) (defun install-hash-table-lock (table) @@ -322,7 +324,7 @@ (defconstant hash-table-kind-eq 0) (defconstant hash-table-kind-eql 1) (defconstant hash-table-kind-equal 2) -(defconstant hash-table-kind-equqlp 3) +(defconstant hash-table-kind-equalp 3) ;;; I don't want to change peoples' assumptions about what operations are threadsafe ;;; on a weak table that was not created as expressly synchronized, so we continue to @@ -366,12 +368,14 @@ approaches 0. Density 1 means an average of one entry per bucket. :HASH-FUNCTION - If NIL (the default), a hash function based on the TEST argument is used, + If unsupplied, a hash function based on the TEST argument is used, which then must be one of the standardized hash table test functions, or one for which a default hash function has been defined using SB-EXT:DEFINE-HASH-TABLE-TEST. If HASH-FUNCTION is specified, the TEST argument can be any two argument predicate consistent with it. The HASH-FUNCTION is expected to return a non-negative fixnum hash code. + If TEST is neither standard nor defined by DEFINE-HASH-TABLE-TEST, + then the HASH-FUNCTION must be specified. :WEAKNESS When :WEAKNESS is not NIL, garbage collection may remove entries from the @@ -522,8 +526,8 @@ table (or hash-vector (= table-kind hash-table-kind-eql)))) (when weakp - (set-header-data kv-vector (logior sb-vm:vector-hashing-subtype - sb-vm:vector-weak-subtype))) + (set-header-data 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)) @@ -641,18 +645,6 @@ (make-array (1+ new-size) :element-type 'hash-table-index)))) (values new-kv-vector new-next-vector new-hash-vector new-index-vector))) -#-(vop-translates sb-kernel:set-header-bits) -(progn - (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))) - ;;; We don't define +-MODFX for all backends, and I can't figure out ;;; the rationale, nor how to detect this other than by trial and error. ;;; Like why does 64-bit ARM have it but 32-bit not have? @@ -722,7 +714,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-subtype) + (set-header-bits 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 @@ -753,7 +745,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-subtype)) + (set-header-bits 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)) @@ -763,7 +755,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-subtype)) + (set-header-bits 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) @@ -799,7 +791,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-subtype) + (unset-header-bits 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 @@ -821,7 +813,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-subtype) + (set-header-bits 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)))))) @@ -834,7 +826,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-subtype)) + (set-header-bits 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 @@ -844,7 +836,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-subtype)) + (set-header-bits 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))))))) @@ -889,7 +881,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-subtype) + (set-header-data old-kv-vector sb-vm:vector-hashing-flag) (setf (kv-vector-supplement old-kv-vector) nil) ;; The high-water-mark remains unchanged. @@ -926,7 +918,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-subtype)) + (set-header-bits 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 @@ -1324,7 +1316,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-subtype) + (set-header-data 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 @@ -1339,7 +1331,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-subtype) + (set-header-bits 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 @@ -1625,7 +1617,7 @@ ;; 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-subtype)) + (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 @@ -1876,7 +1868,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-subtype) + (unset-header-bits 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) @@ -2032,10 +2024,10 @@ ht)))) (defun hash-table-mem-used (ht) - (+ (sb-vm::primitive-object-size (hash-table-pairs ht)) - (sb-vm::primitive-object-size (hash-table-index-vector ht)) - (sb-vm::primitive-object-size (hash-table-next-vector ht)) - (acond ((hash-table-hash-vector ht) (sb-vm::primitive-object-size it)) + (+ (primitive-object-size (hash-table-pairs ht)) + (primitive-object-size (hash-table-index-vector ht)) + (primitive-object-size (hash-table-next-vector ht)) + (acond ((hash-table-hash-vector ht) (primitive-object-size it)) (t 0)))) (defun show-growth (&optional (factor 1.5)) diff -Nru sbcl-2.0.6/src/code/target-lflist.lisp sbcl-2.1.1/src/code/target-lflist.lisp --- sbcl-2.0.6/src/code/target-lflist.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-lflist.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -15,19 +15,11 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(defpackage "SB-LOCKLESS" - (:use "CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-KERNEL") - (:shadow "ENDP")) - (in-package "SB-LOCKLESS") -(setf (system-package-p *package*) t) ;;; The changes to GC to support this code were as follows: -;;; * One bit of the payload length in an instance header is reserved to signify -;;; that the instance has a special GC scavenge method. This avoids indirecting -;;; to the layout to see whether all instances of a type have a special method. ;;; -;;; * If an instance has a header bit so indicating, then the first data slot +;;; * If an instance is flagged as being a LFlist node, then the first data slot ;;; is treated as an instance pointer even if it missing its tag bits. ;;; ;;; * Since you can't pin an object that you don't a-priori have a tagged pointer @@ -45,15 +37,6 @@ ;;; DO-REFERENCED-OBJECT can follow untagged pointers. ;;; This is potentially more of an annoyance than it is a bug. -(eval-when (:compile-toplevel :load-toplevel :execute) - (import 'sb-kernel::list-node)) - -(defstruct (list-node - (:conc-name nil) - (:constructor %make-sentinel-node ()) - (:copier nil)) - (%node-next nil)) - (defstruct (keyed-node (:conc-name nil) (:include list-node) @@ -61,10 +44,6 @@ (node-key 0 :read-only t) (node-data)) -(let ((layout (find-layout 'keyed-node))) - (setf (layout-flags layout) - (logior (layout-flags layout) sb-vm:lockfree-list-node-flag))) - (declaim (inline ptr-markedp node-markedp)) (defun ptr-markedp (bits) (fixnump bits)) (defun node-markedp (node) (fixnump (%node-next node))) @@ -82,20 +61,6 @@ (defmacro endp (node) `(eq ,node (load-time-value *tail-atom*))) -;;; Specialized list variants will be created for -;;; fixnum, integer, real, string, generic "comparable" -;;; but the node type and list type is the same regardless of key type. -(defstruct (linked-list - (:constructor %make-lfl - (head inserter deleter finder inequality equality)) - (:conc-name list-)) - (head nil :type list-node :read-only t) - (inserter nil :type function :read-only t) - (deleter nil :type function :read-only t) - (finder nil :type function :read-only t) - (inequality nil :type function :read-only t) - (equality nil :type function :read-only t)) - (defconstant-eqx +predefined-key-types+ #((fixnum lfl-insert/fixnum lfl-delete/fixnum lfl-find/fixnum < =) (integer lfl-insert/integer lfl-delete/integer lfl-find/integer < =) diff -Nru sbcl-2.0.6/src/code/target-misc.lisp sbcl-2.1.1/src/code/target-misc.lisp --- sbcl-2.0.6/src/code/target-misc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-misc.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -255,3 +255,24 @@ (declare (type (or null string) string)) (push (list string name doc-type) sb-pcl::*!docstrings*) string) + +(in-package "SB-LOCKLESS") +(defstruct (list-node + (:conc-name nil) + (:constructor %make-sentinel-node ()) + (:copier nil)) + (%node-next nil)) + +;;; Specialized list variants will be created for +;;; fixnum, integer, real, string, generic "comparable" +;;; but the node type and list type is the same regardless of key type. +(defstruct (linked-list + (:constructor %make-lfl + (head inserter deleter finder inequality equality)) + (:conc-name list-)) + (head nil :type list-node :read-only t) + (inserter nil :type function :read-only t) + (deleter nil :type function :read-only t) + (finder nil :type function :read-only t) + (inequality nil :type function :read-only t) + (equality nil :type function :read-only t)) diff -Nru sbcl-2.0.6/src/code/target-package.lisp sbcl-2.1.1/src/code/target-package.lisp --- sbcl-2.0.6/src/code/target-package.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-package.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -211,7 +211,7 @@ (ash (ldb (byte pkgnick-index-bits 0) token) 1)))))) ;;; This would have to be bumped ~ 2*most-positive-fixnum times to overflow. -(define-load-time-global *package-names-cookie* sb-xc:most-negative-fixnum) +(define-load-time-global *package-names-cookie* most-negative-fixnum) (declaim (fixnum *package-names-cookie*)) (defmacro with-package-names ((table-var &key) &body body) @@ -1796,7 +1796,10 @@ (fresh-line) (prin1 symbol) (when (boundp symbol) - (write-string " (bound)")) + (let ((value (symbol-value symbol))) + (if (typep value '(or fixnum symbol hash-table)) + (format t " = ~S" value) + (format t " (bound, ~S)" (type-of value))))) (when (fboundp symbol) (write-string " (fbound)"))) @@ -1855,6 +1858,9 @@ (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") (with-package-names (names) (dolist (spec *!initial-symbols*) (let ((pkg (car spec)) (symbols (cdr spec))) diff -Nru sbcl-2.0.6/src/code/target-pathname.lisp sbcl-2.1.1/src/code/target-pathname.lisp --- sbcl-2.0.6/src/code/target-pathname.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-pathname.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -58,34 +58,27 @@ ;;; ;;; Physical pathnames include all these slots and a device slot. -;;; Logical pathnames are a subclass of PATHNAME. Their class -;;; relations are mimicked using structures for efficiency. -(defstruct (logical-pathname (:conc-name %logical-pathname-) - (:include pathname) - (:copier nil) - (:constructor %make-logical-pathname - (host device directory name type version - &aux (dir-hash (pathname-dir-hash directory)) - (stem-hash (mix (sxhash name) (sxhash type))))))) - -;;; FIXME: this, and many other FREEZE-TYPEs don't actually do anything. -;;; Unobvious order of execution of TLFs in cold-init is one potential problem, -;;; but there could be other issues as well, like maybe we're unsealing classes -;;; because the FREEZE-TYPE was wrong to begin with. (So why no warnings then?) -;;; This declamation also freezes LOGICAL-PATHNAME, but we can't freeze HOST -;;; because later on we define either UNIX-HOST or WIN32-HOST. -#-sb-fluid (declaim (freeze-type pathname logical-host)) - -(defmethod make-load-form ((logical-host logical-host) &optional env) - (declare (ignore env)) - (values `(find-logical-host ',(logical-host-name logical-host)) - nil)) +;;; We can't freeze HOST because later on we define either UNIX-HOST or WIN32-HOST. +(declaim (freeze-type logical-host)) ;;; Utility functions (deftype absent-pathname-component () '(member nil :unspecific)) +(defun make-pattern (pieces) + ;; Ensure that the hash will meet the SXASH persistence requirement: + ;; "2. For any two objects, x and y, both of which are ... pathnames ... and which are similar, + ;; (sxhash x) and (sxhash y) yield the same mathematical value even if x and y exist in + ;; different Lisp images of the same implementation." + ;; Specifically, hashes that depend on object identity (address) are impermissible. + (dolist (piece pieces) + (aver (typep piece '(or string symbol (cons (eql :character-set) string))))) + (%make-pattern (sxhash pieces) pieces)) + +(declaim (inline %pathname-directory)) +(defun %pathname-directory (pathname) (car (%pathname-dir+hash pathname))) + (declaim (inline pathname-component-present-p)) (defun pathname-component-present-p (component) (not (typep component 'absent-pathname-component))) @@ -239,36 +232,13 @@ ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is ;;; initialized (at which time we can't safely call e.g. #'PATHNAME). (defun make-trivial-default-pathname () - (%%make-pathname *physical-host* nil nil nil nil :newest)) + (intern-pathname *physical-host* nil nil nil nil :newest)) ;;; pathname methods -;;; SXHASH does a really poor job on pathname directory, especially if in your -;;; environment, the directories of interest are all many levels down from the -;;; filesystem root- every directory in your work space might hash to the same -;;; value under SXHASH. Mixing in all pieces of the directory path solves that. -(defun pathname-dir-hash (directory) - ;; FIXME: all instances of PATTERN hash to the same thing. - ;; We should probably hash the pattern pieces. (Same for stem-hash) - (let ((hash (sxhash (car directory)))) - (dolist (piece (cdr directory) hash) - (mixf hash (sxhash piece))))) -;;; Pathname hashing used to be nested inside SXHASH so that it could utilize -;;; the depth cutoff to avoid performing unbounded work. We don't need that any more, -;;; as the parts of the pathname that invoke SXHASH (host, device, version) are atoms -;;; and hence they entail bounded computation. (defun pathname-sxhash (x) (declare (pathname x)) - ;; Pathnames are EQUAL if all the components are EQUAL, so - ;; we hash all of the components of a pathname together. - (let ((hash (sxhash (pathname-host x)))) - (mixf hash (sxhash (pathname-device x))) - (mixf hash (logxor (%pathname-dir-hash x) - (%pathname-stem-hash x))) - ;; Hash :NEWEST the same as NIL because EQUAL for - ;; pathnames assumes that :newest and nil are equal. - (let ((version (%pathname-version x))) - (mixf hash (sxhash (if (eq version :newest) nil version)))))) + (pathname-key-hash x)) (defmethod print-object ((pathname pathname) stream) (let ((namestring (handler-case (namestring pathname) @@ -289,30 +259,86 @@ (%pathname-name pathname) (%pathname-type pathname) (%pathname-version pathname)))))) - -(defmethod make-load-form ((pathname pathname) &optional environment) - (make-load-form-saving-slots pathname :environment environment)) +;;; Use an unsynchronized weak hash table with explicit locking to "try" +;;; to intern pathnames. "Try" because there are several factors that preclude +;;; ensuring uniqueness: +;;; - pathname is a STRUCTURE-OBJECT, so users might call COPY-STRUCTURE. +;;; We can make that fail by inventing a subtype of instance that is not +;;; a STRUCTURE-OBJECT. Whatever that metatype is could be useful for +;;; PATTERN (parts of the pathname) as well as THREAD, MUTEX, HASH-TABLE +;;; and maybe some other things that yield strange semantics if copied. +;;; - the load form methods use MAKE-LOAD-FORM-SAVING-SLOTS thereby +;;; bypassing the interning operation. That seems totally fixable. +;;; +;;; Additionally, it would be nice if this table would act to reduce +;;; EQUAL to EQ on pathnames by ensuring that we never intern two distinct +;;; pathnames that are EQUAL. +;;; That would require performing some canonicalization immediately which may +;;; or may not pose a problem for fixing https://bugs.launchpad.net/sbcl/+bug/1834266 +;;; which is to say, if hosts can actually be :UNSPECIFIC, then the version +;;; collapsing that is done here would not be done. I don't know if it's that simple. +;;; If it isn't that simple, then the answer is that hash function and comparator +;;; function used for the *PATHNAMES* table needs to be more fine-grained than +;;; the hash value that SXHASH returns for a pathname. +;;; +;;; The spec is actually extremely underspecified in regard to the meaning of +;;; "pathnames that are equal should be functionally equivalent." +;;; The simple test: +;;; (equal (make-pathname :name "a" :version nil) (make-pathname :name "a" :version :newest)) +;;; shows that EQUAL is inconsistent in terms of what "functionally equivalent" means: +;;; SBCL, ABCL, and CCL => T +;;; CLISP and ECL => NIL +;;; Also, on case-sensitive-case-preserving filesystems it's not possible +;;; to know which pathnames are equivalent without asking the filesystem. +;;; +;;; This table uses %MAKE-HASH-TABLE, not MAKE-HASH-TABLE, because the latter +;;; always creates a synchronized table if :WEAKNESS is specified. +;;; But to correctly use the "put-if-absent" operation, the locking must occur +;;; *around* the get and put operations. It makes no sense to lock the table around +;;; individual operations, hence the unsynchronized table. + +(define-load-time-global *pathnames* + (let ((h (%make-hash-table (logior (pack-ht-flags-weakness +ht-weak-value+) + (pack-ht-flags-kind 3) + hash-table-userfun-flag) + 'pathname-key= + #'pathname-key= + #'pathname-key-hash + 10 + default-rehash-size + $1.0))) + (install-hash-table-lock h) + h)) ;;; A pathname is logical if the host component is a logical host. ;;; This constructor is used to make an instance of the correct type ;;; from parsed arguments. -(defun %make-maybe-logical-pathname (host device directory name type version) +(defun intern-pathname (host device directory name type version) ;; We canonicalize logical pathname components to uppercase. ANSI ;; doesn't strictly require this, leaving it up to the implementor; ;; but the arguments given in the X3J13 cleanup issue ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the ;; case, and uppercase is the ordinary way to do that. (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x)))) - (if (typep host 'logical-host) - (%make-logical-pathname host - :unspecific - (mapcar #'upcase-maybe directory) - (upcase-maybe name) - (upcase-maybe type) - version) - (progn - (aver (eq host *physical-host*)) - (%make-pathname host device directory name type version))))) + (when (typep host 'logical-host) + (setq device :unspecific + directory (mapcar #'upcase-maybe directory) + name (upcase-maybe name) + type (upcase-maybe type)))) + (let ((table *pathnames*)) + (declare (inline !allocate-pathname)) ; for DXability + (with-system-mutex ((hash-table-%lock table)) + (let* ((dir+hash (when directory + (ensure-gethash + directory table + (cons directory (pathname-key-hash directory))))) + (key (!allocate-pathname host device dir+hash name type version))) + (declare (truly-dynamic-extent key)) + (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 (gethash key table) key))))))) ;;; Vector of logical host objects, each of which contains its translations. ;;; The vector is never mutated- always a new vector is created when adding @@ -323,9 +349,6 @@ ;;;; patterns -(defmethod make-load-form ((pattern pattern) &optional environment) - (make-load-form-saving-slots pattern :environment environment)) - (defmethod print-object ((pattern pattern) stream) (print-unreadable-object (pattern stream :type t) (if *print-pretty* @@ -463,6 +486,9 @@ (and (simple-string-p that) (string= this that))) (pattern + ;; PATTERN instances should probably become interned objects + ;; so that we can use EQ on them. But that currently has the same + ;; problem as PATHAME= has - the cache can be bypassed. (and (pattern-p that) (pattern= this that))) (cons @@ -472,106 +498,67 @@ ;;;; pathname functions -(defun pathname= (pathname1 pathname2) - (declare (type pathname pathname1) - (type pathname pathname2)) - (or (eq pathname1 pathname2) - (and (eq (%pathname-host pathname1) - (%pathname-host pathname2)) - (= (%pathname-dir-hash pathname1) (%pathname-dir-hash pathname2)) - (= (%pathname-stem-hash pathname1) (%pathname-stem-hash pathname2)) - (compare-component (%pathname-device pathname1) - (%pathname-device pathname2)) - (compare-component (%pathname-directory pathname1) - (%pathname-directory pathname2)) - (compare-component (%pathname-name pathname1) - (%pathname-name pathname2)) - (compare-component (%pathname-type pathname1) - (%pathname-type pathname2)) - (or (eq (%pathname-host pathname1) *physical-host*) - (compare-component (%pathname-version pathname1) - (%pathname-version pathname2)))))) +(macrolet ((compare-most-components () + `(and (eq (%pathname-host a) (%pathname-host b)) ; Interned + ;; Unless the pathname cache can be made 100% reliable, + ;; strength-reducing EQUAL to EQ is inadmissible here. + ;; To fix that, MAKE-LOAD-FORM methods need not to bypass + ;; INTERN-PATHNAME. + (let ((dir-a (%pathname-dir+hash a)) + (dir-b (%pathname-dir+hash b))) + (or (eq dir-a dir-b) + (compare-component (car dir-a) (car dir-b)))) + (compare-component (%pathname-device a) (%pathname-device b)) + (compare-component (%pathname-name a) (%pathname-name b)) + (compare-component (%pathname-type a) (%pathname-type b))))) + +;;; PATHNAME-KEY= can receive two different subsets of keys: +;;; - non-nil LIST is the directory part of a pathname +;;; - entire PATHNAME +(defun pathname-key= (a b) + (etypecase a + (list (and (listp b) (compare-component a b))) + (pathname (and (pathnamep b) + (compare-most-components) + (eql (pathname-version a) (pathname-version b)))))) + +(defun pathname= (a b) + (declare (type pathname a b)) + (or (eq a b) + (and (compare-most-components) + (or (eq (%pathname-host a) *physical-host*) + (compare-component (pathname-version a) + (pathname-version b))))))) + (sb-kernel::assign-equalp-impl 'pathname #'pathname=) +(sb-kernel::assign-equalp-impl 'logical-pathname #'pathname=) -;;; This is conceptually like (DEFUN-CACHED (%MAKE-PATHNAME ...)) -;;; except that we try hard never to evict entries until SAVE-LISP-AND-DIE. -;;; Entries can still be kicked out randomly though. -;;; A two-level lookup is used- it works better than mixing all -;;; pathname components into a hash key. -(define-load-time-global *pathnames* (make-array 211 :initial-element nil)) -(define-load-time-global *pathnames-lock* (sb-thread:make-mutex :name "Pathnames")) - -(defun %make-pathname (host device directory name type version) - (if (or device (neq host *physical-host*)) - (%%make-pathname host device directory name type version) - (let* ((table *pathnames*) - (index (rem (pathname-dir-hash directory) (length table))) - (dir-holder - ;; Candidates is a list of ((dir . contents) ...) - (loop named outer - with candidates = (svref table index) and new = nil - do - (let ((n-candidates 0)) - (dolist (candidate candidates) - (incf n-candidates) - (when (compare-component (car candidate) directory) - (return-from outer candidate))) - (unless new - (setq new (cons directory (make-array 3 :initial-element nil)))) - (cond ((< n-candidates 10) - (let* ((cell (cons new candidates)) - (actual-old (cas (svref table index) candidates cell))) - (when (eq actual-old candidates) - (return-from outer new)) - (setq candidates actual-old))) - (t - ;; Clobber this cache entry, losing all directories in it. - ;; Hopefully this doesn't happen often. - #+nil (format t "~&*** Pathname cache overflow: ~D ~S~%" - index (mapcar 'car candidates)) - (setf (svref table index) (list new)) - (return-from outer new))))))) - (flet ((matchp (stem-hash candidates) - (let ((n-candidates 0)) - (dolist (pathname candidates (values nil n-candidates)) - (when (and (= (%pathname-stem-hash pathname) stem-hash) - (compare-component (%pathname-version pathname) version) - (compare-component (%pathname-name pathname) name) - (compare-component (%pathname-type pathname) type)) - (return (values pathname 0))) - (incf n-candidates))))) - ;; We have tests asserting that the distinction between :NEWEST - ;; and NIL is preserved, though there is no effective difference. - (binding* ((stem-hash (mix (sxhash name) (sxhash type))) - (vector (the simple-vector (cdr dir-holder))) - (index (rem stem-hash (length vector))) - (candidates (svref vector index)) - ((found n-candidates) (matchp stem-hash candidates))) - (when found - (return-from %make-pathname found)) - ;; Optimistically assuming that the pathname won't be found - ;; on the double-check, allocate it now - (let ((pathname (%%make-pathname *physical-host* nil (car dir-holder) - name type version))) - (sb-thread::with-system-mutex (*pathnames-lock*) - (when (>= n-candidates 10) - ;; Rehash into a larger vector - (let* ((old-len (length vector)) - (new-len (+ old-len 4)) - (new-vector (make-array new-len :initial-element nil))) - (dovector (list vector) - (dolist (p list) - (push p (svref new-vector (rem (%pathname-stem-hash p) - new-len))))) - (rplacd dir-holder new-vector) - (setq vector new-vector - index (rem stem-hash new-len) - candidates (svref vector index)))) - (let ((found (matchp stem-hash candidates))) - (if found - (setq pathname found) - (push pathname (svref vector index))))) - pathname)))))) +;;; A pathname key is a key to an entry in *PATHNAMES*, either a pathname +;;; or a pathname-directory. +(defun pathname-key-hash (x) + (flet ((hash-piece (piece) + (etypecase piece + (string (sxhash piece)) ; transformed + (symbol (sxhash piece)) ; transformed + (pattern (pattern-hash piece)) + ((cons (eql :home) (cons string null)) + (sxhash (second piece)))))) + (etypecase x + (pathname + (let* ((host (%pathname-host x)) + ;; NAME-HASH is based on SXHASH of a string + (hash (if (typep host 'logical-host) (logical-host-name-hash host) 0))) + (mixf hash (hash-piece (%pathname-device x))) ; surely stringlike, right? + (awhen (%pathname-dir+hash x) (mixf hash (cdr it))) + (mixf hash (hash-piece (%pathname-name x))) + (mixf hash (hash-piece (%pathname-type x))) + ;; EQUAL might ignore the version, and it doesn't provide many bits + ;; of randomness, so don't bother with it. + hash)) + (list ;; a directory + (let ((hash 0)) + (dolist (piece x hash) + (mixf hash (hash-piece piece)))))))) ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or ;;; stream), into a pathname in PATHNAME. @@ -771,7 +758,7 @@ (if diddle-case (diddle-case default) default))))) - (%make-maybe-logical-pathname + (intern-pathname (or pathname-host default-host) ;; The device of ~/ shouldn't be merged, because the ;; expansion may have a different device @@ -906,7 +893,7 @@ diddle-defaults)) (t nil)))) - (%make-maybe-logical-pathname + (intern-pathname host (pick device devp %pathname-device) ; forced to :UNSPECIFIC when logical dir @@ -1047,8 +1034,7 @@ does not match the explicit HOST argument, ~S." :format-arguments (list new-host host))) (let ((pn-host (or new-host host (pathname-host defaults)))) - (values (%make-maybe-logical-pathname - pn-host device directory file type version) + (values (intern-pathname pn-host device directory file type version) end))))))) (defun parse-namestring (thing @@ -1126,8 +1112,7 @@ does not match the explicit HOST argument, ~S." :format-arguments (list new-host host))) (let ((pn-host (or new-host host (pathname-host defaults)))) - (values (%make-pathname - pn-host device directory file type version) + (values (intern-pathname pn-host device directory file type version) end))))))) (defun parse-native-namestring (thing @@ -1491,7 +1476,7 @@ (if (eq result :error) (error "~S doesn't match ~S." source from) result)))) - (%make-maybe-logical-pathname + (intern-pathname (or to-host source-host) (frob %pathname-device) (frob %pathname-directory translate-directories) @@ -1747,9 +1732,8 @@ (parse-host (logical-chunkify namestr start end))) (values host :unspecific (directory) name type version)))) -;;; We can't initialize this yet because not all host methods are -;;; loaded yet. -(defvar *logical-pathname-defaults*) +(define-load-time-global *logical-pathname-defaults* + (intern-pathname (make-logical-host :name "") :unspecific nil nil nil nil)) (defun logical-namestring-p (x) (and (stringp x) @@ -1943,11 +1927,6 @@ (translate-logical-pathname possibly-logical-pathname) possibly-logical-pathname)) -(defvar *logical-pathname-defaults* - (%make-logical-pathname - (make-logical-host :name (logical-word-or-lose "BOGUS")) - :unspecific nil nil nil nil)) - (defun load-logical-pathname-translations (host) "Reads logical pathname translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST, with HOST replaced by the supplied parameter. Returns T on success. @@ -2024,3 +2003,24 @@ ("SYS:CONTRIB;**;*.*.*" ,(physical-target "contrib")) ("SYS:OUTPUT;**;*.*.*" ,(physical-target "output")) ,@current-translations))))) + +(defmethod make-load-form ((pn pathname) &optional env) + (declare (ignore env)) + (labels ((reconstruct (component) + (cond ((pattern-p component) (patternify component)) + ((and (listp component) (some #'pattern-p component)) + (cons 'list (mapcar #'patternify component))) + (t `',component))) + (patternify (subcomponent) + (if (pattern-p subcomponent) + `(make-pattern ',(pattern-pieces subcomponent)) + `',subcomponent))) + (values `(intern-pathname + ,(if (typep pn 'logical-pathname) + `(find-logical-host ',(logical-host-name (%pathname-host pn))) + '*physical-host*) + ,(reconstruct (%pathname-device pn)) + ,(reconstruct (%pathname-directory pn)) + ,(reconstruct (%pathname-name pn)) + ,(reconstruct (%pathname-type pn)) + ,(reconstruct (%pathname-version pn)))))) diff -Nru sbcl-2.0.6/src/code/target-random.lisp sbcl-2.1.1/src/code/target-random.lisp --- sbcl-2.0.6/src/code/target-random.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-random.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -279,7 +279,7 @@ (declaim (start-block random %random-single-float %random-double-float random-chunk big-random-chunk)) -#-sb-fluid (declaim (inline random-chunk)) +(declaim (inline random-chunk)) #-x86 (defun random-chunk (state) (declare (type random-state state)) @@ -308,7 +308,7 @@ (declare (type random-state state)) (sb-vm::random-mt19937 (random-state-state state))) -#-sb-fluid (declaim (inline big-random-chunk)) +(declaim (inline big-random-chunk)) (defun big-random-chunk (state) (declare (type random-state state)) (logior (ash (random-chunk state) 32) @@ -318,7 +318,7 @@ ;;; float between 0.0 and 1.0 by clobbering the significand of 1.0 ;;; with random bits, then subtracting 1.0. This hides the fact that ;;; we have a hidden bit. -#-sb-fluid (declaim (inline %random-single-float %random-double-float)) +(declaim (inline %random-single-float %random-double-float)) (declaim (ftype (function ((single-float ($0f0)) random-state) (single-float $0f0)) %random-single-float)) @@ -390,9 +390,9 @@ ;;; as the speed gains due to needing fewer loop iterations are by far ;;; outweighted by the cost of the two divisions required (one to find ;;; the multiplier and one to bring the result into the correct range). -#-sb-fluid (declaim (inline %random-fixnum)) +(declaim (inline %random-fixnum)) (defun %random-fixnum (arg state) - (declare (type (integer 1 #.sb-xc:most-positive-fixnum) arg) + (declare (type (integer 1 #.most-positive-fixnum) arg) (type random-state state)) (if (= arg 1) 0 diff -Nru sbcl-2.0.6/src/code/target-signal.lisp sbcl-2.1.1/src/code/target-signal.lisp --- sbcl-2.0.6/src/code/target-signal.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-signal.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -15,14 +15,14 @@ ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL ;;; should be a valid signal number -#-sb-fluid (declaim (inline unix-kill)) +(declaim (inline unix-kill)) (define-alien-routine ("kill" unix-kill) int (pid int) (signal int)) ;;; Send the signal SIGNAL to the all the process in process group ;;; PGRP. SIGNAL should be a valid signal number -#-sb-fluid (declaim (inline unix-killpg)) +(declaim (inline unix-killpg)) (define-alien-routine ("killpg" unix-killpg) int (pgrp int) (signal int)) @@ -44,14 +44,6 @@ nil)) -;;;; C routines that actually do all the work of establishing signal handlers -(define-alien-routine ("install_handler" install-handler) - unsigned-long - (signal int) - (handler unsigned-long) - (ohandler unsigned-long) - (synchronous boolean)) - ;;;; interface to enabling and disabling signal handlers ;;; Note on the SYNCHRONOUS argument: On builds without pseudo-atomic, @@ -67,48 +59,39 @@ ;;; point instructions, certain system calls), hopefully ruling out the ;;; possibility that we would trigger it during allocation. +;;; FIXME: terrible name. doesn't actually "enable" in the sense of unmasking. (defun enable-interrupt (signal handler &key synchronous) - (declare (type (or function fixnum (member :default :ignore)) handler)) - (/show0 "enable-interrupt") - (flet ((run-handler (&rest args) - (declare (truly-dynamic-extent args)) + (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 + ;; on 'lisp_sig_handlers'. The reason for not returning it is that the value was + ;; always a closure, and there's no easy/portable way to ask what function was + ;; really meant. And you can't use that closure to reinstall the old thing + ;; because it would install a new closure on the old closure which, though + ;; feasible, is definitely not what was intended. + 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 () - (apply handler args)))) - (dx-let ((ohandler (make-array 1 :initial-element nil))) - ;; Pin OHANDLER in case the backend heap-allocates it - (with-pinned-objects (#'run-handler ohandler) - ;; 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 and return convention. - (let ((result (install-handler + (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 (case handler (:default 0) (:ignore 1) - (t (sb-kernel:get-lisp-obj-address #'run-handler))) - ;; VECTOR-SAP does not work on SIMPLE-VECTOR - (sb-kernel:get-lisp-obj-address ohandler) - synchronous))) - (cond ((= result 0) :default) - ((= result 1) :ignore) - (t - ;; The value in OHANDLER, if a lisp function, is not the right thing to - ;; return, but we do it anyway. It's always the RUN-HANDLER closure - ;; instead of what was supplied before as HANDLER. We can only hope that - ;; users don't pass the result of ENABLE-INTERRUPT as the argument to - ;; another call, as that would create a chain of closures. - ;; I wonder if the fact that we at some point decided that we need - ;; to allow signal nesting to about 1024 levels deep had anything - ;; to do with this bug? - (the (or function fixnum) (aref ohandler 0))))))))) - -(defun default-interrupt (signal) - (enable-interrupt signal :default)) - -(defun ignore-interrupt (signal) - (enable-interrupt signal :ignore)) + (t (sb-kernel:get-lisp-obj-address #'run-handler))))))) + nil) ;;;; Support for signal handlers which aren't. ;;;; @@ -130,7 +113,7 @@ (context (sap-ref-sap args sb-vm:n-word-bytes))) (dx-flet ((callback () (funcall run-handler signal info context))) - (sb-thread::new-lisp-thread-trampoline thread nil #'callback nil)))) + (sb-thread::run thread nil #'callback nil)))) ;;;; default LISP signal handlers @@ -167,7 +150,7 @@ (flet ((interrupt-it () ;; SB-KERNEL:*CURRENT-INTERNAL-ERROR-CONTEXT* will ;; either be bound in this thread by SIGINT-HANDLER or - ;; in the target thread by SIGPIPE-HANDLER. + ;; in the target thread by SIGURG-HANDLER. (with-alien ((context (* os-context-t) sb-kernel:*current-internal-error-context*)) (with-interrupts @@ -182,9 +165,9 @@ (let ((target (sb-thread::foreground-thread))) ;; Note that INTERRUPT-THREAD on *CURRENT-THREAD* doesn't actually ;; interrupt right away, because deferrables are blocked. Rather, - ;; the kernel would arrange for the SIGPIPE to hit when the SIGINT + ;; the kernel would arrange for the SIGURG to hit when the SIGINT ;; handler is done. However, on safepoint builds, we don't use - ;; SIGPIPE and lack an appropriate mechanism to handle pending + ;; SIGURG and lack an appropriate mechanism to handle pending ;; thruptions upon exit from signal handlers (and this situation is ;; unlike WITHOUT-INTERRUPTS, which handles pending interrupts ;; explicitly at the end). Only as long as safepoint builds pretend @@ -208,12 +191,12 @@ (exit)) #-sb-thruption -;;; SIGPIPE is not used in SBCL for its original purpose, instead it's +;;; 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 -;;; nothing to do so it's safe to receive spurious SIGPIPEs coming +;;; nothing to do so it's safe to receive spurious SIGURGs coming ;;; from the kernel. -(defun sigpipe-handler (signal code sb-kernel:*current-internal-error-context*) +(defun sigurg-handler (signal code sb-kernel:*current-internal-error-context*) (declare (ignore signal code)) (sb-thread::run-interruption)) @@ -222,28 +205,41 @@ (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." - (enable-interrupt sigint #'sigint-handler) - (enable-interrupt sigterm #'sigterm-handler) - (enable-interrupt sigill #'sigill-handler :synchronous t) - #-(or linux android haiku) - (enable-interrupt sigemt #'sigemt-handler) - (enable-interrupt sigfpe #'sb-vm:sigfpe-handler :synchronous t) + (%install-handler sigint #'sigint-handler) + (%install-handler sigterm #'sigterm-handler) + (%install-handler sigill #'sigill-handler) + #-(or linux android haiku) (%install-handler sigemt #'sigemt-handler) + (%install-handler sigfpe #'sb-vm:sigfpe-handler) (if (/= (extern-alien "install_sig_memory_fault_handler" int) 0) - (enable-interrupt sigbus #'sigbus-handler :synchronous t) + (%install-handler sigbus #'sigbus-handler) (write-string ";;;; SIGBUS handler not installed " sb-sys:*stderr*)) - #-(or linux android) - (enable-interrupt sigsys #'sigsys-handler :synchronous t) - #-sb-wtimer - (enable-interrupt sigalrm #'sigalrm-handler) - #-sb-thruption - (enable-interrupt sigpipe #'sigpipe-handler) - (enable-interrupt sigchld #'sigchld-handler) - #+hpux (ignore-interrupt sigxcpu) - #-sb-safepoint (unblock-gc-signals) - (unblock-deferrable-signals) + #-(or linux android) (%install-handler sigsys #'sigsys-handler) + #-sb-wtimer (%install-handler sigalrm #'sigalrm-handler) + #-sb-thruption (%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))) + (with-pinned-objects (mask) + (pthread-sigmask sb-unix::SIG_SETMASK mask nil))) (values)) ;;;; etc. diff -Nru sbcl-2.0.6/src/code/target-stream.lisp sbcl-2.1.1/src/code/target-stream.lisp --- sbcl-2.0.6/src/code/target-stream.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-stream.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -68,14 +68,11 @@ ;;; unread-char, read-byte, listen here that was removed because these ;;; functions are redefined when simple-streams are loaded. -#-sb-fluid (declaim (inline ansi-stream-peek-char)) +(declaim (inline ansi-stream-peek-char)) (defun ansi-stream-peek-char (peek-type stream eof-error-p eof-value recursive-p) (cond ((typep stream 'echo-stream) - (echo-misc stream - :peek-char - peek-type - (list eof-error-p eof-value))) + (echo-stream-peek-char stream peek-type eof-error-p eof-value)) (t (generalized-peeking-mechanism peek-type eof-value char @@ -89,11 +86,15 @@ eof-value recursive-p) (declare (type (or character boolean) peek-type) (explicit-check)) - (let ((stream (in-stream-from-designator stream))) - (if (ansi-stream-p stream) + (stream-api-dispatch (stream (in-stream-from-designator stream)) + :simple (let ((char (s-%peek-char stream peek-type eof-error-p eof-value))) + ;; simple-streams -%PEEK-CHAR always ignored RECURSIVE-P + ;; so I removed it from the call. + (if (eq char eof-value) char (the character char))) + :native (ansi-stream-peek-char peek-type stream eof-error-p eof-value recursive-p) - ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM + :gray (let ((char (generalized-peeking-mechanism peek-type :eof char @@ -108,18 +109,16 @@ (eof-or-lose stream eof-error-p eof-value)))) (if (eq char eof-value) char - (the character char)))))) + (the character char))))) -(defun echo-misc (stream operation &optional arg1 arg2) +(defun echo-misc (stream operation arg1) (let* ((in (two-way-stream-input-stream stream)) (out (two-way-stream-output-stream stream))) - (case operation + (stream-misc-case (operation) (:listen (if (ansi-stream-p in) - (or (/= (the fixnum (ansi-stream-in-index in)) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc in) in :listen)) - (stream-misc-dispatch in :listen))) + (%ansi-stream-listen in) + (stream-misc-dispatch in operation arg1))) (:unread (setf (echo-stream-unread-stuff stream) t) (unread-char arg1 in)) (:element-type @@ -135,9 +134,17 @@ in-mode))) (:close (set-closed-flame stream)) - (:peek-char - ;; For the special case of peeking into an echo-stream - ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE) + (t + (or (if (ansi-stream-p in) + (call-ansi-stream-misc in operation arg1) + (stream-misc-dispatch in operation arg1)) + (if (ansi-stream-p out) + (call-ansi-stream-misc out operation arg1) + (stream-misc-dispatch out operation arg1))))))) + +(defun echo-stream-peek-char (stream peek-type eof-error-p eof-value) + (let* ((in (two-way-stream-input-stream stream)) + (out (two-way-stream-output-stream stream))) ;; returns peeked-char, eof-value, or errors end-of-file ;; ;; Note: This code could be moved into PEEK-CHAR if desired. @@ -163,17 +170,32 @@ (setf unread-p (echo-stream-unread-stuff stream)) (setf (echo-stream-unread-stuff stream) nil)) (setf initial-peek-p nil) - (read-char in (first arg2) :eof))) + (read-char in eof-error-p :eof))) (generalized-peeking-mechanism - arg1 (second arg2) char + peek-type eof-value char (infn) :eof (unread-char char in) - (outfn char))))) - (t - (or (if (ansi-stream-p in) - (funcall (ansi-stream-misc in) in operation arg1 arg2) - (stream-misc-dispatch in operation arg1 arg2)) - (if (ansi-stream-p out) - (funcall (ansi-stream-misc out) out operation arg1 arg2) - (stream-misc-dispatch out operation arg1 arg2))))))) + (outfn char)))))) + +;;; Stop wasting space with unnecessarily preserved inline definitions. +;;; ANSI-STREAM-LISTEN, %ANSI-STREAM-LISTEN, ANSI-STREAM-CLEAR-INPUT +;;; are needed for sb-simple-streams. +;;; Maybe everything else can just get dropped entirely, the symbol and its +;;; function, instead of just the inline sexpr. +(dolist (name '(!ansi-stream-ftell + ansi-stream-read-line ansi-stream-read-char + ansi-stream-unread-char + ansi-stream-read-char-no-hang + ansi-stream-read-byte read-n-bytes + read-char unread-char read-byte + read-sequence/read-function write-sequence/write-function + stream-element-mode)) + (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) + *!removable-symbols*) +;;; These two wants to get invoked by simple-streams but would get tree-shaken out +;;; were they not externalized. +(export '(sb-impl::in-stream-from-designator sb-impl::eof-or-lose) + 'sb-impl) diff -Nru sbcl-2.0.6/src/code/target-sxhash.lisp sbcl-2.1.1/src/code/target-sxhash.lisp --- sbcl-2.0.6/src/code/target-sxhash.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-sxhash.lisp 2021-01-30 11:22:38.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-alloc-region-slot)) #+(and (not sb-thread) cheneygc) (sap-int (dynamic-space-free-pointer)) ;; dynamic-space-free-pointer increments only when a page is full. @@ -111,7 +111,7 @@ (get-lisp-obj-address instance)))) ;; perturb the address (logand (#+64-bit murmur3-fmix64 #-64-bit murmur3-fmix32 addr) - sb-xc:most-positive-fixnum))) + most-positive-fixnum))) (declaim (inline instance-sxhash)) (defun instance-sxhash (instance) @@ -442,7 +442,7 @@ ;; Access as unsigned. +X and -X hash differently because ;; of 2's complement, so disregarding the sign bit is fine. (mixf result (logand (%raw-instance-ref/word key i) - sb-xc:most-positive-fixnum))) + most-positive-fixnum))) (,(1+index-of 'single-float) ,(mix-float '(%raw-instance-ref/single key i) $0f0)) (,(1+index-of 'double-float) @@ -463,7 +463,7 @@ (depthoid (1- depthoid))) (declare (index max-iterations)) (if (/= (layout-bitmap layout) +layout-all-tagged+) - (let ((slots (dd-slots (layout-info layout)))) + (let ((slots (dd-slots (layout-dd layout)))) (loop (unless slots (return)) (let* ((slot (pop slots)) (rsd-index+1 (rsd-index+1 slot)) @@ -524,8 +524,8 @@ ;; it didn't.) (sxhash val))) (macrolet ((hash-float (type key) - (let ((lo (coerce sb-xc:most-negative-fixnum type)) - (hi (coerce sb-xc:most-positive-fixnum type))) + (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. @@ -563,9 +563,9 @@ (double-float (hash-float double-float key)) #+long-float (long-float (error "LONG-FLOAT not currently supported"))))) - (rational (if (and (<= sb-xc:most-negative-double-float + (rational (if (and (<= most-negative-double-float key - sb-xc:most-positive-double-float) + most-positive-double-float) (= (coerce key 'double-float) key)) (sxhash-double-float (coerce key 'double-float)) (sxhash key))) @@ -596,7 +596,7 @@ (declare (fixnum depthoid)) (cond ((atom x) (sxhash x)) ((zerop depthoid) - #.(logand sb-xc:most-positive-fixnum #36Rglobaldbsxhashoid)) + #.(logand most-positive-fixnum #36Rglobaldbsxhashoid)) (t (mix (recurse (car x) (1- depthoid)) (recurse (cdr x) (1- depthoid))))))) (traverse 0 name 10)))) diff -Nru sbcl-2.0.6/src/code/target-thread.lisp sbcl-2.1.1/src/code/target-thread.lisp --- sbcl-2.0.6/src/code/target-thread.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-thread.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,27 @@ (in-package "SB-THREAD") +;;; symbols to protect from tree-shaker, for some tests +(export '(%thread-local-references + current-thread-sap + get-spinlock + pthread-kill + raise + release-spinlock + spinlock + with-deathlok + with-session-lock + with-spinlock)) + +#+(or linux win32) +(defmacro my-kernel-thread-id () + `(sb-ext:truly-the + (unsigned-byte 32) + (sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-os-kernel-tid-slot)))) +;; using the pthread_id seems fine, the umtx interface uses word-sized values +#+freebsd +(defmacro my-kernel-thread-id () `(thread-primitive-thread *current-thread*)) + ;;; CAS Lock ;;; ;;; Locks don't come any simpler -- or more lightweight than this. While @@ -126,6 +147,10 @@ (format s "Joining thread timed out: thread ~A ~ did not exit in time." (thread-error-thread c))) + (:foreign + (format s "Joining thread failed: thread ~A ~ + is not a lisp thread." + (thread-error-thread c))) (:self-join (format s "In thread ~A, attempt to join the current ~ thread." @@ -151,57 +176,48 @@ (condition) (thread-error-thread condition)) -;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is -;;; necessary because threads are only supported with the conservative -;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS) -;;; are treated as references. - (setf (documentation 'thread-name 'function) - "Name of the thread. Can be assigned to using SETF. Thread names can be -arbitrary printable objects, and need not be unique.") + "Name of the thread. Can be assigned to using SETF. A thread name must be +a simple-string (not necessarily unique) or NIL.") (defmethod print-object ((thread thread) stream) (print-unreadable-object (thread stream :type t :identity t) - (let* ((cookie (list thread)) - (info (if (thread-alive-p thread) - :running - (multiple-value-list - (join-thread thread :default cookie)))) - (state (if (eq :running info) - (let* ((thing (progn - (barrier (:read)) - (thread-waiting-for thread)))) - (typecase thing - (cons - (list "waiting on:" (cdr thing) - "timeout: " (car thing))) - (null - (list info)) - (t - (list "waiting on:" thing)))) - (if (eq cookie (car info)) - (list :aborted) - :finished))) - (values (when (eq :finished state) - info)) + (let* ((values (cond ((thread-alive-p thread) :running) + ;; don't call JOIN-THREAD, just read the result if ALIVE-P is NIL + ((listp (thread-result thread)) (thread-result thread)) + (t :aborted))) + (state (cond ((eq values :running) + (let* ((thing (progn + (barrier (:read)) + (thread-waiting-for thread)))) + (typecase thing + (null '(:running)) + (cons + (list "waiting on:" (cdr thing) + "timeout: " (car thing))) + (t + (list "waiting on:" thing))))) + ((eq values :aborted) '(:aborted)) + (t :finished))) (*print-level* 4)) (format stream + ;; if not finished, show the STATE as a list. + ;; if finished, show the VALUES. "~@[~S ~]~:[~{~I~A~^~2I~_ ~}~_~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]" (thread-name thread) (eq :finished state) state values)))) -(defun print-lock (lock name owner stream) - (let ((*print-circle* t)) - (print-unreadable-object (lock stream :type t :identity (not name)) +(defmethod print-object ((mutex mutex) stream) + (let ((name (mutex-name mutex)) + (owner (mutex-owner mutex)) + (*print-circle* t)) + (print-unreadable-object (mutex stream :type t :identity (not name)) (if owner (format stream "~@[~S ~]~2I~_owner: ~S" name owner) (format stream "~@[~S ~](free)" name))))) -(defmethod print-object ((mutex mutex) stream) - (print-lock mutex (mutex-name mutex) (mutex-owner mutex) stream)) - ;; NB: ephemeral threads must terminate strictly before the test of NTHREADS>1 ;; in DEINIT, i.e. this is not a promise that the thread will terminate ;; just-in-time for the final call out to save, but rather by an earlier time. @@ -212,17 +228,27 @@ an error in that case." (thread-%ephemeral-p thread)) -;; A thread is eligible for gc iff it has finished and there are no -;; more references to it. This structure keeps a reference to -;; all running threads ordered by stack base address. +;;; Keep an AVL tree of threads ordered by stack base address. NIL is the empty tree. (sb-ext:define-load-time-global *all-threads* ()) -(sb-ext:define-load-time-global *all-threads-lock* (make-mutex :name "all threads lock")) +;;; Ensure that THREAD is in *ALL-THREADS*. +(defmacro update-all-threads (key thread) + `(let ((addr ,key)) + (barrier (:read)) + (let ((old *all-threads*)) + (loop + ;; If ADDR exists, then we have a bug in the thread exit handler. + ;; The workaround here would be to delete the old thread first, + ;; but I'd rather find out about the bug than bury it. + (aver (not (avl-find addr old))) + (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) - -(defmacro with-all-threads-lock (&body body) - `(with-system-mutex (*all-threads-lock*) - ,@body)) +;;; *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 @@ -232,7 +258,12 @@ ;; Of course by the time we're done collecting nodes, the tree can have ;; been replaced by a different tree. (barrier (:read)) - (avltree-list *all-threads*)) + (avltree-filter (lambda (node) + (let ((thread (avlnode-data node))) + (when (and (= (thread-%visible thread) 1) + (neq thread sb-impl::*finalizer-thread*)) + thread))) + *all-threads*)) ;;; used by debug-int.lisp to access interrupt contexts @@ -250,43 +281,60 @@ #-sb-thread (int-sap 0)) -(declaim (inline current-thread-os-thread)) -(defun current-thread-os-thread () - #+sb-thread - (sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-os-thread-slot)) - #-sb-thread - 0) - (sb-ext:define-load-time-global *initial-thread* nil) -(sb-ext:define-load-time-global *make-thread-lock* nil) - -(eval-when (:compile-toplevel :load-toplevel) - #+(and sb-thread sb-futex linux) (push :futex-use-tid sb-xc:*features*)) -#+linux (define-alien-routine "sb_GetTID" (unsigned 32)) - -(defun init-initial-thread () - (/show0 "Entering INIT-INITIAL-THREAD") - ;;; FIXME: is it purposeful or accidental that we recreate some of - ;;; the global mutexes but not *ALL-THREADS-LOCKS* ? +;;; *JOINABLE-THREADS* is a list of THREAD instances used only if #+pauseless-threadstart +;;; I had attempted to construct the list using the thread's memory to create cons +;;; cells but that turned out to be flawed- the cells must be freshly heap-allocated, +;;; because ATOMIC-POP is vulnerable to the A/B/A problem if cells are reused. +;;; Example: initial state: *JOINABLE-THREADS* -> node1 -> node2 -> node3. +;;; After reading *JOINABLE-THREADS* we want to CAS it to node2. +;;; If, after reading the variable, all of node1, node2, and node3 are popped +;;; by another thread, and then node1 is reused, and made to point to node4, +;;; then the new state is: *JOINABLE-THREADS* -> node1 -> node4 +;;; which looks like CAS(*joinable-threads*, node1, node2) should succeed, +;;; but it should not. The LL/SC model would detect that, but CAS can not. +;;; +;;; A thread is pushed into *JOINABLE-THREADS* while still using its lisp stack. +;;; This is fine, because the C code will perform a join, which will effectively +;;; wait until the lisp thread is off its stack. It won't have to wait long, +;;; because pushing into *JOINABLE-THREADS* is the last thing to happen in lisp. +;;; In theory we could support some mode of keeping the memory while joining +;;; the pthread, but we currently do not. +(sb-ext:define-load-time-global *joinable-threads* nil) +(declaim (list *joinable-threads*)) ; list of threads + +;;; Copy some slots from the C 'struct thread' into the SB-THREAD:THREAD. +(defmacro copy-primitive-thread-fields (this) + `(progn + (setf (thread-primitive-thread ,this) (sap-int (current-thread-sap))) + #-win32 + (setf (thread-os-thread ,this) + (sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-os-thread-slot))))) + +(defmacro set-thread-control-stack-slots (this) + `(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*))) + +;;; Not uncoincidentally, the variables assigned here are also +;;; listed in SB-KERNEL::*SAVE-LISP-CLOBBERED-GLOBALS* +(defun init-main-thread () + (/show0 "Entering INIT-MAIN-THREAD") (setf sb-impl::*exit-lock* (make-mutex :name "Exit Lock") *make-thread-lock* (make-mutex :name "Make-Thread Lock")) - (let ((thread (%make-thread :name "main thread" - :%alive-p t))) - #+linux (setf (thread-os-tid thread) (sb-gettid)) + (let* ((name "main thread") + (thread (%make-thread name nil (make-semaphore :name name)))) + (copy-primitive-thread-fields thread) + (set-thread-control-stack-slots thread) ;; Run the macro-generated function which writes some values into the TLS, ;; most especially *CURRENT-THREAD*. (init-thread-local-storage thread) - (setf (thread-os-thread thread) (current-thread-os-thread) - (thread-stack-end thread) (get-lisp-obj-address sb-vm:*control-stack-end*) - (thread-primitive-thread thread) (sap-int (current-thread-sap)) - *initial-thread* thread) - (grab-mutex (thread-result-lock thread)) - ;; Either *all-threads* is empty or it contains exactly one thread - ;; in case we are in reinit since saving core with multiple - ;; threads doesn't work. + (setf *initial-thread* thread) + (setf *joinable-threads* nil) (setq *all-threads* - (avl-insert nil (get-lisp-obj-address sb-vm:*control-stack-start*) thread)))) + (avl-insert nil + (sb-thread::thread-primitive-thread sb-thread:*current-thread*) + thread)))) (defun main-thread () "Returns the main thread of the process." @@ -356,24 +404,14 @@ ;;;; Aliens, low level stuff -(define-alien-routine "kill_safely" - int - (os-thread #-alpha unsigned #+alpha unsigned-int) - (signal int)) - -(define-alien-routine "wake_thread" - int - (os-thread unsigned)) +;;; *STARTING-THREADS* receives special treatment by the garbage collector. +;;; The contents of it are pinned (in that respect it is like *PINNED-OBJECTS*) +;;; but also the STARTUP-INFO of each thread is pinned. +(sb-ext:define-load-time-global *starting-threads* nil) +(declaim (list *starting-threads*)) ; list of threads #+sb-thread (progn - ;; FIXME it would be good to define what a thread id is or isn't - ;; (our current assumption is that it's a fixnum). It so happens - ;; that on Linux it's a pid, but it might not be on posix thread - ;; implementations. - (define-alien-routine ("create_thread" %create-thread) - unsigned (lisp-fun-address unsigned)) - (declaim (inline %block-deferrable-signals)) (define-alien-routine ("block_deferrable_signals" %block-deferrable-signals) void @@ -385,18 +423,31 @@ #+sb-futex (progn - (declaim (inline futex-wait %futex-wait futex-wake)) + (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (define-structure-slot-addressor mutex-state-address + ;; """ (Futexes are 32 bits in size on all platforms, including 64-bit systems.) """ + ;; which means we need to add 4 bytes to get to the low 32 bits of the slot contents + ;; where we store state. This would be prettier if we had 32-bit raw slots. + :structure mutex + :slot state + :byte-offset (+ #+(and 64-bit big-endian) 4)) + (define-structure-slot-addressor waitqueue-token-address + :structure waitqueue + :slot token + :byte-offset (+ #+(and 64-bit big-endian) 4))) + + (export 'futex-wake) ; for naughty users only + (declaim (inline futex-wait futex-wake)) - (define-alien-routine ("futex_wait" %futex-wait) int - (word unsigned) (old-value #+linux (unsigned 32) #-linux unsigned) - (to-sec long) (to-usec unsigned-long)) - - (defun futex-wait (word old to-sec to-usec) - (with-interrupts - (%futex-wait word old to-sec to-usec))) + (define-alien-routine "futex_wake" int (word-addr unsigned) (n unsigned-long)) - (define-alien-routine "futex_wake" - int (word unsigned) (n unsigned-long)))) + (defun 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")) + (with-interrupts + (alien-funcall %wait word-addr oldval to-sec to-usec)))))) (defmacro with-deadlocks ((thread lock &optional (timeout nil timeoutp)) &body forms) (with-unique-names (n-thread n-lock new n-timeout) @@ -418,7 +469,7 @@ (barrier (:write)) ,@forms) ;; Interrupt handlers and GC save and restore any - ;; previous wait marks using WITHOUT-DEADLOCKS below. + ;; previous wait marks using WITHOUT-THREAD-WAITING-FOR (setf (thread-waiting-for ,n-thread) nil) (barrier (:write)))))) @@ -427,59 +478,8 @@ (setf (documentation 'make-mutex 'function) "Create a mutex." (documentation 'mutex-name 'function) "The name of the mutex. Setfable.") -#+(and sb-thread sb-futex) -(progn - (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) - ;; """ (Futexes are 32 bits in size on all platforms, including 64-bit systems.) """ - ;; which means we need to add 4 bytes to get to the low 32 bits of the slot contents - ;; where we store state. This would be prettier if we had 32-bit raw slots. - (define-structure-slot-addressor mutex-state-address - :structure mutex - :slot state - :byte-offset (+ #+(and 64-bit big-endian) 4))) - ;; Important: current code assumes these are fixnums or other - ;; lisp objects that don't need pinning. - (defconstant +lock-free+ 0) - (defconstant +lock-taken+ 1) - (defconstant +lock-contested+ 2)) - -(defun mutex-owner (mutex) - "Current owner of the mutex, NIL if the mutex is free. Naturally, -this is racy by design (another thread may acquire the mutex after -this function returns), it is intended for informative purposes. For -testing whether the current thread is holding a mutex see -HOLDING-MUTEX-P." - ;; Make sure to get the current value. - (sb-ext:compare-and-swap (mutex-%owner mutex) nil nil)) - (sb-ext:define-load-time-global **deadlock-lock** nil) -#+(or (not sb-thread) sb-futex) -(defstruct (waitqueue (:copier nil) (:constructor make-waitqueue (&key name))) - "Waitqueue type." - #+(and sb-thread sb-futex) - (token 0 - ;; actually 32-bits, but it needs to be a raw slot and we don't have - ;; 32-bit raw slots on 64-bit machines. - #+futex-use-tid :type #+futex-use-tid sb-ext:word) - ;; If adding slots between TOKEN and NAME, please see futex_name() in linux_os.c - ;; which attempts to divine a string from a futex word address. - (name nil :type (or null string))) - -#+(and sb-thread (not sb-futex)) -(defstruct (waitqueue (:copier nil) (:constructor make-waitqueue (&key name))) - "Waitqueue type." - (name nil :type (or null string)) - ;; For WITH-CAS-LOCK: because CONDITION-WAIT must be able to call - ;; %WAITQUEUE-WAKEUP without re-aquiring the mutex, we need a separate - ;; lock. In most cases this should be uncontested thanks to the mutex -- - ;; the only case where that might not be true is when CONDITION-WAIT - ;; unwinds and %WAITQUEUE-DROP is called. - %owner - %head - %tail) -(declaim (sb-ext:freeze-type waitqueue)) - ;;; Signals an error if owner of LOCK is waiting on a lock whose release ;;; depends on the current thread. Does not detect deadlocks from sempahores. (defun check-deadlock () @@ -581,9 +581,9 @@ (loop with max-ticks = (max 100000 (min (* 2 try-ticks) (expt 10 7))) for scale of-type fixnum = 1 - then (let ((x (logand sb-xc:most-positive-fixnum (* 2 scale)))) + then (let ((x (logand most-positive-fixnum (* 2 scale)))) (if (> scale x) - sb-xc:most-positive-fixnum + most-positive-fixnum x)) do (try) (let* ((now (get-tick)) @@ -645,47 +645,96 @@ (,deadline (when ,sec (+ (get-internal-real-time) - (round (* ,seconds sb-xc:internal-time-units-per-second)))))) + (round (* ,seconds internal-time-units-per-second)))))) (flet ((,name () (when ,deadline (let ((,time-left (- ,deadline (get-internal-real-time)))) (if (plusp ,time-left) (* (coerce ,time-left 'single-float) - (sb-xc:/ $1.0f0 sb-xc:internal-time-units-per-second)) + (sb-xc:/ $1.0f0 internal-time-units-per-second)) 0))))) ,@body)))) +;;; If you want to pick at runtime what kind of mutex to use, you can replace +;;; this DEFCONSTANT with a DEFGLOBAL +(defconstant futex-enabled (or #+sb-futex t)) + (defun %try-mutex (mutex new-owner) (declare (type mutex mutex) (optimize (speed 3))) - (barrier (:read)) - (let ((old (mutex-%owner mutex))) - (when (eq new-owner old) - (error "Recursive lock attempt ~S." mutex)) - #-sb-thread - (when old - (error "Strange deadlock on ~S in an unithreaded build?" mutex)) - #-(and sb-thread sb-futex) - (and (not old) - ;; Don't even bother to try to CAS if it looks bad. - (not (sb-ext:compare-and-swap (mutex-%owner mutex) nil new-owner))) - #+(and sb-thread sb-futex) - ;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper. - (when (eql +lock-free+ (sb-ext:compare-and-swap (mutex-state mutex) - +lock-free+ - +lock-taken+)) - (let ((prev (sb-ext:compare-and-swap (mutex-%owner mutex) nil new-owner))) - (when prev - (bug "Old owner in free mutex: ~S" prev)) - t)))) + (cond #+sb-futex + (t + ;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper. + (cond ((= (sb-ext:cas (mutex-state mutex) 0 1) 0) + (setf (mutex-%owner mutex) (sb-ext:truly-the thread new-owner)) + t) ; GRAB-MUTEX wants %TRY-MUTEX to return boolean, not generalized boolean + ((eq (mutex-%owner mutex) new-owner) + (error "Recursive lock attempt ~S." mutex)))) + #-sb-futex + (t + (barrier (:read)) + (let ((old (mutex-%owner mutex))) + (when (eq new-owner old) + (error "Recursive lock attempt ~S." mutex)) + #-sb-thread + (when old + (error "Strange deadlock on ~S in an unithreaded build?" mutex)) + (and (not old) + ;; Don't even bother to try to CAS if it looks bad. + (not (sb-ext:compare-and-swap (mutex-%owner mutex) nil new-owner))))))) #+sb-thread (defun %%wait-for-mutex (mutex new-owner to-sec to-usec stop-sec stop-usec) (declare (type mutex mutex) (optimize (speed 3))) (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) - #-sb-futex - (declare (ignore to-sec to-usec)) - #-sb-futex - (flet ((cas () + (declare (ignorable to-sec to-usec)) + (cond + #+sb-futex + (t + ;; This is a fairly direct translation of the Mutex 2 algorithm from + ;; "Futexes are Tricky" by Ulrich Drepper. + ;; + ;; void lock () { + ;; int c; + ;; if ((c = cmpxchg(val, 0, 1)) != 0) + ;; do { + ;; if (c == 2 || cmpxchg(val, 1, 2) != 0) + ;; futex_wait(&val, 2); + ;; } while ((c = cmpxchg(val, 0, 2)) != 0); + ;; } + ;; + (symbol-macrolet ((val (mutex-state mutex))) + (let ((c (sb-ext:cas val 0 1))) ; available -> taken + (unless (= c 0) ; Got it right off the bat? + (nlx-protect + (if (not stop-sec) + (loop ; untimed + ;; 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) + (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 + (loop ; same as above but check for timeout + (when (or (eql c 2) (/= 0 (sb-ext:cas val 1 2))) + (if (eql 1 (with-pinned-objects (mutex) + (futex-wait (mutex-state-address mutex) 2 to-sec to-usec))) + ;; -1 = EWOULDBLOCK, possibly spurious wakeup + ;; 0 = normal wakeup + ;; 1 = ETIMEDOUT ***DONE*** + ;; 2 = EINTR, a spurious wakeup + (return-from %%wait-for-mutex nil))) + (when (= 0 (setq c (sb-ext:cas val 0 2))) (return)) ; win + ;; Update timeout + (setf (values to-sec to-usec) + (sb-impl::relative-decoded-times stop-sec stop-usec)))) + ;; Unwinding because futex-wait allows interrupts, wake up another futex + (with-pinned-objects (mutex) + (futex-wake (mutex-state-address mutex) 1))))) + (setf (mutex-%owner mutex) new-owner) + t)) + #-sb-futex + (t + (flet ((cas () (loop repeat 100 when (and (progn (barrier (:read)) @@ -698,47 +747,8 @@ (sb-ext:spin-loop-hint)) ;; Check for pending interrupts. (with-interrupts nil))) - (declare (dynamic-extent #'cas)) - (%%wait-for #'cas stop-sec stop-usec)) - #+sb-futex - ;; This is a fairly direct translation of the Mutex 2 algorithm from - ;; "Futexes are Tricky" by Ulrich Drepper. - (flet ((maybe (old) - (when (eql +lock-free+ old) - (let ((prev (sb-ext:compare-and-swap (mutex-%owner mutex) - nil new-owner))) - (when prev - (bug "Old owner in free mutex: ~S" prev)) - (return-from %%wait-for-mutex t))))) - (prog ((old (sb-ext:compare-and-swap (mutex-state mutex) - +lock-free+ +lock-taken+))) - ;; Got it right off the bat? - (maybe old) - :retry - ;; Mark it as contested, and sleep. (Exception: it was just released.) - (when (or (eql +lock-contested+ old) - (not (eql +lock-free+ - (sb-ext:compare-and-swap - (mutex-state mutex) +lock-taken+ +lock-contested+)))) - (when (eql 1 (with-pinned-objects (mutex) - (futex-wait (mutex-state-address mutex) - (get-lisp-obj-address +lock-contested+) - (or to-sec -1) - (or to-usec 0)))) - ;; -1 = EWOULDBLOCK, possibly spurious wakeup - ;; 0 = normal wakeup - ;; 1 = ETIMEDOUT ***DONE*** - ;; 2 = EINTR, a spurious wakeup - (return-from %%wait-for-mutex nil))) - ;; Try to get it, still marking it as contested. - (maybe - (sb-ext:compare-and-swap (mutex-state mutex) +lock-free+ +lock-contested+)) - ;; Update timeout if necessary. - (when stop-sec - (setf (values to-sec to-usec) - (sb-impl::relative-decoded-times stop-sec stop-usec))) - ;; Spin. - (go :retry)))) + (declare (dynamic-extent #'cas)) + (%%wait-for #'cas stop-sec stop-usec))))) #+sb-thread (defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep) @@ -838,23 +848,13 @@ ;; FIXME: Is a :memory barrier too strong here? Can we use a :write ;; barrier instead? (barrier (:memory))) - #+(and sb-thread sb-futex) + #+sb-futex (when old-owner - ;; FIXME: once ATOMIC-INCF supports struct slots with word sized - ;; unsigned-byte type this can be used: - ;; - ;; (let ((old (sb-ext:atomic-incf (mutex-state mutex) -1))) - ;; (unless (eql old +lock-free+) - ;; (setf (mutex-state mutex) +lock-free+) - ;; (with-pinned-objects (mutex) - ;; (futex-wake (mutex-state-address mutex) 1)))) - (let ((old (sb-ext:compare-and-swap (mutex-state mutex) - +lock-taken+ +lock-free+))) - (when (eql old +lock-contested+) - (sb-ext:compare-and-swap (mutex-state mutex) - +lock-contested+ +lock-free+) - (with-pinned-objects (mutex) - (futex-wake (mutex-state-address mutex) 1)))) + (unless (eql (sb-ext:atomic-decf (mutex-state mutex) 1) 1) + (setf (mutex-state mutex) 0) + (sb-thread:barrier (:write)) ; paranoid ? + (with-pinned-objects (mutex) + (futex-wake (mutex-state-address mutex) 1))) nil))) @@ -914,12 +914,13 @@ (setf (documentation 'waitqueue-name 'function) "The name of the waitqueue. Setfable." (documentation 'make-waitqueue 'function) "Create a waitqueue.") -#+(and sb-thread sb-futex) -(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) - (define-structure-slot-addressor waitqueue-token-address - :structure waitqueue - :slot token - :byte-offset (+ #+(and 64-bit big-endian) 4))) +(defmacro nlx-protect-futex (protected &body cleanup) + (declare (ignorable cleanup)) + #+sb-futex + `(nlx-protect ,protected + ,@cleanup) + #-sb-futex + protected) (declaim (inline %condition-wait)) (defun %condition-wait (queue mutex @@ -937,10 +938,37 @@ ;; Need to disable interrupts so that we don't miss grabbing ;; the mutex on our way out. (without-interrupts - (unwind-protect - (progn - #-sb-futex - (progn + (nlx-protect-futex + (unwind-protect + (cond + #+sb-futex + (t + (with-pinned-objects (queue) + (setf (waitqueue-token queue) (my-kernel-thread-id)) + (release-mutex mutex) + ;; Now we go to sleep using futex-wait. If anyone else + ;; manages to grab MUTEX and call CONDITION-NOTIFY during + ;; this comment, it will change the token, and so futex-wait + ;; returns immediately instead of sleeping. Ergo, no lost + ;; wakeup. We may get spurious wakeups, but that's ok. + (setf status + (case (allow-with-interrupts + (futex-wait (waitqueue-token-address queue) + (my-kernel-thread-id) + ;; our way of saying "no + ;; timeout": + (or to-sec -1) + (or to-usec 0))) + ((1) + ;; 1 = ETIMEDOUT + :timeout) + (t + ;; -1 = EWOULDBLOCK, possibly spurious wakeup + ;; 0 = normal wakeup + ;; 2 = EINTR, a spurious wakeup + :ok))))) + #-sb-futex + (t (%with-cas-lock ((waitqueue-%owner queue)) (%waitqueue-enqueue me queue)) (release-mutex mutex) @@ -952,73 +980,48 @@ (declare (dynamic-extent #'wakeup)) (allow-with-interrupts (%%wait-for #'wakeup stop-sec stop-usec))) - :timeout))) - #+sb-futex - (with-pinned-objects (queue - ;; No point in pinning ME if not taking the adddress. - #-futex-use-tid me) - (setf (waitqueue-token queue) #+futex-use-tid (thread-os-tid me) - #-futex-use-tid me) - (release-mutex mutex) - ;; Now we go to sleep using futex-wait. If anyone else - ;; manages to grab MUTEX and call CONDITION-NOTIFY during - ;; this comment, it will change the token, and so futex-wait - ;; returns immediately instead of sleeping. Ergo, no lost - ;; wakeup. We may get spurious wakeups, but that's ok. - (setf status - (case (allow-with-interrupts - (futex-wait (waitqueue-token-address queue) - #+futex-use-tid (thread-os-tid me) - #-futex-use-tid (get-lisp-obj-address me) - ;; our way of saying "no - ;; timeout": - (or to-sec -1) - (or to-usec 0))) - ((1) - ;; 1 = ETIMEDOUT - :timeout) - (t - ;; -1 = EWOULDBLOCK, possibly spurious wakeup - ;; 0 = normal wakeup - ;; 2 = EINTR, a spurious wakeup - :ok))))) - #-sb-futex - (%with-cas-lock ((waitqueue-%owner queue)) - (if (eq queue (thread-waiting-for me)) - (%waitqueue-drop me queue) - (unless (eq :ok status) - ;; CONDITION-NOTIFY thinks we've been woken up, but really - ;; we're unwinding. Wake someone else up. - (%waitqueue-wakeup queue 1)))) - ;; Update timeout for mutex re-aquisition unless we are - ;; already past the requested timeout. - (when (and (eq :ok status) to-sec) - (setf (values to-sec to-usec) - (sb-impl::relative-decoded-times stop-sec stop-usec)) - (when (and (zerop to-sec) (not (plusp to-usec))) - (setf status :timeout))) - ;; If we ran into deadline, try to get the mutex before - ;; signaling. If we don't unwind it will look like a normal - ;; return from user perspective. - (when (and (eq :timeout status) deadlinep) - (let ((got-it (%try-mutex mutex me))) - (allow-with-interrupts - (signal-deadline) - (cond (got-it - (return-from %condition-wait t)) - (t - ;; The deadline may have changed. - (setf (values to-sec to-usec stop-sec stop-usec deadlinep) - (decode-timeout timeout)) - (setf status :ok)))))) - ;; Re-acquire the mutex for normal return. - (when (eq :ok status) - (unless (or (%try-mutex mutex me) - (allow-with-interrupts - (%wait-for-mutex mutex me timeout - to-sec to-usec - stop-sec stop-usec deadlinep))) - (setf status :timeout))))) + :timeout)))) + #-sb-futex + (%with-cas-lock ((waitqueue-%owner queue)) + (if (eq queue (thread-waiting-for me)) + (%waitqueue-drop me queue) + (unless (eq :ok status) + ;; CONDITION-NOTIFY thinks we've been woken up, but really + ;; we're unwinding. Wake someone else up. + (%waitqueue-wakeup queue 1)))) + ;; Update timeout for mutex re-aquisition unless we are + ;; already past the requested timeout. + (when (and (eq :ok status) to-sec) + (setf (values to-sec to-usec) + (sb-impl::relative-decoded-times stop-sec stop-usec)) + (when (and (zerop to-sec) (not (plusp to-usec))) + (setf status :timeout))) + ;; If we ran into deadline, try to get the mutex before + ;; signaling. If we don't unwind it will look like a normal + ;; return from user perspective. + (when (and (eq :timeout status) deadlinep) + (let ((got-it (%try-mutex mutex me))) + (allow-with-interrupts + (signal-deadline) + (cond (got-it + (return-from %condition-wait t)) + (t + ;; The deadline may have changed. + (setf (values to-sec to-usec stop-sec stop-usec deadlinep) + (decode-timeout timeout)) + (setf status :ok)))))) + ;; Re-acquire the mutex for normal return. + (when (eq :ok status) + (unless (or (%try-mutex mutex me) + (allow-with-interrupts + (%wait-for-mutex mutex me timeout + to-sec to-usec + stop-sec stop-usec deadlinep))) + (setf status :timeout)))) + ;; Unwinding because futex-wait and %wait-for-mutex above + ;; allow interrupts, wake up another futex + (with-pinned-objects (queue) + (futex-wake (waitqueue-token-address queue) 1)))) ;; Determine actual return value. :ok means (potentially ;; spurious) wakeup => T. :timeout => NIL. (case status @@ -1095,26 +1098,25 @@ #-sb-thread (error "Not supported in unithread builds.") #+sb-thread - (progn - #-sb-futex - (with-cas-lock ((waitqueue-%owner queue)) - (%waitqueue-wakeup queue n)) - #+sb-futex - (progn + (cond + #+sb-futex + (t ;; No problem if >1 thread notifies during the comment in condition-wait: ;; as long as the value in queue-data isn't the waiting thread's id, it - ;; matters not what it is -- using the queue object itself is handy. - ;; But "handy" is not right (lp#1876825) if pointers are 64 bits, - ;; so then just use 0 which can not correspond to any thread. + ;; matters not what it is. We rely on kernel thread ID being nonzero. ;; ;; XXX we should do something to ensure that the result of this setf ;; is visible to all CPUs. ;; ;; ^-- surely futex_wake() involves a memory barrier? - (setf (waitqueue-token queue) #+futex-use-tid 0 #-futex-use-tid queue) + (setf (waitqueue-token queue) 0) (with-pinned-objects (queue) (futex-wake (waitqueue-token-address queue) n)) - nil))) + nil) + #-sb-futex + (t + (with-cas-lock ((waitqueue-%owner queue)) + (%waitqueue-wakeup queue n))))) (declaim (ftype (sfunction (waitqueue) null) condition-broadcast)) @@ -1127,30 +1129,24 @@ ;; On a 64-bit platform truncating M-P-F to an int ;; results in -1, which wakes up only one thread. (ldb (byte 29 0) - sb-xc:most-positive-fixnum))) + most-positive-fixnum))) ;;;; Semaphores -(defstruct (semaphore (:copier nil) - (:constructor make-semaphore - (&key name ((:count %count) 0)))) - "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT -should be considered an implementation detail, and may change in the -future." - (name nil :type (or null string) :read-only t) - (%count 0 :type (integer 0)) - (waitcount 0 :type sb-vm:word) - (mutex (make-mutex :name "semaphore lock") :read-only t - :type mutex) - (queue (make-waitqueue) :read-only t - :type waitqueue)) -(declaim (sb-ext:freeze-type semaphore)) - -(setf (documentation 'semaphore-name 'function) - "The name of the semaphore INSTANCE. Setfable." - (documentation 'make-semaphore 'function) - "Create a semaphore with the supplied COUNT and NAME.") +(defun make-semaphore (&key name (count 0)) + "Create a semaphore with the supplied COUNT and NAME." + (declare (inline make-mutex make-waitqueue)) + (%make-semaphore count + (make-mutex :name name) + (make-waitqueue :name name))) + +(defun semaphore-name (semaphore) + "The name of the semaphore INSTANCE. Setfable." + (waitqueue-name (semaphore-queue semaphore))) + +(defun (setf semaphore-name) (newval semaphore) + (setf (waitqueue-name (semaphore-queue semaphore)) newval)) (defstruct (semaphore-notification (:constructor make-semaphore-notification ()) (:copier nil)) @@ -1304,10 +1300,18 @@ ;;;; Job control, independent listeners (defstruct (session (:copier nil)) + ;; New threads are atomically pushed into NEW-ENROLLEES without acquiring the + ;; session lock. Any operation on the session that transfers ownership of the + ;; foreground must move the enrollees into THREADS while holding the lock. + (new-enrollees) (lock (make-mutex :name "session lock")) + ;; If we wanted to get fancy, these next 2 lists might become lockfree linked lists + ;; so that it would be possible for threads to exit without acquiring the lock. + ;; It might be tricky (i.e. too much trouble) to figure out how to reimplement + ;; the various operations on a session though. (threads nil) (interactive-threads nil) - (interactive-threads-queue (make-waitqueue))) + (interactive-threads-queue (make-waitqueue :name "session"))) (declaim (sb-ext:freeze-type session)) (defvar *session* nil) @@ -1318,27 +1322,44 @@ ;;; *waiting* for the session lock for things like GET-FOREGROUND to ;;; be interruptible. ;;; -;;; Take care: we sometimes need to obtain the session lock while -;;; holding on to *ALL-THREADS-LOCK*, so we must _never_ obtain it -;;; _after_ getting a session lock! (Deadlock risk.) -;;; -;;; FIXME: It would be good to have ordered locks to ensure invariants -;;; like the above. +;;; FIXME: It might be good to have a way to enforce lock ordering invariants (defmacro with-session-lock ((session) &body body) `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t) + (%enroll-new-threads ,session) ,@body)) -(defun new-session () - (make-session :threads (list *current-thread*) - :interactive-threads (list *current-thread*))) +;;; Move new enrollees into SESSION-THREADS. The session lock must be held. +;;; The reason this can be lazy is that a thread is never an interactive thread +;;; just by joining a session, so it doesn't involve itself with the waitqueue; +;;; it can't cause a thread waiting on the condition to wake. +;;; i.e. even if a newly created thread were required to obtain the lock to insert +;;; itself into the session, it would not and could not have any effect on any other +;;; thread in the session. +(defun %enroll-new-threads (session) + (loop (let ((thread (sb-ext:atomic-pop (session-new-enrollees session)))) + (cond ((not thread) (return)) + ((thread-alive-p thread) + ;; Can it become dead immediately upon insertion into THREADS? + ;; No, because to become dead, it must acquire the session lock. + (push thread (session-threads session))))))) + +(defun new-session (thread) + (make-session :threads (list thread) + :interactive-threads (list thread))) (defun init-job-control () (/show0 "Entering INIT-JOB-CONTROL") - (setf *session* (new-session)) + (setf *session* (new-session *current-thread*)) (/show0 "Exiting INIT-JOB-CONTROL")) -(defun %delete-thread-from-session (thread session) +(defun %delete-thread-from-session (thread &aux (session *session*)) (with-session-lock (session) + ;; One of two things about THREAD must be true, either: + ;; - it was transferred from SESSION-NEW-ENROLLEES to SESSION-THREADS + ;; - it was NOT yet transferred from SESSION-NEW-ENROLLEES. + ;; There can't be an "in flight" state of having done the atomic-pop from + ;; SESSION-NEW-ENROLLEES but not the push into THREADS, because anyone manipulating + ;; the THREADS list must be holding the session lock. (let ((was-foreground (eq thread (foreground-thread session)))) (setf (session-threads session) ;; FIXME: I assume these could use DELQ1. @@ -1350,29 +1371,105 @@ (condition-broadcast (session-interactive-threads-queue session)))))) (defun call-with-new-session (fn) - (%delete-thread-from-session *current-thread* *session*) - (let ((*session* (new-session))) + (%delete-thread-from-session *current-thread*) + (let ((*session* (new-session *current-thread*))) (funcall fn))) (defmacro with-new-session (args &body forms) (declare (ignore args)) ;for extensibility - (with-unique-names (fb-name) + (with-unique-names (fb-name) ; FIXME: what's the significance of "fb-" ? `(labels ((,fb-name () ,@forms)) (call-with-new-session (function ,fb-name))))) -;;; Remove thread from its session, if it has one. +;;; WITH-DEATHLOK ensures that the 'struct thread' and/or OS thread won't go away +;;; by synchronizing with HANDLE-THREAD-EXIT. +(defmacro with-deathlok ((thread &optional c-thread) &body body) + `(with-system-mutex ((thread-interruptions-lock ,thread)) + ,@(if c-thread + `((let ((,c-thread (thread-primitive-thread ,thread))) ,@body)) + body))) + #+sb-thread -(defun handle-thread-exit (thread control-stack-start) - (/show0 "HANDLING THREAD EXIT") - (when *exit-in-process* - (%exit)) - ;; Lisp-side cleanup - (with-all-threads-lock - (setf (thread-%alive-p thread) nil) - (setf (thread-os-thread thread) sb-ext:most-positive-word) - (setq *all-threads* (avl-delete control-stack-start *all-threads*)) - (when *session* - (%delete-thread-from-session thread *session*)))) +(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*) + ;; use the "funny fixnum" representation + (c-thread (%make-lisp-obj (thread-primitive-thread thread))) + (sem (thread-semaphore thread))) + ;; 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*))) + ;; 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 + ;; unmap the memory an do a pthread_join()? I would think so, because until then, + ;; there is no real harm in reading the memory. In this state the pthread library + ;; will usually return ESRCH if you try to use the pthread id - it's a valid + ;; pointer, but it knows that it has no underlying OS thread. + (with-deathlok (thread) + (when sem ; ordinary lisp thread, not FOREIGN-THREAD + (setf (thread-startup-info thread) c-thread)) + (setf (thread-primitive-thread thread) 0) + (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) + ;; only to remove it right away. + (when *session* + (%delete-thread-from-session thread)) + (cond + #+pauseless-threadstart ; If possible, logically remove from *ALL-THREADS* + (sem + ;; Tree pruning is the responsibility of thread creators, not dying threads. + ;; Creators have to manipulate the tree anyway, and they need access to the old + ;; structure to grab the memory. + (let ((old (sb-ext:cas (thread-%visible thread) 1 -1))) + ;; now (LIST-ALL-THREADS) won't see it + (aver (eql old 1))) + (sb-ext:atomic-push thread *joinable-threads*)) + (t ; otherwise, physically remove from *ALL-THREADS* + ;; With #+pauseless-threadstart, this occurs for FOREIGN-THREAD because + ;; the memory allocation/deallocation is handled in C. + ;; I would like to combine the recycle bin for foreign and lisp threads though. + (delete-from-all-threads (get-lisp-obj-address c-thread)))) + (when sem + (setf (thread-semaphore thread) nil) ; nobody needs to wait on it now + ;; + ;; We go out of our way to support something pthreads don't: + ;; "The results of multiple simultaneous calls to pthread_join() + ;; specifying the same target thread are undefined." + ;; - https://pubs.opengroup.org/onlinepubs/9699919799/functions/pthread_join.html + ;; and for std::thread + ;; "No synchronization is performed on *this itself. Concurrently calling join() + ;; on the same thread object from multiple threads constitutes a data race + ;; that results in undefined behavior." + ;; - https://en.cppreference.com/w/cpp/thread/thread/join + ;; That's because (among other reasons), pthread_join deallocates memory. + ;; But in so far as our join does not equate to resource freeing, and our exit flag is + ;; 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))))) + +;;; The "funny fixnum" address format would do no good - AVL-FIND and AVL-DELETE +;;; expect normal happy lisp integers, even if a bignum. +(defun delete-from-all-threads (addr) + (declare (type sb-vm:word addr)) + (barrier (:read)) + (let ((old *all-threads*)) + (loop + (aver (avl-find addr old)) + (let ((new (avl-delete addr old))) + (when (eq old (setq old (sb-ext:cas *all-threads* old new))) + (return))))))) (defvar sb-ext:*invoke-debugger-hook* nil "This is either NIL or a designator for a function of two arguments, @@ -1386,14 +1483,14 @@ called by BREAK.") (defun %exit-other-threads () - ;; Grabbing this lock prevents new threads from - ;; being spawned, and guarantees that *ALL-THREADS* - ;; is up to date. (with-deadline (:seconds nil :override t) - (sb-impl::finalizer-thread-stop) + ;; Grabbing this lock prevents new threads from + ;; being spawned, and guarantees that *ALL-THREADS* + ;; is up to date. (grab-mutex *make-thread-lock*) + #+sb-thread (sb-impl::finalizer-thread-stop) (let ((timeout sb-ext:*exit-timeout*) - (code *exit-in-process*) + (code *exit-in-progress*) (current *current-thread*) (joinees nil) (main nil)) @@ -1418,12 +1515,14 @@ ;; Need to defer till others have joined, because when main ;; thread exits, we're gone. Can't use TERMINATE-THREAD -- would ;; get the exit code wrong. + ;; This isn't a problem if *forcibly-terminate-threads-on-exit* is NIL - + ;; the thread that calls EXIT provides the exit code. It's that simple. (when main (handler-case (interrupt-thread main (lambda () - (setf *exit-in-process* (list code)) + (setf *exit-in-progress* (list code)) (throw 'sb-impl::%end-of-the-world t))) (interrupt-thread-error ())) ;; Normally this never finishes, as once the main-thread unwinds we @@ -1432,6 +1531,7 @@ ;; to calling OS-EXIT. (join-thread main :default t :timeout (time-left))))))) +;;; Pretty much don't use this. It has the same problems as %EXIT-OTHER-THREADS. (defun terminate-session () "Kill all threads in session except for this one. Does nothing if current thread is not the foreground thread." @@ -1553,41 +1653,163 @@ ;;;; The beef +#+pauseless-threadstart ; new way +(progn +;;; Return T if the thread was created +(defun pthread-create (thread thread-sap) + (aver (memq thread *starting-threads*)) + (let ((attr (foreign-symbol-sap "new_lisp_thread_attr" t)) + (c-tramp + (foreign-symbol-sap #+os-thread-stack "new_thread_trampoline_switch_stack" + #-os-thread-stack "new_thread_trampoline"))) + (and (= 0 #+os-thread-stack + (alien-funcall (extern-alien "pthread_attr_setstacksize" + (function int system-area-pointer unsigned)) + attr sb-unix::pthread-min-stack) + #-os-thread-stack + (with-alien ((setstack (function int system-area-pointer system-area-pointer + unsigned) :extern "pthread_attr_setstack")) + #+c-stack-is-control-stack + (alien-funcall setstack attr + (sap-ref-sap thread-sap (ash sb-vm::thread-control-stack-start-slot + sb-vm:word-shift)) + (extern-alien "thread_control_stack_size" unsigned)) + #-c-stack-is-control-stack + (alien-funcall setstack attr + (sap-ref-sap thread-sap (ash sb-vm::thread-alien-stack-start-slot + sb-vm:word-shift)) + (extern-alien "thread_alien_stack_size" unsigned)))) + ;; From "Workaround a problem ... on NetBSD" (git rev af8c4a2933) + ;; If I had to guess, it wrongly assumed existence of memory outside of + ;; the exactly provided stack bounds. + #+netbsd + (= 0 (with-alien ((setguard (function int system-area-pointer unsigned) + :extern "pthread_attr_setguardsize")) + (alien-funcall setguard attr 0))) + (with-pinned-objects (thread) + (= 0 (alien-funcall + (extern-alien "pthread_create" + (function int system-area-pointer system-area-pointer + system-area-pointer system-area-pointer)) + (struct-slot-sap thread thread os-thread) attr c-tramp thread-sap)))))) + +(defmacro free-thread-struct (memory) + `(alien-funcall (extern-alien "free_thread_struct" (function void system-area-pointer)) + ,memory)) + +(defun primitive-join (thread dispose) + ;; It's safe to read from the other thread's memory, because the current thread + ;; has ownership of that memory now. And we can't call this on a FOREIGN-THREAD. + (let ((c-thread (descriptor-sap (thread-startup-info thread)))) + (setf (thread-startup-info thread) 0) + ;; Clean up *ALL-THREADS* + (delete-from-all-threads (sap-int c-thread)) + ;; Free the pthread resources + (alien-funcall (extern-alien "pthread_join" (function int unsigned unsigned)) + (thread-os-thread thread) 0) ; no result pointer + (setf (thread-os-thread thread) 0) + (cond (dispose + (free-thread-struct c-thread) + nil) + (t ; Return the originally mapped address + (sap-ref-sap c-thread (ash sb-vm::thread-os-address-slot sb-vm:word-shift)))))) + +;;; Helper for SB-POSIX:FORK so that the child starts with no joinable threads. +;;; It might work to just set *JOINABLE-THREADS* to NIL in the child, but it's better to prune +;;; the *ALL-THREADS* tree as well. Must be called with the *MAKE-THREAD-LOCK* held +;;; or interrupts inhibited or both. +;;; Heuristic decides when to stop trying to free. Passing in #'IDENTITY means that +;;; all joinables should be processed. Passing in #'CDR or #'CDDR returns early if there +;;; are not at least 1 or 2 threads respectively that could be joined. +(export 'join-pthread-joinables) +(defun join-pthread-joinables (heuristic) + (loop (unless (funcall heuristic *joinable-threads*) (return)) + (let ((item (sb-ext:atomic-pop *joinable-threads*))) + (if item (primitive-join item t) (return))))) + +;;; Allocate lisp thread memory, attempting first to join any exited +;;; threads, freeing their memory. Possibly reuse the memory from one of +;;; the exited threads, +;;; Why do it this way instead of having JOIN-THREAD just defer to pthread_join() ? +;;; Because the interface would be less lispy. e.g. what happens if you don't join +;;; a thread - do you leak the memory?; That's bad. GC doesn't clean up threads. +;;; It could if we used finalizers, but finalizers have an additional problem: +;;; if the user does call JOIN-THREAD then the finalizer should do nothing. +;;; But there's no "atomic pthread_join + cancel-finalization", short of blocking +;;; signals around the join perhaps. +;;; One more thing- it's illegal to pthread_join() a thread more than once, +;;; but we allow JOIN-THREAD more than one. I think that's a bug. +;;; Ours has the meaning of "get result if done, otherwise wait" +;;; which is not the same as deallocation of the thread's OS resources. +(defun allocate-thread-memory () + (let ((reuse (let ((corpse (sb-ext:atomic-pop *joinable-threads*))) + (when corpse (primitive-join corpse nil))))) + ;; If there is more than 1 more joinable, join all but 1. + ;; Two threads could both find > 1 thread to join, and both do + ;; a join, leaving 0 to join. That's ok. + (join-pthread-joinables #'cdr) + (let ((thread-sap (alien-funcall (extern-alien "alloc_thread_struct" + (function system-area-pointer + system-area-pointer unsigned)) + (or reuse (int-sap 0)) + sb-vm:no-tls-value-marker-widetag))) + (when (and (not reuse) (/= (sap-int thread-sap) 0)) + ;; these would have been done already if reusing the memory + ;; of a completed thread. + (macrolet ((prot (fun) + `(alien-funcall (extern-alien ,fun (function void int + system-area-pointer)) + 1 thread-sap))) + (prot "protect_control_stack_guard_page") + (prot "protect_binding_stack_guard_page") + (prot "protect_alien_stack_guard_page"))) + (unless (= (sap-int thread-sap) 0) thread-sap)))) + +(defmacro thread-trampoline-defining-macro (&body body) ; NEW WAY + `(defun run () + (macrolet ((apply-real-function () + '(apply (svref (thread-startup-info *current-thread*) 2) + (prog1 (svref (thread-startup-info *current-thread*) 3) + (setf (thread-startup-info *current-thread*) 0))))) + (flet ((unmask-signals () + (let ((mask (svref (thread-startup-info *current-thread*) 4))) + (if mask + ;; If the original mask (at thread creation time) was provided, + ;; then restore exactly that mask. + (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))))) + ;; 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 + ;; pure cargo-cultism. + (without-interrupts (with-local-interrupts ,@body)))))) +) ; end PROGN + +#-pauseless-threadstart +(defmacro thread-trampoline-defining-macro (&body body) ; OLD WAY + `(defun run (thread setup-sem function arguments) + (macrolet ((unmask-signals () '(sb-unix::unblock-deferrable-signals)) + (apply-real-function () '(apply function arguments))) + (copy-primitive-thread-fields thread) + (update-all-threads (thread-primitive-thread thread) thread) + (sb-ext:atomic-push thread (session-new-enrollees *session*)) + (when setup-sem + (signal-semaphore setup-sem) + ;; setup-sem was dx-allocated, set it to NIL so that the + ;; backtrace doesn't get confused + (setf setup-sem nil)) + ,@body))) + ;;; All threads other than the initial thread start via this function. #+sb-thread -(defun new-lisp-thread-trampoline (thread setup-sem real-function arguments) - (setf (thread-os-thread thread) (current-thread-os-thread) - (thread-stack-end thread) (get-lisp-obj-address sb-vm:*control-stack-end*) - (thread-primitive-thread thread) (sap-int (current-thread-sap))) - ;; *ALLOC-SIGNAL* is made thread-local by create_thread_struct() - ;; so this assigns into TLS, not the global value. - (setf sb-vm:*alloc-signal* *default-alloc-signal*) - #+linux (setf (thread-os-tid thread) (sb-gettid)) - (with-mutex ((thread-result-lock thread)) - (with-all-threads-lock - (let ((addr (get-lisp-obj-address sb-vm:*control-stack-start*))) - ;; If ADDR exists, then we have a bug in the thread exit handler. - ;; The workaround here would be to delete the old thread first, - ;; but I'd rather find out about the bug than bury it. - (aver (not (avl-find addr *all-threads*))) - (setq *all-threads* (avl-insert *all-threads* addr thread)))) - (let ((session *session*) - (session-cons (list thread))) - (with-session-lock (session) - (setf (cdr session-cons) (session-threads session) - (session-threads session) session-cons))) - (setf (thread-%alive-p thread) t) - - (when setup-sem - (signal-semaphore setup-sem) - ;; setup-sem was dx-allocated, set it to NIL so that the - ;; backtrace doesn't get confused - (setf setup-sem nil)) - +(thread-trampoline-defining-macro + (set-thread-control-stack-slots *current-thread*) ;; Using handling-end-of-the-world would be a bit tricky ;; due to other catches and interrupts, so we essentially ;; re-implement it here. Once and only once more. - (catch 'sb-impl::toplevel-catcher + (catch 'sb-impl::toplevel-catcher (catch 'sb-impl::%end-of-the-world (catch '%abort-thread (restart-bind ((abort @@ -1600,19 +1822,18 @@ (without-interrupts (unwind-protect (with-local-interrupts - (sb-unix::unblock-deferrable-signals) - (setf (thread-result thread) - (prog1 - (multiple-value-list + (unmask-signals) + (let ((list + (multiple-value-list (unwind-protect (catch '%return-from-thread (sb-c::inspect-unwinding - (apply real-function arguments) + (apply-real-function) #'sb-di::catch-runaway-unwind)) - (when *exit-in-process* - (sb-impl::call-exit-hooks)))) - #+sb-safepoint - (sb-kernel::gc-safepoint)))) + (when *exit-in-progress* + (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) @@ -1624,10 +1845,9 @@ (setq *interrupt-pending* nil) #+sb-thruption (setq *thruption-pending* nil) - (handle-thread-exit thread - (get-lisp-obj-address - sb-vm:*control-stack-start*))))))))) - (values)) + (handle-thread-exit))))))) + ;; this returns to C, so return a single value + 0) (defun make-thread (function &key name arguments) "Create a new thread of NAME that runs FUNCTION with the argument @@ -1642,71 +1862,181 @@ #-sb-thread (declare (ignore function name arguments)) #-sb-thread (error "Not supported in unithread builds.") #+sb-thread - (progn (assert (or (atom arguments) - (null (cdr (last arguments)))) - (arguments) - "Argument passed to ~S, ~S, is an improper list." - 'make-thread arguments) - (run-thread (%make-thread :name name) function arguments))) + (let ((name (when name (possibly-base-stringize name)))) + (assert (or (atom arguments) (null (cdr (last arguments)))) + (arguments) + "Argument passed to ~S, ~S, is an improper list." + 'make-thread arguments) + (start-thread (%make-thread name nil (make-semaphore :name name)) + (coerce function 'function) + (ensure-list arguments)))) ;;; System-internal use only #+sb-thread (defun make-ephemeral-thread (name function arguments) - (run-thread (%make-thread :name name :%ephemeral-p t) function arguments)) - -;;; The purpose of splitting out RUN-THREAD from MAKE-THREAD is that when -;;; starting the finalizer thread, we might be able to do: -;;; (let ((thread (%make-thread :name "finalizer" :%ephemeral-p t))) -;;; (when (cas *finalizer-thread* nil thread) -;;; (run-thread thread ...) -;;; which is possibly an improvement in two ways: - -;;; (1) it ensures that there is no hidden state in the transition diagram -;;; when we are invisibly starting the finalizer thread but have not made it -;;; known to FINALIZER-THREAD-STOP that we are doing so. There would be a -;;; thread object published or not - and no "maybe starting" state. -;;; (2) imagine two threads, each of which actually GC'd - so the 'gc_happened' -;;; flag in gc-common.c is T for both - and each wants to start the finalizer. -;;; They both get all the way into NEW-LISP-THREAD-TRAMPOLINE, only for one -;;; to lose the CAS on *FINALIZER-THREAD*. It's a lot of overhead to start -;;; a thread that does nothing and then exits. -;;; -;;; But it's not all fun and games, because we'd have to figure out how to -;;; get FINALIZER-THREAD-STOP _not_ to attempt to join a thread that has not -;;; yet sprung into being as an OS-level thread. + (start-thread (%make-thread name t (make-semaphore :name name)) + function arguments)) -#+sb-thread -(defun run-thread (thread function arguments) - (declare (inline make-semaphore - make-waitqueue - make-mutex)) - (let* ((setup-sem (make-semaphore :name "Thread setup semaphore")) - (real-function (coerce function 'function)) - (arguments (ensure-list arguments)) - #+(or win32 darwin) - (fp-modes (dpb 0 sb-vm:float-sticky-bits ;; clear accrued bits - (sb-vm:floating-point-modes)))) - (declare (dynamic-extent setup-sem)) - (dx-flet ((start-routine () +;;; This is the faster variant of RUN-THREAD that does not wait for the new +;;; thread to start executing before returning. +#+pauseless-threadstart +(defun start-thread (thread function arguments) + (let* ((trampoline + (lambda (arg) + ;; If an error occurs prior to getting the thread into a consistent lisp state, + ;; there's no chance of debugging anything anyway. + (declare (optimize (safety 0))) + (let ((new-thread + (%make-lisp-obj (logior (get-lisp-obj-address arg) + sb-vm:instance-pointer-lowtag)))) + ;; Now that this thread is known to GC, NEW-THREAD is either implicitly + ;; pinned (on conservative gc) or movable. It can hance be deleted from + ;; *STARTING-THREADS* list which occurs lazily on the next MAKE-THREAD. + ;; To avoid unnecessary GC work meanwhile, smash the cell in *STARTING-THREADS* + ;; that points to NEW-THREAD. That cell is pointed to by the startup-info. + (rplaca (svref (thread-startup-info new-thread) 1) 0) + (init-thread-local-storage new-thread) ; assign *CURRENT-THREAD* + ;; Expose this thread in *ALL-THREADS*. + ;; Why not set this before calling pthread_create() ? If it fails there should + ;; be no transient effect on the list of all threads. But it's indeterminate + ;; whether the creating or created thread will make progress first, + ;; so they both do this assignment. + (setf (thread-%visible new-thread) 1) + ;; Foreign threads don't pass the saved FP modes, so the modes have to be + ;; restored here and not in RUN. + #+(or win32 darwin freebsd) + (setf (sb-vm:floating-point-modes) + (svref (thread-startup-info *current-thread*) 5))) + (run))) + (saved-sigmask (make-array (* sb-unix::sizeof-sigset_t sb-vm:n-byte-bits) + :element-type 'bit :initial-element 0)) + (child-sigmask (make-array (* sb-unix::sizeof-sigset_t sb-vm:n-byte-bits) + :element-type 'bit :initial-element 0)) + (created)) + (declare (truly-dynamic-extent saved-sigmask child-sigmask)) + (with-pinned-objects (saved-sigmask child-sigmask) ; if not stack-allocated + ;; Block deferrables to ensure that the new thread is unaffected by signals + ;; 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) + saved-sigmask) + (replace child-sigmask saved-sigmask) + ;; Ensure that timers and interrupt-thread are directed only to "user" threads. + #+unix + (when (thread-ephemeral-p thread) + (with-alien ((sigaddset (function int system-area-pointer int) :extern "sigaddset")) + ;; It is essentially impossible to call INTERRUPT-THREAD on the finalizer + ;; thread, as it spends most of its time with interrupts disabled. + ;; So it doesn't much matter if SIGURG is added to the signal mask here. + ;; Unfortunately, this means that SB-INTROSPECT's MAP-ROOTS will hang + ;; if you give it the finalizer thread. + ;; The right answer may be that introspect needs to utilize some kind + ;; of stop-the-thread API that it shares in common with stop-the-world. + (alien-funcall sigaddset (vector-sap child-sigmask) sb-unix:sigalrm)))) + (binding* ((thread-sap (allocate-thread-memory) :EXIT-IF-NULL) + (cell (list thread)) + (startup-info + (vector trampoline cell function arguments + (if (position 1 child-sigmask) ; if there are any signals masked + (copy-seq child-sigmask) ; heap-allocate to pass to the new thread + nil) ; otherwise, don't pass the saved mask + ;; pass fp modes if neccessary, clearing the accrued exception bits + (+ #+(or win32 darwin freebsd) + (dpb 0 sb-vm:float-sticky-bits (sb-vm:floating-point-modes)))))) + (setf (thread-primitive-thread thread) (sap-int thread-sap) + (thread-startup-info thread) startup-info) + ;; Add new thread to *ALL-THREADS* now so that if the creator asserts + ;; something about "all" threads, it can find the new thread. + ;; But there is a slight ploy involved: the thread does not appear in + ;; (LIST-ALL-THREADS) until a POSIX thread is successfully started. + (setf (thread-%visible thread) 0) + (update-all-threads (sap-int thread-sap) thread) + (when *session* + (sb-ext:atomic-push thread (session-new-enrollees *session*))) + ;; Absence of the startup semaphore notwithstanding, creation is synchronized + ;; so that we can prevent new threads from starting, typically in SB-POSIX:FORK + ;; or SAVE-LISP-AND-DIE. + ;; The locks also guards access to *STARTING-THREADS* - a lockfree list wouldn't + ;; improve concurrency, as long as creation is synchronized anyway. + (dx-flet ((thunk () + ;; Consing THREAD into *STARTING-THREADS* pins it as well as some elements + ;; of startup-info. Consequently those objects can be safely manipulated + ;; from C before inserting the thread into 'all_threads'. + ;; Assuming that new threads are scheduled by the OS as fast as we can create + ;; them, there should usually be only one item to delete from *STARTING-THREADS*. + (let ((old (delete 0 *starting-threads*))) + (setf *starting-threads* (rplacd cell old)) + (barrier (:write)) + ;; Assign the thread's *CURRENT-THREAD*. This is GC-safe because + ;; the thread instance is pinned via *STARTING-THREADS*. + (setf (sap-ref-lispobj thread-sap (ash sb-vm::thread-lisp-thread-slot + sb-vm:word-shift)) + thread) + (setq created (pthread-create thread thread-sap)) + (cond (created + ;; Still holding the MAKE-THREAD-LOCK, expose the thread in *all-threads*. + ;; In this manner, anyone who acquires the MAKE-THREAD-LOCK can be sure that + ;; (list-all-threads) enumerates every running thread. + ;; On CPUs where CAS can spuriously fail, this probably needs to loop and retry. + ;; It's ok if the thread changed 0 -> {1 | -1}, then failure here is correct. + (sb-ext:cas (thread-%visible thread) 0 1)) + (t ; unlikely. Out of memory perhaps? + (setq *starting-threads* old)))))) + ;; System threads are created with the mutex already held + (if (thread-ephemeral-p thread) + (thunk) + (sb-thread::call-with-system-mutex #'thunk *make-thread-lock*))) + (unless created ; Remove side-effects of trying to create + (delete-from-all-threads (sap-int thread-sap)) + (when *session* + (%delete-thread-from-session thread)) + (free-thread-struct thread-sap))) + (with-pinned-objects (saved-sigmask) + (sb-unix::pthread-sigmask sb-unix::SIG_SETMASK saved-sigmask nil)) + (if created thread (error "Could not create new OS thread.")))) + +#+(and sb-thread (not pauseless-threadstart)) +(defun start-thread (thread function arguments) + (let* ((setup-sem (make-semaphore :name "Thread setup semaphore")) + #+(or win32 darwin freebsd) + (fp-modes (dpb 0 sb-vm:float-sticky-bits ;; clear accrued bits + (sb-vm:floating-point-modes)))) + (declare (dynamic-extent setup-sem)) + (dx-flet ((start-routine () ;; Inherit parent thread's FP modes #+(or win32 darwin) (setf (sb-vm:floating-point-modes) fp-modes) ;; As it is, this lambda must not cons until we are ;; ready to run GC. Be careful. (init-thread-local-storage thread) - (new-lisp-thread-trampoline thread setup-sem - real-function arguments))) + ;; I literally don't know what these WITH/WITHOUT wrappings are for, + ;; but tests fail when removed. + ;; It's the body of CALL-WITH-MUTEX omitting the grab and release. + (without-interrupts + (with-local-interrupts + (run thread setup-sem function arguments))))) ;; Holding mutexes or waiting on sempahores inside WITHOUT-GCING will lock up - (aver (not *gc-inhibit*)) + (aver (not *gc-inhibit*)) ;; Keep INITIAL-FUNCTION in the dynamic extent until the child ;; thread is initialized properly. Wrap the whole thing in ;; WITHOUT-INTERRUPTS (via WITH-SYSTEM-MUTEX) because we pass ;; INITIAL-FUNCTION to another thread. ;; (Does WITHOUT-INTERRUPTS really matter now that it's DXed?) - (with-system-mutex (*make-thread-lock*) - (if (zerop (%create-thread (get-lisp-obj-address #'start-routine))) - (setf thread nil) - (wait-on-semaphore setup-sem))))) + (dx-flet ((thunk () + (with-alien ((create-thread (function unsigned unsigned unsigned) + :extern "create_thread")) + (with-pinned-objects (thread #'start-routine) + (if (eql (alien-funcall create-thread + (- (get-lisp-obj-address thread) + sb-vm:instance-pointer-lowtag) + (get-lisp-obj-address #'start-routine)) + 0) + (setq thread nil) + (wait-on-semaphore setup-sem)))))) + (if (thread-ephemeral-p thread) + (thunk) + (sb-thread::call-with-system-mutex #'thunk *make-thread-lock*))))) (or thread (error "Could not create a new thread."))) (defun join-thread (thread &key (default nil defaultp) timeout) @@ -1730,30 +2060,44 @@ TIMEOUT occurs or the process exits: when the main thread exits, the entire process exits. +Users should not rely on the ability to join a chosen THREAD from more +than one other thread simultaneously. Future changes to JOIN-THREAD may +directly call the underlying thread library, and not all threading +implementations consider such usage to be well-defined. + NOTE: Return convention in case of a timeout is experimental and subject to change." (when (eq thread *current-thread*) (error 'join-thread-error :thread thread :problem :self-join)) - (let ((lock (thread-result-lock thread)) - (got-it nil) - (problem :timeout)) - (without-interrupts - (unwind-protect - (cond - ((not (setf got-it - (allow-with-interrupts - ;; Don't use the timeout if the thread is - ;; not alive anymore. - (grab-mutex lock :timeout (and (thread-alive-p thread) - timeout)))))) - ((listp (thread-result thread)) - (return-from join-thread - (values-list (thread-result thread)))) - (t - (setf problem :abort))) - (when got-it - (release-mutex lock)))) + ;; First, free up the pthread resources of any thread(s), not necessarily + ;; one we're tryinng to join. + #+pauseless-threadstart + (when (cddr *joinable-threads*) ; if strictly > 2 are joinable, + (without-interrupts (join-pthread-joinables #'cddr))) + ;; No result semaphore indicates that there's nothing to wait for- + ;; the thread is either a foreign-thread, or finished running. + (let* ((semaphore (thread-semaphore thread)) + (problem + (cond (semaphore + (if (wait-on-semaphore semaphore :timeout timeout) nil :timeout)) + ((typep thread 'foreign-thread) :foreign)))) + (unless problem + (cond ((listp (thread-result thread)) + ;; Implementation note, were this to become a native pthread semaphore- + ;; we would need a sem_post() here to support concurrent join of THREAD + ;; from N>1 other threads, because the hypothetical sem_post() in HANDLE-THREAD-EXIT + ;; will only bump the count up by 1, and so at most 1 waiter would execute. + ;; [Alternatively - still hypothetically - HANDLE-THREAD-EXIT could sem_post() + ;; as many times as there are currently running threads, which seems iffy] + ;; And though it's potentially poor style to wait on a chosen thread from N>1 other + ;; threads, it happens, and users might rely on it, though POSIX specifically + ;; precludes that in the spec of pthread_join() which this isn't exactly. + ;; Also for what it's worth, the win32 WaitOnSingleObject and GetExitCodeThread + ;; APIs have no such prohibition as long as the object handle remains valid. + (return-from join-thread (values-list (thread-result thread)))) + (t + (setq problem :abort)))) (if defaultp (values default problem) (error 'join-thread-error :thread thread :problem problem)))) @@ -1766,28 +2110,45 @@ :late ("SBCL" "1.2.15") (function destroy-thread :replacement terminate-thread))) -(defmacro with-interruptions-lock ((thread) &body body) - `(with-system-mutex ((thread-interruptions-lock ,thread)) - ,@body)) +;;; 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) (defun run-interruption () - (let ((interruption (with-interruptions-lock (*current-thread*) + (let ((interruption (with-deathlok (*current-thread*) (pop (thread-interruptions *current-thread*))))) ;; If there is more to do, then resignal and let the normal ;; interrupt deferral mechanism take care of the rest. From the ;; 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*) - (kill-safely (thread-os-thread *current-thread*) sb-unix:sigpipe)) + (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 (defun run-interruption (*current-internal-error-context*) (in-interruption () ;the non-thruption code does this in the signal handler - (let ((interruption (with-interruptions-lock (*current-thread*) + (let ((interruption (with-deathlok (*current-thread*) (pop (thread-interruptions *current-thread*))))) (when interruption (funcall interruption) @@ -1810,7 +2171,24 @@ ;; -- DFL (setf *thruption-pending* t))))) +#+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)) + (defun interrupt-thread (thread function) + (declare (ignorable thread)) "Interrupt THREAD and make it run FUNCTION. The interrupt is asynchronous, and can occur anywhere with the exception of @@ -1863,35 +2241,42 @@ (interrupt-thread thread #'break) Short version: be careful out there." - #+(and (not sb-thread) win32) - #+(and (not sb-thread) win32) - (declare (ignore thread)) - (with-interrupt-bindings - (with-interrupts (funcall function))) - #-(and (not sb-thread) win32) - (let ((os-thread (thread-os-thread thread))) - (cond ((= os-thread (ldb (byte sb-vm:n-word-bits 0) -1)) - (error 'interrupt-thread-error :thread thread)) - (t - (let (invoked) - (with-interruptions-lock (thread) + (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) + `(setf (thread-interruptions thread) (append (thread-interruptions thread) (list (lambda () - (setf invoked t) - (barrier (:memory)) + (barrier (:memory)) ; why??? (without-interrupts (allow-with-interrupts - (funcall function)))))))) - (when (and (minusp (wake-thread os-thread)) - ;; The interrupt queue has been processed by - ;; some other interrupt. - (progn (barrier (:memory)) - (not invoked))) - (error 'interrupt-thread-error :thread thread))))))) + (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)))) (defun terminate-thread (thread) "Terminate the thread identified by THREAD, by interrupting it and @@ -1944,16 +2329,12 @@ ;;; should probably discuss with a professional psychiatrist first #+sb-thread (progn - (sb-ext:define-load-time-global sb-vm::*free-tls-index* 0) (defun %symbol-value-in-thread (symbol thread) - ;; Prevent the thread from dying completely while we look for the TLS - ;; area... - (with-all-threads-lock - (if (thread-alive-p thread) - (let ((val (sap-ref-lispobj (int-sap (thread-primitive-thread thread)) - (symbol-tls-index symbol)))) + (with-deathlok (thread c-thread) + (if (/= c-thread 0) + (let ((val (sap-ref-lispobj (int-sap c-thread) (symbol-tls-index symbol)))) (case (get-lisp-obj-address val) (#.sb-vm:no-tls-value-marker-widetag (values nil :no-tls-value)) (#.sb-vm:unbound-marker-widetag (values nil :unbound-in-thread)) @@ -1961,17 +2342,13 @@ (values nil :thread-dead)))) (defun %set-symbol-value-in-thread (symbol thread value) - ;; Prevent the thread from dying completely while we look for the TLS - ;; area... - (with-all-threads-lock - (if (thread-alive-p thread) + (with-deathlok (thread c-thread) + (if (/= c-thread 0) (let ((offset (symbol-tls-index symbol))) (cond ((zerop offset) (values nil :no-tls-value)) (t - (setf (sap-ref-lispobj (int-sap (thread-primitive-thread thread)) - offset) - value) + (setf (sap-ref-lispobj (int-sap c-thread) offset) value) (values value :ok)))) (values nil :thread-dead)))) @@ -1984,12 +2361,12 @@ ;; (raw value) manifesting in Lisp as a fixnum. ;; The sign bit of sb-vm::*free-tls-index* is a semaphore, ;; except on PPC where it isn't, but masking is fine in any case. - (do ((index (- (ash (logand sb-vm::*free-tls-index* sb-xc:most-positive-fixnum) + (do ((index (- (ash (logand sb-vm::*free-tls-index* most-positive-fixnum) sb-vm:n-fixnum-tag-bits) sb-vm:n-word-bytes) (- index sb-vm:n-word-bytes)) - ;; (There's no reason this couldn't work on any thread now.) - (sap (int-sap (thread-primitive-thread *current-thread*))) + ;; (There's almost no reason this couldn't work on any thread.) + (sap (current-thread-sap)) (list)) ((< index (ash sb-vm::primitive-thread-object-length sb-vm:word-shift)) list) @@ -2064,46 +2441,34 @@ ;;; Here's the problem: Some of the backends implement those semantics as dictated ;;; by globaldb - assigning into TLS even if the current TLS value is NO_TLS_VALUE; ;;; while others do not make use of that information, and will therefore assign into -;;; the global value if the TLS value is NO_TLS_VALUE. +;;; the symbol-global-value if the TLS value is NO_TLS_VALUE. ;;; This can not be "corrected" by genesis - there is no TLS when genesis executes. -;;; The only way to do this reliably is to compute the address of the thread-local -;;; storage slot, and use (SETF SAP-REF-LISPOBJ) -;;; (Nor is #+(vop-translates ensure-symbol-tls-index) a reliable indicator that the +;;; The only way to do this uniformly for all the platforms is to compute the address +;;; of the thread-local storage slot, and use (SETF SAP-REF-LISPOBJ) on that. +;;; (Existence of a vop for ENSURE-SYMBOL-TLS-INDEX is not an indicator that the ;;; SET vop will assign into a thread-local symbol that currently has no TLS value.) - -;;; Note also that this is called by REINIT, which _should_ reinitialize -;;; the *CURRENT-THREAD* but should _NOT_ reinitialize anything else. -;;; That's actually kind of weird, but it's necessary to ensure that *RESTART-CLUSTERS* -;;; does not get clobbered if there were any restarts available. -;;; There's a SAVE-LISP-AND-DIE test which asserts that you can resume -;;; from a failed save. -;;; It might behoove us to pass in a flag as to whether this is coming from REINIT, -;;; but INIT-INITIAL-THREAD doesn't know either. We'd have to plumb a new flag -;;; down all the way from SAVE. (defun init-thread-local-storage (thread) ;; In addition to wanting the expressly unsafe variant of SYMBOL-VALUE, any error ;; signaled such as invalid-arg-count would just go totally wrong at this point. (declare (optimize (safety 0))) #-sb-thread - ;; *CURRENT-THREAD* is known always bound, so BOUNDP would be T - ;; We need to see whether it's really boundp. - (if (unbound-marker-p *current-thread*) - (macrolet ((expand () - `(setf ,@(apply #'append (cdr *thread-local-specials*))))) - (expand)) - (setf *current-thread* thread)) + (macrolet ((expand () `(setf ,@(apply #'append (cdr *thread-local-specials*))))) + (expand)) ;; See %SET-SYMBOL-VALUE-IN-THREAD for comparison's sake #+sb-thread (let ((sap (current-thread-sap))) (macrolet ((expand () - `(if (= (sap-ref-word sap ,(info :variable :wired-tls '*current-thread*)) - sb-vm:no-tls-value-marker-widetag) - (setf ,@(loop for (var form) in (cdr *thread-local-specials*) - for index = (info :variable :wired-tls var) - append `((sap-ref-lispobj sap ,index) ,form))) - (setf *current-thread* thread)))) + `(setf ,@(loop for (var form) in (cdr *thread-local-specials*) + for index = (info :variable :wired-tls var) + append `((sap-ref-lispobj sap ,index) ,form))))) (expand))) - nil) + ;; Straightforwardly assign *current-thread* because it's never the NO-TLS-VALUE marker. + ;; 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) ;; Inform genesis of the index <-> symbol mapping made by DEFINE-THREAD-LOCAL @@ -2148,29 +2513,28 @@ (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 &optional thread-slot-p) - (if thread-slot-p - (format t " ~3d ~30a : #x~x~%" - (ash tlsindex (- sb-vm:word-shift)) - (aref names (ash tlsindex (- sb-vm:word-shift))) - val) - (let ((*print-right-margin* 128) - (*print-lines* 4)) - (format t " ~3d ~30a : ~s~%" - (ash tlsindex (- sb-vm:word-shift)) - ;; FIND-SYMBOL-FROM-TLS-INDEX uses MAP-ALLOCATED-OBJECTS - ;; which is not defined during cross-compilation. - (funcall 'sb-ext::find-symbol-from-tls-index tlsindex) - val))))) + (show (tlsindex val) + (let ((*print-right-margin* 128) + (*print-lines* 4)) + (format t " ~3d ~30a : ~s~%" + (ash tlsindex (- sb-vm:word-shift)) + ;; 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) + 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) by sb-vm:n-word-bytes - do (if (< tlsindex (ash thread-obj-len sb-vm:word-shift)) - (show tlsindex (sap-ref-word sap tlsindex) t) - (let ((val (safely-read sap tlsindex))) - (unless (eq val :no-tls-value) - (show tlsindex val))))) + do (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)))))) (let ((from (descriptor-sap sb-vm:*binding-stack-start*)) (to (binding-stack-pointer-sap))) (format t "~%Binding stack: (depth ~d)~%" diff -Nru sbcl-2.0.6/src/code/target-unicode.lisp sbcl-2.1.1/src/code/target-unicode.lisp --- sbcl-2.0.6/src/code/target-unicode.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/target-unicode.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -41,7 +41,7 @@ #+sb-unicode :size #+sb-unicode (length data)))) (loop for (source . target) in data when (and #-sb-unicode - (< source sb-xc:char-code-limit)) + (< source char-code-limit)) do (flet ((minimize (x) (case (length x) (1 @@ -214,7 +214,7 @@ (let* ((code (char-code character)) (block-index (ordered-ranges-position code - #.(sb-xc:coerce (sb-cold:read-from-file "output/block-ranges.lisp-expr") + #.(coerce (sb-cold:read-from-file "output/block-ranges.lisp-expr") '(vector (unsigned-byte 32)))))) (if block-index (aref #.(sb-cold:read-from-file "output/block-names.lisp-expr") block-index) @@ -347,7 +347,7 @@ (eval-when (:compile-toplevel) (sb-xc:defmacro coerce-to-ordered-ranges (array) - (sb-xc:coerce array '(vector (unsigned-byte 32))))) + (coerce array '(vector (unsigned-byte 32))))) (defun default-ignorable-p (character) "Returns T if CHARACTER is a Default_Ignorable_Code_Point" @@ -1384,7 +1384,6 @@ new-i index)))) (loop for index from new-i below len for char = (char str index) - for previous-combining-class = combining-class for combining-class = (combining-class char) until (eql combining-class 0) unless (and (>= (- index new-i) 1) diff -Nru sbcl-2.0.6/src/code/thread.lisp sbcl-2.1.1/src/code/thread.lisp --- sbcl-2.0.6/src/code/thread.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/thread.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,94 +11,41 @@ (in-package "SB-THREAD") -;;; N.B.: If you alter this definition, then you need to verify that FOP-FUNCALL -;;; in genesis can properly emulate MAKE-MUTEX for the altered structure, -;;; or even better, make sure that genesis can emulate any constructor, -;;; provided that it is sufficiently trivial. -(defstruct (mutex (:constructor make-mutex (&key name)) - (:copier nil)) - "Mutex type." - ;; C code could (but doesn't currently) access the name - #+(and sb-thread sb-futex) - (state 0 :type fixnum) - ;; If adding slots between STATE and NAME, please see futex_name() in linux_os.c - ;; which attempts to divine a string from a futex word address. - (name nil :type (or null simple-string)) - (%owner nil :type (or null thread))) - -(defstruct (thread (:constructor %make-thread (&key name %alive-p %ephemeral-p)) - (:copier nil)) - "Thread type. Do not rely on threads being structs as it may change -in future versions." - (name nil :type (or null simple-string)) ; C code could read this - (%alive-p nil :type boolean) - (%ephemeral-p nil :type boolean :read-only t) - ;; 0 is used on thread-less builds - (os-thread (ldb (byte sb-vm:n-word-bits 0) -1) :type sb-vm:word) - ;; Keep a copy of CONTROL-STACK-END from the "primitive" thread (C memory). - ;; Reading that memory for any thread except *CURRENT-THREAD* is not safe - ;; due to possible unmapping on thread death. Technically this is a fixed amount - ;; below PRIMITIVE-THREAD, but the exact offset varies by build configuration. - (stack-end 0 :type sb-vm:word) - ;; Points to the SB-VM::THREAD primitive object. - ;; Yes, there are three different thread structures. - (primitive-thread 0 :type sb-vm:word) - (interruptions nil :type list) - ;; Gotta have half a dozen or more different ways to identify a thread. - #+linux (os-tid 0 :type (unsigned-byte 32)) - ;; On succesful execution of the thread's lambda a list of values. - (result 0) - (interruptions-lock - (make-mutex :name "thread interruptions lock") - :type mutex :read-only t) - (result-lock - (make-mutex :name "thread result lock") - :type mutex :read-only t) - waiting-for) - (declaim (inline thread-alive-p)) (defun thread-alive-p (thread) "Return T if THREAD is still alive. Note that the return value is potentially stale even before the function returns, as the thread may exit at any time." - (thread-%alive-p thread)) + (declare (ignorable thread)) + (barrier (:read)) + #+sb-thread (/= (thread-primitive-thread thread) 0) + #-sb-thread t) -(sb-impl::define-thread-local *current-thread* - ;; This initform is magical - DEFINE-THREAD-LOCAL stuffs the initial - ;; value form into a SETQ in INIT-THREAD-LOCAL-STORAGE, and the name - ;; of its first and only argument is THREAD. - thread +(setf (documentation '*current-thread* 'variable) "Bound in each thread to the thread itself.") -(declaim (type thread *current-thread*)) - -(defstruct (foreign-thread - (:copier nil) - (:include thread) - (:conc-name "THREAD-")) - "Type of native threads which are attached to the runtime as Lisp threads -temporarily.") - -#+(and sb-safepoint-strictly (not win32)) -(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)) (defun mutex-value (mutex) "Current owner of the mutex, NIL if the mutex is free. May return a stale value, use MUTEX-OWNER instead." (mutex-%owner mutex)) +(declaim (inline holding-mutex-p)) (defun holding-mutex-p (mutex) "Test whether the current thread is holding MUTEX." ;; This is about the only use for which a stale value of owner is ;; sufficient. (eq sb-thread:*current-thread* (mutex-%owner mutex))) +(declaim (inline mutex-owner)) +(defun mutex-owner (mutex) + "Current owner of the mutex, NIL if the mutex is free. Naturally, +this is racy by design (another thread may acquire the mutex after +this function returns), it is intended for informative purposes. For +testing whether the current thread is holding a mutex see +HOLDING-MUTEX-P." + ;; Make sure to get the current value. + (sb-ext:compare-and-swap (mutex-%owner mutex) nil nil)) + (defsetf mutex-value set-mutex-value) (declaim (sb-ext:deprecated :final ("SBCL" "1.2.15") #'set-mutex-value)) @@ -143,6 +90,10 @@ (function with-recursive-spinlock :replacement with-recursive-lock) (function with-spinlock :replacement with-mutex))) +;;; Needed to pacify deadlock detection if inerrupting wait-for-mutex, +;;; otherwise it would appear that if there is a lock grabbed inside +;;; of BODY it would appear backwards--waiting on a lock while holding +;;; the new one, which looks like a deadlock. (defmacro without-thread-waiting-for ((&key already-without-interrupts) &body body) (with-unique-names (thread prev) (let ((without (if already-without-interrupts @@ -170,7 +121,7 @@ (barrier (:write))))) (exec))))))) -(defmacro with-mutex ((mutex &key (wait-p t) timeout value) +(defmacro with-mutex ((mutex &key (wait-p t) timeout (value nil valuep)) &body body) "Acquire MUTEX for the dynamic scope of BODY. If WAIT-P is true (the default), and the MUTEX is not immediately available, sleep until it is available. @@ -192,9 +143,20 @@ (call-with-mutex #'with-mutex-thunk ,mutex - ,value ,wait-p - ,timeout))) + ;; Users should not pass VALUE. If they do, the overhead of validity checking + ;; is at the call site so that normal invocations of CALL-WITH-MUTEX receive + ;; only the useful arguments. + ;; And as is true of so many macros, strict left-to-right evaluation of args + ;; is not promised, but let's try to be consistent with the order in the lambda list. + ;; (i.e. You don't know if the source form was ":value me :wait-p nil") + ,(if valuep + `(prog1 ,timeout + (let ((value ,value)) + (unless (or (null value) (eq *current-thread* value)) + (error "~S called with non-nil :VALUE that isn't the current thread." + 'with-mutex)))) + timeout)))) (defmacro with-recursive-lock ((mutex &key (wait-p t) timeout) &body body) "Acquire MUTEX for the dynamic scope of BODY. @@ -247,12 +209,9 @@ #-sb-thread (progn - (defun call-with-mutex (function mutex value waitp timeout) + (defun call-with-mutex (function mutex waitp timeout) (declare (ignore mutex waitp timeout) (function function)) - (unless (or (null value) (eq *current-thread* value)) - (error "~S called with non-nil :VALUE that isn't the current thread." - 'with-mutex)) (funcall function)) (defun call-with-recursive-lock (function mutex waitp timeout) @@ -267,12 +226,9 @@ #+sb-thread (progn - (defun call-with-mutex (function mutex value waitp timeout) + (defun call-with-mutex (function mutex waitp timeout) (declare (function function)) (declare (dynamic-extent function)) - (unless (or (null value) (eq *current-thread* value)) - (error "~S called with non-nil :VALUE that isn't the current thread." - 'with-mutex)) (let ((got-it nil)) (without-interrupts (unwind-protect @@ -286,13 +242,13 @@ (defun call-with-recursive-lock (function mutex waitp timeout) (declare (function function)) (declare (dynamic-extent function)) - (let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*)) + (let ((had-it (holding-mutex-p mutex)) (got-it nil)) (without-interrupts (unwind-protect - (when (or inner-lock-p (setf got-it (allow-with-interrupts - (grab-mutex mutex :waitp waitp - :timeout timeout)))) + (when (or had-it + (setf got-it (allow-with-interrupts + (grab-mutex mutex :waitp waitp :timeout timeout)))) (with-local-interrupts (funcall function))) (when got-it (release-mutex mutex)))))) @@ -301,11 +257,12 @@ (declare (function function)) (declare (dynamic-extent function)) (without-interrupts - (let ((inner-lock-p (eq *current-thread* (mutex-owner lock))) + (let ((had-it (holding-mutex-p lock)) (got-it nil)) (unwind-protect - (when (or inner-lock-p - (setf got-it (grab-mutex lock))) + (when (or had-it (setf got-it (grab-mutex lock))) (funcall function)) (when got-it (release-mutex lock))))))) + +(sb-ext:define-load-time-global *make-thread-lock* nil) diff -Nru sbcl-2.0.6/src/code/thread-structs.lisp sbcl-2.1.1/src/code/thread-structs.lisp --- sbcl-2.0.6/src/code/thread-structs.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/code/thread-structs.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,170 @@ +;;;; support for threads needed at cross-compile 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-THREAD") + +;;; It's possible to make futex/non-futex switchable at runtime by ensuring that +;;; these synchronization primitive structs contain all the slots for the union +;;; of any kind of backing object. Some of the #+sb-futex/#-sb-futex cases in +;;; target-thread also have to be changed to a COND rather than a compile-time test. +;;; Among the uses of this would be to test real posix mutexes (with a finalizer on +;;; each lisp-side proxy) or support older C APIs. Posix mutexes work nicely now +;;; because finalizers are more efficient than they were, and when many threads +;;; compete for a mutex, the pthread code seems to do a better job at reducing +;;; cycles spent in the OS. + +;;; N.B.: If you alter this definition, then you need to verify that FOP-FUNCALL +;;; in genesis can properly emulate MAKE-MUTEX for the altered structure, +;;; or even better, make sure that genesis can emulate any constructor, +;;; provided that it is sufficiently trivial. +(sb-xc:defstruct (mutex (:constructor make-mutex (&key name)) + (:copier nil)) + "Mutex type." + #+sb-futex (state 0 :type sb-vm:word) + ;; If adding slots between STATE and NAME, please see futex_name() in linux_os.c + ;; which attempts to divine a string from a futex word address. + (name nil :type (or null simple-string)) + (%owner nil :type (or null thread))) + +(sb-xc:defstruct (waitqueue (:copier nil) (:constructor make-waitqueue (&key name))) + "Waitqueue type." + ;; futex words are actually 32-bits, but it needs to be a raw slot and we don't have + ;; 32-bit raw slots on 64-bit machines. + #+sb-futex (token 0 :type sb-ext:word) + ;; If adding slots between TOKEN and NAME, please see futex_name() in linux_os.c + ;; which attempts to divine a string from a futex word address. + (name nil :type (or null string)) + ;; For WITH-CAS-LOCK: because CONDITION-WAIT must be able to call + ;; %WAITQUEUE-WAKEUP without re-aquiring the mutex, we need a separate + ;; lock. In most cases this should be uncontested thanks to the mutex -- + ;; the only case where that might not be true is when CONDITION-WAIT + ;; unwinds and %WAITQUEUE-DROP is called. + . #+sb-futex nil + #-sb-futex (%owner %head %tail)) + +(sb-xc:defstruct (semaphore (:copier nil) + (:constructor %make-semaphore (%count mutex queue))) + "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT +should be considered an implementation detail, and may change in the +future." + (%count 0 :type (integer 0)) + (waitcount 0 :type sb-vm:word) + (mutex nil :read-only t :type mutex) + (queue nil :read-only t :type waitqueue)) + +(declaim (sb-ext:freeze-type waitqueue semaphore)) + +(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 +in future versions." + (name nil :type (or null simple-string)) ; C code could read this + (%ephemeral-p nil :type boolean :read-only t) + ;; This is one of a few different views of a lisp thread: + ;; 1. the memory space (thread->os_addr in C) + ;; 2. 'struct thread' at some offset into the memory space, coinciding + ;; with the SB-VM::THREAD primitive object + ;; 3. a pthread, which may reside anywhere, possibly the high end of the lisp stack + ;; (above the SP given to your entrypoint), whatever the pthread library chooses. + ;; 4. the THREAD instance (this structure) + ;; This value is 0 if the thread is not considered alive, though the pthread + ;; may be running its termination code (unlinking from all_threads etc) + (primitive-thread 0 :type sb-vm:word) + ;; This is a redundant copy of the pthread identifier from the primitive thread. + ;; It's needed in the SB-THREAD:THREAD as well because there are valid reasons to + ;; manipulate the new thread before it has assigned 'th->os_thread = pthread_self()'. + ;; While we always have access to the C struct thread from Lisp, apparently the C + ;; code can't pass "&th->os_thread" as the first argument to pthread_create() for the + ;; incredible reason that the word might be written *after* the memory pointed at + ;; by 'th' has already been freed. Such action might seem to violate: + ;; "Before returning, a successful call to pthread_create() stores the ID of the + ;; new thread in the buffer pointed to by thread" + ;; (https://man7.org/linux/man-pages/man3/pthread_create.3.html) + ;; but that's not exactly what POSIX says, which is only: + ;; "Upon successful completion, pthread_create() stores the ID of the created thread + ;; in the location referenced by thread." + ;; (https://pubs.opengroup.org/onlinepubs/007908799/xsh/pthread_create.html) + ;; so there seems to be some leeway, and linux + glibc provides more of a guarantee. + ;; Technically we should have only one authoritative source of the pthread identifier, + ;; but it's not too critical, it's just annoying that there are two sources of + ;; the same value. + ;; The slot is somewhat poorly named (for consistency with C) because though it may + ;; correspond to an OS thread, it could be the case that the threading model has + ;; user-visible threads that do not map directly to OSs threads (or LWPs). + ;; Any use of THREAD-OS-THREAD from lisp should take care to ensure validity of + ;; the thread id by holding the INTERRUPTIONS-LOCK. + ;; Not needed for win32 threads. + #-win32 (os-thread 0 :type sb-vm:word) + ;; Keep a copy of the stack range for use in SB-EXT:STACK-ALLOCATED-P so that + ;; we don't have to read it from the primitive thread which is unsafe for any + ;; thread other than the current thread. + ;; Usually this is a fixed amount below PRIMITIVE-THREAD, but the exact offset + ;; varies by build configuration, and if #+win32 it is not related in any way. + (control-stack-start 0 :type sb-vm:word) + (control-stack-end 0 :type sb-vm:word) + ;; At the beginning of the thread's life, this is a vector of data required + ;; to start the user code. At the end, is it pointer to the 'struct thread' + ;; so that it can be either freed or reused. + (startup-info 0 :type (or fixnum (simple-vector 6))) + ;; Whether this thread should be returned in LIST-ALL-THREADS. + ;; This is almost-but-not-quite the same as what formerly + ;; might have been known as the %ALIVE-P flag. + (%visible 1 :type fixnum) + (interruptions nil :type list) + (interruptions-lock + (make-mutex :name "thread interruptions lock") + :type mutex :read-only t) + + ;; Per-thread memoization of GET-INTERNAL-REAL-TIME, for race-free update. + ;; This might be a bignum, which is why we bother. + #-64-bit (observed-internal-real-time-delta-sec 0 :type sb-vm:word) + #-64-bit (observed-internal-real-time-delta-millisec + ;; This needs a sentinel that can not possibly match an actual delta. + ;; I have seen threads start up where 0 and 0 do match sec,msec + ;; respectively, and then we'd return the cached NIL as if it were + ;; the time. Forcing mismatch avoids putting in an extra test for NIL. + (ash sb-ext:most-positive-word -1) + :type sb-vm:signed-word) + #-64-bit (internal-real-time) + + ;; On succesful execution of the thread's lambda, a list of values. + (result 0) + ;; The completion condition _could_ be manifested as a condition var, but a difficulty + ;; in doing so is that condition vars can always experience a spurious wakeup. + ;; Dealing with timeouts becomes troublesome then. But we can utilize the fact that + ;; WAIT-ON-SEMPAHORE implements a timeout, though as its comment says, the timeout + ;; doesn't account for re-acquiring the internal mutex if that takes nontrivial time, + ;; which it shouldn't since it guards very little work. + ;; At any rate, the semaphore abstraction is never subject to spurious wakeup. + (semaphore nil :type (or null semaphore)) + waiting-for) + +(sb-xc:defstruct (foreign-thread + (:copier nil) + (:include thread (name "callback")) + (:constructor make-foreign-thread ()) + (:conc-name "THREAD-")) + "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 + (defvar *current-thread*) + (declaim (type thread *current-thread*))) diff -Nru sbcl-2.0.6/src/code/time.lisp sbcl-2.1.1/src/code/time.lisp --- sbcl-2.0.6/src/code/time.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/time.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,9 +11,6 @@ (in-package "SB-IMPL") -(defun time-reinit () - (reinit-internal-real-time)) - ;;; Implemented in unix.lisp and win32.lisp. (setf (documentation 'get-internal-real-time 'function) "Return the real time (\"wallclock time\") since startup in the internal @@ -193,14 +190,15 @@ (truncate years 100)) (truncate (+ years 300) 400)))) -(defconstant +days-before-month+ +(defconstant-eqx +days-before-month+ #.(let ((reversed-result nil) (sum 0)) (push nil reversed-result) (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31)) (push sum reversed-result) (incf sum days-in-month)) - (coerce (nreverse reversed-result) 'simple-vector))) + (coerce (nreverse reversed-result) 'simple-vector)) + #'equalp) (defun encode-universal-time (second minute hour date month year &optional time-zone) @@ -431,12 +429,8 @@ old-page-faults new-page-faults real-time-overhead - run-utime-overhead - run-stime-overhead - page-faults-overhead old-bytes-consed new-bytes-consed - cons-overhead (fun (if (functionp function) function (fdefinition function)))) (declare (function fun)) ;; Calculate the overhead... @@ -450,14 +444,10 @@ (multiple-value-setq (new-run-utime new-run-stime new-page-faults new-bytes-consed) (time-get-sys-info)) - (setq run-utime-overhead (- new-run-utime old-run-utime)) - (setq run-stime-overhead (- new-run-stime old-run-stime)) - (setq page-faults-overhead (- new-page-faults old-page-faults)) (setq old-real-time (get-internal-real-time)) (setq old-real-time (get-internal-real-time)) (setq new-real-time (get-internal-real-time)) (setq real-time-overhead (- new-real-time old-real-time)) - (setq cons-overhead (- new-bytes-consed old-bytes-consed)) ;; Now get the initial times. (multiple-value-setq (old-run-utime old-run-stime old-page-faults old-bytes-consed) @@ -467,7 +457,6 @@ (*eval-calls* 0) (sb-c::*lambda-conversions* 0) (aborted t)) - (declare (special *eval-calls* sb-c::*lambda-conversions*)) (multiple-value-bind (h0 l0) (read-cycle-counter) (unwind-protect (multiple-value-prog1 (apply fun arguments) @@ -496,8 +485,10 @@ (note :processor-cycles cycles #'zerop)) (note :lambdas-converted sb-c::*lambda-conversions* #'zerop) (note :eval-calls *eval-calls* #'zerop) - (note :gc-run-time-ms gc-internal-run-time) + (note :gc-run-time-ms (floor gc-internal-run-time + (/ internal-time-units-per-second 1000))) (note :system-run-time-us system-run-time) (note :user-run-time-us user-run-time) - (note :real-time-ms real-time)) + (note :real-time-ms (floor real-time + (/ internal-time-units-per-second 1000)))) (apply timer plist)))))))))) diff -Nru sbcl-2.0.6/src/code/timer.lisp sbcl-2.1.1/src/code/timer.lisp --- sbcl-2.0.6/src/code/timer.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/timer.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -188,7 +188,7 @@ (defmacro with-scheduler-lock ((&optional) &body body) ;; Don't let the SIGALRM handler mess things up. - `(sb-thread::with-system-mutex (*scheduler-lock*) + `(with-system-mutex (*scheduler-lock*) ,@body)) (defun under-scheduler-lock-p () @@ -205,7 +205,7 @@ ;;; real time conversion (defun delta->real (delta) - (floor (* delta sb-xc:internal-time-units-per-second))) + (floor (* delta internal-time-units-per-second))) ;;; Public interface @@ -403,8 +403,8 @@ (let ((min-nsec 100000)) (if (minusp time) (values 0 min-nsec) - (multiple-value-bind (s u) (floor time sb-xc:internal-time-units-per-second) - (setf u (floor (* (/ u sb-xc:internal-time-units-per-second) + (multiple-value-bind (s u) (floor time internal-time-units-per-second) + (setf u (floor (* (/ u internal-time-units-per-second) #.(expt 10 9)))) (if (and (= 0 s) (< u min-nsec)) ;; 0 0 means "shut down the timer" for setitimer diff -Nru sbcl-2.0.6/src/code/toplevel.lisp sbcl-2.1.1/src/code/toplevel.lisp --- sbcl-2.0.6/src/code/toplevel.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/toplevel.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -58,7 +58,7 @@ (%exit))))) (define-load-time-global *exit-lock* nil) -(define-thread-local *exit-in-process* nil) +(define-thread-local *exit-in-progress* nil) (declaim (type (or null real) *exit-timeout*)) (defvar *exit-timeout* 60 "Default amount of seconds, if any, EXIT should wait for other @@ -67,21 +67,86 @@ (defun os-exit-handler (condition) (declare (ignore condition)) - (os-exit *exit-in-process* :abort t)) + (os-exit *exit-in-progress* :abort t)) (defvar *exit-error-handler* #'os-exit-handler) (defun call-exit-hooks () - (unless *exit-in-process* - (setf *exit-in-process* 0)) + (unless *exit-in-progress* + (setf *exit-in-progress* 0)) (handler-bind ((serious-condition *exit-error-handler*)) (call-hooks "exit" *exit-hooks* :on-error :warn))) +;;; TERMINATE-THREAD as it exists is basically unsuitable for anything other than +;;; interactive use, because it uses INTERRUPT-THREAD to unwind through user code. +;;; It is only slightly ok to call INTERRUPT-THREAD on a thread when you know +;;; exactly what it is doing. But even if you know what it's doing, you don't know +;;; when, so even if it's your code, it might be calling an alien destructor. +;;; It says right in the docstring of INTERRUPT-THREAD not to call it, +;;; and then what do we do? We go full steam ahead and call it. +;;; https://www.dictionary.com/e/slang/i-cant-even/ +;;; +;;; The full story here is that some users seem to think that EXIT is responsible +;;; for stopping any threads. There was a not-insignificant amount of discussion +;;; in https://groups.google.com/g/sbcl-devel/c/6Xj_d1dM1k0/m/G9OPAbOueDsJ +;;; But the mechanism employed for %EXIT-OTHER-THREADS is TERMINATE-THREAD, +;;; and that's just horrible. No matter how well the SBCL code is constructed, +;;; this approach can cause lockup. +;;; +;;; The *EXIT-HOOKS* are fine, but we can't assume that users call JOIN-THREAD in +;;; the exit hooks - they might ask threads to stop by assigning a global polled +;;; flag or by CONDITION-BROADCAST. They may do nothing. It's arbitrary. +;;; So maybe the threads are stopping "peacefully" and would finish on their own +;;; and we {could,should} just call JOIN-THREAD on them. But there's no way to know. +;;; Instead we just abort random threads with INTERRUPT-THREAD. +;;; Some of those threads that we forcibly terminate might have already been +;;; halfway through cleanly unwinding, which very possibly (or even likely) +;;; involves calling free() to release resources. When we interrupt a thread +;;; in the midst of its voluntary call to free(), no matter how clever free() is, +;;; we can presume that it will acquire a global lock. +;;; +;;; And there you have it - some dead thread owned a global lock that can't become +;;; available because we just punched that thread in the guts and killed it. +;;; Hence *all* threads (including non-Lisp) are permanently stuck waiting on +;;; a lock that is not owned by any running thread. +;;; +;;; I tried to remedy this by having the SIGURG signal handler silently discard +;;; a signal if interrupted at a non-Lisp program counter, but that presumes the +;;; call stack is never Lisp -> C -> Lisp, which first of all means that the handler +;;; needs to be entirely in C (if called from TERMINATE-THREAD) and secondly requires +;;; TERMINATE-THREAD to keep trying to send a signal if it thinks the signal was dropped. +;;; And you can't figure out whether a signal got purposely discard because then you'd +;;; need to wait an arbitrary amount of time to decide whether it might have been. +;;; Or invent a synchronized technique to see whether the asynchronous mechanism worked. +;;; +;;; So then the solution occurred to me: +;;; --> just don't terminate threads by force. Problem solved. <-- +;;; +;;; Therefore, if you want EXIT to be as near to the C exit() call as possible, +;;; after doing the lisp exit hooks, just set this global flag to NIL. +;;; Or leave it as T if you're fine with the old lockup-prone behavior. +;;; +;;; And if you think it's up to the Lisp environment to try to make threads stop +;;; by hook or by crook as a precondition to calling OS-EXIT (with which I disagree), +;;; the right solution is possibly modeled on pthread_cancel() which has specified +;;; 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 +;;; 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 +;;; 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. +(define-load-time-global *forcibly-terminate-threads-on-exit* t) + (defun %exit () ;; If anything goes wrong, we will exit immediately and forcibly. (handler-bind ((serious-condition *exit-error-handler*)) (let ((ok nil) - (code *exit-in-process*)) + (code *exit-in-progress*)) (if (consp code) ;; Another thread called EXIT, and passed the buck to us -- only ;; final call left to do. @@ -89,7 +154,11 @@ (unwind-protect (progn (flush-standard-output-streams) - (sb-thread::%exit-other-threads) + (if *forcibly-terminate-threads-on-exit* + (sb-thread::%exit-other-threads) + (with-deadline (:seconds nil :override t) + #+sb-thread (finalizer-thread-stop) + (sb-thread:grab-mutex sb-thread::*make-thread-lock*))) (setf ok t)) (os-exit code :abort (not ok))))))) @@ -119,9 +188,9 @@ $1f9))))))) (declare (inline split-float)) (typecase seconds - ((single-float $0f0 #.(float sb-xc:most-positive-fixnum $1f0)) + ((single-float $0f0 #.(float most-positive-fixnum $1f0)) (split-float)) - ((double-float $0d0 #.(float sb-xc:most-positive-fixnum $1d0)) + ((double-float $0d0 #.(float most-positive-fixnum $1d0)) (split-float)) (ratio (split-ratio-for-sleep seconds)) @@ -181,11 +250,11 @@ ;; use the largest representable value in that case. (timeout (or (seconds-to-maybe-internal-time seconds) (* safe-internal-seconds-limit - sb-xc:internal-time-units-per-second)))) + internal-time-units-per-second)))) (labels ((sleep-for-a-bit (remaining) (multiple-value-bind (timeout-sec timeout-usec stop-sec stop-usec deadlinep) - (decode-timeout (/ remaining sb-xc:internal-time-units-per-second)) + (decode-timeout (/ remaining internal-time-units-per-second)) (declare (ignore stop-sec stop-usec)) ;; Sleep until either the timeout or the deadline ;; expires. @@ -246,31 +315,28 @@ ;;; Flush anything waiting on one of the ANSI Common Lisp standard ;;; output streams before proceeding. (defun flush-standard-output-streams () - (let ((null (make-broadcast-stream))) - (dolist (name '(*debug-io* - *error-output* - *query-io* - *standard-output* - *trace-output* - *terminal-io*)) ;; 0. Pull out the underlying stream, so we know what it is. ;; 1. Handle errors on it. We're doing this on entry to ;; debugger, so we don't want recursive errors here. ;; 2. Rebind the stream symbol in case some poor sod sees ;; a broken stream here while running with *BREAK-ON-ERRORS*. - (let ((stream (stream-output-stream (symbol-value name)))) - ;; This is kind of crummy because it checks in globaldb for each - ;; stream symbol whether it can be bound to a stream. The translator - ;; for PROGV could skip ABOUT-TO-MODIFY-SYMBOL-VALUE based on - ;; an aspect of a policy, but if users figure that out they could - ;; do something horrible like rebind T and NIL. - (progv (list name) (list null) - (handler-bind ((stream-error - (lambda (c) - (when (eq stream (stream-error-stream c)) - (go :next))))) - (force-output stream)))) - :next)) + (flet ((flush (stream) + (let ((stream (stream-output-stream stream))) + (handler-bind ((stream-error + (lambda (c) + (when (eq (stream-error-stream c) stream) + (return-from flush))))) + (force-output stream))))) + (let ((null-stream (load-time-value *null-broadcast-stream* t))) + (macrolet ((flush-all (&rest streamvars) + `(progn + ,@(mapcar (lambda (streamvar) + `(let ((stream ,streamvar) + (,streamvar null-stream)) + (flush stream))) + streamvars)))) + (flush-all *debug-io* *error-output* *query-io* *standard-output* + *trace-output* *terminal-io*)))) (values)) (defun process-eval/load-options (options) @@ -652,3 +718,67 @@ ;;; a convenient way to get into the assembly-level debugger (defun %halt () (%primitive sb-c:halt)) + + +;;;; Examples of why NEVER NEVER NEVER to call TERMINATE-THREAD in production. + +#| +Example 1. Stuck somewhere in free() and in JOIN-THREAD. +[stuck at https://github.com/google/tcmalloc/blob/master/tcmalloc/cpu_cache.cc#L204] + Thread "A": + 0x98e697c [AbslInternalSpinLockDelay] + 0x9898287 [tcmalloc::CPUCache::UpdateCapacity(int, unsigned long, unsigned long, bool, tcmalloc::CPUCache::ObjectClass*, unsigned long*)] + 0x9898b38 [tcmalloc::CPUCache::Overflow(void*, unsigned long, int)] + 0x9891f39 [(anonymous namespace)::do_free_no_hooks(void*)] + 0x988cea1 [MallocBlock::ProcessFreeQueue(MallocBlock*, unsigned long, int)] + 0x26f490a [CFFI::FOREIGN-ARRAY-FREE] + Thread "main thread": + 0x9877f23 [futex_wait] + 0x32f32c8 [(FLET SB-UNIX::BODY :IN SB-THREAD::FUTEX-WAIT)] + 0x32f301f [SB-THREAD::%%WAIT-FOR-MUTEX] + 0x2f97f5d [SB-THREAD::%WAIT-FOR-MUTEX] + 0x2f287be [SB-THREAD::JOIN-THREAD] + +Example 2. Stuck somewhere else in free() and in JOIN-THREAD. + Thread "A": + 0x7f657d1a7cb9 [syscall] + 0x98e697c [AbslInternalSpinLockDelay] + 0x995e9e7 [absl::base_internal::SpinLock::SlowLock()] + 0x988d63b [MallocBlock::CheckAndClear(int)] + 0x9a8511f [__libc_free] + 0x26f490a [CFFI::FOREIGN-ARRAY-FREE] + Thread "main thread": + 0x9877f23 [futex_wait] + 0x32f32c8 [(FLET SB-UNIX::BODY :IN SB-THREAD::FUTEX-WAIT)] + 0x32f301f [SB-THREAD::%%WAIT-FOR-MUTEX] + 0x2f97f5d [SB-THREAD::%WAIT-FOR-MUTEX] + 0x2f287be [SB-THREAD::JOIN-THREAD] + +Example 3. main thread stuck in a C library exit handler: + 0x98e697c [AbslInternalSpinLockDelay] + 0x995e9e7 [absl::base_internal::SpinLock::SlowLock()] + 0x98a43cf [tcmalloc::HugePageAwareAllocator::LockAndAlloc(unsigned long, bool*)] + 0x98a423f [tcmalloc::HugePageAwareAllocator::New(unsigned long)] + 0x9896ee8 [tcmalloc::CentralFreeList::Populate()] + 0x9896c69 [tcmalloc::CentralFreeList::RemoveRange(void**, int)] + 0x9897e74 [tcmalloc::CPUCache::Refill(int, unsigned long)] + 0x989221b [tcmalloc::dbg_do_malloc(unsigned long, unsigned long*)] + 0x9a85045 [__libc_malloc] + 0x7f25a8ad5772 [__run_exit_handlers] + 0x7f25a8ad57c5 [exit] + 0x2fa99a3 [SB-SYS::OS-EXIT] + +Example 4. main thread stuck in a different C library exit handler: + 0x992ecfe [absl::synchronization_internal::Waiter::Wait(absl::synchronization_internal::KernelTimeout)] + 0x98e6865 [AbslInternalPerThreadSemWait] + 0x992fd4d [absl::Mutex::Block(absl::base_internal::PerThreadSynch*)] + 0x99324a0 [absl::Mutex::LockSlowLoop(absl::SynchWaitParams*, int)] + 0x9930b0e [absl::Mutex::LockSlow(absl::MuHowS const*, absl::Condition const*, int)] + 0x9930346 [absl::Mutex::Lock()] + 0x97ca6c0 [thread::local::internal::Var::~Var()] + 0x7fcf3fde0772 [__run_exit_handlers] + 0x7fcf3fde07c5 [exit] + 0x2fa99a3 [SB-SYS::OS-EXIT] + +There are plenty more where those came from. +|# diff -Nru sbcl-2.0.6/src/code/traceroot.lisp sbcl-2.1.1/src/code/traceroot.lisp --- sbcl-2.0.6/src/code/traceroot.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/traceroot.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -34,13 +34,6 @@ :all)) 0) -(defun find-lisp-thread-from-thread-struct (addr) - ;; It is of course possible to do this without consing the list - ;; of all threads, but I don't care. - (dolist (thread (sb-thread:list-all-threads)) - (when (= (sb-thread::thread-primitive-thread thread) addr) - (return thread)))) - ;;; Convert each path to (TARGET . NODES) ;;; where the first node in NODES is one of: ;;; @@ -89,8 +82,9 @@ (root-kind (car root))) (if (eq root-kind 0) ; heap object (rplaca path :static) - (let* ((thread (find-lisp-thread-from-thread-struct - (ash (cadr root) sb-vm:n-fixnum-tag-bits))) + (let* ((thread (sap-ref-lispobj + (sb-int:descriptor-sap (cadr root)) + (ash sb-vm::thread-lisp-thread-slot sb-vm:word-shift))) (extra (cddr root)) (symbol (unless (eql root-kind 1) @@ -171,9 +165,11 @@ &key (:criterion (member :oldest :pseudo-static :static)) (:gc t) + (:ignore list) (:print (or boolean (eql :verbose))))) search-roots)) -(defun search-roots (weak-pointers &key (criterion :oldest) (gc nil) (print t)) +(defun search-roots (weak-pointers &key (criterion :oldest) (gc nil) + (ignore nil) (print t)) "Find roots keeping the targets of WEAK-POINTERS alive. WEAK-POINTERS must be a single SB-EXT:WEAK-POINTER or a list of those, @@ -208,6 +204,10 @@ To find a root of an image-backed object, you want to stop only at a truly :STATIC object. +IGNORE is a list of objects to treat as if nonexistent in the heap. +It can often be useful for finding a path to an interned symbol other than +through its package by specifying the package as an ignored object. + PRINT controls whether discovered paths should be returned or printed. Possible values are @@ -252,7 +252,9 @@ Experimental: subject to change without prior notice." (let* ((input (ensure-list weak-pointers)) (output (make-array (length input))) - (param (cons input (cons :result output))) + (param (vector input + (if ignore (coerce ignore 'simple-vector) 0) + (cons :result output))) (criterion-value (ecase criterion (:oldest 0) (:pseudo-static 1) @@ -270,7 +272,7 @@ (extern-alien "prove_liveness" (function int unsigned int)) (sb-kernel:get-lisp-obj-address param) criterion-value)))) - (case (cadr param) + (case (car (elt param 2)) (-1 (error "Input is not a proper list of weak pointers."))) (let ((paths (preprocess-traceroot-results input output))) (cond (print diff -Nru sbcl-2.0.6/src/code/type-class.lisp sbcl-2.1.1/src/code/type-class.lisp --- sbcl-2.0.6/src/code/type-class.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/type-class.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -209,7 +209,7 @@ (coerce :type (or symbol null)) |# ) -#-sb-fluid (declaim (freeze-type type-class)) +(declaim (freeze-type type-class)) (defun type-class-or-lose (name) (or (find name *type-classes* :key #'type-class-name) @@ -552,13 +552,13 @@ ;;; FIXME: This was a macro in CMU CL, and is now an INLINE function. Is ;;; it important for it to be INLINE, or could be become an ordinary ;;; function without significant loss? -- WHN 19990413 -#-sb-fluid (declaim (inline type-cache-hash)) +(declaim (inline type-cache-hash)) (declaim (ftype (function (ctype ctype) (signed-byte #.sb-vm:n-fixnum-bits)) type-cache-hash)) (defun type-cache-hash (type1 type2) (logxor (ash (type-hash-value type1) -3) (type-hash-value type2))) -#-sb-fluid (declaim (inline type-list-cache-hash)) +(declaim (inline type-list-cache-hash)) (declaim (ftype (function (list) (signed-byte #.sb-vm:n-fixnum-bits)) type-list-cache-hash)) (defun type-list-cache-hash (types) diff -Nru sbcl-2.0.6/src/code/typep.lisp sbcl-2.1.1/src/code/typep.lisp --- sbcl-2.0.6/src/code/typep.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/typep.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -193,11 +193,10 @@ ;;; 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. -;;; LAYOUT is the *expected* type, not the the layout currently in OBJECT. -(defun update-object-layout-or-invalid (object layout) +(defun update-object-layout (object) (if (%pcl-instance-p object) (sb-pcl::check-wrapper-validity object) - (sb-c::%layout-invalid-error object layout))) + (layout-of object))) ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID. @@ -208,14 +207,14 @@ ;;; could be done in either order, * HOWEVER * it is less racy to perform ;;; them in this exact order. Consider the case that OBJ-LAYOUT is T ;;; for a class that satisfies CLASS-FINALIZED-P and suppose these operations were -;;; reversed from the order below. UPDATE-OBJECT-LAYOUT-OR-INVALID is going to make +;;; reversed from the order below. CHECK-WRAPPER-VALIDITY is going to make ;;; a new layout, registering it and installing into the classoid. ;;; Then %ENSURE-CLASSOID-VALID is going to call %FORCE-CACHE-FLUSHES which is going ;;; to make yet another new layout. The "transitivity of wrapper updates" usually ;;; causes the first new layout to automatically update to the second new layout, ;;; except that the other thread has already fetched the old layout. ;;; But by using the order below, there will not be two new layouts made, only one, -;;; because UPDATE-OBJECT-LAYOUT-OR-INVALID is able to use the layout +;;; because CHECK-WRAPPER-VALIDITY is able to use the layout ;;; that was updated into the classoid by %ENSURE-CLASSOID-VALID. ;;; All other things being equal, one new layout is better than two. ;;; At least I think that's what happens. @@ -238,16 +237,27 @@ ;; locking here makes Slime unusable with :SPAWN in post *WORLD-LOCK* world. So... ;; -- NS 2008-12-16 (multiple-value-bind (obj-layout layout) - (do ((layout (classoid-layout classoid) (classoid-layout classoid)) - (i 0 (+ i 1)) - (obj-layout obj-layout)) - ((and (not (layout-invalid obj-layout)) - (not (layout-invalid layout))) - (values obj-layout layout)) - (aver (< i 2)) - (%ensure-classoid-valid classoid layout "typep") - (when (zerop (layout-clos-hash obj-layout)) - (setq obj-layout (update-object-layout-or-invalid object layout)))) + (cond ((not (layout-for-pcl-obj-p obj-layout)) + ;; If the object is a structure or condition, just ensure validity of the class + ;; 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))) + (t + ;; And this case is even more racy, naturally. + (do ((layout (classoid-layout classoid) (classoid-layout classoid)) + (i 0 (+ i 1)) + (obj-layout obj-layout)) + ((and (not (layout-invalid obj-layout)) + (not (layout-invalid layout))) + (values obj-layout layout)) + (aver (< i 2)) + (%ensure-classoid-valid classoid layout "typep") + (when (zerop (layout-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))) (dotimes (i (length obj-inherits) nil) diff -Nru sbcl-2.0.6/src/code/uncross.lisp sbcl-2.1.1/src/code/uncross.lisp --- sbcl-2.0.6/src/code/uncross.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/uncross.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -19,7 +19,7 @@ ;;; In the target system's compiler, uncrossing is just identity. #-sb-xc-host (progn - #-sb-fluid (declaim (inline uncross)) + (declaim (inline uncross)) (defun uncross (x) x)) ;;; In the cross-compiler, uncrossing is slightly less trivial. diff -Nru sbcl-2.0.6/src/code/unix.lisp sbcl-2.1.1/src/code/unix.lisp --- sbcl-2.0.6/src/code/unix.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/unix.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -32,7 +32,7 @@ (defun c-strings->string-list (c-strings) (declare (type (alien (* c-string)) c-strings)) (let ((reversed-result nil)) - (dotimes (i sb-xc:most-positive-fixnum (error "argh! can't happen")) + (dotimes (i most-positive-fixnum (error "argh! can't happen")) (declare (type index i)) (let ((c-string (deref c-strings i))) (if c-string @@ -42,7 +42,7 @@ ;;;; Lisp types used by syscalls (deftype unix-pathname () 'simple-string) -(deftype unix-fd () `(integer 0 ,sb-xc:most-positive-fixnum)) +(deftype unix-fd () `(integer 0 ,most-positive-fixnum)) (deftype unix-file-mode () '(unsigned-byte 32)) (deftype unix-pid () '(unsigned-byte 32)) @@ -53,13 +53,24 @@ (/show0 "unix.lisp 74") -;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other -;;; macros in this file, are only used in this file, and could be -;;; implemented using SB-XC:DEFMACRO wrapped in EVAL-WHEN. -;;; -;;; SB-EXECUTABLE, at least, uses one of these macros; other libraries -;;; and programs have been known to use them as well. Perhaps they -;;; should live in SB-SYS or even SB-EXT? +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun libc-name-for (x) + (assert (stringp x)) + ;; This function takes a possibly-wrapped C name and strips off "sb_" + ;; if it doesn't need a wrapper. The list of functions that can be + ;; called directly is listed explicitly, because there are also others + ;; that might want to be wrapped even if they don't need to be, + ;; like sb_opendir and sb_closedir. Why are those wrapped in fact? + #+netbsd x + #-netbsd (if (member x '("sb_getrusage" ; syscall* + "sb_gettimeofday" ;syscall* + "sb_select" ; int-syscall + "sb_getitimer" ; syscall* + "sb_setitimer" ; syscall* + "sb_utimes") ; posix + :test #'string=) + (subseq x 3) + x))) (defmacro syscall ((name &rest arg-types) success-form &rest args) (when (eql 3 (mismatch "[_]" name)) @@ -67,7 +78,8 @@ (concatenate 'string #+win32 "_" (subseq name 3)))) `(locally (declare (optimize (sb-c::float-accuracy 0))) - (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + (let ((result (alien-funcall (extern-alien ,(libc-name-for name) + (function int ,@arg-types)) ,@args))) (if (minusp result) (values nil (get-errno)) @@ -79,14 +91,15 @@ (defmacro syscall* ((name &rest arg-types) success-form &rest args) `(locally (declare (optimize (sb-c::float-accuracy 0))) - (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + (let ((result (alien-funcall (extern-alien ,(libc-name-for name) + (function int ,@arg-types)) ,@args))) (if (minusp result) (error "Syscall ~A failed: ~A" ,name (strerror)) ,success-form)))) (defmacro int-syscall ((name &rest arg-types) &rest args) - `(syscall (,name ,@arg-types) (values result 0) ,@args)) + `(syscall (,(libc-name-for name) ,@arg-types) (values result 0) ,@args)) (defmacro with-restarted-syscall ((&optional (value (gensym)) (errno (gensym))) @@ -387,17 +400,17 @@ ;; ;; Signal an error at compile-time, since it's needed for the ;; runtime to start up - #-(or android linux openbsd freebsd netbsd sunos darwin hpux dragonfly haiku) + #-(or android linux openbsd freebsd netbsd sunos darwin dragonfly haiku) #.(error "POSIX-GETCWD is not implemented.") (or - #+(or linux openbsd freebsd netbsd sunos darwin hpux dragonfly haiku) + #+(or linux openbsd freebsd netbsd sunos darwin dragonfly haiku) (newcharstar-string (alien-funcall (extern-alien "getcwd" (function (* char) (* char) size-t)) nil #+(or linux openbsd freebsd netbsd darwin dragonfly haiku) 0 - #+(or sunos hpux) 1025)) + #+(or sunos) 1025)) #+android (with-alien ((ptr (array char #.path-max))) ;; Older bionic versions do not have the above feature. @@ -537,26 +550,6 @@ ;;;; sys/resource.h -;;; FIXME: All we seem to need is the RUSAGE_SELF version of this. -;;; -;;; This is like getrusage(2), except it returns only the system and -;;; user time, and returns the seconds and microseconds as separate -;;; values. -#-win32 (declaim (inline unix-fast-getrusage)) -#-win32 -(defun unix-fast-getrusage (who) - (declare (values (member t) - unsigned-byte fixnum - unsigned-byte fixnum)) - (with-alien ((usage (struct rusage))) - (syscall* ("sb_getrusage" int (* (struct rusage))) - (values t - (slot (slot usage 'ru-utime) 'tv-sec) - (slot (slot usage 'ru-utime) 'tv-usec) - (slot (slot usage 'ru-stime) 'tv-sec) - (slot (slot usage 'ru-stime) 'tv-usec)) - who (addr usage)))) - ;;; Return information about the resource usage of the process ;;; specified by WHO. WHO can be either the current process ;;; (rusage_self) or all of the terminated child processes @@ -1003,14 +996,13 @@ #-win32 (defun unix-setitimer (which int-secs int-usec val-secs val-usec) - "UNIX-SETITIMER sets the INTERVAL and VALUE slots of one of - three system timers (:real :virtual or :profile). A SIGALRM signal - will be delivered VALUE from now. INTERVAL, - when non-zero, is to be loaded each time - the timer expires. Setting INTERVAL and VALUE to zero disables - the timer. See the Unix man page for more details. On success, - unix-setitimer returns the old contents of the INTERVAL and VALUE - slots as in unix-getitimer." + "UNIX-SETITIMER sets the INTERVAL and VALUE slots of one of three system + timers (:real :virtual or :profile). A SIGALRM, SIGVTALRM, or SIGPROF + respectively will be delivered in VALUE from now. + INTERVAL, when non-zero, is reloaded into the timer on each expiration. + Setting VALUE to zero disables the timer. See the Unix man page for more + details. On success, unix-setitimer returns the + old contents of the INTERVAL and VALUE slots as in unix-getitimer." (declare (type (member :real :virtual :profile) which) (type unsigned-byte int-secs val-secs) (type (integer 0 (1000000)) int-usec val-usec) @@ -1027,13 +1019,13 @@ (slot (slot itvn 'it-interval) 'tv-usec) int-usec (slot (slot itvn 'it-value ) 'tv-sec ) val-secs (slot (slot itvn 'it-value ) 'tv-usec) val-usec) - (syscall* ("sb_setitimer" int (* (struct timeval))(* (struct timeval))) + (syscall* ("sb_setitimer" int (* (struct timeval)) (* (struct timeval))) (values t (slot (slot itvo 'it-interval) 'tv-sec) (slot (slot itvo 'it-interval) 'tv-usec) (slot (slot itvo 'it-value) 'tv-sec) (slot (slot itvo 'it-value) 'tv-usec)) - which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) + which (alien-sap (addr itvn)) (alien-sap (addr itvo)))))) ;;; FIXME: Many Unix error code definitions were deleted from the old @@ -1043,41 +1035,64 @@ ;;; enough of them all in one place here that they should probably be ;;; removed by hand. -(defconstant micro-seconds-per-internal-time-unit - (/ 1000000 sb-xc:internal-time-units-per-second)) +(defconstant microseconds-per-internal-time-unit + (/ 1000000 internal-time-units-per-second)) +(defconstant nanoseconds-per-internal-time-unit + (* microseconds-per-internal-time-unit 1000)) ;;; UNIX specific code, that has been cleanly separated from the ;;; Windows build. #-win32 (progn + (declaim (inline clock-gettime)) + (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)))) + clockid (addr ts)) + ;; 'seconds' is definitely a fixnum for 64-bit, because most-positive-fixnum + ;; can express 1E11 years in seconds. + (values #+64-bit (truly-the fixnum (slot ts 'tv-sec)) + #-64-bit (slot ts 'tv-sec) + (truly-the (integer 0 #.(expt 10 9)) (slot ts 'tv-nsec))))) + (declaim (inline get-time-of-day)) (defun get-time-of-day () "Return the number of seconds and microseconds since the beginning of the UNIX epoch (January 1st 1970.)" (with-alien ((tv (struct timeval))) - (syscall* ("sb_gettimeofday" (* (struct timeval))) + (syscall* ("sb_gettimeofday" (* (struct timeval)) system-area-pointer) (values (slot tv 'tv-sec) (slot tv 'tv-usec)) - (addr tv)))) + (addr tv) (int-sap 0)))) - (declaim (inline system-internal-run-time - system-real-time-values)) - (defun system-real-time-values () - (multiple-value-bind (sec usec) (get-time-of-day) - (declare (type unsigned-byte sec) (type (unsigned-byte 31) usec)) - (values sec (truncate usec micro-seconds-per-internal-time-unit)))) - - ;; There are two optimizations here that actually matter (on 32-bit - ;; systems): substract the epoch from seconds and milliseconds - ;; separately, as those should remain fixnums for the first 17 years - ;; or so of runtime. Also, avoid doing consing a new bignum if the - ;; result would be = to the last result given. - ;; - ;; Note: the next trick would be to spin a separate thread to update - ;; a global value once per internal tick, so each individual call to - ;; get-internal-real-time would be just a memory read... but that is - ;; probably best left for user-level code. ;) + ;; The "optimizations that actually matter" don't actually matter for 64-bit. + ;; Microseconds can express at least 1E5 years of uptime: + ;; (float (/ most-positive-fixnum (* 1000000 60 60 24 (+ 365 1/4)))) + ;; = microseconds-per-second * seconds-per-minute * minutes-per-hour + ;; * hours-per-day * days-per-year + + (defun get-internal-real-time () + (with-alien ((base (struct timespec) :extern "lisp_init_time")) + (multiple-value-bind (c-sec c-nsec) + ;; By scaling down we end up with far less resolution than clock-realtime + ;; offers, and COARSE is about twice as fast, so use that, but only for linux. + ;; BSD has something similar. + (clock-gettime #+linux clock-monotonic-coarse #-linux clock-monotonic) + + #+64-bit ;; I know that my math is valid for 64-bit. + (declare (optimize (sb-c::type-check 0))) + #+64-bit + (let ((delta-sec (the fixnum (- c-sec (the fixnum (slot base 'tv-sec))))) + (delta-nsec (the fixnum (- c-nsec (the fixnum (slot base 'tv-nsec)))))) + (the sb-kernel:internal-time + (+ (the fixnum (* delta-sec internal-time-units-per-second)) + (truncate delta-nsec nanoseconds-per-internal-time-unit)))) + + ;; There are two optimizations here that actually matter on 32-bit systems: + ;; (1) subtract the epoch from seconds and milliseconds separately, + ;; (2) avoid consing a new bignum if the result is unchanged. ;; ;; Thanks to James Anderson for the optimization hint. ;; @@ -1085,60 +1100,40 @@ ;; bound. ;; ;; --NS 2007-04-05 - (let ((e-sec 0) - (e-msec 0) - (c-sec 0) - (c-msec 0) - (now 0)) - (declare (type sb-kernel:internal-seconds e-sec c-sec) - (type sb-kernel:internal-seconds e-msec c-msec) - (type sb-kernel:internal-time now)) - (defun reinit-internal-real-time () - (setf (values e-sec e-msec) (system-real-time-values) - c-sec 0 - c-msec 0)) - ;; If two threads call this at the same time, we're still safe, I - ;; believe, as long as NOW is updated before either of C-MSEC or - ;; C-SEC. Same applies to interrupts. --NS - ;; - ;; I believe this is almost correct with x86/x86-64 cache - ;; coherency, but if the new value of C-SEC, C-MSEC can become - ;; visible to another CPU without NOW doing the same then it's - ;; unsafe. It's `almost' correct on x86 because writes by other - ;; processors may become visible in any order provided transitity - ;; holds. With at least three cpus, C-MSEC and C-SEC may be from - ;; different threads and an incorrect value may be returned. - ;; Considering that this failure is not detectable by the caller - - ;; it looks like time passes a bit slowly - and that it should be - ;; an extremely rare occurance I'm inclinded to leave it as it is. - ;; --MG - (defun get-internal-real-time () - (multiple-value-bind (sec msec) (system-real-time-values) - (unless (and (= msec c-msec) (= sec c-sec)) - (setf now (+ (* (- sec e-sec) - sb-xc:internal-time-units-per-second) - (- msec e-msec)) - c-msec msec - c-sec sec)) - now))) + #-64-bit + (symbol-macrolet ((observed-sec + (sb-thread::thread-observed-internal-real-time-delta-sec thr)) + (observed-msec + (sb-thread::thread-observed-internal-real-time-delta-millisec thr)) + (time (sb-thread::thread-internal-real-time thr))) + (let* ((delta-sec (- c-sec (slot base 'tv-sec))) + ;; I inadvertently had too many THE casts in here, so I'd prefer + ;; to err on the side of caution rather than cause GC lossage + ;; (which I accidentally did). So assert that nanoseconds are <= 10^9 + ;; and the compiler will do as best it can with that information. + (delta-nsec (- c-nsec (the (integer 0 #.(expt 10 9)) + (slot base 'tv-nsec)))) + ;; ROUND, FLOOR? Who cares, it's a number that's going to change. + ;; More math = more self-induced jitter. + (delta-millisec (floor delta-nsec 1000000)) + (thr sb-thread:*current-thread*)) + (if (and (= delta-sec observed-sec) (= delta-millisec observed-msec)) + time + (let ((current (+ (* delta-sec internal-time-units-per-second) + ;; ASSUMPTION: delta-millisec = delta-itu + delta-millisec))) + (setf time current + observed-msec delta-millisec + observed-sec delta-sec) + current))))))) + (declaim (inline system-internal-run-time)) + #-sunos ; defined in sunos-os (defun system-internal-run-time () - (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec) - (unix-fast-getrusage rusage_self) - (declare (ignore ignore) - (type unsigned-byte utime-sec stime-sec) - ;; (Classic CMU CL had these (MOD 1000000) instead, but - ;; at least in Linux 2.2.12, the type doesn't seem to - ;; be documented anywhere and the observed behavior is - ;; to sometimes return 1000000 exactly.) - (type fixnum utime-usec stime-usec)) - (let ((result (+ (* (+ utime-sec stime-sec) - sb-xc:internal-time-units-per-second) - (floor (+ utime-usec - stime-usec - (floor micro-seconds-per-internal-time-unit 2)) - micro-seconds-per-internal-time-unit)))) - result)))) + (multiple-value-bind (sec nsec) (clock-gettime clock-process-cputime-id) + (+ (* sec internal-time-units-per-second) + (floor (+ nsec (floor nanoseconds-per-internal-time-unit 2)) + nanoseconds-per-internal-time-unit))))) ;;; FIXME, KLUDGE: GET-TIME-OF-DAY used to be UNIX-GETTIMEOFDAY, and had a ;;; primary return value indicating sucess, and also returned timezone diff -Nru sbcl-2.0.6/src/code/warm-error.lisp sbcl-2.1.1/src/code/warm-error.lisp --- sbcl-2.0.6/src/code/warm-error.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/warm-error.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -25,7 +25,11 @@ (setf (sb-int:info :function :type s) parsed))))) ;; One good kludge deserves another. ;; This is OK only because it's the very first file compiled in warm build. - (assert (<= (length sb-c::*undefined-warnings*) 2)) + (let ((disallowed-undefineds + (remove-if (lambda (x) (member x '(class sb-pcl::condition-class))) + (mapcar #'sb-c::undefined-warning-name + sb-c::*undefined-warnings*)))) + (assert (not disallowed-undefineds))) (setf sb-c::*undefined-warnings* nil)) ;;; Moved from 'cold-error' to this file because of (at least) these reasons: diff -Nru sbcl-2.0.6/src/code/warm-mswin.lisp sbcl-2.1.1/src/code/warm-mswin.lisp --- sbcl-2.0.6/src/code/warm-mswin.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/warm-mswin.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -32,8 +32,17 @@ (stdout handle) (stderr handle))) +(defconstant +startf-use-show-window+ #x001) (defconstant +startf-use-std-handles+ #x100) +(defconstant +sw-hide+ 0) +(defconstant +sw-show-normal+ 1) +(defconstant +sw-show-minimized+ 2) +(defconstant +sw-show-maximized+ 3) +(defconstant +sw-show-no-activate+ 4) +(defconstant +sw-show-min-no-active+ 7) +(defconstant +sw-show-na+ 8) + (define-alien-routine ("CreateProcessW" create-process) lispbool (application-name system-string) (command-line system-string) @@ -46,8 +55,6 @@ (startup-info (* t)) (process-information (* t))) - - (defun search-path (partial-name) "Searh executable using the system path" (with-alien ((pathname-buffer pathname-buffer)) @@ -76,12 +83,16 @@ (process handle) (exit-code uint)) -(defun mswin-spawn (program argv stdin stdout stderr searchp envp directory) +(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)) (flet ((maybe-std-handle (arg) (let ((default (pop std-handles))) (case arg (-1 default) (otherwise (setf inheritp t) arg))))) + (when preserve-handles + (setf inheritp t) + (loop for handle in preserve-handles + do (setf (inheritable-handle-p handle) t))) (with-alien ((process-information process-information) (startup-info startup-info)) (sb-kernel:system-area-ub8-fill @@ -94,7 +105,18 @@ (slot startup-info 'reserved1) nil (slot startup-info 'reserved2) 0 (slot startup-info 'reserved3) nil - (slot startup-info 'flags) (if inheritp +startf-use-std-handles+ 0)) + (slot startup-info 'show-window) (ecase window + (:hide +sw-hide+) + (:show-normal +sw-show-normal+) + (:show-maximized +sw-show-maximized+) + (:show-minimized +sw-show-minimized+) + (:show-no-activate +sw-show-no-activate+) + (:show-min-no-active +sw-show-min-no-active+) + (:show-na +sw-show-na+) + ((nil) 0)) + (slot startup-info 'flags) (logior (if inheritp +startf-use-std-handles+ 0) + (if window +startf-use-show-window+ 0))) + (without-interrupts ;; KLUDGE: pass null image file name when searchp is true. ;; This way, file extension gets resolved by OS if omitted. diff -Nru sbcl-2.0.6/src/code/weak.lisp sbcl-2.1.1/src/code/weak.lisp --- sbcl-2.0.6/src/code/weak.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/weak.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -15,7 +15,7 @@ "Allocate and return a weak pointer which points to OBJECT." (make-weak-pointer object)) -#-sb-fluid (declaim (inline weak-pointer-value)) +(declaim (inline weak-pointer-value)) (defun weak-pointer-value (weak-pointer) "If WEAK-POINTER is valid, return the value of WEAK-POINTER and T. If the referent of WEAK-POINTER has been garbage collected, diff -Nru sbcl-2.0.6/src/code/win32.lisp sbcl-2.1.1/src/code/win32.lisp --- sbcl-2.0.6/src/code/win32.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/win32.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -146,9 +146,11 @@ handle)) (t (with-alien ((avail dword)) - - (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil)) - (return-from handle-listen (plusp avail)))) + (let* ((res (peek-named-pipe handle nil 0 nil (addr avail) nil)) + (code (get-last-error))) + (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))) (unless (zerop res) (return-from handle-listen (= res 1)))) @@ -343,7 +345,7 @@ ;;;; Process time information (defconstant 100ns-per-internal-time-unit - (/ 10000000 sb-xc:internal-time-units-per-second)) + (/ 10000000 internal-time-units-per-second)) ;; FILETIME ;; The FILETIME structure is a 64-bit value representing the number of @@ -376,6 +378,12 @@ (addr ,kernel-time) (addr ,user-time)))) +#+64-bit +(progn + (defun reinit-internal-real-time () nil) + (defun get-internal-real-time () + (alien-funcall (extern-alien "get_monotonic_time" (function unsigned))))) +#-64-bit (let ((epoch 0)) (declare (unsigned-byte epoch)) ;; FIXME: For optimization ideas see the unix implementation. @@ -427,7 +435,6 @@ (defconstant +filetime-unit+ 10000000) (defconstant +common-lisp-epoch-filetime-seconds+ 9435484800) -#-sb-fluid (declaim (inline get-time-of-day)) (defun get-time-of-day () "Return the number of seconds and microseconds since the beginning of the @@ -889,7 +896,7 @@ (defun windows-pipe () (multiple-value-bind (created read-handle write-handle) - (create-pipe nil 256) + (create-pipe nil 0) (if created (values read-handle write-handle) (win32-error 'create-pipe)))) diff -Nru sbcl-2.0.6/src/code/x86-64-vm.lisp sbcl-2.1.1/src/code/x86-64-vm.lisp --- sbcl-2.0.6/src/code/x86-64-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/x86-64-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -13,64 +13,7 @@ (defun machine-type () "Return a string describing the type of the local machine." "X86-64") - -;;;; :CODE-OBJECT fixups -;;; This gets called by LOAD to resolve newly positioned objects -;;; with things (like code instructions) that have to refer to them. -;;; Return KIND if the fixup needs to be recorded in %CODE-FIXUPS. -;;; The code object we're fixing up is pinned whenever this is called. -(defun fixup-code-object (code offset fixup kind flavor) - (declare (type index offset) (ignorable flavor)) - (let* ((sap (code-instructions code)) - (fixup (+ (if (eq kind :absolute64) - (signed-sap-ref-64 sap offset) - (signed-sap-ref-32 sap offset)) - fixup))) - (ecase kind - (:absolute64 - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-64 sap offset) fixup)) - (:absolute - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-32 sap offset) fixup)) - (:relative - ;; Fixup is the actual address wanted. - ;; Replace word with value to add to that loc to get there. - ;; In the #-immobile-code case, there's nothing to assert. - ;; Relative fixups don't exist with movable code. - #+immobile-code - (unless (immobile-space-obj-p code) - (error "Can't compute fixup relative to movable object ~S" code)) - (setf (signed-sap-ref-32 sap offset) - ;; JMP/CALL are relative to the next instruction, - ;; so add 4 bytes for the size of the displacement itself. - (- fixup (sap-int (sap+ sap (+ offset 4)))))))) - ;; An absolute fixup is stored in the code header's %FIXUPS slot if it - ;; references an immobile-space (but not static-space) object. - ;; Note that: - ;; (1) Call fixups occur in both :RELATIVE and :ABSOLUTE kinds. - ;; We can ignore the :RELATIVE kind, except for foreign call, - ;; as those point to the linkage table which has an absolute address - ;; and therefore might change in displacement from the call site - ;; if the immobile code space is relocated on startup. - ;; (2) :STATIC-CALL fixups point to immobile space, not static space. - #+immobile-space - (return-from fixup-code-object - (case flavor - ((:named-call :layout :immobile-symbol :symbol-value ; -> fixedobj subspace - :assembly-routine :assembly-routine* :static-call) ; -> varyobj subspace - (if (eq kind :absolute) :absolute)) - (:foreign - ;; linkage-table calls using the "CALL rel32" format need to be saved, - ;; because the linkage table resides at a fixed address. - ;; Space defragmentation can handle the fixup automatically, - ;; but core relocation can't - it can't find all the call sites. - (if (eq kind :relative) :relative)))) - nil) ; non-immobile-space builds never record code fixups - #+(or darwin linux openbsd win32 sunos (and freebsd x86-64)) (define-alien-routine ("os_context_float_register_addr" context-float-register-addr) (* unsigned) (context (* os-context-t)) (index int)) @@ -218,22 +161,9 @@ (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)) - sb-kernel:+layout-all-tagged+)) + +layout-all-tagged+)) (eql kind sb-vm:closure-widetag)))) -(defconstant sb-pcl::+machine-code-embedding-fsc-instance-bitmap+ - (logxor (1- (ash 1 funcallable-instance-info-offset)) - (ash 1 (1- funcallable-instance-trampoline-slot)))) - -;;; This allocator is in its own function because the immobile allocator -;;; VOPs are impolite (i.e. bad) and trash all registers. -;;; Since there are no callee-saved registers, this makes it legit' -;;; to put in a separate function. -#+immobile-code -(defun alloc-immobile-funinstance () - (values (%primitive alloc-immobile-fixedobj fun-pointer-lowtag 6 ; kludge - (logior (ash 5 n-widetag-bits) funcallable-instance-widetag)))) - ;; TODO: put a trampoline in all fins and allocate them anywhere. ;; Revision e7cd2bd40f5b9988 caused some FINs to go in dynamic space ;; which is fine, but those fins need to have a default bitmap of -1 instead @@ -262,7 +192,10 @@ ;; 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-funinstance)))) + (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+)) ;; Set layout prior to writing raw slots @@ -283,14 +216,13 @@ (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) - (allocate-immobile-obj (* fdefn-size n-word-bytes) + (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 - (values (%primitive alloc-immobile-fixedobj other-pointer-lowtag - fdefn-size - (logior (ash undefined-fdefn-header 16) - fdefn-widetag))))) ; word 0 + (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)) @@ -439,7 +371,7 @@ (setf (aref replacements fdefn-index) nil)))) (let ((stored-locs (if any-ambiguous (make-array fdefns-count :initial-element nil)))) - (sb-thread::with-system-mutex (sb-c::*static-linker-lock*) + (with-system-mutex (sb-c::*static-linker-lock*) (dolist (fixup fixups) (binding* ((fdefn-index (car fixup) :exit-if-null) (offset (cdr fixup)) diff -Nru sbcl-2.0.6/src/code/x86-vm.lisp sbcl-2.1.1/src/code/x86-vm.lisp --- sbcl-2.0.6/src/code/x86-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/x86-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -14,47 +14,7 @@ (defun machine-type () "Return a string describing the type of the local machine." "X86") - -;;;; :CODE-OBJECT fixups -;;; This gets called by LOAD to resolve newly positioned objects -;;; with things (like code instructions) that have to refer to them. -;;; Return T if and only if the fixup needs to be recorded in %CODE-FIXUPS -(defun fixup-code-object (code offset fixup kind flavor) - (declare (type index offset)) - (declare (ignorable flavor)) - (let* ((obj-start-addr (logandc2 (get-lisp-obj-address code) sb-vm:lowtag-mask)) - (sap (code-instructions code)) - (code-end-addr (+ (sap-int sap) (%code-code-size code)))) - (ecase kind - (:absolute - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (let ((final-val (+ fixup (sap-ref-32 sap offset)))) - (setf (sap-ref-32 sap offset) final-val) - ;; Record absolute fixups that point into CODE itself, with one - ;; exception: fixups within the range of unboxed words containing - ;; jump tables are automatically adjusted if the code moves. - (let ((n-jump-table-words - (the (unsigned-byte 16) - (get-lisp-obj-address - (code-header-ref code (code-header-words code)))))) - (and (< obj-start-addr final-val code-end-addr) - (>= offset (ash n-jump-table-words word-shift)))))) - (:relative - ;; Fixup is the actual address wanted. - ;; Replace word with value to add to that loc to get there. - (let* ((loc-sap (+ (sap-int sap) offset)) - ;; Use modular arithmetic so that if the offset - ;; doesn't fit into signed-byte-32 it'll wrap around - ;; when added to EIP - (rel-val (ldb (byte 32 0) (- fixup loc-sap n-word-bytes)))) - (declare (type (unsigned-byte 32) loc-sap rel-val)) - (setf (sap-ref-32 sap offset) rel-val)) - ;; Relative fixups point outside of this object. Keep them all. - (aver (or (< fixup obj-start-addr) (> fixup code-end-addr))) - t)))) - ;;;; low-level signal context access functions ;;;; ;;;; Note: In CMU CL, similar functions were hardwired to access diff -Nru sbcl-2.0.6/src/code/xset.lisp sbcl-2.1.1/src/code/xset.lisp --- sbcl-2.0.6/src/code/xset.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/code/xset.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -89,9 +89,11 @@ (defun xset-member-p (elt xset) (let ((data (xset-data xset))) - (if (listp data) - (member elt data :test #'eql) - (gethash elt data)))) + (if (if (listp data) + (member elt data :test #'eql) + (gethash elt data)) + t + nil))) (defun xset-members (xset) (let ((data (xset-data xset))) @@ -135,6 +137,6 @@ xset1)) t)) -#-sb-fluid (declaim (inline xset-empty-p)) +(declaim (inline xset-empty-p)) (defun xset-empty-p (xset) (not (xset-data xset))) diff -Nru sbcl-2.0.6/src/cold/chill.lisp sbcl-2.1.1/src/cold/chill.lisp --- sbcl-2.0.6/src/cold/chill.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/chill.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -46,17 +46,8 @@ (declare (ignore stream char)) (values)) ; ignore the $ as if it weren't there (compile 'read-target-float) -;;; We need the #! readtable modifications. -(load (merge-pathnames "shebang.lisp" *load-pathname*)) -;;; ... applied to the default readtable -(set-dispatch-macro-character #\# #\+ #'read-targ-feature-expr) -(set-dispatch-macro-character #\# #\- #'read-targ-feature-expr) (set-macro-character #\$ #'read-target-float t) -;;; Just in case we want to play with the initial value of -;;; backend-subfeatures -(setf sb-cold:*shebang-backend-subfeatures* sb-c:*backend-subfeatures*) - ;; Restore !DEFINE-LOAD-TIME-GLOBAL macro (setf (macro-function 'sb-int::!define-load-time-global) (macro-function 'sb-ext:define-load-time-global)) @@ -71,3 +62,9 @@ (setf (macro-function 'sb-int:/noshow) (macro-function 'sb-int:/show) (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*)))))) diff -Nru sbcl-2.0.6/src/cold/compile-cold-sbcl.lisp sbcl-2.1.1/src/cold/compile-cold-sbcl.lisp --- sbcl-2.0.6/src/cold/compile-cold-sbcl.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/compile-cold-sbcl.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -181,9 +181,10 @@ (let ((sb-xc:*compile-print* nil)) (if (make-host-2-parallelism) (funcall 'parallel-make-host-2 (make-host-2-parallelism)) - (let ((total + (let ((total-files (count-if (lambda (x) (not (find :not-target (cdr x)))) (get-stems-and-flags 2))) + (total-time 0) (n 0) (sb-xc:*compile-verbose* nil)) ;; Workaround memory exhaustion in SB-FASTEVAL. @@ -193,10 +194,16 @@ (with-math-journal (do-stems-and-flags (stem flags 2) (unless (position :not-target flags) - (format t "~&[~D/~D] ~A" (incf n) total (stem-remap-target stem)) - (target-compile-stem stem flags) - (terpri) + (format t "~&[~3D/~3D] ~40A" (incf n) total-files (stem-remap-target stem)) + (let ((start (get-internal-real-time))) + (target-compile-stem stem flags) + (let ((elapsed (/ (- (get-internal-real-time) start) + internal-time-units-per-second))) + (format t " (~f sec)~%" elapsed) + (incf total-time elapsed))) ;; The specialized array registry has file-wide scope. Hacking that aspect ;; into the xc build scaffold seemed slightly easier than hacking the ;; compiler (i.e. making the registry a slot of the fasl-output struct) - (clear-specialized-array-registry))))))))) + (clear-specialized-array-registry))) + (format t "~&~50t ~f~%" total-time)) + (sb-c::dump/restore-interesting-types 'write)))))) diff -Nru sbcl-2.0.6/src/cold/defun-load-or-cload-xcompiler.lisp sbcl-2.1.1/src/cold/defun-load-or-cload-xcompiler.lisp --- sbcl-2.0.6/src/cold/defun-load-or-cload-xcompiler.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/defun-load-or-cload-xcompiler.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -155,6 +155,7 @@ ;; Let's check that the type system, and various other things, are ;; reasonably sane. (It's easy to spend a long time wandering around ;; confused trying to debug cross-compilation if it isn't.) + (funcall 'sb-c::check-vop-existence-correctness) (let ((*readtable* *xc-readtable*) (*load-verbose* t)) (with-math-journal diff -Nru sbcl-2.0.6/src/cold/set-up-cold-packages.lisp sbcl-2.1.1/src/cold/set-up-cold-packages.lisp --- sbcl-2.0.6/src/cold/set-up-cold-packages.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/set-up-cold-packages.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -201,7 +201,101 @@ ;; "BYTE" "BYTE-POSITION" "BYTE-SIZE" "DPB" "LDB" "LDB-TEST" - "DEPOSIT-FIELD" "MASK-FIELD")) + "DEPOSIT-FIELD" "MASK-FIELD" + ;; + ;; the constants (except for T and NIL which have + ;; a specially hacked correspondence between + ;; cross-compilation host Lisp and target Lisp) + + ;; We include these here since there is no reason to reference + ;; host constants. + "ARRAY-DIMENSION-LIMIT" + "ARRAY-RANK-LIMIT" + "ARRAY-TOTAL-SIZE-LIMIT" + "BOOLE-1" + "BOOLE-2" + "BOOLE-AND" + "BOOLE-ANDC1" + "BOOLE-ANDC2" + "BOOLE-C1" + "BOOLE-C2" + "BOOLE-CLR" + "BOOLE-EQV" + "BOOLE-IOR" + "BOOLE-NAND" + "BOOLE-NOR" + "BOOLE-ORC1" + "BOOLE-ORC2" + "BOOLE-SET" + "BOOLE-XOR" + "CALL-ARGUMENTS-LIMIT" + "CHAR-CODE-LIMIT" + "DOUBLE-FLOAT-EPSILON" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" + "INTERNAL-TIME-UNITS-PER-SECOND" + "LAMBDA-LIST-KEYWORDS" + "LAMBDA-PARAMETERS-LIMIT" + "LEAST-NEGATIVE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-LONG-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" + "LEAST-NEGATIVE-SHORT-FLOAT" + "LEAST-NEGATIVE-SINGLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-FLOAT" + "LEAST-POSITIVE-LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" + "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" + "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" + "LEAST-POSITIVE-SHORT-FLOAT" + "LEAST-POSITIVE-SINGLE-FLOAT" + "LONG-FLOAT-EPSILON" + "LONG-FLOAT-NEGATIVE-EPSILON" + "MOST-NEGATIVE-DOUBLE-FLOAT" + "MOST-NEGATIVE-FIXNUM" + "MOST-NEGATIVE-LONG-FLOAT" + "MOST-NEGATIVE-SHORT-FLOAT" + "MOST-NEGATIVE-SINGLE-FLOAT" + "MOST-POSITIVE-DOUBLE-FLOAT" + "MOST-POSITIVE-FIXNUM" + "MOST-POSITIVE-LONG-FLOAT" + "MOST-POSITIVE-SHORT-FLOAT" + "MOST-POSITIVE-SINGLE-FLOAT" + "MULTIPLE-VALUES-LIMIT" + "PI" + "SHORT-FLOAT-EPSILON" + "SHORT-FLOAT-NEGATIVE-EPSILON" + "SINGLE-FLOAT-EPSILON" + "SINGLE-FLOAT-NEGATIVE-EPSILON" + + ;; The cross-compiler itself shouldn't really need to use the host + ;; versions of these in target code except in exceptional cases. + "COMPILE-FILE" + "COMPILE-FILE-PATHNAME" + "*COMPILE-FILE-PATHNAME*" + "*COMPILE-FILE-TRUENAME*" + "*COMPILE-PRINT*" + "*COMPILE-VERBOSE*" + "COMPILER-MACRO-FUNCTION" + "CONSTANTP" + "GET-SETF-EXPANSION" + "*GENSYM-COUNTER*" + "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" + "MACRO-FUNCTION" + "MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*" + "MAKE-LOAD-FORM-SAVING-SLOTS" + "SPECIAL-OPERATOR-P" + "SUBTYPEP" + "UPGRADED-ARRAY-ELEMENT-TYPE" + "UPGRADED-COMPLEX-PART-TYPE" + "WITH-COMPILATION-UNIT" + + ;; For debugging purposes, we want to be able to intercept inline + ;; and block compilation declamations in the host. + "DECLAIM" + )) ;;; A symbol in the "dual personality" list refers to the symbol in CL unless ;;; package-prefixed with SB-XC:. The main reason for not putting these @@ -253,102 +347,22 @@ (let ((package-name "SB-XC")) (dolist (name (append (append *undefineds* *dual-personality-math-symbols*))) (export (intern name package-name) package-name)) - (dolist (name '(;; the constants (except for T and NIL which have - ;; a specially hacked correspondence between - ;; cross-compilation host Lisp and target Lisp) - "ARRAY-DIMENSION-LIMIT" - "ARRAY-RANK-LIMIT" - "ARRAY-TOTAL-SIZE-LIMIT" - "BOOLE-1" - "BOOLE-2" - "BOOLE-AND" - "BOOLE-ANDC1" - "BOOLE-ANDC2" - "BOOLE-C1" - "BOOLE-C2" - "BOOLE-CLR" - "BOOLE-EQV" - "BOOLE-IOR" - "BOOLE-NAND" - "BOOLE-NOR" - "BOOLE-ORC1" - "BOOLE-ORC2" - "BOOLE-SET" - "BOOLE-XOR" - "CALL-ARGUMENTS-LIMIT" - "CHAR-CODE-LIMIT" - "DOUBLE-FLOAT-EPSILON" - "DOUBLE-FLOAT-NEGATIVE-EPSILON" - "INTERNAL-TIME-UNITS-PER-SECOND" - "LAMBDA-LIST-KEYWORDS" - "LAMBDA-PARAMETERS-LIMIT" - "LEAST-NEGATIVE-DOUBLE-FLOAT" - "LEAST-NEGATIVE-LONG-FLOAT" - "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" - "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" - "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" - "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" - "LEAST-NEGATIVE-SHORT-FLOAT" - "LEAST-NEGATIVE-SINGLE-FLOAT" - "LEAST-POSITIVE-DOUBLE-FLOAT" - "LEAST-POSITIVE-LONG-FLOAT" - "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" - "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" - "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" - "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" - "LEAST-POSITIVE-SHORT-FLOAT" - "LEAST-POSITIVE-SINGLE-FLOAT" - "LONG-FLOAT-EPSILON" - "LONG-FLOAT-NEGATIVE-EPSILON" - "MOST-NEGATIVE-DOUBLE-FLOAT" - "MOST-NEGATIVE-FIXNUM" - "MOST-NEGATIVE-LONG-FLOAT" - "MOST-NEGATIVE-SHORT-FLOAT" - "MOST-NEGATIVE-SINGLE-FLOAT" - "MOST-POSITIVE-DOUBLE-FLOAT" - "MOST-POSITIVE-FIXNUM" - "MOST-POSITIVE-LONG-FLOAT" - "MOST-POSITIVE-SHORT-FLOAT" - "MOST-POSITIVE-SINGLE-FLOAT" - "MULTIPLE-VALUES-LIMIT" - "PI" - "SHORT-FLOAT-EPSILON" - "SHORT-FLOAT-NEGATIVE-EPSILON" - "SINGLE-FLOAT-EPSILON" - "SINGLE-FLOAT-NEGATIVE-EPSILON" - "*READ-DEFAULT-FLOAT-FORMAT*" - + (dolist (name '("*READ-DEFAULT-FLOAT-FORMAT*" "ARRAY-ELEMENT-TYPE" "CHAR-CODE" "CODE-CHAR" - "COMPILE-FILE" - "COMPILE-FILE-PATHNAME" - "*COMPILE-FILE-PATHNAME*" - "*COMPILE-FILE-TRUENAME*" - "*COMPILE-PRINT*" - "*COMPILE-VERBOSE*" - "COMPILER-MACRO-FUNCTION" - "CONSTANTP" - "DEFCONSTANT" - "DEFINE-MODIFY-MACRO" - "DEFINE-SETF-EXPANDER" - "DEFMACRO" "DEFSETF" "DEFSTRUCT" "DEFTYPE" - "GENSYM" "*GENSYM-COUNTER*" - "GET-SETF-EXPANSION" - "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" - "MACRO-FUNCTION" - "MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*" + "DEFMACRO" "DEFSTRUCT" "DEFTYPE" + "GENSYM" "MAKE-ARRAY" "MAKE-LOAD-FORM" - "MAKE-LOAD-FORM-SAVING-SLOTS" "PROCLAIM" "SIMPLE-VECTOR" - "SPECIAL-OPERATOR-P" - "SUBTYPEP" "TYPE-OF" "TYPEP" - "UPGRADED-ARRAY-ELEMENT-TYPE" - "UPGRADED-COMPLEX-PART-TYPE" - "WITH-COMPILATION-UNIT")) + + "DEFCLASS" + "DEFGENERIC" + "DEFMETHOD" + )) (export (intern name package-name) package-name))) (defun count-symbols (pkg) @@ -359,7 +373,7 @@ ;;; Build a new package that exports a not-necessarily-strict subset of ;;; what the host CL exports. This deals with hosts that have too many -;;; symbols exported froM CL. +;;; symbols exported from CL. (let ((cl-model-package (make-package "XC-STRICT-CL" :use nil))) (flet ((new-external (x package &aux (s (intern x package))) (export s package) @@ -469,8 +483,8 @@ (reexport x)) (assert (= (length done) (length package-data-list))))))) -(export '*undefined-fun-whitelist*) -(defvar *undefined-fun-whitelist* (make-hash-table :test 'equal)) +(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")) ;; There's no need to use the precautionary READ-FROM-FILE function @@ -478,7 +492,7 @@ (create-target-packages (let ((*readtable* *xc-readtable*)) (read data))) (let ((*readtable* *xc-readtable*)) (read data))))) (dolist (name (apply #'append list)) - (setf (gethash name *undefined-fun-whitelist*) t))) + (setf (gethash name *undefined-fun-allowlist*) t))) (defvar *asm-package-use-list* '("SB-ASSEM" "SB-DISASSEM" diff -Nru sbcl-2.0.6/src/cold/shared.lisp sbcl-2.1.1/src/cold/shared.lisp --- sbcl-2.0.6/src/cold/shared.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/shared.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -197,10 +197,10 @@ (unuse-package ext "CL-USER"))) #+cmu -(setq *compile-print* nil) ; too much noise, can't see the actual warnings +(setq cl:*compile-print* nil) ; too much noise, can't see the actual warnings #+sbcl (progn - (setq *compile-print* nil) + (setq cl:*compile-print* nil) (load "src/cold/muffler.lisp") ;; Let's just say we never care to see these. (declaim (sb-ext:muffle-conditions @@ -213,6 +213,15 @@ (load "src/cold/shebang.lisp") +(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))) + ;;; When cross-compiling, the *FEATURES* set for the target Lisp is ;;; not in general the same as the *FEATURES* set for the host Lisp. ;;; In order to refer to target features specifically, we refer to @@ -243,6 +252,13 @@ (gc (find-if (lambda (x) (member x '(:cheneygc :gencgc))) target-feature-list)) (arch (target-platform-keyword target-feature-list))) + ;; 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)) ;; 0xCE is a perfectly good 32-bit instruction, @@ -254,6 +270,9 @@ (setq target-feature-list (remove :int4-breakpoints target-feature-list)) (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)) ;; 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. @@ -263,15 +282,6 @@ (remove arch (remove gc target-feature-list))) #'string<)))) -(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))) - ;;; Call for effect of signaling an error if no target picked. (target-platform-keyword) @@ -287,11 +297,17 @@ (let ((feature-compatibility-tests '(("(and sb-thread (not gencgc))" ":SB-THREAD requires :GENCGC") + ("(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 gencgc cheneygc)" ":GENCGC and :CHENEYGC are incompatible") - ("(and cheneygc (not (or alpha arm arm64 hppa mips ppc riscv sparc)))" + ("(and cheneygc (not (or arm arm64 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") @@ -320,6 +336,8 @@ ":IMMOBILE-CODE requires :IMMOBILE-SPACE feature") ("(and immobile-symbols (not immobile-space))" ":IMMOBILE-SYMBOLS requires :IMMOBILE-SPACE feature") + ("(and sb-futex (not sb-thread))" + "Can't enable SB-FUTEX on platforms lacking thread support") ;; There is still hope to make multithreading on DragonFly x86-64 ("(and sb-thread x86 dragonfly)" ":SB-THREAD not supported on selected architecture"))) @@ -330,7 +348,7 @@ (push (second test) failed-test-descriptions)))) (when failed-test-descriptions (error "Feature compatibility check failed, ~S" - failed-test-descriptions))) + (reverse failed-test-descriptions)))) ;;;; cold-init-related PACKAGE and SYMBOL tools @@ -529,7 +547,18 @@ (if *compile-for-effect-only* "-scratch" "-tmp"))) (compile-file (ecase mode - (:host-compile #'compile-file) + (:host-compile + #+ccl + (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) (:target-compile (if (find :assem flags) *target-assemble-file* *target-compile-file*)))) @@ -538,7 +567,7 @@ (ignore-failure-p (find :ignore-failure-p flags))) (declare (type function compile-file)) - (ensure-directories-exist obj :verbose *compile-print*) ; host's value + (ensure-directories-exist obj :verbose cl:*compile-print*) ; host's value ;; We're about to set about building a new object file. First, we ;; delete any preexisting object file in order to avoid confusing diff -Nru sbcl-2.0.6/src/cold/shebang.lisp sbcl-2.1.1/src/cold/shebang.lisp --- sbcl-2.0.6/src/cold/shebang.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/shebang.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -25,7 +25,7 @@ (defvar sb-xc:*features*) (defun target-platform-keyword (&optional (features sb-xc:*features*)) - (let ((arch (intersection '(:alpha :arm :arm64 :hppa :mips :ppc :ppc64 :riscv :sparc :x86 :x86-64) + (let ((arch (intersection '(:arm :arm64 :mips :ppc :ppc64 :riscv :sparc :x86 :x86-64) features))) (cond ((not arch) (error "No architecture selected")) ((> (length arch) 1) (error "More than one architecture selected"))) @@ -42,80 +42,23 @@ (defun backend-asm-package-name () (concatenate 'string "SB-" (string (backend-assembler-target-name)) "-ASM")) -(defun any-vop-named-p (vop-name) - (let ((ht (symbol-value (find-symbol "*BACKEND-PARSED-VOPS*" "SB-C")))) - (not (null (gethash vop-name ht))))) - -(defun any-vop-translates-p (fun-name) - (let ((f (intern "INFO" "SB-INT"))) - (when (fboundp f) - (let ((info (funcall f :function :info fun-name))) - (if info - (let ((f (intern "FUN-INFO-TEMPLATES" "SB-C"))) - (and (fboundp f) (not (null (funcall f info)))))))))) - -(defvar *feature-eval-results-file* "output/feature-tests.lisp-expr") -(defvar *feature-evaluation-results*) - -(defun recording-feature-eval (expression value) - ;; This safety check does not work for parallel build, but that produces - ;; different code anyway due to missing derived types in any file that would - ;; have been compiled in the serial order but was interpreted instead. - (when (boundp '*feature-evaluation-results*) - ; (format t "~&FEATURE EXPR: ~S -> ~S~%" expression value) - (push (cons expression value) *feature-evaluation-results*)) - value) - -(defun write-feature-eval-results () - (with-open-file (f *feature-eval-results-file* - :direction :output - :if-exists :supersede :if-does-not-exist :create) - (let ((*print-readably* t)) - (format f "(~{~S~^~% ~})~%" *feature-evaluation-results*)))) - -(defun sanity-check-feature-evaluation () - (flet ((check (phase list) - (dolist (x list) - (let ((answer - (ecase (caar x) - (:vop-named (any-vop-named-p (cadar x))) - (:vop-translates (any-vop-translates-p (cadar x)))))) - (unless (eq answer (cdr x)) - (error "make-host-~D DEFINE-VOP ordering bug:~@ - ~S should be ~S, was ~S at xc time" phase x answer (cdr x))))))) - (check 1 (with-open-file (f *feature-eval-results-file*) (read f))) - (check 2 *feature-evaluation-results*))) - ;;; We should never call this with a selector of :HOST any more, ;;; but I'm keeping it in case of emergency. -(defun feature-in-list-p (feature selector - &aux (list (ecase selector - (:host cl:*features*) - (:target sb-xc:*features*)))) +;;; SB-XC:*FEATURES* might not be bound yet when computing derived features. +(defun featurep (feature &optional (list sb-xc:*features*)) (etypecase feature (symbol - (if (and (string= feature "SBCL") (eq selector :target)) + (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) - (feature-in-list-p subfeature selector))) + (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)))) - ((:vop-named :vop-translates) - (when (eq selector :host) - (error "Invalid host feature test: ~S" feature)) - (destructuring-bind (subexpr) (cdr feature) - (case (first feature) - (:vop-named - (recording-feature-eval feature - (any-vop-named-p subexpr))) - (:vop-translates - (recording-feature-eval - feature (any-vop-translates-p subexpr))))))))))) -(compile 'feature-in-list-p) + (not (subfeature-in-list-p subexpr))))))))) +(compile 'featurep) (defun read-targ-feature-expr (stream sub-character infix-parameter) (when infix-parameter @@ -123,7 +66,7 @@ (if (char= (if (let* ((*package* (find-package "KEYWORD")) (*read-suppress* nil) (feature (read stream t nil t))) - (feature-in-list-p feature :target)) + (featurep feature)) #\+ #\-) sub-character) (read stream t nil t) diff -Nru sbcl-2.0.6/src/cold/slam.lisp sbcl-2.1.1/src/cold/slam.lisp --- sbcl-2.0.6/src/cold/slam.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/slam.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -76,7 +76,7 @@ (target-compile-stem stem flags))))) (when (and (eq (car sb-thread::*thread-local-specials*) :not-final) - (not (equal (cdr sb-thread::*thread-local-specials*) + (not (equal (cdr sb-thread::*thread-local-specials*) *original-thread-local-specials*))) (sb-int:style-warn "Detected modified thread-local-specials. Slam may not have recompiled everything as required.")) diff -Nru sbcl-2.0.6/src/cold/snapshot.lisp sbcl-2.1.1/src/cold/snapshot.lisp --- sbcl-2.0.6/src/cold/snapshot.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/snapshot.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -108,6 +108,7 @@ / // /// + ++ +++ - + *break-on-signals* *gensym-counter* ;; These are bound when compiling and/or loading: *package* diff -Nru sbcl-2.0.6/src/cold/warm.lisp sbcl-2.1.1/src/cold/warm.lisp --- sbcl-2.0.6/src/cold/warm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/cold/warm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -13,6 +13,18 @@ ;;;; general warm init compilation policy +;;; First things first, bootstrap the WARNING handler. +sb-kernel:: +(setq **initial-handler-clusters** + `(((,(find-classoid-cell 'warning) . + ,(named-lambda "MAYBE-MUFFLE" (warning) + (when (muffle-warning-p warning) + (muffle-warning warning)))) + (,(find-classoid-cell 'step-condition) . sb-impl::invoke-stepper)))) +;;;; And now a trick: splice those into the oldest *HANDLER-CLUSTERS* +;;;; which had a placeholder NIL reserved for this purpose. +sb-kernel::(rplaca (last *handler-clusters*) (car **initial-handler-clusters**)) + ;;;; Use the same settings as PROCLAIM-TARGET-OPTIMIZATION ;;;; I could not think of a trivial way to ensure that this stays functionally ;;;; identical to the corresponding code in 'compile-cold-sbcl'. @@ -145,9 +157,20 @@ retry-compile-file (multiple-value-bind (output-truename warnings-p failure-p) (ecase (if (boundp '*compile-files-p*) *compile-files-p* t) - ((t) (let ((sb-c::*source-namestring* fullname)) - (ensure-directories-exist output) - (compile-file stem :output-file output))) + ((t) + (let ((sb-c::*source-namestring* fullname) + (sb-ext:*derive-function-types* + (unless (search "/pcl/" stem) + t))) + (ensure-directories-exist output) + ;; Like PROCLAIM-TARGET-OPTIMIZATION in 'compile-cold-sbcl' + ;; We should probably stash a copy of the POLICY instance from + ;; make-host-2 in a global var and apply it here. + (proclaim '(optimize + (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))) ((nil) output)) (cond ((not output-truename) (error "COMPILE-FILE of ~S failed." stem)) @@ -180,7 +203,7 @@ (error "LOAD of ~S failed." output-truename)) (sb-int:/show "done loading" output-truename)))))))) - (let ((*compile-print* nil)) + (let ((cl:*compile-print* nil)) (dolist (group sources) (handler-bind ((#+x86-64 warning #-x86-64 simple-warning (lambda (c) @@ -190,8 +213,18 @@ (search "undefined variable" (write-to-string c :escape nil))) (cerror "Finish warm compile ignoring the problem" c))))) - (with-compilation-unit () (do-srcs group))))))) + (with-compilation-unit () + (do-srcs group) + ;; I do not know why #+sb-show gets several "undefined-type CLASS" warnings + ;; that #-sb-show doesn't. And CLASS is a reserved name not defined as yet, + ;; so we have to pretend that didn't happen, otherwise the warning about + ;; not being able to define CLASS as a type name breaks the build. + #+sb-show + (setq sb-c::*undefined-warnings* + (delete 'class sb-c::*undefined-warnings* + :key #'sb-c::undefined-warning-name)))))))) +(sb-c::dump/restore-interesting-types 'write) (when (hash-table-p sb-c::*static-vop-usage-counts*) (with-open-file (output "output/warm-vop-usage.txt" :direction :output :if-exists :supersede) diff -Nru sbcl-2.0.6/src/compiler/aliencomp.lisp sbcl-2.1.1/src/compiler/aliencomp.lisp --- sbcl-2.0.6/src/compiler/aliencomp.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/aliencomp.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -710,7 +710,7 @@ (reference-tn-list (remove-if-not #'tn-p (flatten-list arg-tns)) nil)) (result-operands (reference-tn-list (remove-if-not #'tn-p result-tns) t))) - (cond #+(vop-named sb-vm::call-out-named) + (cond #+#.(cl:if (sb-c::vop-existsp :named sb-vm::call-out-named) '(and) '(or)) ((and (constant-lvar-p function) (stringp (lvar-value function))) (vop* call-out-named call block (arg-operands) (result-operands) (lvar-value function) diff -Nru sbcl-2.0.6/src/compiler/alpha/alloc.lisp sbcl-2.1.1/src/compiler/alpha/alloc.lisp --- sbcl-2.0.6/src/compiler/alpha/alloc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/alloc.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,182 +0,0 @@ -;;;; allocation VOPs for the Alpha port - -;;;; 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") - -;;;; LIST and LIST* -(define-vop (list-or-list*) - (:args (things :more t)) - (:temporary (:scs (descriptor-reg)) ptr) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) - res) - (:info num) - (:results (result :scs (descriptor-reg))) - (:variant-vars star) - (:policy :safe) - (:node-var node) - (:generator 0 - (cond ((zerop num) - (move null-tn result)) - ((and star (= num 1)) - (move (tn-ref-tn things) result)) - (t - (macrolet - ((store-car (tn list &optional (slot cons-car-slot)) - `(let ((reg - (sc-case ,tn - ((any-reg descriptor-reg) ,tn) - (zero zero-tn) - (null null-tn) - (control-stack - (load-stack-tn temp ,tn) - temp)))) - (storew reg ,list ,slot list-pointer-lowtag)))) - (let* ((dx-p (node-stack-allocate-p node)) - (cons-cells (if star (1- num) num)) - (space (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (:extra (if dx-p 0 space)) - (cond (dx-p - (align-csp res) - (inst bis csp-tn list-pointer-lowtag res) - (inst lda csp-tn space csp-tn)) - (t - (inst bis alloc-tn list-pointer-lowtag res))) - (move res ptr) - (dotimes (i (1- cons-cells)) - (store-car (tn-ref-tn things) ptr) - (setf things (tn-ref-across things)) - (inst lda ptr (pad-data-block cons-size) ptr) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-lowtag)) - (store-car (tn-ref-tn things) ptr) - (cond (star - (setf things (tn-ref-across things)) - (store-car (tn-ref-tn things) ptr cons-cdr-slot)) - (t - (storew null-tn ptr - cons-cdr-slot list-pointer-lowtag))) - (aver (null (tn-ref-across things))) - (move res result)))))))) - -(define-vop (list list-or-list*) - (:variant nil)) - -(define-vop (list* list-or-list*) - (:variant t)) - -;;;; special purpose inline allocators - -(define-vop (make-fdefn) - (:policy :fast-safe) - (:translate make-fdefn) - (:args (name :scs (descriptor-reg) :to :eval)) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg) :from :argument)) - (:generator 37 - (with-fixed-allocation (result temp fdefn-widetag fdefn-size) - (storew name result fdefn-name-slot other-pointer-lowtag) - (storew null-tn result fdefn-fun-slot other-pointer-lowtag) - (inst li (make-fixup 'undefined-tramp :assembly-routine) temp) - (storew temp result fdefn-raw-addr-slot other-pointer-lowtag)))) - -(define-vop (make-closure) - (:args (function :to :save :scs (descriptor-reg))) - (:info label length stack-allocate-p) - (:ignore label) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 10 - (let* ((size (+ length closure-info-offset)) - (alloc-size (pad-data-block size))) - (inst li - (logior (ash (1- size) n-widetag-bits) closure-widetag) - temp) - (pseudo-atomic (:extra (if stack-allocate-p 0 alloc-size)) - (cond (stack-allocate-p - (align-csp result) - (inst bis csp-tn fun-pointer-lowtag result) - (inst lda csp-tn alloc-size csp-tn)) - (t - (inst bis alloc-tn fun-pointer-lowtag result))) - (storew temp result 0 fun-pointer-lowtag) - (storew function result closure-fun-slot fun-pointer-lowtag))))) - -;;; The compiler likes to be able to directly make value cells. -(define-vop (make-value-cell) - (:args (value :to :save :scs (descriptor-reg any-reg null zero))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:info stack-allocate-p) - (:ignore stack-allocate-p) - (:results (result :scs (descriptor-reg))) - (:generator 10 - (with-fixed-allocation - (result temp value-cell-widetag value-cell-size) - (storew value result value-cell-value-slot other-pointer-lowtag)))) - -;;;; automatic allocators for primitive objects - -(define-vop (make-unbound-marker) - (:args) - (:results (result :scs (descriptor-reg any-reg))) - (:generator 1 - (inst li unbound-marker-widetag result))) - -(define-vop (make-funcallable-instance-tramp) - (:args) - (:results (result :scs (any-reg))) - (:generator 1 - (inst li (make-fixup 'funcallable-instance-tramp :assembly-routine) result))) - -(define-vop (fixed-alloc) - (:args) - (:info name words type lowtag stack-allocate-p) - (:ignore name) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 4 - (pseudo-atomic (:extra (if stack-allocate-p - 0 - (pad-data-block words))) - (cond (stack-allocate-p - (align-csp result) - (inst bis csp-tn lowtag result) - (inst addq csp-tn (pad-data-block words) csp-tn)) - (t - (inst bis alloc-tn lowtag result))) - (when type - (inst li (logior (ash (1- words) (length-field-shift type)) type) temp) - (storew temp result 0 lowtag))))) - -(define-vop (var-alloc) - (:args (extra :scs (any-reg))) - (:arg-types positive-fixnum) - (:info name words type lowtag stack-allocate-p) - (:ignore name stack-allocate-p) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) header) - (:temporary (:scs (non-descriptor-reg)) bytes) - (:generator 6 - (inst lda bytes (* (1+ words) n-word-bytes) extra) - (inst sll bytes (- (length-field-shift type) 2) header) - ;; The specified EXTRA value is the exact value placed in the header - ;; as the word count when allocating code. - (cond ((= type code-header-widetag) - (inst lda header type header)) - (t - (inst lda header (+ (ash -2 (length-field-shift type)) type) header) - (inst srl bytes n-lowtag-bits bytes) - (inst sll bytes n-lowtag-bits bytes))) - (pseudo-atomic () - (inst bis alloc-tn lowtag result) - (storew header result 0 lowtag) - (inst addq alloc-tn bytes alloc-tn)))) diff -Nru sbcl-2.0.6/src/compiler/alpha/arith.lisp sbcl-2.1.1/src/compiler/alpha/arith.lisp --- sbcl-2.0.6/src/compiler/alpha/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/arith.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,823 +0,0 @@ -;;;; the VM definition arithmetic VOPs for the Alpha - -;;;; 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") - -;;;; unary operations - -(define-vop (fixnum-unop) - (:args (x :scs (any-reg))) - (:results (res :scs (any-reg))) - (:note "inline fixnum arithmetic") - (:arg-types tagged-num) - (:result-types tagged-num) - (:policy :fast-safe)) - -(define-vop (signed-unop) - (:args (x :scs (signed-reg))) - (:results (res :scs (signed-reg))) - (:note "inline (signed-byte 64) arithmetic") - (:arg-types signed-num) - (:result-types signed-num) - (:policy :fast-safe)) - -(define-vop (fast-negate/fixnum fixnum-unop) - (:translate %negate) - (:generator 1 - (inst subq zero-tn x res))) - -(define-vop (fast-negate/signed signed-unop) - (:translate %negate) - (:generator 2 - (inst subq zero-tn x res))) - -(define-vop (fast-lognot/fixnum fixnum-unop) - (:translate lognot) - (:generator 1 - (inst eqv x fixnum-tag-mask res))) - -(define-vop (fast-lognot/signed signed-unop) - (:translate lognot) - (:generator 2 - (inst not x res))) - -;;;; binary fixnum operations - -;;; Assume that any constant operand is the second arg... - -(define-vop (fast-fixnum-binop) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:results (r :scs (any-reg))) - (:result-types tagged-num) - (:note "inline fixnum arithmetic") - (:policy :fast-safe)) - -(define-vop (fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:note "inline (unsigned-byte 64) arithmetic") - (:policy :fast-safe)) - -(define-vop (fast-signed-binop) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:results (r :scs (signed-reg))) - (:result-types signed-num) - (:note "inline (signed-byte 64) arithmetic") - (:policy :fast-safe)) - -(define-vop (fast-fixnum-c-binop fast-fixnum-binop) - (:args (x :target r :scs (any-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(define-vop (fast-signed-c-binop fast-signed-binop) - (:args (x :target r :scs (signed-reg))) - (:info y) - (:arg-types signed-num (:constant integer))) - -(define-vop (fast-unsigned-c-binop fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg))) - (:info y) - (:arg-types unsigned-num (:constant integer))) - -(defmacro define-binop (translate cost untagged-cost op - tagged-type untagged-type - &optional arg-swap restore-fixnum-mask) - `(progn - (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") - fast-fixnum-binop) - ,@(when restore-fixnum-mask - `((:temporary (:sc non-descriptor-reg) temp))) - (:args (x ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg)) - (y ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg))) - (:translate ,translate) - (:generator ,(1+ cost) - ,(if arg-swap - `(inst ,op y x ,(if restore-fixnum-mask 'temp 'r)) - `(inst ,op x y ,(if restore-fixnum-mask 'temp 'r))) - ,@(when restore-fixnum-mask - `((inst bic temp #.(ash lowtag-mask -1) r))))) - (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") - fast-signed-binop) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:translate ,translate) - (:generator ,(1+ untagged-cost) - ,(if arg-swap - `(inst ,op y x r) - `(inst ,op x y r)))) - (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") - fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) - (:translate ,translate) - (:generator ,(1+ untagged-cost) - ,(if arg-swap - `(inst ,op y x r) - `(inst ,op x y r)))) - ,@(when (and tagged-type (not arg-swap)) - `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") - fast-fixnum-c-binop) - (:args (x ,@(unless restore-fixnum-mask `(:target r)) - :scs (any-reg))) - (:arg-types tagged-num (:constant ,tagged-type)) - ,@(when restore-fixnum-mask - `((:temporary (:sc non-descriptor-reg) temp))) - (:translate ,translate) - (:generator ,cost - (inst ,op x (fixnumize y) ,(if restore-fixnum-mask 'temp 'r)) - ,@(when restore-fixnum-mask - `((inst bic temp #.(ash lowtag-mask -1) r))))))) - ,@(when (and untagged-type (not arg-swap)) - `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") - fast-signed-c-binop) - (:arg-types signed-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - (inst ,op x y r))) - (define-vop (,(symbolicate "FAST-" translate - "-C/UNSIGNED=>UNSIGNED") - fast-unsigned-c-binop) - (:arg-types unsigned-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - (inst ,op x y r))))))) - -(define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8)) -(define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8)) -(define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8)) -(define-binop logandc1 1 3 bic (unsigned-byte 6) (unsigned-byte 8) t) -(define-binop logandc2 1 3 bic (unsigned-byte 6) (unsigned-byte 8)) -(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8)) -(define-binop logorc1 1 3 ornot (unsigned-byte 6) (unsigned-byte 8) t t) -(define-binop logorc2 1 3 ornot (unsigned-byte 6) (unsigned-byte 8) nil t) -(define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8)) -(define-binop logeqv 1 3 eqv (unsigned-byte 6) (unsigned-byte 8) nil t) - -;;; special cases for LOGAND where we can use a mask operation -(define-vop (fast-logand-c-mask/unsigned=>unsigned fast-unsigned-c-binop) - (:translate logand) - (:arg-types unsigned-num - (:constant (or (integer #xffffffff #xffffffff) - (integer #xffffffff00000000 #xffffffff00000000)))) - (:generator 1 - (ecase y - (#xffffffff (inst mskll x 4 r)) - (#xffffffff00000000 (inst mskll x 0 r))))) - -;;;; shifting - -(define-vop (fast-ash/unsigned=>unsigned) - (:note "inline ASH") - (:args (number :scs (unsigned-reg) :to :save) - (amount :scs (signed-reg))) - (:arg-types unsigned-num signed-num) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate ash) - (:policy :fast-safe) - (:temporary (:sc non-descriptor-reg) ndesc) - (:temporary (:sc non-descriptor-reg) temp) - (:generator 3 - (inst bge amount positive) - (inst subq zero-tn amount ndesc) - (inst cmplt ndesc 64 temp) - (inst srl number ndesc result) - ;; FIXME: this looks like a candidate for a conditional move -- - ;; CSR, 2003-09-10 - (inst bne temp done) - (move zero-tn result) - (inst br zero-tn done) - - POSITIVE - (inst sll number amount result) - - DONE)) - -(define-vop (fast-ash/signed=>signed) - (:note "inline ASH") - (:args (number :scs (signed-reg) :to :save) - (amount :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:results (result :scs (signed-reg))) - (:result-types signed-num) - (:translate ash) - (:policy :fast-safe) - (:temporary (:sc non-descriptor-reg) ndesc) - (:temporary (:sc non-descriptor-reg) temp) - (:generator 3 - (inst bge amount positive) - (inst subq zero-tn amount ndesc) - (inst cmplt ndesc 63 temp) - (inst sra number ndesc result) - (inst bne temp done) - (inst sra number 63 result) - (inst br zero-tn done) - - POSITIVE - (inst sll number amount result) - - DONE)) - -(define-vop (fast-ash-c/signed=>signed) - (:policy :fast-safe) - (:translate ash) - (:note nil) - (:args (number :scs (signed-reg))) - (:info count) - (:arg-types signed-num (:constant integer)) - (:results (result :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (cond - ((< count 0) (inst sra number (min 63 (- count)) result)) - ((> count 0) (inst sll number (min 63 count) result)) - (t (bug "identity ASH not transformed away"))))) - -(define-vop (fast-ash-c/unsigned=>unsigned) - (:policy :fast-safe) - (:translate ash) - (:note nil) - (:args (number :scs (unsigned-reg))) - (:info count) - (:arg-types unsigned-num (:constant integer)) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (cond - ((< count -63) (move zero-tn result)) - ((< count 0) (inst sra number (- count) result)) - ((> count 0) (inst sll number (min 63 count) result)) - (t (bug "identity ASH not transformed away"))))) - -(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 immediate))) - (:arg-types ,type positive-fixnum) - (:results (result :scs (,result-type))) - (:result-types ,type) - (:policy :fast-safe) - (:generator ,cost - (sc-case amount - ((signed-reg unsigned-reg) - (inst sll number amount result)) - (immediate - (let ((amount (tn-value amount))) - (aver (> amount 0)) - (inst sll number amount result)))))))) - (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)) - -(define-vop (signed-byte-64-len) - (:translate integer-length) - (:note "inline (signed-byte 64) integer-length") - (:policy :fast-safe) - (:args (arg :scs (signed-reg) :to (:argument 1))) - (:arg-types signed-num) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) - (:generator 30 - (inst not arg shift) - (inst cmovge arg arg shift) - (inst subq zero-tn (fixnumize 1) res) - (inst sll shift 1 shift) - LOOP - (inst addq res (fixnumize 1) res) - (inst srl shift 1 shift) - (inst bne shift loop))) - -(define-vop (unsigned-byte-64-count) - (:translate logcount) - (:note "inline (unsigned-byte 64) logcount") - (:policy :fast-safe) - (:args (arg :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:guard (member :cix *backend-subfeatures*)) - (:generator 1 - (inst ctpop zero-tn arg res))) - -(define-vop (unsigned-byte-64-count) - (:translate logcount) - (:note "inline (unsigned-byte 64) logcount") - (:policy :fast-safe) - (:args (arg :scs (unsigned-reg) :target num)) - (:arg-types unsigned-num) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) - :target res) num) - (:temporary (:scs (non-descriptor-reg)) mask temp) - (:generator 60 - ;; FIXME: now this looks expensive, what with these 64bit loads. - ;; Maybe a loop and count would be faster? -- CSR, 2003-09-10 - (inst li #x5555555555555555 mask) - (inst srl arg 1 temp) - (inst and arg mask num) - (inst and temp mask temp) - (inst addq num temp num) - (inst li #x3333333333333333 mask) - (inst srl num 2 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst addq num temp num) - (inst li #x0f0f0f0f0f0f0f0f mask) - (inst srl num 4 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst addq num temp num) - (inst li #x00ff00ff00ff00ff mask) - (inst srl num 8 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst addq num temp num) - (inst li #x0000ffff0000ffff mask) - (inst srl num 16 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst addq num temp num) - (inst li #x00000000ffffffff mask) - (inst srl num 32 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst addq num temp res))) - -;;;; multiplying - -(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:translate *) - (:generator 4 - (inst sra y n-fixnum-tag-bits temp) - (inst mulq x temp r))) - -(define-vop (fast-*/signed=>signed fast-signed-binop) - (:translate *) - (:generator 3 - (inst mulq x y r))) - -(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop) - (:translate *) - (:generator 3 - (inst mulq x y r))) - -;;;; Modular functions: -(define-modular-fun lognot-mod64 (x) lognot :untagged nil 64) -(define-vop (lognot-mod64/unsigned=>unsigned) - (:translate lognot-mod64) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (res :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe) - (:generator 1 - (inst not x res))) - -(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned - fast-ash-c/unsigned=>unsigned) - (:translate ash-left-mod64)) -(define-vop (fast-ash-left-mod64/unsigned=>unsigned - fast-ash-left/unsigned=>unsigned)) -(deftransform ash-left-mod64 ((integer count) - ((unsigned-byte 64) (unsigned-byte 6))) - (when (sb-c::constant-lvar-p count) - (sb-c::give-up-ir1-transform)) - '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count)) - -(macrolet - ((define-modular-backend (fun &optional constantp) - (let ((mfun-name (symbolicate fun '-mod64)) - (modvop (symbolicate 'fast- fun '-mod64/unsigned=>unsigned)) - (modcvop (symbolicate 'fast- fun '-mod64-c/unsigned=>unsigned)) - (vop (symbolicate 'fast- fun '/unsigned=>unsigned)) - (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned))) - `(progn - (define-modular-fun ,mfun-name (x y) ,fun :untagged nil 64) - (define-vop (,modvop ,vop) - (:translate ,mfun-name)) - ,@(when constantp - `((define-vop (,modcvop ,cvop) - (:translate ,mfun-name)))))))) - (define-modular-backend + t) - (define-modular-backend - t) - (define-modular-backend logeqv t) - (define-modular-backend logandc1) - (define-modular-backend logandc2 t) - (define-modular-backend logorc1) - (define-modular-backend logorc2 t)) - -(define-source-transform lognand (x y) - `(lognot (logand ,x ,y))) -(define-source-transform lognor (x y) - `(lognot (logior ,x ,y))) - -;;;; binary conditional VOPs - -(define-vop (fast-conditional) - (:conditional) - (:info target not-p) - (:temporary (:scs (non-descriptor-reg)) temp) - (:policy :fast-safe)) - -(define-vop (fast-conditional/fixnum fast-conditional) - (:args (x :scs (any-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison")) - -(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg))) - (:arg-types tagged-num (:constant (unsigned-byte-with-a-bite-out 6 4))) - (:info target not-p y)) - -(define-vop (fast-conditional/signed fast-conditional) - (:args (x :scs (signed-reg)) - (y :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:note "inline (signed-byte 64) comparison")) - -(define-vop (fast-conditional-c/signed fast-conditional/signed) - (:args (x :scs (signed-reg))) - (:arg-types signed-num (:constant (unsigned-byte-with-a-bite-out 8 1))) - (:info target not-p y)) - -(define-vop (fast-conditional/unsigned fast-conditional) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:note "inline (unsigned-byte 64) comparison")) - -(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num (:constant (unsigned-byte-with-a-bite-out 8 1))) - (:info target not-p y)) - - -(defmacro define-conditional-vop (translate &rest generator) - `(progn - ,@(mapcar (lambda (suffix cost signed) - (unless (and (member suffix '(/fixnum -c/fixnum)) - (eq translate 'eql)) - `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" - translate suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,translate) - (:generator ,cost - (let* ((signed ,signed) - (-c/fixnum ,(eq suffix '-c/fixnum)) - (y (if -c/fixnum (fixnumize y) y))) - ,@generator))))) - '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - '(3 2 5 4 5 4) - '(t t t t nil nil)))) - -(define-conditional-vop < - (cond ((and signed (eql y 0)) - (if not-p - (inst bge x target) - (inst blt x target))) - (t - (if signed - (inst cmplt x y temp) - (inst cmpult x y temp)) - (if not-p - (inst beq temp target) - (inst bne temp target))))) - -(define-conditional-vop > - (cond ((and signed (eql y 0)) - (if not-p - (inst ble x target) - (inst bgt x target))) - ((integerp y) - (let ((y (+ y (if -c/fixnum (fixnumize 1) 1)))) - (if signed - (inst cmplt x y temp) - (inst cmpult x y temp)) - (if not-p - (inst bne temp target) - (inst beq temp target)))) - (t - (if signed - (inst cmplt y x temp) - (inst cmpult y x temp)) - (if not-p - (inst beq temp target) - (inst bne temp target))))) - -;;; EQL/FIXNUM is funny because the first arg can be of any type, not -;;; just a known fixnum. - -(define-conditional-vop eql - (declare (ignore signed)) - (when (integerp y) - (inst li y temp) - (setf y temp)) - (inst cmpeq x y temp) - (if not-p - (inst beq temp target) - (inst bne temp target))) - -;;; These versions specify a fixnum restriction on their first arg. We -;;; have also generic-eql/fixnum VOPs which are the same, but have no -;;; restriction on the first arg and a higher cost. The reason for -;;; doing this is to prevent fixnum specific operations from being -;;; used on word integers, spuriously consing the argument. -(define-vop (fast-eql/fixnum fast-conditional) - (:args (x :scs (any-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison") - (:translate eql) - (:generator 3 - (cond ((equal y zero-tn) - (if not-p - (inst bne x target) - (inst beq x target))) - (t - (inst cmpeq x y temp) - (if not-p - (inst beq temp target) - (inst bne temp target)))))) - -;;; -(define-vop (generic-eql/fixnum fast-eql/fixnum) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg))) - (:arg-types * tagged-num) - (:variant-cost 7)) - -(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg))) - (:arg-types tagged-num (:constant (signed-byte 6))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:info target not-p y) - (:translate eql) - (:generator 2 - (let ((y (cond ((eql y 0) zero-tn) - (t - (inst li (fixnumize y) temp) - temp)))) - (inst cmpeq x y temp) - (if not-p - (inst beq temp target) - (inst bne temp target))))) -;;; -(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:arg-types * (:constant (signed-byte 6))) - (:variant-cost 6)) - - -;;;; 32-bit logical operations - -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:temporary (:sc non-descriptor-reg) temp) - (:generator 1 - (inst and amount #x1f temp) - (inst srl num temp r))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:temporary (:sc non-descriptor-reg) temp) - (:generator 1 - (inst and amount #x1f temp) - (inst sll num temp r))) - -;;;; bignum stuff - -(define-vop (bignum-length get-header-data) - (:translate sb-bignum:%bignum-length) - (:policy :fast-safe)) - -(define-vop (bignum-set-length set-header-data) - (:translate sb-bignum:%bignum-set-length) - (:policy :fast-safe)) - -(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag - (unsigned-reg) unsigned-num sb-bignum:%bignum-ref) - -(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag - (unsigned-reg) unsigned-num sb-bignum:%bignum-set #+gengc nil) - -(define-vop (digit-0-or-plus) - (:translate sb-bignum:%digit-0-or-plusp) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:temporary (:sc non-descriptor-reg) temp) - (:conditional) - (:info target not-p) - (:generator 2 - (inst sll digit 32 temp) - (if not-p - (inst blt temp target) - (inst bge temp target)))) - -(define-vop (add-w/carry) - (:translate sb-bignum:%add-with-carry) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg) :from :load) - (carry :scs (unsigned-reg) :from :eval)) - (:result-types unsigned-num positive-fixnum) - (:generator 5 - (inst addq a b result) - (inst addq result c result) - (inst sra result 32 carry) - (inst mskll result 4 result))) - -(define-vop (sub-w/borrow) - (:translate sb-bignum:%subtract-with-borrow) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg) :from :load) - (borrow :scs (unsigned-reg) :from :eval)) - (:result-types unsigned-num positive-fixnum) - (:generator 4 - (inst xor c 1 result) - (inst subq a result result) - (inst subq result b result) - (inst srl result 63 borrow) - (inst xor borrow 1 borrow) - (inst mskll result 4 result))) - -(define-vop (bignum-mult-and-add-3-arg) - (:translate sb-bignum:%multiply-and-add) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg)) - (carry-in :scs (unsigned-reg) :to :save)) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 6 - (inst mulq x y lo) - (inst addq lo carry-in lo) - (inst srl lo 32 hi) - (inst mskll lo 4 lo))) - - -(define-vop (bignum-mult-and-add-4-arg) - (:translate sb-bignum:%multiply-and-add) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg)) - (prev :scs (unsigned-reg)) - (carry-in :scs (unsigned-reg) :to :save)) - (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 9 - (inst mulq x y lo) - (inst addq lo prev lo) - (inst addq lo carry-in lo) - (inst srl lo 32 hi) - (inst mskll lo 4 lo))) - -(define-vop (bignum-mult) - (:translate sb-bignum:%multiply) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 3 - (inst mulq x y lo) - (inst srl lo 32 hi) - (inst mskll lo 4 lo))) - -(define-vop (bignum-lognot) - (:translate sb-bignum:%lognot) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst not x r) - (inst mskll r 4 r))) - -(define-vop (fixnum-to-digit) - (:translate sb-bignum:%fixnum-to-digit) - (:policy :fast-safe) - (:args (fixnum :scs (any-reg))) - (:arg-types tagged-num) - (:results (digit :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst sra fixnum n-fixnum-tag-bits digit))) - -(define-vop (bignum-floor) - (:translate sb-bignum:%bigfloor) - (:policy :fast-safe) - (:args (num-high :scs (unsigned-reg)) - (num-low :scs (unsigned-reg)) - (denom-arg :scs (unsigned-reg) :target denom)) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :from (:argument 2)) denom) - (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) - (:results (quo :scs (unsigned-reg) :from (:eval 0)) - (rem :scs (unsigned-reg) :from (:argument 0))) - (:result-types unsigned-num unsigned-num) - (:generator 325 ; number of inst assuming targeting works. - (inst sll num-high 32 rem) - (inst bis rem num-low rem) - (inst sll denom-arg 32 denom) - (inst cmpule denom rem quo) - (inst beq quo shift1) - (inst subq rem denom rem) - SHIFT1 - (dotimes (i 32) - (let ((shift2 (gen-label))) - (inst srl denom 1 denom) - (inst cmpule denom rem temp) - (inst sll quo 1 quo) - (inst beq temp shift2) - (inst subq rem denom rem) - (inst bis quo 1 quo) - (emit-label shift2))))) - -(define-vop (signify-digit) - (:translate sb-bignum:%fixnum-digit-with-correct-sign) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target res)) - (:arg-types unsigned-num) - (:results (res :scs (any-reg signed-reg))) - (:result-types signed-num) - (:generator 2 - (sc-case res - (any-reg - (inst sll digit 34 res) - (inst sra res 32 res)) - (signed-reg - (inst sll digit 32 res) - (inst sra res 32 res))))) - - -(define-vop (digit-ashr) - (:translate sb-bignum:%ashr) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg)) - (count :scs (unsigned-reg))) - (:arg-types unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg) :from (:argument 0))) - (:result-types unsigned-num) - (:generator 1 - (inst sll digit 32 result) - (inst sra result count result) - (inst srl result 32 result))) - -(define-vop (digit-lshr digit-ashr) - (:translate sb-bignum:%digit-logical-shift-right) - (:generator 1 - (inst srl digit count result))) - -(define-vop (digit-ashl digit-ashr) - (:translate sb-bignum:%ashl) - (:generator 1 - (inst sll digit count result))) diff -Nru sbcl-2.0.6/src/compiler/alpha/array.lisp sbcl-2.1.1/src/compiler/alpha/array.lisp --- sbcl-2.0.6/src/compiler/alpha/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/array.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,534 +0,0 @@ -;;;; the Alpha definitions for array operations - -;;;; 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") - -;;;; allocator for the array header -(define-vop (make-array-header) - (:policy :fast-safe) - (:translate make-array-header) - (:args (type :scs (any-reg)) - (rank :scs (any-reg))) - (:arg-types positive-fixnum positive-fixnum) - (:temporary (:scs (any-reg)) bytes) - (:temporary (:scs (non-descriptor-reg)) header) - (:results (result :scs (descriptor-reg))) - (:generator 13 - (inst addq rank (+ (* array-dimensions-offset n-word-bytes) - lowtag-mask) - bytes) - (inst li (lognot lowtag-mask) header) - (inst and bytes header bytes) - (inst addq rank (fixnumize (1- array-dimensions-offset)) header) - (inst sll header n-widetag-bits header) - (inst bis header type header) - (inst srl header n-fixnum-tag-bits header) - (pseudo-atomic () - (inst bis alloc-tn other-pointer-lowtag result) - (storew header result 0 other-pointer-lowtag) - (inst addq alloc-tn bytes alloc-tn)))) - -;;;; additional accessors and setters for the array header -(define-full-reffer %array-dimension * - array-dimensions-offset other-pointer-lowtag - (any-reg) positive-fixnum %array-dimension) - -(define-full-setter %set-array-dimension * - array-dimensions-offset other-pointer-lowtag - (any-reg) positive-fixnum %set-array-dimension #+gengc nil) - -(define-vop (array-rank-vop) - (:translate %array-rank) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw temp x 0 other-pointer-lowtag) - (inst sra temp n-widetag-bits temp) - (inst subq temp (1- array-dimensions-offset) temp) - (inst sll temp n-fixnum-tag-bits res))) - -;;;; bounds checking routine -(define-vop (check-bound) - (:translate %check-bound) - (:policy :fast-safe) - (:args (array :scs (descriptor-reg)) - (bound :scs (any-reg descriptor-reg)) - (index :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (let ((error (generate-error-code vop 'invalid-array-index-error - array bound index))) - (%test-fixnum index temp error t) - (inst cmpult index bound temp) - (inst beq temp error)))) - -;;;; accessors/setters - -;;; Variants built on top of word-index-ref, etc. I.e. those vectors -;;; whose elements are represented in integer registers and are built -;;; out of 8, 16, or 32 bit elements. -(macrolet ((def-full-data-vector-frobs (type element-type &rest scs) - `(progn - (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) - ,type - vector-data-offset other-pointer-lowtag - ,(remove-if (lambda (x) (member x '(null zero))) scs) - ,element-type - data-vector-ref) - (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) - ,type - vector-data-offset other-pointer-lowtag ,scs ,element-type - data-vector-set #+gengc ,(if (member 'descriptor-reg scs) - t - nil)))) - - (def-partial-data-vector-frobs - (type element-type size signed &rest scs) - `(progn - (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) - ,type - ,size ,signed vector-data-offset other-pointer-lowtag ,scs - ,element-type data-vector-ref) - (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) - ,type - ,size vector-data-offset other-pointer-lowtag ,scs - ,element-type data-vector-set))) - (def-small-data-vector-frobs (type bits) - (let* ((elements-per-word (floor n-word-bits bits)) - (bit-shift (1- (integer-length elements-per-word)))) - `(progn - (define-vop (,(symbolicate 'data-vector-ref/ type)) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) - temp result) - (:generator 20 - (inst srl index ,bit-shift temp) - (inst sll temp n-fixnum-tag-bits temp) - (inst addq object temp lip) - (inst ldl result - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip) - (inst and index ,(1- elements-per-word) temp) - ,@(unless (= bits 1) - `((inst sll temp - ,(1- (integer-length bits)) temp))) - (inst srl result temp result) - (inst and result ,(1- (ash 1 bits)) result) - (inst sll result n-fixnum-tag-bits value))) - (define-vop (,(symbolicate 'data-vector-ref-c/ type)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:arg-types ,type - (:constant - (integer 0 - ,(1- (* (1+ (- (floor (+ #x7fff - other-pointer-lowtag) - n-word-bytes) - vector-data-offset)) - elements-per-word))))) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 15 - (multiple-value-bind (word extra) - (floor index ,elements-per-word) - (loadw result object (+ word - vector-data-offset) - other-pointer-lowtag) - (unless (zerop extra) - (inst srl result (* extra ,bits) result)) - (unless (= extra ,(1- elements-per-word)) - (inst and result ,(1- (ash 1 bits)) - result))))) - (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 zero immediate) - :target result)) - (: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) - (:generator 25 - (inst srl index ,bit-shift temp) - (inst sll temp n-fixnum-tag-bits temp) - (inst addq object temp lip) - (inst ldl old - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip) - (inst and index ,(1- elements-per-word) shift) - ,@(unless (= bits 1) - `((inst sll shift ,(1- (integer-length - bits)) - shift))) - (unless (and (sc-is value immediate) - (= (tn-value value) - ,(1- (ash 1 bits)))) - (inst li ,(1- (ash 1 bits)) temp) - (inst sll temp shift temp) - (inst not temp temp) - (inst and old temp old)) - (unless (sc-is value zero) - (sc-case value - (immediate - (inst li - (logand (tn-value value) - ,(1- (ash 1 bits))) - temp)) - (unsigned-reg - (inst and value - ,(1- (ash 1 bits)) - temp))) - (inst sll temp shift temp) - (inst bis old temp old)) - (inst stl old - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip) - (sc-case value - (immediate - (inst li (tn-value value) result)) - (zero - (move zero-tn result)) - (unsigned-reg - (move value result))))) - (define-vop (,(symbolicate 'data-vector-set-c/ type)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg zero immediate) - :target result)) - (:arg-types ,type - (:constant - (integer 0 - ,(1- (* (1+ (- (floor (+ #x7fff - other-pointer-lowtag) - n-word-bytes) - vector-data-offset)) - elements-per-word)))) - positive-fixnum) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp old) - (:generator 20 - (multiple-value-bind (word extra) - (floor index ,elements-per-word) - (inst ldl old - (- (* (+ word vector-data-offset) - n-word-bytes) - other-pointer-lowtag) - object) - (unless (and (sc-is value immediate) - (= (tn-value value) - ,(1- (ash 1 bits)))) - (cond #+#.(cl:if - (cl:= sb-vm:n-word-bits sb-vm:n-machine-word-bits) - '(and) '(or)) - ((= extra ,(1- elements-per-word)) - (inst sll old ,bits old) - (inst srl old ,bits old)) - (t - (inst li - (lognot (ash ,(1- (ash 1 - bits)) - (* extra ,bits))) - temp) - (inst and old temp old)))) - (sc-case value - (zero) - (immediate - (let ((value - (ash (logand (tn-value - value) - ,(1- (ash 1 - bits))) - (* extra - ,bits)))) - (cond ((< value #x100) - (inst bis old value old)) - (t - (inst li value temp) - (inst bis old temp old))))) - (unsigned-reg - (inst sll value (* extra ,bits) - temp) - (inst bis old temp old))) - (inst stl old - (- (* (+ word vector-data-offset) - n-word-bytes) - other-pointer-lowtag) - object) - (sc-case value - (immediate - (inst li (tn-value value) result)) - (zero - (move zero-tn result)) - (unsigned-reg - (move value result)))))))))) - (def-full-data-vector-frobs simple-vector * - descriptor-reg any-reg null zero) - - (def-partial-data-vector-frobs simple-base-string character :byte nil - character-reg) - #+sb-unicode ; FIXME: what about when a word is 64 bits? - (def-full-data-vector-frobs simple-character-string character character-reg) - - (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum - :byte nil unsigned-reg signed-reg) - (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum - :byte nil unsigned-reg signed-reg) - - (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum - :short nil unsigned-reg signed-reg) - (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum - :short nil unsigned-reg signed-reg) - - (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num - unsigned-reg) - (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num - unsigned-reg) - - (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num - :byte t signed-reg) - - (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num - :short t signed-reg) - - (def-full-data-vector-frobs simple-array-unsigned-fixnum positive-fixnum - any-reg) - (def-full-data-vector-frobs simple-array-fixnum tagged-num any-reg) - - (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num - signed-reg) - - ;; Integer vectors whos elements are smaller than a byte. I.e. bit, - ;; 2-bit, and 4-bit vectors. - (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)) - -;;; and the float variants.. - -(define-vop (data-vector-ref/simple-array-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-single-float positive-fixnum) - (:results (value :scs (single-reg))) - (:result-types single-float) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst addq object index lip) - (inst lds value - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip))) - -(define-vop (data-vector-set/simple-array-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (single-reg) :target result)) - (: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 20 - (inst addq object index lip) - (inst sts value - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip) - (unless (location= result value) - (inst fmove value result)))) - -(define-vop (data-vector-ref/simple-array-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-double-float positive-fixnum) - (:results (value :scs (double-reg))) - (:result-types double-float) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst addq object index lip) - (inst addq lip index lip) - (inst ldt value - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip))) - -(define-vop (data-vector-set/simple-array-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (double-reg) :target result)) - (: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 addq object index lip) - (inst addq lip index lip) - (inst stt value - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) lip) - (unless (location= result value) - (inst fmove value result)))) - -;;; complex float arrays - -(define-vop (data-vector-ref/simple-array-complex-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-complex-single-float positive-fixnum) - (:results (value :scs (complex-single-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types complex-single-float) - (:generator 5 - (let ((real-tn (complex-single-reg-real-tn value))) - (inst addq object index lip) - (inst addq lip index lip) - (inst lds real-tn - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip)) - (let ((imag-tn (complex-single-reg-imag-tn value))) - (inst lds imag-tn - (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag) - lip)))) - -(define-vop (data-vector-set/simple-array-complex-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (complex-single-reg) :target result)) - (: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 addq object index lip) - (inst addq lip index lip) - (inst sts value-real - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip) - (unless (location= result-real value-real) - (inst fmove value-real result-real))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) - (inst sts value-imag - (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag) - lip) - (unless (location= result-imag value-imag) - (inst fmove value-imag result-imag))))) - -(define-vop (data-vector-ref/simple-array-complex-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-complex-double-float positive-fixnum) - (:results (value :scs (complex-double-reg))) - (:result-types complex-double-float) - (:temporary (:scs (interior-reg)) lip) - (:generator 7 - (let ((real-tn (complex-double-reg-real-tn value))) - (inst addq object index lip) - (inst addq lip index lip) - (inst addq lip index lip) - (inst addq lip index lip) - (inst ldt real-tn - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip)) - (let ((imag-tn (complex-double-reg-imag-tn value))) - (inst ldt imag-tn - (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag) - lip)))) - -(define-vop (data-vector-set/simple-array-complex-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (complex-double-reg) :target result)) - (: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 addq object index lip) - (inst addq lip index lip) - (inst addq lip index lip) - (inst addq lip index lip) - (inst stt value-real - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip) - (unless (location= result-real value-real) - (inst fmove value-real result-real))) - (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) - (inst stt value-imag - (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag) - lip) - (unless (location= result-imag value-imag) - (inst fmove value-imag result-imag))))) - - -;;; These vops are useful for accessing the bits of a vector irrespective of -;;; what type of vector it is. -;;; -(define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag - (unsigned-reg) unsigned-num %vector-raw-bits) -(define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag - (unsigned-reg) unsigned-num %set-vector-raw-bits) diff -Nru sbcl-2.0.6/src/compiler/alpha/call.lisp sbcl-2.1.1/src/compiler/alpha/call.lisp --- sbcl-2.0.6/src/compiler/alpha/call.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/call.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1214 +0,0 @@ -;;;; the VM definition of function call for the Alpha - -;;;; 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 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) - (if standard - (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number lra-offset) - (make-restricted-tn *backend-t-primitive-type* descriptor-reg-sc-number))) - -;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a -;;; location to pass OLD-FP in. This is (obviously) wired in the -;;; standard convention, but is totally unrestricted in non-standard -;;; conventions, since we can always fetch it off of the stack using -;;; the arg pointer. -(defun make-old-fp-passing-location () - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)) - -(defconstant old-fp-passing-offset - (make-sc+offset descriptor-reg-sc-number ocfp-offset)) - -;;; These functions 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) - (specify-save-tn - (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) - (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset))) -(defun make-return-pc-save-location (env) - (let ((ptype *backend-t-primitive-type*)) - (specify-save-tn - (physenv-debug-live-tn (make-normal-tn ptype) env) - (make-wired-tn ptype control-stack-arg-scn lra-save-offset)))) - -;;; Make a TN for the standard argument count passing location. We -;;; only need to make the standard location, since a count is never -;;; passed when we are using non-standard conventions. -(defun make-arg-count-location () - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) - -;;;; frame hackery - -;;; Return the number of bytes needed for the current non-descriptor -;;; stack frame. Non-descriptor stack frames must be multiples of 16 -;;; bytes to preserve alien stack alignment. -(defun bytes-needed-for-non-descriptor-stack-frame () - (* (logandc2 (+ 3 (sb-allocated-size 'non-descriptor-stack)) 3) - n-word-bytes)) - -;;; This is used for setting up the Old-FP in local call. -(define-vop (current-fp) - (:results (val :scs (any-reg))) - (:generator 1 - (move cfp-tn val))) - -;;; This is used for computing the caller's NFP for use in -;;; known-values return. It only works assuming there is no variable -;;; size stuff on the nstack. -(define-vop (compute-old-nfp) - (:results (val :scs (any-reg))) - (:vop-var vop) - (:generator 1 - (let ((nfp (current-nfp-tn vop))) - (when nfp - (inst lda val (bytes-needed-for-non-descriptor-stack-frame) nfp))))) - -;;; Accessing a slot from an earlier stack frame is definite hackery. -(define-vop (ancestor-frame-ref) - (:args (frame-pointer :scs (descriptor-reg)) - (variable-home-tn :load-if nil)) - (:results (value :scs (descriptor-reg any-reg))) - (:policy :fast-safe) - (:generator 4 - (aver (sc-is variable-home-tn control-stack)) - (loadw value frame-pointer (tn-offset variable-home-tn)))) -(define-vop (ancestor-frame-set) - (:args (frame-pointer :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:results (variable-home-tn :load-if nil)) - (:policy :fast-safe) - (:generator 4 - (aver (sc-is variable-home-tn control-stack)) - (storew value frame-pointer (tn-offset variable-home-tn)))) - -(define-vop (xep-allocate-frame) - (:info start-lab) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 1 - ;; Make sure the function is aligned, and drop a label pointing to - ;; this function header. - (emit-alignment n-lowtag-bits) - (emit-label start-lab) - ;; Allocate function header. - (inst simple-fun-header-word) - (inst .skip (* (1- simple-fun-insts-offset) n-word-bytes)) - ;; The start of the actual code. - ;; Compute CODE from the address of this entry point. - (let ((entry-point (gen-label))) - (emit-label entry-point) - (inst compute-code-from-lip code-tn lip-tn entry-point temp) - ;; ### We should also save it on the stack so that the garbage - ;; collector won't forget about us if we call anyone else. - ))) - -(define-vop (xep-setup-sp) - (:vop-var vop) - (:generator 1 - (inst lda - csp-tn - (* n-word-bytes (sb-allocated-size 'control-stack)) - cfp-tn) - (let ((nfp (current-nfp-tn vop))) - (when nfp - (inst lda nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame)) nsp-tn) - (move nsp-tn nfp))))) - -(define-vop (allocate-frame) - (:results (res :scs (any-reg)) - (nfp :scs (any-reg))) - (:info callee) - (:generator 2 - (move csp-tn res) - (inst lda - csp-tn - (* n-word-bytes (sb-allocated-size 'control-stack)) - csp-tn) - (when (ir2-physenv-number-stack-p callee) - (inst lda nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame)) nsp-tn) - (move nsp-tn nfp)))) - -;;; 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. -(define-vop (allocate-full-call-frame) - (:info nargs) - (:results (res :scs (any-reg))) - (:generator 2 - (when (> nargs register-arg-count) - (move csp-tn res) - (inst lda csp-tn (* nargs n-word-bytes) csp-tn)))) - -;;; 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 -;;; list for the locations that the values are to be received into. -;;; Nvals is the number of values that are to be received (should -;;; equal the length of Values). -;;; -;;; Move-Temp is a Descriptor-Reg TN used as a temporary. -;;; -;;; This code exploits the fact that in the unknown-values convention, -;;; a single value return returns at the return PC + 8, whereas a -;;; return of other than one value returns directly at the return PC. -;;; -;;; If 0 or 1 values are expected, then we just emit an instruction to -;;; reset the SP (which will only be executed when other than 1 value -;;; is returned.) -;;; -;;; In the general case, we have to do three things: -;;; -- Default unsupplied register values. This need only be done when a -;;; single value is returned, since register values are defaulted by the -;;; called in the non-single case. -;;; -- Default unsupplied stack values. This needs to be done whenever there -;;; are stack values. -;;; -- Reset SP. This must be done whenever other than 1 value is returned, -;;; regardless of the number of values desired. -;;; -;;; The general-case code looks like this: -#| - b regs-defaulted ; Skip if MVs - nop - - move a1 null-tn ; Default register values - ... - loadi nargs 1 ; Force defaulting of stack values - move ocfp csp ; Set up args for SP resetting - -regs-defaulted - subu temp nargs register-arg-count - - bltz temp default-value-7 ; jump to default code - addu temp temp -1 - loadw move-temp ocfp-tn 6 ; Move value to correct location. - store-stack-tn val4-tn move-temp - - bltz temp default-value-8 - addu temp temp -1 - loadw move-temp ocfp-tn 7 - store-stack-tn val5-tn move-temp - - ... - -defaulting-done - move sp ocfp ; Reset SP. - - - -default-value-7 - store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) - -default-value-8 - store-stack-tn val5-tn null-tn ; Nil out 8'th value. - - ... - - br defaulting-done - nop -|# -(defun default-unknown-values (vop values nvals move-temp temp lra-label) - (declare (type (or tn-ref null) values) - (type unsigned-byte nvals) (type tn move-temp temp)) - (if (<= nvals 1) - (progn - ;; Note that this is a single-value return point. This is - ;; actually the multiple-value entry point for a single - ;; desired value, but the code location has to be here, or the - ;; debugger backtrace gets confused. - (without-scheduling () - (note-this-location vop :single-value-return) - (move ocfp-tn csp-tn) - (inst nop)) - (when lra-label - (inst compute-code-from-lra code-tn code-tn lra-label temp))) - (let ((regs-defaulted (gen-label)) - (defaulting-done (gen-label)) - (default-stack-vals (gen-label))) - (without-scheduling () - ;; Note that this is an unknown-values return point. - (note-this-location vop :unknown-return) - ;; If there are no stack results, clear the stack now. - (if (> nvals register-arg-count) - (inst subq nargs-tn (fixnumize register-arg-count) temp) - (move ocfp-tn csp-tn)) - ;; Branch off to the MV case. - (inst br zero-tn regs-defaulted)) - - ;; Do the single value case. - (do ((i 1 (1+ i)) - (val (tn-ref-across values) (tn-ref-across val))) - ((= i (min nvals register-arg-count))) - (move null-tn (tn-ref-tn val))) - (when (> nvals register-arg-count) - (move csp-tn ocfp-tn) - (inst br zero-tn default-stack-vals)) - - (emit-label regs-defaulted) - - (when (> nvals register-arg-count) - ;; If there are stack results, we have to default them - ;; and clear the stack. - (collect ((defaults)) - (do ((i register-arg-count (1+ i)) - (val (do ((i 0 (1+ i)) - (val values (tn-ref-across val))) - ((= i register-arg-count) val)) - (tn-ref-across val))) - ((null val)) - - (let ((default-lab (gen-label)) - (tn (tn-ref-tn val))) - (defaults (cons default-lab tn)) - - (inst ble temp default-lab) - (inst ldl move-temp (* i n-word-bytes) ocfp-tn) - (inst subq temp (fixnumize 1) temp) - (store-stack-tn tn move-temp))) - - (emit-label defaulting-done) - (move ocfp-tn csp-tn) - - (let ((defaults (defaults))) - (aver defaults) - (assemble (:elsewhere) - (emit-label default-stack-vals) - (do ((remaining defaults (cdr remaining))) - ((null remaining)) - (let ((def (car remaining))) - (emit-label (car def)) - (store-stack-tn (cdr def) null-tn))) - (inst br zero-tn defaulting-done))))) - - (when lra-label - (inst compute-code-from-lra code-tn code-tn lra-label temp)))) - (values)) - -;;;; unknown values receiving - -;;; Emit code needed at the return point for an unknown-values call -;;; for an arbitrary number of values. -;;; -;;; We do the single and non-single cases with no shared code: there -;;; doesn't seem to be any potential overlap, and receiving a single -;;; value is more important efficiency-wise. -;;; -;;; When there is a single value, we just push it on the stack, -;;; returning the old SP and 1. -;;; -;;; When there is a variable number of values, we move all of the -;;; argument registers onto the stack, and return Args and Nargs. -;;; -;;; 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 temp) - (declare (type tn args nargs start count temp)) - (let ((variable-values (gen-label)) - (done (gen-label))) - (without-scheduling () - (inst br zero-tn variable-values) - (inst nop)) - - (when lra-label - (inst compute-code-from-lra code-tn code-tn lra-label temp)) - (inst addq csp-tn 4 csp-tn) - (storew (first *register-arg-tns*) csp-tn -1) - (inst subq csp-tn 4 start) - (inst li (fixnumize 1) count) - - (emit-label done) - - (assemble (:elsewhere) - (emit-label variable-values) - (when lra-label - (inst compute-code-from-lra code-tn code-tn lra-label temp)) - (do ((arg *register-arg-tns* (rest arg)) - (i 0 (1+ i))) - ((null arg)) - (storew (first arg) args i)) - (move args start) - (move nargs count) - (inst br zero-tn done))) - (values)) - -;;; a VOP that can be inherited by unknown values receivers. The main -;;; thing this handles is allocation of the result temporaries. -(define-vop (unknown-values-receiver) - (:results - (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:sc descriptor-reg :offset ocfp-offset - :from :eval :to (:result 0)) - values-start) - (:temporary (:sc any-reg :offset nargs-offset - :from :eval :to (:result 1)) - nvals) - (:temporary (:scs (non-descriptor-reg)) temp)) - -;;; This hook by the codegen lets us insert code before fall-thru entry 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)) - (when trampoline-label - (emit-label trampoline-label)) - (emit-label start-label)) - - -;;;; local call with unknown values convention return - -;;; Non-TR local call for a fixed number of values passed according to the -;;; unknown values convention. -;;; -;;; Args are the argument passing locations, which are specified only to -;;; terminate their lifetimes in the caller. -;;; -;;; Values are the return value locations (wired to the standard passing -;;; locations). -;;; -;;; Save is the save info, which we can ignore since saving has been -;;; done. Return-PC is the TN that the return PC should be passed in. -;;; Target is a continuation pointing to the start of the called -;;; function. Nvals is the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, -;;; since all registers may be tied up by the more operand. Instead, -;;; we use MAYBE-LOAD-STACK-TN. -(define-vop (call-local) - (:args (fp) - (nfp) - (args :more t)) - (:results (values :more t)) - (:save-p t) - (:move-args :local-call) - (:info arg-locs callee target nvals) - (:vop-var vop) - (:temporary (:scs (descriptor-reg) :from :eval) move-temp) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp) - (:ignore arg-locs args ocfp) - (:generator 5 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (maybe-load-stack-nfp-tn callee-nfp nfp temp)) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) - (note-this-location vop :call-site) - (inst br zero-tn target) - (emit-return-pc label) - (default-unknown-values vop values nvals move-temp temp label) - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))) - - -;;; Non-TR local call for a variable number of return values passed -;;; according to the unknown values convention. The results are the -;;; start of the values glob and the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, -;;; since all registers may be tied up by the more operand. Instead, -;;; we use MAYBE-LOAD-STACK-TN. -(define-vop (multiple-call-local unknown-values-receiver) - (:args (fp) - (nfp) - (args :more t)) - (:save-p t) - (:move-args :local-call) - (:info save callee target) - (:ignore args save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 20 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (maybe-load-stack-nfp-tn callee-nfp nfp temp)) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) - (note-this-location vop :call-site) - (inst bsr zero-tn target) - (emit-return-pc label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count label temp) - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))) - - -;;;; local call with known values return - -;;; Non-TR local call with known return locations. Known-value return -;;; works just like argument passing in local call. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -(define-vop (known-call-local) - (:args (fp) - (nfp) - (args :more t)) - (:results (res :more t)) - (:move-args :local-call) - (:save-p t) - (:info save callee target) - (:ignore args res save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (maybe-load-stack-nfp-tn callee-nfp nfp temp)) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) - (note-this-location vop :call-site) - (inst bsr zero-tn target) - (emit-return-pc label) - (note-this-location vop :known-return) - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))) - -;;; Return from known values call. We receive the return locations as -;;; arguments to terminate their lifetimes in the returning function. -;;; We restore FP and CSP and jump to the Return-PC. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, -;;; since all registers may be tied up by the more operand. Instead, -;;; we use MAYBE-LOAD-STACK-TN. -(define-vop (known-return) - (:args (ocfp :target ocfp-temp) - (return-pc :target return-pc-temp) - (vals :more t)) - (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp) - (:temporary (:sc any-reg :from (:argument 1)) - return-pc-temp) - (:temporary (:scs (interior-reg)) lip) - (:move-args :known-return) - (:info val-locs) - (:ignore val-locs vals) - (:vop-var vop) - (:generator 6 - (maybe-load-stack-tn ocfp-temp ocfp) - (maybe-load-stack-tn return-pc-temp return-pc) - (move cfp-tn csp-tn) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst lda nsp-tn (bytes-needed-for-non-descriptor-stack-frame) - cur-nfp))) - (inst subq return-pc-temp (- other-pointer-lowtag n-word-bytes) lip) - (move ocfp-temp cfp-tn) - (inst ret zero-tn lip 1))) - -;;;; full call: -;;;; -;;;; There is something of a cross-product effect with full calls. -;;;; Different versions are used depending on whether we know the -;;;; number of arguments or the name of the called function, and -;;;; whether we want fixed values, unknown values, or a tail call. -;;;; -;;;; In full call, the arguments are passed creating a partial frame on -;;;; the stack top and storing stack arguments into that frame. On -;;;; entry to the callee, this partial frame is pointed to by FP. If -;;;; there are no stack arguments, we don't bother allocating a partial -;;;; frame, and instead set FP to SP just before the call. - -;;; This macro helps in the definition of full call VOPs by avoiding -;;; code replication in defining the cross-product VOPs. -;;; -;;; Name is the name of the VOP to define. -;;; -;;; Named is true if the first argument is a symbol whose global -;;; function definition is to be called. -;;; -;;; Return is either :FIXED, :UNKNOWN or :TAIL: -;;; -- If :FIXED, then the call is for a fixed number of values, returned -;;; in the standard passing locations (passed as result operands). -;;; -- If :UNKNOWN, then the result values are pushed on the stack, and -;;; the result values are specified by the Start and Count as in the -;;; unknown-values continuation representation. -;;; -- If :TAIL, then do a tail-recursive call. No values are returned. -;;; The Ocfp and Return-PC are passed as the second and third arguments. -;;; -;;; In non-tail calls, the pointer to the stack arguments is passed as -;;; the last fixed argument. If Variable is false, then the passing -;;; locations are passed as a more arg. Variable is true if there are -;;; a variable number of arguments passed on the stack. Variable -;;; cannot be specified with :TAIL return. TR variable argument call -;;; is implemented separately. -;;; -;;; 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. -(defmacro define-full-call (name named return variable) - (aver (not (and variable (eq return :tail)))) - `(define-vop (,name - ,@(when (eq return :unknown) - '(unknown-values-receiver))) - (:args - ,@(unless (eq return :tail) - '((new-fp :scs (any-reg) :to :eval))) - ,@(case named - ((nil) - '((arg-fun :target lexenv))) - (:direct) - (t - '((name :target name-pass)))) - - ,@(when (eq return :tail) - '((ocfp :target ocfp-pass) - (return-pc :target return-pc-pass))) - - ,@(unless variable '((args :more t :scs (descriptor-reg))))) - - ,@(when (eq return :fixed) - '((:results (values :more t)))) - - (:save-p ,(if (eq return :tail) :compute-only t)) - - ,@(unless (or (eq return :tail) variable) - '((:move-args :full-call))) - - (:vop-var vop) - (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(nargs)) - ,@(when (eq named :direct) '(fun)) - ,@(when (eq return :fixed) '(nvals)) - step-instrumenting) - - (:ignore #+gengc ,@(unless (eq return :tail) '(return-pc-pass)) - ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(args)) - ;; Step instrumentation for full calls not implemented yet. - ;; See the PPC backend for an example. - step-instrumenting) - - (:temporary (:sc descriptor-reg - :offset ocfp-offset - :from (:argument 1) - ,@(unless (eq return :fixed) - '(:to :eval))) - ocfp-pass) - - (:temporary (:sc descriptor-reg - :offset #-gengc lra-offset #+gengc ra-offset - :from (:argument ,(if (eq return :tail) 2 1)) - :to :eval) - return-pc-pass) - - ,@(case named - ((t) - `((:temporary (:sc descriptor-reg :offset fdefn-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - name-pass))) - ((nil) - `((:temporary (:sc descriptor-reg :offset lexenv-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - lexenv) - #-gengc - (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) - function)))) - - (:temporary (:sc any-reg :offset nargs-offset :to :eval) - nargs-pass) - - ,@(when variable - (mapcar (lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :to :eval) - ,name)) - register-arg-names *register-arg-offsets*)) - ,@(when (eq return :fixed) - '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) - - ,@(unless (eq return :tail) - '((:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) - - (:temporary (:sc interior-reg :offset lip-offset) entry-point) - - (:generator ,(+ (if named 5 0) - (if variable 19 1) - (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 :load-nargs - ,@(if (eq return :tail) - '((unless (location= ocfp ocfp-pass) - :load-ocfp) - (unless (location= return-pc - return-pc-pass) - :load-return-pc) - (when cur-nfp - :frob-nfp)) - '(#-gengc - :comp-lra - (when cur-nfp - :frob-nfp) - :save-fp - :load-fp)))))) - (flet ((do-next-filler () - (let* ((next (pop filler)) - (what (if (consp next) (car next) next))) - (ecase what - (:load-nargs - ,@(if variable - `((inst subq csp-tn new-fp nargs-pass) - ,@(let ((index -1)) - (mapcar (lambda (name) - `(inst ldl ,name - ,(ash (incf index) - word-shift) - new-fp)) - register-arg-names))) - '((inst li (fixnumize nargs) nargs-pass)))) - ,@(if (eq return :tail) - '((:load-ocfp - (sc-case ocfp - (any-reg - (inst move ocfp ocfp-pass)) - (control-stack - (inst ldl ocfp-pass - (ash (tn-offset ocfp) - word-shift) - cfp-tn)))) - (:load-return-pc - (sc-case return-pc - (#-gengc descriptor-reg #+gengc any-reg - (inst move return-pc return-pc-pass)) - (control-stack - (inst ldl return-pc-pass - (ash (tn-offset return-pc) - word-shift) - cfp-tn)))) - (:frob-nfp - (inst lda nsp-tn - (bytes-needed-for-non-descriptor-stack-frame) - cur-nfp))) - `(#-gengc - (:comp-lra - (inst compute-lra-from-code - return-pc-pass code-tn lra-label temp)) - (:frob-nfp - (store-stack-tn nfp-save cur-nfp)) - (:save-fp - (inst move cfp-tn ocfp-pass)) - (:load-fp - ,(if variable - '(move new-fp cfp-tn) - '(if (> nargs register-arg-count) - (move new-fp cfp-tn) - (move csp-tn cfp-tn)))))) - ((nil)))))) - ,@(case named - ((t) - `((sc-case name - (descriptor-reg (move name name-pass)) - (control-stack - (inst ldl name-pass - (tn-byte-offset name) cfp-tn) - (do-next-filler)) - (constant - (inst ldl name-pass - (- (tn-byte-offset name) - other-pointer-lowtag) code-tn) - (do-next-filler))) - (inst ldl entry-point - (- (ash fdefn-raw-addr-slot word-shift) - other-pointer-lowtag) name-pass) - (do-next-filler))) - ((nil) - `((sc-case arg-fun - (descriptor-reg (move arg-fun lexenv)) - (control-stack - (inst ldl lexenv - (tn-byte-offset arg-fun) cfp-tn) - (do-next-filler)) - (constant - (inst ldl lexenv - (- (tn-byte-offset arg-fun) - other-pointer-lowtag) code-tn) - (do-next-filler))) - #-gengc - (inst ldl function - (- (ash closure-fun-slot word-shift) - fun-pointer-lowtag) lexenv) - #-gengc - (do-next-filler) - #-gengc - (inst addq function - (- (ash simple-fun-insts-offset word-shift) - fun-pointer-lowtag) entry-point) - #+gengc - (inst ldl entry-point - (- (ash closure-entry-point-slot word-shift) - fun-pointer-lowtag) lexenv) - #+gengc - (do-next-filler))) - (:direct - `((inst ldl entry-point (static-fun-offset fun) null-tn)))) - (loop - (if (cdr filler) - (do-next-filler) - (return))) - - (note-this-location vop :call-site) - (do-next-filler) - (inst jsr zero-tn entry-point)) - - ,@(ecase return - (:fixed - '((emit-return-pc lra-label) - (default-unknown-values vop values nvals - move-temp temp lra-label) - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) - (:unknown - '((emit-return-pc lra-label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count - lra-label temp) - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) - (:tail)))))) - -(define-full-call call nil :fixed nil) -(define-full-call call-named t :fixed nil) -(define-full-call static-call-named :direct :fixed nil) -(define-full-call multiple-call nil :unknown nil) -(define-full-call multiple-call-named t :unknown nil) -(define-full-call static-multiple-call-named :direct :unknown nil) -(define-full-call tail-call nil :tail nil) -(define-full-call tail-call-named t :tail nil) -(define-full-call static-tail-call-named :direct :tail nil) - -(define-full-call call-variable nil :fixed t) -(define-full-call multiple-call-variable nil :unknown t) - -;;; This is defined separately, since it needs special code that blits -;;; the arguments down. -(define-vop (tail-call-variable) - (:args - (args-arg :scs (any-reg) :target args) - (function-arg :scs (descriptor-reg) :target lexenv) - (ocfp-arg :scs (any-reg) :target ocfp) - (lra-arg :scs (#-gengc descriptor-reg #+gengc any-reg) :target lra)) - - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) - (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) - (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp) - (:temporary (:sc any-reg :offset #-gengc lra-offset #+gengc ra-offset - :from (:argument 3)) lra) - (:temporary (:scs (non-descriptor-reg)) temp) - - (:vop-var vop) - - (:generator 75 - - ;; Move these into the passing locations if they are not already there. - (move args-arg args) - (move function-arg lexenv) - (move ocfp-arg ocfp) - (move lra-arg lra) - - ;; Clear the number stack if anything is there. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst lda nsp-tn (bytes-needed-for-non-descriptor-stack-frame) - cur-nfp))) - - ;; And jump to the assembly-routine that does the bliting. - (inst li (make-fixup 'tail-call-variable :assembly-routine) temp) - (inst jmp zero-tn temp))) - -;;;; unknown values return - -;;; Return a single value using the unknown-values convention. -(define-vop (return-single) - (:args (ocfp :scs (any-reg)) - #-gengc (return-pc :scs (descriptor-reg)) - #+gengc (return-pc :scs (any-reg) :target ra) - (value)) - (:ignore value) - #-gengc (:temporary (:scs (interior-reg)) lip) - #+gengc (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra) - #+gengc (:temporary (:scs (any-reg) :from (:argument 1)) temp) - (:vop-var vop) - (:generator 6 - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst lda nsp-tn (bytes-needed-for-non-descriptor-stack-frame) - cur-nfp))) - ;; Clear the control stack, and restore the frame pointer. - (move cfp-tn csp-tn) - (move ocfp cfp-tn) - ;; Out of here. - #-gengc (lisp-return return-pc lip :offset 2) - #+gengc - (progn - (inst addq return-pc (* 2 n-word-bytes) temp) - (unless (location= ra return-pc) - (inst move ra return-pc)) - (inst ret zero-tn temp 1)))) - -;;; 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 number of values returned. -;;; -;;; If returning a single value, then deallocate the current frame, -;;; restore FP and jump to the single-value entry at Return-PC + 8. -;;; -;;; If returning other than one value, then load the number of values -;;; returned, NIL out unsupplied values registers, restore FP and -;;; return at Return-PC. When there are stack values, we must -;;; initialize the argument pointer to point to the beginning of the -;;; values block (which is the beginning of the current frame.) -(define-vop (return) - (:args (ocfp :scs (any-reg)) - (return-pc :scs (#-gengc descriptor-reg #+gengc any-reg) - :to (:eval 1) - #+gengc :target #+gengc ra) - (values :more t)) - (:ignore values) - (:info nvals) - (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) - (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1) - (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2) - (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) - (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4) - (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) - #-gengc (:temporary (:scs (interior-reg)) lip) - #+gengc (:temporary (:sc any-reg :offset ra-offset :from (:eval 1)) ra) - (:vop-var vop) - (:generator 6 - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst lda nsp-tn (bytes-needed-for-non-descriptor-stack-frame) - cur-nfp))) - ;; Establish the values pointer and values count. - (move cfp-tn val-ptr) - (inst li (fixnumize nvals) nargs) - ;; restore the frame pointer and clear as much of the control - ;; stack as possible. - (move ocfp cfp-tn) - ;; ADDQ only accepts immediates of type (UNSIGNED-BYTE 8). Here, - ;; instead of adding (* NVALS N-WORD-BYTES), we use NARGS that - ;; we've carefully set up, but protect ourselves by averring that - ;; FIXNUMIZEation and multiplication by N-WORD-BYTES is the same. - (aver (= (* nvals n-word-bytes) (fixnumize nvals))) - (inst addq val-ptr nargs csp-tn) - ;; pre-default any argument register that need it. - (when (< nvals register-arg-count) - (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) - (move null-tn reg))) - ;; And away we go. - (lisp-return return-pc lip))) - -;;; Do unknown-values return of an arbitrary number of values (passed -;;; on the stack.) We check for the common case of a single return -;;; value, and do that inline using the normal single value return -;;; convention. Otherwise, we branch off to code that calls an -;;; assembly-routine. -(define-vop (return-multiple) - (:args (ocfp-arg :scs (any-reg) :target ocfp) - #-gengc (lra-arg :scs (descriptor-reg) :target lra) - #+gengc (return-pc :scs (any-reg) :target ra) - (vals-arg :scs (any-reg) :target vals) - (nvals-arg :scs (any-reg) :target nvals)) - - (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp) - #-gengc - (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) - #+gengc - (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) - (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) - (:temporary (:sc descriptor-reg :offset a0-offset) a0) - (:temporary (:scs (non-descriptor-reg)) temp) - #-gengc (:temporary (:scs (interior-reg)) lip) - #+gengc (:temporary (:scs (any-reg) :from (:argument 0)) temp) - - (:vop-var vop) - - (:generator 13 - (let ((not-single (gen-label))) - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst lda nsp-tn (bytes-needed-for-non-descriptor-stack-frame) - cur-nfp))) - - ;; Check for the single case. - (inst li (fixnumize 1) a0) - (inst cmpeq nvals-arg a0 temp) - (inst ldl a0 0 vals-arg) - (inst beq temp not-single) - - ;; Return with one value. - (move cfp-tn csp-tn) - (move ocfp-arg cfp-tn) - (lisp-return lra-arg lip :offset 2) - - ;; Nope, not the single case. - (emit-label not-single) - (move ocfp-arg ocfp) - (move lra-arg lra) - (move vals-arg vals) - (move nvals-arg nvals) - (inst li (make-fixup 'return-multiple :assembly-routine) temp) - (inst jmp zero-tn temp)))) - -;;;; XEP hackery - -;;; Get the lexical environment from its passing location. -(define-vop (setup-closure-environment) - (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure - :to (:result 0)) - lexenv) - (:results (closure :scs (descriptor-reg))) - (:info label) - (:ignore label) - (:generator 6 - ;; Get result. - (move lexenv closure))) - -;;; Copy a &MORE arg from the argument area to the end of the current -;;; frame. FIXED is the number of non-&MORE arguments. -(define-vop (copy-more-arg) - (:temporary (:sc any-reg :offset nl0-offset) result) - (:temporary (:sc any-reg :offset nl1-offset) count) - (:temporary (:sc any-reg :offset nl2-offset) src) - (:temporary (:sc any-reg :offset nl4-offset) dst) - (:temporary (:sc descriptor-reg :offset l0-offset) temp) - (:info fixed) - (:generator 20 - (let ((loop (gen-label)) - (do-regs (gen-label)) - (done (gen-label))) - (when (< fixed register-arg-count) - ;; Save a pointer to the results so we can fill in register - ;; args. We don't need this if there are more fixed args than - ;; reg args. - (move csp-tn result)) - ;; Allocate the space on the stack. - (cond ((zerop fixed) - (inst addq csp-tn nargs-tn csp-tn) - (inst beq nargs-tn done)) - (t - (inst subq nargs-tn (fixnumize fixed) count) - (inst ble count done) - (inst addq csp-tn count csp-tn))) - (when (< fixed register-arg-count) - ;; We must stop when we run out of stack args, not when we run - ;; out of &MORE args. - (inst subq nargs-tn (fixnumize register-arg-count) count)) - ;; Initialize dst to be end of stack. - (move csp-tn dst) - ;; Everything of interest in registers. - (inst ble count do-regs) - ;; Initialize SRC to be end of args. - (inst addq cfp-tn nargs-tn src) - - (emit-label loop) - ;; *--dst = *--src, --count - (inst subq src n-word-bytes src) - (inst subq count (fixnumize 1) count) - (loadw temp src) - (inst subq dst n-word-bytes dst) - (storew temp dst) - (inst bgt count loop) - - (emit-label do-regs) - (when (< fixed register-arg-count) - ;; Now we have to deposit any more args that showed up in - ;; registers. We know there is at least one &MORE arg, - ;; otherwise we would have branched to DONE up at the top. - (inst subq nargs-tn (fixnumize (1+ fixed)) count) - (do ((i fixed (1+ i))) - ((>= i register-arg-count)) - ;; Store it relative to the pointer saved at the start. - (storew (nth i *register-arg-tns*) result (- i fixed)) - ;; Is this the last one? - (inst beq count done) - ;; Decrement count. - (inst subq count (fixnumize 1) count))) - (emit-label done)))) - -;;; &MORE args are stored consecutively on the stack, starting -;;; immediately at the context pointer. The context pointer is not -;;; typed, so the lowtag is 0. - -(define-vop (more-arg) - (:translate %more-arg) - (:policy :fast-safe) - (:args (context :scs (descriptor-reg)) (index :scs (any-reg))) - (:arg-types * tagged-num) - (:temporary (:scs (any-reg)) temp) - (:results (value :scs (descriptor-reg any-reg))) - (:result-types *) - (:generator 5 - (inst addq context index temp) - (inst ldl value 0 temp))) -(define-vop (more-arg-c) - (:translate %more-arg) - (:policy :fast-safe) - (:args (context :scs (descriptor-reg))) - (:info index) - (:arg-types * (:constant (load/store-index 8 0 0))) - (:results (value :scs (descriptor-reg any-reg))) - (:result-types *) - (:generator 4 - (inst ldl value (* index n-word-bytes) context))) - -;;; Turn &MORE arg (context, count) into a list. -(define-vop () - (:args (context-arg :target context :scs (descriptor-reg)) - (count-arg :target count :scs (any-reg))) - (:arg-types * tagged-num) - (:temporary (:scs (any-reg) :from (:argument 0)) context) - (:temporary (:scs (any-reg) :from (:argument 1)) count) - (:temporary (:scs (descriptor-reg) :from :eval) temp dst) - (:results (result :scs (descriptor-reg))) - (:translate %listify-rest-args) - (:policy :safe) - (:node-var node) - (:generator 20 - (let* ((enter (gen-label)) - (loop (gen-label)) - (done (gen-label)) - (dx-p (node-stack-allocate-p node)) - (alloc-area-tn (if dx-p csp-tn alloc-tn))) - (move context-arg context) - (move count-arg count) - ;; Check to see if there are any arguments. - (move null-tn result) - (inst beq count done) - - ;; We need to do this atomically. - (pseudo-atomic () - ;; align CSP - (when dx-p (align-csp temp)) - ;; Allocate a cons (2 words) for each item. - (inst bis alloc-area-tn list-pointer-lowtag result) - (move result dst) - (inst sll count 1 temp) - (inst addq alloc-area-tn temp alloc-area-tn) - (inst br zero-tn enter) - - ;; Store the current cons in the cdr of the previous cons. - (emit-label loop) - (inst addq dst (* 2 n-word-bytes) dst) - (storew dst dst -1 list-pointer-lowtag) - - (emit-label enter) - ;; Grab one value. - (loadw temp context) - (inst addq context n-word-bytes context) - - ;; Store the value in the car (in delay slot) - (storew temp dst 0 list-pointer-lowtag) - - ;; Decrement count, and if != zero, go back for more. - (inst subq count (fixnumize 1) count) - (inst bne count loop) - - ;; NIL out the last cons. - (storew null-tn dst 1 list-pointer-lowtag)) - (emit-label done)))) - -;;; Return the location and size of the &MORE arg glob created by -;;; COPY-MORE-ARG. Supplied is the total number of arguments supplied -;;; (originally passed in NARGS.) Fixed is the number of non-&rest -;;; arguments. -;;; -;;; We must duplicate some of the work done by COPY-MORE-ARG, since at -;;; that time the environment is in a pretty brain-damaged state, -;;; preventing this info from being returned as values. What we do is -;;; compute supplied - fixed, and return a pointer that many words -;;; below the current stack top. -(define-vop () - (:policy :fast-safe) - (:translate sb-c::%more-arg-context) - (:args (supplied :scs (any-reg))) - (:arg-types tagged-num (:constant fixnum)) - (:info fixed) - (:results (context :scs (descriptor-reg)) - (count :scs (any-reg))) - (:result-types t tagged-num) - (:note "more-arg-context") - (:generator 5 - (inst subq supplied (fixnumize fixed) count) - (inst subq csp-tn count context))) - -(define-vop (verify-arg-count) - (:policy :fast-safe) - (:args (nargs :scs (any-reg))) - (:arg-types positive-fixnum (:constant t) (:constant t)) - (:info min max) - (:temporary (:scs (unsigned-reg)) temp) - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (let ((err-lab - (generate-error-code vop 'invalid-arg-count-error nargs))) - (cond ((not min) - (cond ((zerop max) - (inst bne nargs err-lab)) - (t - (inst subq nargs (fixnumize max) temp) - (inst bne temp err-lab)))) - (max - (when (plusp min) - (inst li (fixnumize min) temp) - (inst cmpult nargs temp temp) - (inst bne temp err-lab)) - (inst li (fixnumize max) temp) - (inst cmpult temp nargs temp) - (inst bne temp err-lab)) - ((plusp min) - (inst li (fixnumize min) temp) - (inst cmpult nargs temp temp) - (inst bne temp err-lab)))))) - -;;; Single-stepping -(define-vop (step-instrument-before-vop) - (:policy :fast-safe) - (:vop-var vop) - (:generator 3 - ;; Stub! See the PPC backend for an example. - (note-this-location vop :internal-error))) diff -Nru sbcl-2.0.6/src/compiler/alpha/c-call.lisp sbcl-2.1.1/src/compiler/alpha/c-call.lisp --- sbcl-2.0.6/src/compiler/alpha/c-call.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/c-call.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,199 +0,0 @@ -;;;; VOPs and other machine-specific support routines for call-out to C - -;;;; 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") - -(defstruct arg-state - (stack-frame-size 0)) - -(define-alien-type-method (integer :arg-tn) (type state) - (let ((stack-frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (multiple-value-bind - (ptype reg-sc stack-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-64 signed-reg-sc-number signed-stack-sc-number) - (values 'unsigned-byte-64 unsigned-reg-sc-number unsigned-stack-sc-number)) - (if (< stack-frame-size 4) - (make-wired-tn* ptype reg-sc (+ stack-frame-size nl0-offset)) - (make-wired-tn* ptype stack-sc (* 2 (- stack-frame-size 4))))))) - -(define-alien-type-method (system-area-pointer :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (if (< stack-frame-size 4) - (make-wired-tn* 'system-area-pointer sap-reg-sc-number - (+ stack-frame-size nl0-offset)) - (make-wired-tn* 'system-area-pointer sap-stack-sc-number - (* 2 (- stack-frame-size 4)))))) - -(define-alien-type-method (double-float :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (if (< stack-frame-size 6) - (make-wired-tn* 'double-float double-reg-sc-number - (+ stack-frame-size nl0-offset)) - (make-wired-tn* 'double-float double-stack-sc-number - (* 2 (- stack-frame-size 4)))))) - -(define-alien-type-method (single-float :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (if (< stack-frame-size 6) - (make-wired-tn* 'single-float single-reg-sc-number - (+ stack-frame-size nl0-offset)) - (make-wired-tn* 'single-float single-stack-sc-number - (* 2 (- stack-frame-size 4)))))) - -(define-alien-type-method (integer :result-tn) (type state) - (declare (ignore state)) - (multiple-value-bind - (ptype reg-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-64 signed-reg-sc-number) - (values 'unsigned-byte-64 unsigned-reg-sc-number)) - (make-wired-tn* ptype reg-sc lip-offset))) - -(define-alien-type-method (integer :naturalize-gen) (type alien) - (if (<= (alien-type-bits type) 32) - (if (alien-integer-type-signed type) - `(sign-extend ,alien ,(alien-type-bits type)) - `(logand ,alien ,(1- (ash 1 (alien-type-bits type))))) - alien)) - -(define-alien-type-method (system-area-pointer :result-tn) (type state) - (declare (ignore type state)) - (make-wired-tn* 'system-area-pointer sap-reg-sc-number lip-offset)) - -(define-alien-type-method (double-float :result-tn) (type state) - (declare (ignore type state)) - (make-wired-tn* 'double-float double-reg-sc-number lip-offset)) - -(define-alien-type-method (single-float :result-tn) (type state) - (declare (ignore type state)) - (make-wired-tn* 'single-float single-reg-sc-number lip-offset)) - -(define-alien-type-method (values :result-tn) (type state) - (let ((values (alien-values-type-values type))) - (when (cdr values) - (error "Too many result values from c-call.")) - (when values - (invoke-alien-type-method :result-tn (car values) state)))) - -(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))) - (values (make-wired-tn* 'positive-fixnum any-reg-sc-number nsp-offset) - (* (max (- (logandc2 (1+ (arg-state-stack-frame-size arg-state)) 1) 4) 2) - n-word-bytes - #.(floor n-machine-word-bits n-word-bits)) - (arg-tns) - (invoke-alien-type-method :result-tn - (alien-fun-type-result-type type) - nil))))) - -(defknown sign-extend ((signed-byte 64) t) fixnum - (foldable flushable movable)) - -(define-vop (sign-extend) - (:translate sign-extend) - (:policy :fast-safe) - (:args (val :scs (signed-reg) :target res)) - (:arg-types signed-num (:constant fixnum)) - (:info size) - (:results (res :scs (signed-reg))) - (:result-types fixnum) - (:generator 1 - (ecase size - (8 - ;;(inst sextb val res) ;; Under what circumstances can we use this? - (inst sll val 56 res) - (inst sra res 56 res)) - (16 - ;;(inst sextw val res) ;; Under what circumstances can we use this? - (inst sll val 48 res) - (inst sra res 48 res)) - (32 - (inst sll val 32 res) - (inst sra res 32 res))))) - -#-sb-xc-host -(defun sign-extend (x size) - (declare (type (signed-byte 64) x)) - (ecase size - (8 (sign-extend x size)) - (16 (sign-extend x size)) - (32 (sign-extend x size)))) - -(define-vop (foreign-symbol-sap) - (:translate foreign-symbol-sap) - (:policy :fast-safe) - (:args) - (:arg-types (:constant simple-string)) - (:info foreign-symbol) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst li (make-fixup foreign-symbol :foreign) res))) - -(define-vop (call-out) - (:args (function :scs (sap-reg) :target cfunc) - (args :more t)) - (:results (results :more t)) - (:ignore args results) - (:save-p t) - (:temporary (:sc any-reg :offset cfunc-offset - :from (:argument 0) :to (:result 0)) cfunc) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:generator 0 - (let ((cur-nfp (sb-c:current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move function cfunc) - (inst li (make-fixup "call_into_c" :foreign) temp) - (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign)) - (when cur-nfp - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))) - -(define-vop (alloc-number-stack-space) - (:info amount) - (:results (result :scs (sap-reg any-reg))) - (:result-types system-area-pointer) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst lda nsp-tn (- delta) nsp-tn)) - (t - (inst li delta temp) - (inst subq nsp-tn temp nsp-tn))))) - (move nsp-tn result))) - -(define-vop (dealloc-number-stack-space) - (:info amount) - (:policy :fast-safe) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst lda nsp-tn delta nsp-tn)) - (t - (inst li delta temp) - (inst addq nsp-tn temp nsp-tn))))))) diff -Nru sbcl-2.0.6/src/compiler/alpha/cell.lisp sbcl-2.1.1/src/compiler/alpha/cell.lisp --- sbcl-2.0.6/src/compiler/alpha/cell.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/cell.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,632 +0,0 @@ -;;;; the VM definition of various primitive memory access VOPs for the -;;;; Alpha - -;;;; 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") - -;;;; data object ref/set stuff - -(define-vop (slot) - (:args (object :scs (descriptor-reg))) - (:info name offset lowtag) - (:ignore name) - (:results (result :scs (descriptor-reg any-reg))) - (:generator 1 - (loadw result object offset lowtag))) - -(define-vop (set-slot) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg null zero))) - (:info name offset lowtag #+gengc remember) - (:ignore name) - (:results) - (:generator 1 - #+gengc - (if remember - (storew-and-remember-slot value object offset lowtag) - (storew value object offset lowtag)) - #-gengc - (storew value object offset lowtag))) - -(define-vop (init-slot set-slot) - (:info name dx-p offset lowtag) - (:ignore name dx-p)) - -;;;; symbol hacking VOPs - -;;; The compiler likes to be able to directly SET symbols. -(define-vop (set cell-set) - (:variant symbol-value-slot other-pointer-lowtag)) - -;;; Do a cell ref with an error check for being unbound. -(define-vop (checked-cell-ref) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) - -;;; With SYMBOL-VALUE, we check that the value isn't the trap object. -;;; So SYMBOL-VALUE of NIL is NIL. -(define-vop (symbol-value checked-cell-ref) - (:translate symeval) - (:generator 9 - (move object obj-temp) - (loadw value obj-temp symbol-value-slot other-pointer-lowtag) - (let ((err-lab (generate-error-code vop 'unbound-symbol-error obj-temp))) - (inst xor value unbound-marker-widetag temp) - (inst beq temp err-lab)))) - -;;; 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) - (:temporary (:scs (non-descriptor-reg)) temp)) - -(define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst xor value unbound-marker-widetag temp) - (if not-p - (inst beq temp target) - (inst bne temp target)))) - -(define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-lowtag) - (:policy :fast) - (:translate symeval)) - -(define-vop (symbol-hash) - (:policy :fast-safe) - (:translate symbol-hash) - (:args (symbol :scs (descriptor-reg))) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:generator 2 - ;; The symbol-hash slot of NIL holds NIL because it is also the - ;; cdr slot, so we have to strip off the two low bits 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 res symbol symbol-hash-slot other-pointer-lowtag) - (inst bic res #.(ash lowtag-mask -1) res))) - -;;; On unithreaded builds these are just copies of the non-global versions. -(define-vop (%set-symbol-global-value set)) -(define-vop (symbol-global-value symbol-value) - (:translate sym-global-val)) -(define-vop (fast-symbol-global-value fast-symbol-value) - (:translate sym-global-val)) - -;;;; fdefinition (FDEFN) objects - -(define-vop (fdefn-fun cell-ref) - (:variant fdefn-fun-slot other-pointer-lowtag)) - -(define-vop (safe-fdefn-fun) - (:translate safe-fdefn-fun) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 10 - (move object obj-temp) - (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag) - (let ((err-lab (generate-error-code vop 'undefined-fun-error obj-temp))) - (inst cmpeq value null-tn temp) - (inst bne temp err-lab)))) - -(define-vop (set-fdefn-fun) - (:policy :fast-safe) - (:translate (setf fdefn-fun)) - (:args (function :scs (descriptor-reg) :target result) - (fdefn :scs (descriptor-reg))) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg)) type) - (:results (result :scs (descriptor-reg))) - (:generator 38 - (let ((normal-fn (gen-label))) - (load-type type function (- fun-pointer-lowtag)) - (inst xor type simple-fun-widetag type) - (inst addq function - (- (ash simple-fun-insts-offset word-shift) fun-pointer-lowtag) - lip) - (inst beq type normal-fn) - (inst li (make-fixup 'closure-tramp :assembly-routine) lip) - (emit-label normal-fn) - (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) - (storew function fdefn fdefn-fun-slot other-pointer-lowtag) - (move function result)))) - - -(define-vop (fdefn-makunbound) - (:policy :fast-safe) - (:translate fdefn-makunbound) - (:args (fdefn :scs (descriptor-reg) :target result)) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 38 - (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag) - (inst li (make-fixup 'undefined-tramp :assembly-routine) temp) - (move fdefn result) - (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag))) - -;;;; binding and Unbinding - -;;; Establish VAL as a binding for SYMBOL. Save the old value and the -;;; symbol on the binding stack and stuff the new value into the symbol. -;;; -;;; See the "Chapter 9: Specials" of the SBCL Internals Manual. - -(define-vop (dynbind) - (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:generator 5 - (loadw temp symbol symbol-value-slot other-pointer-lowtag) - (inst addq bsp-tn (* 2 n-word-bytes) bsp-tn) - (storew temp bsp-tn (- binding-value-slot binding-size)) - (storew symbol bsp-tn (- binding-symbol-slot binding-size)) - (#+gengc storew-and-remember-slot #-gengc storew - val symbol symbol-value-slot other-pointer-lowtag))) - - -(define-vop (unbind) - (:temporary (:scs (descriptor-reg)) symbol value) - (:generator 0 - (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) - (loadw value bsp-tn (- binding-value-slot binding-size)) - (#+gengc storew-and-remember-slot #-gengc storew - value symbol symbol-value-slot other-pointer-lowtag) - (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) - (storew zero-tn bsp-tn (- binding-value-slot binding-size)) - (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn))) - - -(define-vop (unbind-to-here) - (:args (arg :scs (descriptor-reg any-reg) :target where)) - (:temporary (:scs (any-reg) :from (:argument 0)) where) - (:temporary (:scs (descriptor-reg)) symbol value) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 0 - (let ((loop (gen-label)) - (skip (gen-label)) - (done (gen-label))) - (move arg where) - (inst cmpeq where bsp-tn temp) - (inst bne temp done) - - (emit-label loop) - (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) - (loadw value bsp-tn (- binding-value-slot binding-size)) - (inst beq symbol skip) - (#+gengc storew-and-remember-slot #-gengc storew - value symbol symbol-value-slot other-pointer-lowtag) - (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) - - (emit-label skip) - (storew zero-tn bsp-tn (- binding-value-slot binding-size)) - (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn) - (inst cmpeq where bsp-tn temp) - (inst beq temp loop) - - (emit-label done)))) - -;;;; closure indexing - -(define-full-reffer closure-index-ref * - 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 zero) * %set-funcallable-instance-info) - -(define-full-reffer funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (descriptor-reg any-reg) * %funcallable-instance-info) - -(define-vop (closure-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:info offset) - (:generator 4 - (loadw value object (+ closure-info-offset offset) fun-pointer-lowtag))) - -(define-vop (closure-init) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:info offset) - (:generator 4 - (storew value object (+ closure-info-offset offset) fun-pointer-lowtag))) - -(define-vop (closure-init-from-fp) - (:args (object :scs (descriptor-reg))) - (:info offset) - (:generator 4 - (storew cfp-tn object (+ closure-info-offset offset) fun-pointer-lowtag))) - -;;;; value cell hackery - -(define-vop (value-cell-ref cell-ref) - (:variant value-cell-value-slot other-pointer-lowtag)) - -(define-vop (value-cell-set cell-set) - (:variant value-cell-value-slot other-pointer-lowtag)) - -;;;; instance hackery - -(define-vop () - (:policy :fast-safe) - (:translate %instance-length) - (:args (struct :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 4 - (loadw res struct 0 instance-pointer-lowtag) - (inst srl res instance-length-shift res))) - -(define-full-reffer instance-index-ref * instance-slots-offset - instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref) - -(define-full-setter instance-index-set * instance-slots-offset - instance-pointer-lowtag (descriptor-reg any-reg null zero) * %instance-set) - -;;;; code object frobbing - -(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 zero) * code-header-set) - -;;;; mutator accessing - -#+gengc -(progn - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; SBCL has never had GENGC. Now that we have Alpha support, it - ;; would probably be nice to restore GENGC support so that the Alpha - ;; doesn't have to crawl along with stop'n'copy. When we do, the CMU - ;; CL code below will need updating to the SBCL way of looking at - ;; things, e.g. at least using "SB-KERNEL" or "SB-KERNEL" instead of - ;; :KERNEL. -- WHN 2001-05-08 - (error "This code is stale as of sbcl-0.6.12.")) - -(define-vop (mutator-ub32-ref) - (:policy :fast-safe) - (:args) - (:results (res :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant-vars slot) - (:generator 2 - (loadw res mutator-tn slot))) - -(define-vop (mutator-descriptor-ref mutator-ub32-ref) - (:results (res :scs (any-reg descriptor-reg))) - (:result-types *)) - -(define-vop (mutator-sap-ref mutator-ub32-ref) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer)) - - -(define-vop (mutator-ub32-set) - (:policy :fast-safe) - (:args (arg :scs (unsigned-reg) :target res)) - (:arg-types unsigned-num) - (:results (res :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant-vars slot) - (:generator 2 - (storew arg mutator-tn slot) - (move res arg))) - -(define-vop (mutator-descriptor-set mutator-ub32-set) - (:args (arg :scs (any-reg descriptor-reg null zero) :target res)) - (:arg-types *) - (:results (res :scs (any-reg descriptor-reg))) - (:result-types *)) - -(define-vop (mutator-sap-set mutator-ub32-set) - (:args (arg :scs (sap-reg) :target res)) - (:arg-types system-area-pointer) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer)) - - -(macrolet ((define-mutator-accessors (slot type writable) - (let ((ref (symbolicate "MUTATOR-" slot "-REF")) - (set (and writable (symbolicate "MUTATOR-" slot "-SET"))) - (offset (symbolicate "MUTATOR-" slot "-SLOT")) - (fn - (let ((*package* (find-package :kernel))) - (symbolicate "MUTATOR-" slot)))) - (multiple-value-bind - (lisp-type ref-vop set-vop) - (ecase type - (:des - (values t - 'mutator-descriptor-ref - 'mutator-descriptor-set)) - (:ub32 - (values '(unsigned-byte 32) - 'mutator-ub32-ref - 'mutator-ub32-set)) - (:sap - (values 'system-area-pointer - 'mutator-sap-ref - 'mutator-sap-set))) - `(progn - (export ',fn :kernel) - (defknown ,fn () ,lisp-type (flushable)) - (define-vop (,ref ,ref-vop) - (:translate ,fn) - (:variant ,offset)) - ,@(when writable - `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type - ()) - (define-vop (,set ,set-vop) - (:translate (setf ,fn)) - (:variant ,offset))))))))) - (define-mutator-accessors thread :des t) - (define-mutator-accessors suspends-disabled-count :ub32 t) - (define-mutator-accessors suspend-pending :ub32 t) - (define-mutator-accessors control-stack-base :sap nil) - (define-mutator-accessors control-stack-end :sap nil) - (define-mutator-accessors current-unwind-protect :sap nil) - (define-mutator-accessors current-catch-block :sap nil) - (define-mutator-accessors binding-stack-base :sap nil) - (define-mutator-accessors binding-stack-end :sap nil) - (define-mutator-accessors number-stack-base :sap nil) - (define-mutator-accessors number-stack-end :sap nil) - (define-mutator-accessors nursery-start :sap nil) - (define-mutator-accessors nursery-end :sap nil) - (define-mutator-accessors storebuf-start :sap nil) - (define-mutator-accessors storebuf-end :sap nil) - (define-mutator-accessors words-consed :ub32 nil)) - -); #+gengc progn - - - -;;;; raw instance slot accessors - -(macrolet ((def (signedp sc result-type) - `(progn - (define-vop () - (:translate ,(symbolicate "%RAW-INSTANCE-REF/" signedp "WORD")) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types * positive-fixnum) - (:results (value :scs (,sc))) - (:temporary (:scs (interior-reg)) lip) - (:result-types ,result-type) - (:generator 5 - (inst addq object index lip) - (inst ldl - value - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) - (inst mskll value 4 value))) - - (define-vop (raw-instance-set/word) - (:translate ,(symbolicate "%RAW-INSTANCE-SET/" signedp "WORD")) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (,sc))) - (:arg-types * positive-fixnum ,result-type) - (:results (result :scs (,sc))) - (:temporary (:scs (interior-reg)) lip) - (:result-types ,result-type) - (:generator 5 - (inst addq object index lip) - (inst stl - value - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) - (move value result)))))) - (def "" unsigned-reg unsigned-num) - (def "SIGNED-" signed-reg signed-num)) - -(define-vop (raw-instance-ref/single) - (:translate %raw-instance-ref/single) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types * positive-fixnum) - (:results (value :scs (single-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types single-float) - (:generator 5 - (inst addq object index lip) - (inst lds - value - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip))) - -(define-vop (raw-instance-set/single) - (:translate %raw-instance-set/single) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (single-reg))) - (:arg-types * positive-fixnum single-float) - (:results (result :scs (single-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types single-float) - (:generator 5 - (inst addq object index lip) - (inst sts - value - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) - (unless (location= result value) - (inst fmove value result)))) - -(define-vop (raw-instance-ref/double) - (:translate %raw-instance-ref/double) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types * positive-fixnum) - (:results (value :scs (double-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types double-float) - (:generator 5 - (inst addq object index lip) - (inst ldt - value - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip))) - -(define-vop (raw-instance-set/double) - (:translate %raw-instance-set/double) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (double-reg))) - (:arg-types * positive-fixnum double-float) - (:results (result :scs (double-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types double-float) - (:generator 5 - (inst addq object index lip) - (inst stt - value - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) - (unless (location= result value) - (inst fmove value result)))) - -(define-vop (raw-instance-ref/complex-single) - (:translate %raw-instance-ref/complex-single) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types * positive-fixnum) - (:results (value :scs (complex-single-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types complex-single-float) - (:generator 5 - (inst addq object index lip) - (inst lds - (complex-double-reg-real-tn value) - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) - (inst lds - (complex-double-reg-imag-tn value) - (- (* (1+ instance-slots-offset) n-word-bytes) - instance-pointer-lowtag) - lip))) - -(define-vop (raw-instance-set/complex-single) - (:translate %raw-instance-set/complex-single) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (complex-single-reg))) - (:arg-types * positive-fixnum complex-single-float) - (:results (result :scs (complex-single-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types complex-single-float) - (:generator 5 - (inst addq object index lip) - (let ((value-real (complex-single-reg-real-tn value)) - (result-real (complex-single-reg-real-tn result))) - (inst sts - value-real - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) - (unless (location= result-real value-real) - (inst fmove value-real result-real))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) - (inst sts - value-imag - (- (* (1+ instance-slots-offset) n-word-bytes) - instance-pointer-lowtag) - lip) - (unless (location= result-imag value-imag) - (inst fmove value-imag result-imag))))) - -(define-vop (raw-instance-ref/complex-double) - (:translate %raw-instance-ref/complex-double) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types * positive-fixnum) - (:results (value :scs (complex-double-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types complex-double-float) - (:generator 5 - (inst addq object index lip) - (inst ldt - (complex-double-reg-real-tn value) - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) - (inst ldt - (complex-double-reg-imag-tn value) - (- (* (+ instance-slots-offset 2) n-word-bytes) - instance-pointer-lowtag) - lip))) - -(define-vop (raw-instance-set/complex-double) - (:translate %raw-instance-set/complex-double) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (complex-double-reg))) - (:arg-types * positive-fixnum complex-double-float) - (:results (result :scs (complex-double-reg))) - (:temporary (:scs (interior-reg)) lip) - (:result-types complex-double-float) - (:generator 5 - (inst addq object index lip) - (let ((value-real (complex-double-reg-real-tn value)) - (result-real (complex-double-reg-real-tn result))) - (inst stt - value-real - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) - (unless (location= result-real value-real) - (inst fmove value-real result-real))) - (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) - (inst stt - value-imag - (- (* (+ instance-slots-offset 2) n-word-bytes) - instance-pointer-lowtag) - lip) - (unless (location= result-imag value-imag) - (inst fmove value-imag result-imag))))) diff -Nru sbcl-2.0.6/src/compiler/alpha/char.lisp sbcl-2.1.1/src/compiler/alpha/char.lisp --- sbcl-2.0.6/src/compiler/alpha/char.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/char.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,155 +0,0 @@ -;;;; the Alpha VM definition of character operations - -;;;; 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") - -;;;; moves and coercions - -;;; Move a tagged char to an untagged representation. -(define-vop (move-to-character) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (character-reg))) - (:generator 1 - (inst srl x n-widetag-bits y))) -(define-move-vop move-to-character :move - (any-reg descriptor-reg) (character-reg)) - -;;; Move an untagged char to a tagged representation. -(define-vop (move-from-character) - (:args (x :scs (character-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:generator 1 - (inst sll x n-widetag-bits y) - (inst bis y character-widetag y))) -(define-move-vop move-from-character :move - (character-reg) (any-reg descriptor-reg)) - -;;; Move untagged character values. -(define-vop (character-move) - (:args (x :target y - :scs (character-reg) - :load-if (not (location= x y)))) - (:results (y :scs (character-reg) - :load-if (not (location= x y)))) - (:generator 0 - (move x y))) -(define-move-vop character-move :move - (character-reg) (character-reg)) - -;;; Move untagged character arguments/return-values. -(define-vop (move-character-arg) - (:args (x :target y - :scs (character-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y character-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (character-reg - (move x y)) - (character-stack - (storew x fp (tn-offset y)))))) -(define-move-vop move-character-arg :move-arg - (any-reg character-reg) (character-reg)) - -;;; Use standard MOVE-ARG + coercion to move an untagged character -;;; to a descriptor passing location. -;;; -(define-move-vop move-arg :move-arg - (character-reg) (any-reg descriptor-reg)) - -;;;; other operations -(define-vop (char-code) - (:translate char-code) - (:policy :fast-safe) - (:args (ch :scs (character-reg) :target res)) - (:arg-types character) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:generator 1 - (inst sll ch n-fixnum-tag-bits res))) - -(define-vop (code-char) - (:translate code-char) - (:policy :fast-safe) - (:args (code :scs (any-reg) :target res)) - (:arg-types positive-fixnum) - (:results (res :scs (character-reg))) - (:result-types character) - (:generator 1 - (inst srl code n-fixnum-tag-bits res))) - -;;;; comparison of CHARACTERs - -(define-vop (character-compare) - (:args (x :scs (character-reg)) - (y :scs (character-reg))) - (:arg-types character character) - (:temporary (:scs (non-descriptor-reg)) temp) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:note "inline comparison") - (:variant-vars cond) - (:generator 3 - (ecase cond - (:eq (inst cmpeq x y temp)) - (:lt (inst cmplt x y temp)) - (:gt (inst cmplt y x temp))) - (if not-p - (inst beq temp target) - (inst bne temp target)))) - -(define-vop (fast-char=/character character-compare) - (:translate char=) - (:variant :eq)) - -(define-vop (fast-char/character character-compare) - (:translate char>) - (:variant :gt)) - -(define-vop (character-compare/c) - (:args (x :scs (character-reg))) - (:arg-types character (:constant (character-set ((0 . #xFF))))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:conditional) - (:info target not-p y) - (:policy :fast-safe) - (:note "inline constant comparison") - (:variant-vars cond) - (:generator 2 - (ecase cond - (:eq (inst cmpeq x (sb-xc:char-code y) temp)) - (:lt (inst cmplt x (sb-xc:char-code y) temp)) - (:gt (inst cmple x (sb-xc:char-code y) temp))) - (if not-p - (if (eq cond :gt) - (inst bne temp target) - (inst beq temp target)) - (if (eq cond :gt) - (inst beq temp target) - (inst bne temp target))))) - -(define-vop (fast-char=/character/c character-compare/c) - (:translate char=) - (:variant :eq)) - -(define-vop (fast-char/character/c character-compare/c) - (:translate char>) - (:variant :gt)) diff -Nru sbcl-2.0.6/src/compiler/alpha/debug.lisp sbcl-2.1.1/src/compiler/alpha/debug.lisp --- sbcl-2.0.6/src/compiler/alpha/debug.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/debug.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,118 +0,0 @@ -;;;; Alpha compiler support for the new whizzy debugger - -;;;; 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") - -(define-vop () - (:translate current-sp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move csp-tn res))) - -(define-vop () - (:translate current-fp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move cfp-tn res))) - -(define-vop () - (:translate stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg))) - (:arg-types system-area-pointer positive-fixnum) - (:temporary (:scs (sap-reg) :from :eval) sap) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 5 - (inst addq object offset sap) - (inst ldl result 0 sap))) - -(define-vop () - (:translate %set-stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg)) - (value :scs (descriptor-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:temporary (:scs (sap-reg) :from (:argument 1)) sap) - (:generator 2 - (inst addq object offset sap) - (inst stl value 0 sap) - (move value result))) - -(define-vop (code-from-mumble) - (:policy :fast-safe) - (:args (thing :scs (descriptor-reg))) - (:results (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:variant-vars lowtag) - (:generator 5 - (let ((bogus (gen-label)) - (done (gen-label))) - (loadw temp thing 0 lowtag) - (inst srl temp n-widetag-bits temp) - (inst beq temp bogus) - (inst sll temp word-shift temp) - (unless (= lowtag other-pointer-lowtag) - (inst subq temp (- other-pointer-lowtag lowtag) temp)) - (inst subq thing temp code) - (emit-label done) - (assemble (:elsewhere) - (emit-label bogus) - (move null-tn code) - (inst br zero-tn done))))) - -(define-vop (code-from-lra code-from-mumble) - (:translate lra-code-header) - (:variant other-pointer-lowtag)) - -(define-vop (code-from-function code-from-mumble) - (:translate fun-code-header) - (:variant fun-pointer-lowtag)) - -(define-vop (%make-lisp-obj) - (:policy :fast-safe) - (:translate %make-lisp-obj) - (:args (value :scs (unsigned-reg) :target result)) - (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 1 - (move value result))) - -(define-vop (get-lisp-obj-address) - (:policy :fast-safe) - (:translate get-lisp-obj-address) - (:args (thing :scs (descriptor-reg any-reg) :target result)) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (move thing result))) - -(defknown make-number-stack-pointer ((unsigned-byte 32)) system-area-pointer - (movable foldable flushable)) - -(define-vop (make-number-stack-pointer) - (:policy :fast-safe) - (:translate make-number-stack-pointer) - (:args (arg :scs (unsigned-reg) :to (:argument 1))) - (:arg-types unsigned-num) - (:results (res :scs (sap-reg) :from (:argument 0))) - (:result-types system-area-pointer) - (:generator 5 - (inst mskll nsp-tn 0 res) - (inst bis res arg res))) diff -Nru sbcl-2.0.6/src/compiler/alpha/float.lisp sbcl-2.1.1/src/compiler/alpha/float.lisp --- sbcl-2.0.6/src/compiler/alpha/float.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/float.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,865 +0,0 @@ -;;;; floating point support for the Alpha - -;;;; 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") - -;;;; float move functions - -(define-move-fun (load-fp-zero 1) (vop x y) - ((fp-single-zero) (single-reg) - (fp-double-zero) (double-reg)) - (inst fmove x y)) - -(define-move-fun (load-single 1) (vop x y) - ((single-stack) (single-reg)) - (inst lds y (tn-byte-offset x) (current-nfp-tn vop))) - -(define-move-fun (store-single 1) (vop x y) - ((single-reg) (single-stack)) - (inst sts x (tn-byte-offset y) (current-nfp-tn vop))) - -(define-move-fun (load-double 2) (vop x y) - ((double-stack) (double-reg)) - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset x))) - (inst ldt y offset nfp))) - -(define-move-fun (store-double 2) (vop x y) - ((double-reg) (double-stack)) - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset y))) - (inst stt x offset nfp))) - -;;;; float move VOPs - -(macrolet ((frob (vop sc) - `(progn - (define-vop (,vop) - (:args (x :scs (,sc) - :target y - :load-if (not (location= x y)))) - (:results (y :scs (,sc) - :load-if (not (location= x y)))) - (:note "float move") - (:generator 0 - (unless (location= y x) - (inst fmove x y)))) - (define-move-vop ,vop :move (,sc) (,sc))))) - (frob single-move single-reg) - (frob double-move double-reg)) - - -(define-vop (move-from-float) - (:args (x :to :save)) - (:results (y)) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:variant-vars double-p size type data) - (:note "float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y ndescr type size) - (if double-p - (inst stt x (- (* data n-word-bytes) other-pointer-lowtag) y) - (inst sts x (- (* data n-word-bytes) other-pointer-lowtag) y))))) - -(macrolet ((frob (name sc &rest args) - `(progn - (define-vop (,name move-from-float) - (:args (x :scs (,sc) :to :save)) - (:results (y :scs (descriptor-reg))) - (:variant ,@args)) - (define-move-vop ,name :move (,sc) (descriptor-reg))))) - (frob move-from-single single-reg - nil single-float-size single-float-widetag single-float-value-slot) - (frob move-from-double double-reg - t double-float-size double-float-widetag double-float-value-slot)) - -(macrolet ((frob (name sc double-p value) - `(progn - (define-vop (,name) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (,sc))) - (:note "pointer to float coercion") - (:generator 2 - ,@(if double-p - `((inst ldt y (- (* ,value n-word-bytes) - other-pointer-lowtag) - x)) - `((inst lds y (- (* ,value n-word-bytes) - other-pointer-lowtag) - x))))) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-single single-reg nil single-float-value-slot) - (frob move-to-double double-reg t double-float-value-slot)) - - -(macrolet ((frob (name sc stack-sc double-p) - `(progn - (define-vop (,name) - (:args (x :scs (,sc) :target y) - (nfp :scs (any-reg) - :load-if (not (sc-is y ,sc)))) - (:results (y)) - (:note "float argument move") - (:generator ,(if double-p 2 1) - (sc-case y - (,sc - (unless (location= x y) - (inst fmove x y))) - (,stack-sc - (let ((offset (tn-byte-offset y))) - ,@(if double-p - '((inst stt x offset nfp)) - '((inst sts x offset nfp)))))))) - (define-move-vop ,name :move-arg - (,sc descriptor-reg) (,sc))))) - (frob move-single-float-arg single-reg single-stack nil) - (frob move-double-float-arg double-reg double-stack t)) - -;;;; complex float move functions - -(defun complex-single-reg-real-tn (x) - (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg ) - :offset (tn-offset x))) -(defun complex-single-reg-imag-tn (x) - (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg ) - :offset (1+ (tn-offset x)))) - -(defun complex-double-reg-real-tn (x) - (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg ) - :offset (tn-offset x))) -(defun complex-double-reg-imag-tn (x) - (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg ) - :offset (1+ (tn-offset x)))) - - -(define-move-fun (load-complex-single 2) (vop x y) - ((complex-single-stack) (complex-single-reg)) - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset x))) - (let ((real-tn (complex-single-reg-real-tn y))) - (inst lds real-tn offset nfp)) - (let ((imag-tn (complex-single-reg-imag-tn y))) - (inst lds imag-tn (+ offset n-word-bytes) nfp)))) - -(define-move-fun (store-complex-single 2) (vop x y) - ((complex-single-reg) (complex-single-stack)) - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset y))) - (let ((real-tn (complex-single-reg-real-tn x))) - (inst sts real-tn offset nfp)) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (inst sts imag-tn (+ offset n-word-bytes) nfp)))) - - -(define-move-fun (load-complex-double 4) (vop x y) - ((complex-double-stack) (complex-double-reg)) - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset x))) - (let ((real-tn (complex-double-reg-real-tn y))) - (inst ldt real-tn offset nfp)) - (let ((imag-tn (complex-double-reg-imag-tn y))) - (inst ldt imag-tn (+ offset (* 2 n-word-bytes)) nfp)))) - -(define-move-fun (store-complex-double 4) (vop x y) - ((complex-double-reg) (complex-double-stack)) - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset y))) - (let ((real-tn (complex-double-reg-real-tn x))) - (inst stt real-tn offset nfp)) - (let ((imag-tn (complex-double-reg-imag-tn x))) - (inst stt imag-tn (+ offset (* 2 n-word-bytes)) nfp)))) - -;;; -;;; complex float register to register moves. -;;; -(define-vop (complex-single-move) - (:args (x :scs (complex-single-reg) :target y - :load-if (not (location= x y)))) - (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) - (:note "complex single float move") - (:generator 0 - (unless (location= x y) - ;; Note the complex-float-regs are aligned to every second - ;; float register so there is not need to worry about overlap. - (let ((x-real (complex-single-reg-real-tn x)) - (y-real (complex-single-reg-real-tn y))) - (inst fmove x-real y-real)) - (let ((x-imag (complex-single-reg-imag-tn x)) - (y-imag (complex-single-reg-imag-tn y))) - (inst fmove x-imag y-imag))))) -;;; -(define-move-vop complex-single-move :move - (complex-single-reg) (complex-single-reg)) - -(define-vop (complex-double-move) - (:args (x :scs (complex-double-reg) - :target y :load-if (not (location= x y)))) - (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) - (:note "complex double float move") - (:generator 0 - (unless (location= x y) - ;; Note the complex-float-regs are aligned to every second - ;; float register so there is not need to worry about overlap. - (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (inst fmove x-real y-real)) - (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst fmove x-imag y-imag))))) -;;; -(define-move-vop complex-double-move :move - (complex-double-reg) (complex-double-reg)) - -;;; -;;; Move from a complex float to a descriptor register allocating a -;;; new complex float object in the process. -;;; -(define-vop (move-from-complex-single) - (:args (x :scs (complex-single-reg) :to :save)) - (:results (y :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:note "complex single float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y ndescr complex-single-float-widetag - complex-single-float-size) - (let ((real-tn (complex-single-reg-real-tn x))) - (inst sts real-tn (- (* complex-single-float-real-slot - n-word-bytes) - other-pointer-lowtag) - y)) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (inst sts imag-tn (- (* complex-single-float-imag-slot - n-word-bytes) - other-pointer-lowtag) - y))))) -;;; -(define-move-vop move-from-complex-single :move - (complex-single-reg) (descriptor-reg)) - -(define-vop (move-from-complex-double) - (:args (x :scs (complex-double-reg) :to :save)) - (:results (y :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:note "complex double float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y ndescr complex-double-float-widetag - complex-double-float-size) - (let ((real-tn (complex-double-reg-real-tn x))) - (inst stt real-tn (- (* complex-double-float-real-slot - n-word-bytes) - other-pointer-lowtag) - y)) - (let ((imag-tn (complex-double-reg-imag-tn x))) - (inst stt imag-tn (- (* complex-double-float-imag-slot - n-word-bytes) - other-pointer-lowtag) - y))))) -;;; -(define-move-vop move-from-complex-double :move - (complex-double-reg) (descriptor-reg)) - -;;; -;;; Move from a descriptor to a complex float register. -;;; -(define-vop (move-to-complex-single) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (complex-single-reg))) - (:note "pointer to complex float coercion") - (:generator 2 - (let ((real-tn (complex-single-reg-real-tn y))) - (inst lds real-tn (- (* complex-single-float-real-slot - n-word-bytes) - other-pointer-lowtag) - x)) - (let ((imag-tn (complex-single-reg-imag-tn y))) - (inst lds imag-tn (- (* complex-single-float-imag-slot - n-word-bytes) - other-pointer-lowtag) - x)))) -(define-move-vop move-to-complex-single :move - (descriptor-reg) (complex-single-reg)) - -(define-vop (move-to-complex-double) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (complex-double-reg))) - (:note "pointer to complex float coercion") - (:generator 2 - (let ((real-tn (complex-double-reg-real-tn y))) - (inst ldt real-tn (- (* complex-double-float-real-slot - n-word-bytes) - other-pointer-lowtag) - x)) - (let ((imag-tn (complex-double-reg-imag-tn y))) - (inst ldt imag-tn (- (* complex-double-float-imag-slot - n-word-bytes) - other-pointer-lowtag) - x)))) -(define-move-vop move-to-complex-double :move - (descriptor-reg) (complex-double-reg)) - -;;; -;;; complex float MOVE-ARG VOP -;;; -(define-vop (move-complex-single-float-arg) - (:args (x :scs (complex-single-reg) :target y) - (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) - (:results (y)) - (:note "complex single float argument move") - (:generator 1 - (sc-case y - (complex-single-reg - (unless (location= x y) - (let ((x-real (complex-single-reg-real-tn x)) - (y-real (complex-single-reg-real-tn y))) - (inst fmove x-real y-real)) - (let ((x-imag (complex-single-reg-imag-tn x)) - (y-imag (complex-single-reg-imag-tn y))) - (inst fmove x-imag y-imag)))) - (complex-single-stack - (let ((offset (tn-byte-offset y))) - (let ((real-tn (complex-single-reg-real-tn x))) - (inst sts real-tn offset nfp)) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (inst sts imag-tn (+ offset n-word-bytes) nfp))))))) -(define-move-vop move-complex-single-float-arg :move-arg - (complex-single-reg descriptor-reg) (complex-single-reg)) - -(define-vop (move-complex-double-float-arg) - (:args (x :scs (complex-double-reg) :target y) - (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) - (:results (y)) - (:note "complex double float argument move") - (:generator 2 - (sc-case y - (complex-double-reg - (unless (location= x y) - (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (inst fmove x-real y-real)) - (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst fmove x-imag y-imag)))) - (complex-double-stack - (let ((offset (tn-byte-offset y))) - (let ((real-tn (complex-double-reg-real-tn x))) - (inst stt real-tn offset nfp)) - (let ((imag-tn (complex-double-reg-imag-tn x))) - (inst stt imag-tn (+ offset (* 2 n-word-bytes)) nfp))))))) -(define-move-vop move-complex-double-float-arg :move-arg - (complex-double-reg descriptor-reg) (complex-double-reg)) - - -(define-move-vop move-arg :move-arg - (single-reg double-reg complex-single-reg complex-double-reg) - (descriptor-reg)) - - -;;;; float arithmetic VOPs - -(define-vop (float-op) - (:args (x) (y)) - (:results (r)) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only)) - -;;; We need to insure that ops that can cause traps do not clobber an -;;; argument register with invalid results. This so the software trap -;;; handler can re-execute the instruction and produce correct IEEE -;;; result. The :from :load hopefully does that. -(macrolet ((frob (name sc ptype) - `(define-vop (,name float-op) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:results (r :scs (,sc) :from :load)) - (:arg-types ,ptype ,ptype) - (:result-types ,ptype)))) - (frob single-float-op single-reg single-float) - (frob double-float-op double-reg double-float)) - -;; This is resumption-safe with underflow traps enabled, -;; with software handling and (notyet) dynamic rounding mode. -(macrolet ((frob (op sinst sname scost dinst dname dcost) - `(progn - (define-vop (,sname single-float-op) - (:translate ,op) - (:variant-cost ,scost) - (:generator ,scost - (inst ,sinst x y r) - (note-this-location vop :internal-error) - (inst trapb))) - (define-vop (,dname double-float-op) - (:translate ,op) - (:variant-cost ,dcost) - (:generator ,dcost - (inst ,dinst x y r) - (note-this-location vop :internal-error) - (inst trapb)))))) - ;; Not sure these cost number are right. +*- about same / is 4x - (frob + adds_su +/single-float 1 addt_su +/double-float 1) - (frob - subs_su -/single-float 1 subt_su -/double-float 1) - (frob * muls_su */single-float 1 mult_su */double-float 1) - (frob / divs_su //single-float 4 divt_su //double-float 4)) - -(macrolet ((frob (name inst translate sc type) - `(define-vop (,name) - (:args (x :scs (,sc) :target y)) - (:results (y :scs (,sc))) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (note-this-location vop :internal-error) - (inst ,inst x y))))) - (frob abs/single-float fabs abs single-reg single-float) - (frob abs/double-float fabs abs double-reg double-float) - (frob %negate/single-float fneg %negate single-reg single-float) - (frob %negate/double-float fneg %negate double-reg double-float)) - - -;;;; float comparison - -(define-vop (float-compare) - (:args (x) (y)) - (:conditional) - (:info target not-p) - (:variant-vars eq complement) - (:temporary (:scs (single-reg)) temp) - (:policy :fast-safe) - (:note "inline float comparison") - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (note-this-location vop :internal-error) - (inst cmptun x y temp) - (inst fbne temp (if not-p target fall-through)) - (if eq - (inst cmpteq x y temp) - (if complement - (inst cmptle x y temp) - (inst cmptlt x y temp))) - (inst trapb) - (if (if complement (not not-p) not-p) - (inst fbeq temp target) - (inst fbne temp target)) - FALL-THROUGH)) - -(macrolet ((frob (name sc ptype) - `(define-vop (,name float-compare) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:arg-types ,ptype ,ptype)))) - (frob single-float-compare single-reg single-float) - (frob double-float-compare double-reg double-float)) - -(macrolet ((frob (translate complement sname dname eq) - `(progn - (define-vop (,sname single-float-compare) - (:translate ,translate) - (:variant ,eq ,complement)) - (define-vop (,dname double-float-compare) - (:translate ,translate) - (:variant ,eq ,complement))))) - (frob < nil t >/single-float >/double-float nil) - (frob = nil =/single-float =/double-float t)) - - -;;;; float conversion - -(macrolet - ((frob (name translate inst ld-inst to-sc to-type) - `(define-vop (,name) - (:args (x :scs (signed-reg) :target temp - :load-if (not (sc-is x signed-stack)))) - (:temporary (:scs (,to-sc)) freg1) - (:temporary (:scs (,to-sc)) freg2) - (:temporary (:scs (single-stack)) temp) - - (:results (y :scs (,to-sc))) - (:arg-types signed-num) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (let ((stack-tn - (sc-case x - (signed-reg - (inst stl x - (* (tn-offset temp) - n-word-bytes) - (current-nfp-tn vop)) - temp) - (signed-stack - x)))) - (inst ,ld-inst freg1 - (tn-byte-offset stack-tn) - (current-nfp-tn vop)) - (note-this-location vop :internal-error) - (inst cvtlq freg1 freg2) - (inst ,inst freg2 y) - (inst excb) - ))))) - (frob %single-float/signed %single-float cvtqs_sui lds single-reg single-float) - (frob %double-float/signed %double-float cvtqt_sui lds double-reg double-float)) - -;;; see previous comment about software trap handlers: also applies here -(macrolet ((frob (name translate inst from-sc from-type to-sc to-type) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (,to-sc) :from :load)) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator 2 - (note-this-location vop :internal-error) - (inst ,inst x y) - (inst excb) - )))) - (frob %single-float/double-float %single-float cvtts_su - double-reg double-float single-reg single-float) - (frob %double-float/single-float %double-float fmove - single-reg single-float double-reg double-float)) - -(macrolet - ((frob (trans from-sc from-type inst &optional single) - (declare (ignorable single)) - `(define-vop (,(symbolicate trans "/" from-type)) - (:args (x :scs (,from-sc) :target temp)) - (:temporary (:from :load ;(:argument 0) - :sc single-reg) temp) - (:temporary (:scs (signed-stack)) stack-temp) - (:results (y :scs (signed-reg) - :load-if (not (sc-is y signed-stack)))) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate ,trans) - (:policy :fast-safe) - (:note "inline float truncate") - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (note-this-location vop :internal-error) - (inst ,inst x temp) - (sc-case y - (signed-stack - (inst stt temp - (tn-byte-offset y) - (current-nfp-tn vop))) - (signed-reg - (inst stt temp - (* (tn-offset stack-temp) - n-word-bytes) - (current-nfp-tn vop)) - (inst ldq y - (tn-byte-offset stack-temp) - (current-nfp-tn vop)))) - (inst excb) - )))) - (frob %unary-truncate/single-float single-reg single-float cvttq/c_sv t) - (frob %unary-truncate/double-float double-reg double-float cvttq/c_sv) - (frob %unary-round single-reg single-float cvttq_sv t) - (frob %unary-round double-reg double-float cvttq_sv)) - -(define-vop (make-single-float) - (:args (bits :scs (signed-reg) :target res - :load-if (not (sc-is bits signed-stack)))) - (:results (res :scs (single-reg) - :load-if (not (sc-is res single-stack)))) - (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (signed-stack)) stack-temp) - (:arg-types signed-num) - (:result-types single-float) - (:translate make-single-float) - (:policy :fast-safe) - (:vop-var vop) - (:generator 4 - (sc-case bits - (signed-reg - (sc-case res - (single-reg - (inst stl bits - (tn-byte-offset stack-temp) - (current-nfp-tn vop)) - (inst lds res - (tn-byte-offset stack-temp) - (current-nfp-tn vop))) - (single-stack - (inst stl bits - (tn-byte-offset res) - (current-nfp-tn vop))))) - (signed-stack - (sc-case res - (single-reg - (inst lds res - (tn-byte-offset bits) - (current-nfp-tn vop))) - (single-stack - (unless (location= bits res) - (inst ldl temp - (tn-byte-offset bits) - (current-nfp-tn vop)) - (inst stl temp - (tn-byte-offset res) - (current-nfp-tn vop))))))))) - -(define-vop (make-double-float) - (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) - (:results (res :scs (double-reg) - :load-if (not (sc-is res double-stack)))) - (:temporary (:scs (double-stack)) temp) - (:arg-types signed-num unsigned-num) - (:result-types double-float) - (:translate make-double-float) - (:policy :fast-safe) - (:vop-var vop) - (:generator 2 - (let ((stack-tn (sc-case res - (double-stack res) - (double-reg temp)))) - (inst stl hi-bits - (* (1+ (tn-offset stack-tn)) n-word-bytes) - (current-nfp-tn vop)) - (inst stl lo-bits - (tn-byte-offset stack-tn) - (current-nfp-tn vop))) - (when (sc-is res double-reg) - (inst ldt res - (tn-byte-offset temp) - (current-nfp-tn vop))))) - -(define-vop (single-float-bits) - (:args (float :scs (single-reg descriptor-reg) - :load-if (not (sc-is float single-stack)))) - (:results (bits :scs (signed-reg) - :load-if (or (sc-is float descriptor-reg single-stack) - (not (sc-is bits signed-stack))))) - (:temporary (:scs (signed-stack)) stack-temp) - (:arg-types single-float) - (:result-types signed-num) - (:translate single-float-bits) - (:policy :fast-safe) - (:vop-var vop) - (:generator 4 - (sc-case bits - (signed-reg - (sc-case float - (single-reg - (inst sts float - (tn-byte-offset stack-temp) - (current-nfp-tn vop)) - (inst ldl bits - (tn-byte-offset stack-temp) - (current-nfp-tn vop))) - (single-stack - (inst ldl bits - (tn-byte-offset float) - (current-nfp-tn vop))) - (descriptor-reg - (loadw bits float single-float-value-slot - other-pointer-lowtag)))) - (signed-stack - (sc-case float - (single-reg - (inst sts float - (tn-byte-offset bits) - (current-nfp-tn vop)))))))) - -(define-vop (double-float-high-bits) - (:args (float :scs (double-reg descriptor-reg) - :load-if (not (sc-is float double-stack)))) - (:results (hi-bits :scs (signed-reg))) - (:temporary (:scs (double-stack)) stack-temp) - (:arg-types double-float) - (:result-types signed-num) - (:translate double-float-high-bits) - (:policy :fast-safe) - (:vop-var vop) - (:generator 5 - (sc-case float - (double-reg - (inst stt float - (tn-byte-offset stack-temp) - (current-nfp-tn vop)) - (inst ldl hi-bits - (* (1+ (tn-offset stack-temp)) n-word-bytes) - (current-nfp-tn vop))) - (double-stack - (inst ldl hi-bits - (* (1+ (tn-offset float)) n-word-bytes) - (current-nfp-tn vop))) - (descriptor-reg - (loadw hi-bits float (1+ double-float-value-slot) - other-pointer-lowtag))))) - -(define-vop (double-float-low-bits) - (:args (float :scs (double-reg descriptor-reg) - :load-if (not (sc-is float double-stack)))) - (:results (lo-bits :scs (unsigned-reg))) - (:temporary (:scs (double-stack)) stack-temp) - (:arg-types double-float) - (:result-types unsigned-num) - (:translate double-float-low-bits) - (:policy :fast-safe) - (:vop-var vop) - (:generator 5 - (sc-case float - (double-reg - (inst stt float - (tn-byte-offset stack-temp) - (current-nfp-tn vop)) - (inst ldl lo-bits - (tn-byte-offset stack-temp) - (current-nfp-tn vop))) - (double-stack - (inst ldl lo-bits - (tn-byte-offset float) - (current-nfp-tn vop))) - (descriptor-reg - (loadw lo-bits float double-float-value-slot - other-pointer-lowtag))) - (inst mskll lo-bits 4 lo-bits))) - - -;;;; float mode hackery has moved to alpha-vm.lisp - - -;;;; complex float VOPs - -(define-vop (make-complex-single-float) - (:translate complex) - (:args (real :scs (single-reg) :target r) - (imag :scs (single-reg) :to :save)) - (:arg-types single-float single-float) - (:results (r :scs (complex-single-reg) :from (:argument 0) - :load-if (not (sc-is r complex-single-stack)))) - (:result-types complex-single-float) - (:note "inline complex single-float creation") - (:policy :fast-safe) - (:vop-var vop) - (:generator 5 - (sc-case r - (complex-single-reg - (let ((r-real (complex-single-reg-real-tn r))) - (unless (location= real r-real) - (inst fmove real r-real))) - (let ((r-imag (complex-single-reg-imag-tn r))) - (unless (location= imag r-imag) - (inst fmove imag r-imag)))) - (complex-single-stack - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset r))) - (inst sts real offset nfp) - (inst sts imag (+ offset n-word-bytes) nfp)))))) - -(define-vop (make-complex-double-float) - (:translate complex) - (:args (real :scs (double-reg) :target r) - (imag :scs (double-reg) :to :save)) - (:arg-types double-float double-float) - (:results (r :scs (complex-double-reg) :from (:argument 0) - :load-if (not (sc-is r complex-double-stack)))) - (:result-types complex-double-float) - (:note "inline complex double-float creation") - (:policy :fast-safe) - (:vop-var vop) - (:generator 5 - (sc-case r - (complex-double-reg - (let ((r-real (complex-double-reg-real-tn r))) - (unless (location= real r-real) - (inst fmove real r-real))) - (let ((r-imag (complex-double-reg-imag-tn r))) - (unless (location= imag r-imag) - (inst fmove imag r-imag)))) - (complex-double-stack - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset r))) - (inst stt real offset nfp) - (inst stt imag (+ offset (* 2 n-word-bytes)) nfp)))))) - -(define-vop (complex-single-float-value) - (:args (x :scs (complex-single-reg) :target r - :load-if (not (sc-is x complex-single-stack)))) - (:arg-types complex-single-float) - (:results (r :scs (single-reg))) - (:result-types single-float) - (:variant-vars slot) - (:policy :fast-safe) - (:vop-var vop) - (:generator 3 - (sc-case x - (complex-single-reg - (let ((value-tn (ecase slot - (:real (complex-single-reg-real-tn x)) - (:imag (complex-single-reg-imag-tn x))))) - (unless (location= value-tn r) - (inst fmove value-tn r)))) - (complex-single-stack - (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x)) - n-word-bytes) - (current-nfp-tn vop)))))) - -(define-vop (realpart/complex-single-float complex-single-float-value) - (:translate realpart) - (:note "complex single float realpart") - (:variant :real)) - -(define-vop (imagpart/complex-single-float complex-single-float-value) - (:translate imagpart) - (:note "complex single float imagpart") - (:variant :imag)) - -(define-vop (complex-double-float-value) - (:args (x :scs (complex-double-reg) :target r - :load-if (not (sc-is x complex-double-stack)))) - (:arg-types complex-double-float) - (:results (r :scs (double-reg))) - (:result-types double-float) - (:variant-vars slot) - (:policy :fast-safe) - (:vop-var vop) - (:generator 3 - (sc-case x - (complex-double-reg - (let ((value-tn (ecase slot - (:real (complex-double-reg-real-tn x)) - (:imag (complex-double-reg-imag-tn x))))) - (unless (location= value-tn r) - (inst fmove value-tn r)))) - (complex-double-stack - (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x)) - n-word-bytes) - (current-nfp-tn vop)))))) - -(define-vop (realpart/complex-double-float complex-double-float-value) - (:translate realpart) - (:note "complex double float realpart") - (:variant :real)) - -(define-vop (imagpart/complex-double-float complex-double-float-value) - (:translate imagpart) - (:note "complex double float imagpart") - (:variant :imag)) - diff -Nru sbcl-2.0.6/src/compiler/alpha/insts.lisp sbcl-2.1.1/src/compiler/alpha/insts.lisp --- sbcl-2.0.6/src/compiler/alpha/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/insts.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,693 +0,0 @@ -;;; the instruction set definition for the Alpha - -;;;; 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-ALPHA-ASM") - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Imports from this package into SB-VM - (import '(reg-tn-encoding) "SB-VM") - ;; Imports from SB-VM into this package - (import '(sb-vm::zero sb-vm::fp-single-zero sb-vm::fp-double-zero - sb-vm::registers sb-vm::float-registers - sb-vm::zero-tn sb-vm::fp-single-zero-tn sb-vm::fp-double-zero-tn - sb-vm::zero-offset sb-vm::null-offset sb-vm::code-offset))) - - -;;;; utility functions - -(defun reg-tn-encoding (tn) - (declare (type tn tn) - (values (unsigned-byte 5))) - (sc-case tn - (zero zero-offset) - (null null-offset) - (t - (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) - (tn-offset tn)))) - -(defun fp-reg-tn-encoding (tn) - (declare (type tn tn)) - (sc-case tn - (fp-single-zero (tn-offset fp-single-zero-tn)) - (fp-double-zero (tn-offset fp-double-zero-tn)) - (t - (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) - (error "~S isn't a floating-point register." tn)) - (tn-offset tn)))) - -;;;; initial disassembler setup - -(defvar *disassem-use-lisp-reg-names* t) - -(defparameter reg-symbols - (map 'vector - (lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "$" name))))) - sb-vm::*register-names*)) - -(define-arg-type reg - :printer (lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (maybe-note-associated-storage-ref - value - 'registers - regname - dstate)))) - -(define-arg-type memory-address-annotation - :printer (lambda (value stream dstate) - (declare (ignore stream)) - (destructuring-bind (reg offset) value - (cond - ((= reg code-offset) - (note-code-constant offset dstate)) - ((= reg null-offset) - (maybe-note-nil-indexed-object offset dstate)))))) - -(defparameter float-reg-symbols - #.(coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "~D" n))) - 'vector)) - -(define-arg-type fp-reg - :printer (lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref float-reg-symbols value))) - (princ regname stream) - (maybe-note-associated-storage-ref - value - 'float-registers - regname - dstate)))) - -(define-arg-type relative-label - :sign-extend t - :use-label (lambda (value dstate) - (declare (type (signed-byte 21) value) - (type disassem-state dstate)) - (+ 4 (ash value 2) (dstate-cur-addr dstate)))) - -;;;; DEFINE-INSTRUCTION-FORMATs for the disassembler - -(define-instruction-format (memory 32 - :default-printer '(:name :tab ra "," disp "(" rb ")" - memory-address-annotation)) - (op :field (byte 6 26)) - (ra :field (byte 5 21) :type 'reg) - (rb :field (byte 5 16) :type 'reg) - (disp :field (byte 16 0) :sign-extend t) - (memory-address-annotation :fields (list (byte 5 16) (byte 16 0)) - :type 'memory-address-annotation)) - -(define-instruction-format (jump 32 - :default-printer '(:name :tab ra ",(" rb ")," hint)) - (op :field (byte 6 26)) - (ra :field (byte 5 21) :type 'reg) - (rb :field (byte 5 16) :type 'reg) - (subop :field (byte 2 14)) - (hint :field (byte 14 0))) - -(define-instruction-format (branch 32 - :default-printer '(:name :tab ra "," disp)) - (op :field (byte 6 26)) - (ra :field (byte 5 21) :type 'reg) - (disp :field (byte 21 0) :type 'relative-label)) - -(define-instruction-format (reg-operate 32 - :default-printer '(:name :tab ra "," rb "," rc)) - (op :field (byte 6 26)) - (ra :field (byte 5 21) :type 'reg) - (rb :field (byte 5 16) :type 'reg) - (sbz :field (byte 3 13)) - (f :field (byte 1 12) :value 0) - (fn :field (byte 7 5)) - (rc :field (byte 5 0) :type 'reg)) - -(define-instruction-format (lit-operate 32 - :default-printer '(:name :tab ra "," lit "," rc)) - (op :field (byte 6 26)) - (ra :field (byte 5 21) :type 'reg) - (lit :field (byte 8 13)) - (f :field (byte 1 12) :value 1) - (fn :field (byte 7 5)) - (rc :field (byte 5 0) :type 'reg)) - -(define-instruction-format (fp-operate 32 - :default-printer '(:name :tab fa "," fb "," fc)) - (op :field (byte 6 26)) - (fa :field (byte 5 21) :type 'fp-reg) - (fb :field (byte 5 16) :type 'fp-reg) - (fn :field (byte 11 5)) - (fc :field (byte 5 0) :type 'fp-reg)) - -(define-instruction-format (call-pal 32 - :default-printer '('call_pal :tab 'pal_ :name)) - (op :field (byte 6 26) :value 0) - (palcode :field (byte 26 0))) - -(define-instruction-format (bugchk 32 - :default-printer '('call_pal :tab 'pal_bugchk "," code)) - (op :field (byte 6 26) :value 0) - (palcode :field (byte 26 0) :value #x81) - ;; We use CALL-PAL BUGCHK as part of our trap logic. It is invariably - ;; followed by a trap-code word, which we pick out with the - ;; semi-traditional prefilter approach. - (code :prefilter (lambda (dstate) (read-suffix 32 dstate)) - :reader bugchk-trap-code)) - -;;;; emitters - -(define-bitfield-emitter emit-word 16 - (byte 16 0)) - -(define-bitfield-emitter emit-lword 32 - (byte 32 0)) - -(define-bitfield-emitter emit-qword 64 - (byte 64 0)) - -(define-bitfield-emitter emit-memory 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0)) - -(define-bitfield-emitter emit-branch 32 - (byte 6 26) (byte 5 21) (byte 21 0)) - -(define-bitfield-emitter emit-reg-operate 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 1 12) (byte 7 5) - (byte 5 0)) - -(define-bitfield-emitter emit-lit-operate 32 - (byte 6 26) (byte 5 21) (byte 8 13) (byte 1 12) (byte 7 5) (byte 5 0)) - -(define-bitfield-emitter emit-fp-operate 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 11 5) (byte 5 0)) - -(define-bitfield-emitter emit-pal 32 - (byte 6 26) (byte 26 0)) - -;;;; macros for instructions - -(macrolet ((define-memory (name op &optional fixup float) - `(define-instruction ,name (segment ra disp rb ,@(if fixup - '(&optional type))) - (:declare (type tn ra rb) - ,@(if fixup ; ### unsigned-byte 16 bad idea? - '((type (or (unsigned-byte 16) (signed-byte 16) fixup) - disp)) - '((type (or (unsigned-byte 16) (signed-byte 16)) disp)))) - (:printer memory ((op ,op)) - ,@(when fixup - ;; Don't try to parse a constant - ;; reference if we're doing LDA or LDAH - ;; against $CODE. - '('(:name :tab ra "," disp "(" rb ")")))) - (:emitter - ,@(when fixup - `((when (fixup-p disp) - (note-fixup segment (or type ,fixup) disp) - (setf disp 0)))) - (emit-memory segment ,op ,@(if float - '((fp-reg-tn-encoding ra)) - '((reg-tn-encoding ra))) - (reg-tn-encoding rb) - disp))))) - (define-memory lda #x08 :lda) - (define-memory ldah #x09 :ldah) - (define-memory ldbu #x0a) ; BWX extension - (define-memory ldwu #x0c) ; BWX extension - (define-memory ldl #x28) - (define-memory ldq #x29) - (define-memory ldl_l #x2a) - (define-memory ldq_q #x2b) - (define-memory ldq_u #x0b) - (define-memory stw #x0d) ; BWX extension - (define-memory stb #x0e) ; BWX extension - (define-memory stl #x2c) - (define-memory stq #x2d) - (define-memory stl_c #x2e) - (define-memory stq_c #x2f) - (define-memory stq_u #x0f) - (define-memory ldf #x20 nil t) - (define-memory ldg #x21 nil t) - (define-memory lds #x22 nil t) - (define-memory ldt #x23 nil t) - (define-memory stf #x24 nil t) - (define-memory stg #x25 nil t) - (define-memory sts #x26 nil t) - (define-memory stt #x27 nil t)) - -(macrolet ((define-jump (name subop) - `(define-instruction ,name (segment ra rb &optional (hint 0)) - (:declare (type tn ra rb) - (type (or (unsigned-byte 14) fixup) hint)) - (:printer jump ((op #x1a) (subop ,subop))) - (:emitter - (when (fixup-p hint) - (note-fixup segment :jmp-hint hint) - (setf hint 0)) - (emit-memory segment #x1a (reg-tn-encoding ra) (reg-tn-encoding rb) - (logior (ash ,subop 14) hint)))))) - (define-jump jmp 0) - (define-jump jsr 1) - (define-jump ret 2) - (define-jump jsr-coroutine 3)) - - -(macrolet ((define-branch (name op &optional (float nil)) - `(define-instruction ,name (segment ra target) - (:declare (type tn ra) - (type label target)) - (:printer branch ((op ,op) - ,@(when float - '((ra nil :type 'fp-reg))))) - (:emitter - (emit-back-patch segment 4 - (lambda (segment posn) - (emit-branch segment ,op - ,@(if float - '((fp-reg-tn-encoding ra)) - '((reg-tn-encoding ra))) - (ash (- (label-position target) - (+ posn 4)) - -2)))))))) - (define-branch br #x30) - (define-branch bsr #x34) - (define-branch blbc #x38) - (define-branch blbs #x3c) - (define-branch fbeq #x31 t) - (define-branch fbne #x35 t) - (define-branch beq #x39) - (define-branch bne #x3d) - (define-branch fblt #x32 t) - (define-branch fbge #x36 t) - (define-branch blt #x3a) - (define-branch bge #x3e) - (define-branch fble #x33 t) - (define-branch fbgt #x37 t) - (define-branch ble #x3b) - (define-branch bgt #x3f)) - -(macrolet ((define-operate (name op fn) - `(define-instruction ,name (segment ra rb rc) - (:declare (type tn ra rc) - (type (or tn (unsigned-byte 8)) rb)) - (:printer reg-operate ((op ,op) (fn ,fn))) - (:printer lit-operate ((op ,op) (fn ,fn))) - ,@(when (and (= op #x11) (= fn #x20)) - `((:printer reg-operate ((op ,op) (fn ,fn) (ra 31)) - '('move :tab rb "," rc)) - (:printer reg-operate ((op ,op) (fn ,fn) (ra 31) (rb 31) (rc 31)) - '('nop)))) - (:emitter - (etypecase rb - (tn - (emit-reg-operate segment ,op (reg-tn-encoding ra) - (reg-tn-encoding rb) 0 0 ,fn (reg-tn-encoding rc))) - (number - (emit-lit-operate segment ,op (reg-tn-encoding ra) rb 1 ,fn - (reg-tn-encoding rc)))))))) - (define-operate addl #x10 #x00) - (define-operate addl/v #x10 #x40) - (define-operate addq #x10 #x20) - (define-operate addq/v #x10 #x60) - (define-operate cmpule #x10 #x3d) - (define-operate cmpbge #x10 #x0f) - (define-operate subl #x10 #x09) - (define-operate subl/v #x10 #x49) - (define-operate subq #x10 #x29) - (define-operate subq/v #x10 #x69) - (define-operate cmpeq #x10 #x2d) - (define-operate cmplt #x10 #x4d) - (define-operate cmple #x10 #x6d) - (define-operate cmpult #x10 #x1d) - (define-operate s4addl #x10 #x02) - (define-operate s4addq #x10 #x22) - (define-operate s4subl #x10 #x0b) - (define-operate s4subq #x10 #x2b) - (define-operate s8addl #x10 #x12) - (define-operate s8addq #x10 #x32) - (define-operate s8subl #x10 #x1b) - (define-operate s8subq #x10 #x3b) - - (define-operate and #x11 #x00) - (define-operate bic #x11 #x08) - (define-operate cmoveq #x11 #x24) - (define-operate cmovne #x11 #x26) - (define-operate cmovlbs #x11 #x14) - (define-operate bis #x11 #x20) - (define-operate ornot #x11 #x28) - (define-operate cmovlt #x11 #x44) - (define-operate cmovge #x11 #x46) - (define-operate cmovlbc #x11 #x16) - (define-operate xor #x11 #x40) - (define-operate eqv #x11 #x48) - (define-operate cmovle #x11 #x64) - (define-operate cmovgt #x11 #x66) - - (define-operate sll #x12 #x39) - (define-operate extbl #x12 #x06) - (define-operate extwl #x12 #x16) - (define-operate extll #x12 #x26) - (define-operate extql #x12 #x36) - (define-operate extwh #x12 #x5a) - (define-operate extlh #x12 #x6a) - (define-operate extqh #x12 #x7a) - (define-operate sra #x12 #x3c) - (define-operate insbl #x12 #x0b) - (define-operate inswl #x12 #x1b) - (define-operate insll #x12 #x2b) - (define-operate insql #x12 #x3b) - (define-operate inswh #x12 #x57) - (define-operate inslh #x12 #x67) - (define-operate insqh #x12 #x77) - (define-operate srl #x12 #x34) - (define-operate mskbl #x12 #x02) - (define-operate mskwl #x12 #x12) - (define-operate mskll #x12 #x22) - (define-operate mskql #x12 #x32) - (define-operate mskwh #x12 #x52) - (define-operate msklh #x12 #x62) - (define-operate mskqh #x12 #x72) - (define-operate zap #x12 #x30) - (define-operate zapnot #x12 #x31) - - (define-operate mull #x13 #x00) - (define-operate mulq/v #x13 #x60) - (define-operate mull/v #x13 #x40) - (define-operate umulh #x13 #x30) - (define-operate mulq #x13 #x20) - - (define-operate ctpop #x1c #x30) ; CIX extension - (define-operate ctlz #x1c #x32) ; CIX extension - (define-operate cttz #x1c #x33)) ; CIX extension - - -(macrolet ((define-fp-operate (name op fn &optional (args 3)) - `(define-instruction ,name (segment ,@(when (= args 3) '(fa)) fb fc) - (:declare (type tn ,@(when (= args 3) '(fa)) fb fc)) - (:printer fp-operate ((op ,op) (fn ,fn) ,@(when (= args 2) '((fa 31)))) - ,@(when (= args 2) - '('(:name :tab fb "," fc)))) - ,@(when (and (= op #x17) (= fn #x20)) - `((:printer fp-operate ((op ,op) (fn ,fn) (fa 31)) - '('fabs :tab fb "," fc)))) - (:emitter - (emit-fp-operate segment ,op ,@(if (= args 3) - '((fp-reg-tn-encoding fa)) - '(31)) - (fp-reg-tn-encoding fb) ,fn (fp-reg-tn-encoding fc)))))) - (define-fp-operate cpys #x17 #x020) - (define-fp-operate mf_fpcr #x17 #x025) - (define-fp-operate cpysn #x17 #x021) - (define-fp-operate mt_fpcr #x17 #x024) - (define-fp-operate cpyse #x17 #x022) - (define-fp-operate cvtql/sv #x17 #x530 2) - (define-fp-operate cvtlq #x17 #x010 2) - (define-fp-operate cvtql #x17 #x030 2) - (define-fp-operate cvtql/v #x17 #x130 2) - (define-fp-operate fcmoveq #x17 #x02a) - (define-fp-operate fcmovne #x17 #x02b) - (define-fp-operate fcmovlt #x17 #x02c) - (define-fp-operate fcmovge #x17 #x02d) - (define-fp-operate fcmovle #x17 #x02e) - (define-fp-operate fcmovgt #x17 #x02f) - - (define-fp-operate cvtqs #x16 #x0bc 2) - (define-fp-operate cvtqt #x16 #x0be 2) - (define-fp-operate cvtts #x16 #x0ac 2) - (define-fp-operate cvttq #x16 #x0af 2) - (define-fp-operate cvttq/c #x16 #x02f 2) - (define-fp-operate cmpteq #x16 #x5a5) - (define-fp-operate cmptlt #x16 #x5a6) - (define-fp-operate cmptle #x16 #x5a7) - (define-fp-operate cmptun #x16 #x5a4) - (define-fp-operate adds #x16 #x080) - (define-fp-operate addt #x16 #x0a0) - (define-fp-operate divs #x16 #x083) - (define-fp-operate divt #x16 #x0a3) - (define-fp-operate muls #x16 #x082) - (define-fp-operate mult #x16 #x0a2) - (define-fp-operate subs #x16 #x081) - (define-fp-operate subt #x16 #x0a1) - -;;; IEEE support - (defconstant +su+ #x500) ; software, underflow enabled - (defconstant +sui+ #x700) ; software, inexact & underflow enabled - (defconstant +sv+ #x500) ; software, interger overflow enabled - (defconstant +svi+ #x700) - (defconstant +rnd+ #x0c0) ; dynamic rounding mode - (defconstant +sud+ #x5c0) - (defconstant +svid+ #x7c0) - (defconstant +suid+ #x7c0) - - (define-fp-operate cvtqs_su #x16 (logior +su+ #x0bc) 2) - (define-fp-operate cvtqs_sui #x16 (logior +sui+ #x0bc) 2) - (define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2) - (define-fp-operate cvtqt_sui #x16 (logior +sui+ #x0be) 2) - (define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2) - - (define-fp-operate cvttq_sv #x16 (logior +su+ #x0af) 2) - (define-fp-operate cvttq/c_sv #x16 (logior +su+ #x02f) 2) - - (define-fp-operate adds_su #x16 (logior +su+ #x080)) - (define-fp-operate addt_su #x16 (logior +su+ #x0a0)) - (define-fp-operate divs_su #x16 (logior +su+ #x083)) - (define-fp-operate divt_su #x16 (logior +su+ #x0a3)) - (define-fp-operate muls_su #x16 (logior +su+ #x082)) - (define-fp-operate mult_su #x16 (logior +su+ #x0a2)) - (define-fp-operate subs_su #x16 (logior +su+ #x081)) - (define-fp-operate subt_su #x16 (logior +su+ #x0a1))) - -(define-instruction excb (segment) - (:emitter (emit-lword segment #x63ff0400))) - -(define-instruction trapb (segment) - (:emitter (emit-lword segment #x63ff0000))) - -(define-instruction imb (segment) - (:emitter (emit-lword segment #x00000086))) - -(define-instruction gentrap (segment code) - (:printer bugchk () :default - :control #'bugchk-trap-control) - (:emitter - (emit-lword segment #x000081) ;actually bugchk - (emit-lword segment code))) - -(define-instruction-macro move (src dst) - `(inst bis zero-tn ,src ,dst)) - -(define-instruction-macro not (src dst) - `(inst ornot zero-tn ,src ,dst)) - -(define-instruction-macro fmove (src dst) - `(inst cpys ,src ,src ,dst)) - -(define-instruction-macro fabs (src dst) - `(inst cpys fp-single-zero-tn ,src ,dst)) - -(define-instruction-macro fneg (src dst) - `(inst cpysn ,src ,src ,dst)) - -(define-instruction-macro nop () - `(inst bis zero-tn zero-tn zero-tn)) - -(defun %li (value reg) - (etypecase value - ((signed-byte 16) - (inst lda reg value zero-tn)) - ((signed-byte 32) - (flet ((se (x n) - (let ((x (logand x (lognot (ash -1 n))))) - (if (logbitp (1- n) x) - (logior (ash -1 (1- n)) x) - x)))) - (let* ((value (se value 32)) - (low (ldb (byte 16 0) value)) - (tmp1 (- value (se low 16))) - (high (ldb (byte 16 16) tmp1)) - (tmp2 (- tmp1 (se (ash high 16) 32))) - (extra 0)) - (unless (= tmp2 0) - (setf extra #x4000) - (setf tmp1 (- tmp1 #x40000000)) - (setf high (ldb (byte 16 16) tmp1))) - (inst lda reg low zero-tn) - (unless (= extra 0) - (inst ldah reg extra reg)) - (unless (= high 0) - (inst ldah reg high reg))))) - ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64)) - ;; Since it took NJF and CSR a good deal of puzzling to work out - ;; (a) what a previous version of this was doing and (b) why it - ;; was wrong: - ;; - ;; write VALUE = a_63 * 2^63 + a_48-62 * 2^48 - ;; + a_47 * 2^47 + a_32-46 * 2^32 - ;; + a_31 * 2^31 + a_16-30 * 2^16 - ;; + a_15 * 2^15 + a_0-14 - ;; - ;; then, because of the wonders of sign-extension and - ;; twos-complement arithmetic modulo 2^64, if a_15 is set, LDA - ;; (which sign-extends its argument) will add - ;; - ;; (a_15 * 2^15 + a_0-14 - 65536). - ;; - ;; So we need to add that 65536 back on, which is what this - ;; LOGBITP business is doing. The same applies for bits 31 and - ;; 47 (bit 63 is taken care of by the fact that all of this - ;; arithmetic is mod 2^64 anyway), but we have to be careful that - ;; we consider the altered value, not the original value. - ;; - ;; I think, anyway. -- CSR, 2003-09-26 - (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value2 (if (logbitp 31 value1) (+ value1 (ash 1 32)) value1)) - (value3 (if (logbitp 47 value2) (+ value2 (ash 1 48)) value2))) - (inst lda reg (ldb (byte 16 32) value2) zero-tn) - ;; FIXME: Don't yet understand these conditionals. If I'm - ;; right, surely we can just consider the zeroness of the - ;; particular bitfield, not the zeroness of the whole thing? - ;; -- CSR, 2003-09-26 - (unless (= value3 0) - (inst ldah reg (ldb (byte 16 48) value3) reg)) - (unless (and (= value2 0) (= value3 0)) - (inst sll reg 32 reg)) - (unless (= value 0) - (inst lda reg (ldb (byte 16 0) value) reg)) - (unless (= value1 0) - (inst ldah reg (ldb (byte 16 16) value1) reg)))) - (fixup - (inst lda reg value zero-tn :bits-47-32) - (inst ldah reg value reg :bits-63-48) - (inst sll reg 32 reg) - (inst lda reg value reg) - (inst ldah reg value reg)))) - -(define-instruction-macro li (value reg) - `(%li ,value ,reg)) - - -;;;; - -(define-instruction lword (segment lword) - (:declare (type (or (unsigned-byte 32) (signed-byte 32) fixup) lword)) - (:cost 0) - (:emitter - (etypecase lword - (fixup - (note-fixup segment :absolute32 lword) - (emit-lword segment 0)) - (integer - (emit-lword segment lword))))) - -(define-instruction short (segment word) - (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word)) - (:cost 0) - (:emitter - (emit-word segment word))) - -(define-instruction byte (segment byte) - (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte)) - (:cost 0) - (:emitter - (emit-byte segment byte))) - -(defun emit-header-data (segment type) - (emit-back-patch - segment 4 - (lambda (segment posn) - (emit-lword segment - (logior type - (ash (+ posn (component-header-length)) - (- n-widetag-bits word-shift))))))) - -(define-instruction simple-fun-header-word (segment) - (:cost 0) - (:emitter - (emit-header-data segment simple-fun-widetag))) - -(define-instruction lra-header-word (segment) - (:cost 0) - (:emitter - (emit-header-data segment return-pc-widetag))) - -(defun emit-compute-inst (segment vop dst src label temp calc) - (declare (ignore temp)) - (emit-chooser - ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments. - segment 12 3 - (lambda (segment chooser posn delta-if-after) - (declare (ignore chooser)) - (let ((delta (funcall calc label posn delta-if-after))) - (when (<= (- (ash 1 15)) delta (1- (ash 1 15))) - (emit-back-patch segment 4 - (lambda (segment posn) - (assemble (segment vop) - (inst lda dst - (funcall calc label posn 0) - src)))) - t))) - (lambda (segment posn) - (assemble (segment vop) - (flet ((se (x n) - (let ((x (logand x (lognot (ash -1 n))))) - (if (logbitp (1- n) x) - (logior (ash -1 (1- n)) x) - x)))) - (let* ((value (se (funcall calc label posn 0) 32)) - (low (ldb (byte 16 0) value)) - (tmp1 (- value (se low 16))) - (high (ldb (byte 16 16) tmp1)) - (tmp2 (- tmp1 (se (ash high 16) 32))) - (extra 0)) - (unless (= tmp2 0) - (setf extra #x4000) - (setf tmp1 (- tmp1 #x40000000)) - (setf high (ldb (byte 16 16) tmp1))) - (inst lda dst low src) - (inst ldah dst extra dst) - (inst ldah dst high dst))))))) - -;; code = lip - header - label-offset + other-pointer-tag -(define-instruction compute-code-from-lip (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - (lambda (label posn delta-if-after) - (- other-pointer-lowtag - (label-position label posn delta-if-after) - (component-header-length)))))) - -;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag -;; = lra - (header + label-offset) -(define-instruction compute-code-from-lra (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - (lambda (label posn delta-if-after) - (- (+ (label-position label posn delta-if-after) - (component-header-length))))))) - -;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag -;; = code + header + label-offset -(define-instruction compute-lra-from-code (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - (lambda (label posn delta-if-after) - (+ (label-position label posn delta-if-after) - (component-header-length)))))) diff -Nru sbcl-2.0.6/src/compiler/alpha/macros.lisp sbcl-2.1.1/src/compiler/alpha/macros.lisp --- sbcl-2.0.6/src/compiler/alpha/macros.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/macros.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,488 +0,0 @@ -;;;; various useful macros for generating Alpha code - -;;;; 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 handy macro for defining top level forms that depend on the -;;; compile environment -(defmacro expand (expr) - (let ((gensym (gensym))) - `(macrolet - ((,gensym () - ,expr)) - (,gensym)))) - -;;; instruction-like macros - -;;; c.f. x86 backend: -;;(defmacro move (dst src) -;; "Move SRC into DST unless they are location=." -;; (once-only ((n-dst dst) -;; (n-src src)) -;; `(unless (location= ,n-dst ,n-src) -;; (inst mov ,n-dst ,n-src)))) - -(defmacro move (src dst) - "Move SRC into DST unless they are location=." - (once-only ((n-src src) (n-dst dst)) - `(unless (location= ,n-src ,n-dst) - (inst move ,n-src ,n-dst)))) - -(defmacro loadw (result base &optional (offset 0) (lowtag 0)) - (once-only ((result result) (base base)) - `(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base))) - -(defmacro loadq (result base &optional (offset 0) (lowtag 0)) - (once-only ((result result) (base base)) - `(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base))) - -(defmacro storew (value base &optional (offset 0) (lowtag 0)) - (once-only ((value value) (base base) (offset offset) (lowtag lowtag)) - `(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base))) - -(defmacro storeq (value base &optional (offset 0) (lowtag 0)) - (once-only ((value value) (base base) (offset offset) (lowtag lowtag)) - `(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base))) - -(defmacro load-symbol (reg symbol) - (once-only ((reg reg) (symbol symbol)) - `(inst lda ,reg (static-symbol-offset ,symbol) null-tn))) - -(defmacro load-symbol-value (reg symbol) - `(inst ldl ,reg - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag)) - null-tn)) - -(defmacro store-symbol-value (reg symbol) - `(inst stl ,reg - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag)) - null-tn)) - -(defmacro load-type (target source &optional (offset 0)) - "Loads the type bits of a pointer into target independent of - byte-ordering issues." - (once-only ((n-target target) - (n-source source) - (n-offset offset)) - `(progn - (inst ldl ,n-target ,n-offset ,n-source) - (inst and ,n-target #xff ,n-target)))) - -;;; macros to handle the fact that we cannot use the machine native -;;; call and return instructions - -(defmacro lisp-jump (function lip) - "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." - `(progn - (inst lda ,lip (- (ash simple-fun-insts-offset word-shift) - fun-pointer-lowtag) - ,function) - (move ,function code-tn) - (inst jsr zero-tn ,lip 1))) - -(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) - "Return to RETURN-PC. LIP is an interior-reg temporary." - `(progn - (inst lda ,lip - (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) - ,return-pc) - ,@(when frob-code - `((move ,return-pc code-tn))) - (inst ret zero-tn ,lip 1))) - - -(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 - -;;; Move a stack TN to a register and vice-versa. -(defmacro load-stack-tn (reg stack) - `(let ((reg ,reg) - (stack ,stack)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (loadw reg cfp-tn offset)))))) -(defmacro store-stack-tn (stack reg) - `(let ((stack ,stack) - (reg ,reg)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (storew reg cfp-tn offset)))))) - -;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. -(defmacro maybe-load-stack-tn (reg reg-or-stack) - (once-only ((n-reg reg) - (n-stack reg-or-stack)) - `(sc-case ,n-reg - ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) - -;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. -(defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp) - (once-only ((n-reg reg) - (n-stack reg-or-stack)) - `(when ,reg - (sc-case ,n-reg - ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)) - (inst mskll nsp-tn 0 ,temp) - (inst bis ,temp ,n-reg ,n-reg)))))))) - -;;;; storage allocation - -;;; Do stuff to allocate an other-pointer object of fixed SIZE with a -;;; single word header having the specified WIDETAG value. The result is -;;; placed in RESULT-TN, Flag-Tn must be wired to NL3-OFFSET, and -;;; Temp-TN is a non- descriptor temp (which may be randomly used by -;;; the body.) The body is placed inside the PSEUDO-ATOMIC, and -;;; presumably initializes the object. -(defmacro with-fixed-allocation ((result-tn temp-tn widetag size) - &body body) - (unless body - (bug "empty &body in WITH-FIXED-ALLOCATION")) - (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size)) - `(pseudo-atomic (:extra (pad-data-block ,size)) - (inst bis alloc-tn other-pointer-lowtag ,result-tn) - (inst li (compute-object-header ,size ,widetag) ,temp-tn) - (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) - ,@body))) - -(defun align-csp (temp) - ;; is used for stack allocation of dynamic-extent objects - (let ((aligned (gen-label))) - (inst and csp-tn lowtag-mask temp) - (inst beq temp aligned) - (inst addq csp-tn n-word-bytes csp-tn) - (storew zero-tn csp-tn -1) - (emit-label aligned))) - -;;;; error code -(defun emit-error-break (vop kind code values) - (assemble () - (when vop - (note-this-location vop :internal-error)) - (emit-internal-error kind code values - :trap-emitter (lambda (tramp-number) - (inst gentrap tramp-number))) - (emit-alignment word-shift))) - -(defun generate-error-code (vop error-code &rest values) - "Generate-Error-Code Error-code Value* - Emit code for an error with the specified Error-Code and context Values." - (assemble (:elsewhere) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (apply #'error-call vop error-code values) - start-lab))) - -;;; a handy macro for making sequences look atomic -(defmacro pseudo-atomic ((&key (extra 0)) &rest forms) - `(progn - (inst addq alloc-tn 1 alloc-tn) - ,@forms - (inst lda alloc-tn (1- ,extra) alloc-tn) - (inst stl zero-tn 0 alloc-tn))) - -;;;; memory accessor vop generators - -(sb-xc:deftype load/store-index (scale lowtag min-offset - &optional (max-offset min-offset)) - `(integer ,(- (truncate (+ (ash 1 16) - (* min-offset sb-vm:n-word-bytes) - (- lowtag)) - scale)) - ,(truncate (- (+ (1- (ash 1 16)) lowtag) - (* max-offset sb-vm:n-word-bytes)) - scale))) - -(defmacro define-full-reffer (name type offset lowtag scs el-type - &optional translate) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types ,type tagged-num) - (:temporary (:scs (interior-reg)) lip) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst addq object index lip) - (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip) - ,@(when (equal scs '(unsigned-reg)) - '((inst mskll value 4 value))))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 4 - (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) - object) - ,@(when (equal scs '(unsigned-reg)) - '((inst mskll value 4 value))))))) - -(defmacro define-full-setter (name type offset lowtag scs el-type - &optional translate #+gengc (remember t)) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type tagged-num ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 2 - (inst addq index object lip) - (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip) - (move value result))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 1 - (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) - object) - (move value result))))) - - -(defmacro define-partial-reffer (name type size signed offset lowtag scs - el-type &optional translate) - (let ((scale (ecase size (:byte 1) (:short 2)))) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:generator 5 - (inst addq object index lip) - ,@(when (eq size :short) - '((inst addq index lip lip))) - ,@(ecase size - (:byte - (if signed - `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag)) - lip) - (inst extqh temp temp1 temp) - (inst sra temp 56 value)) - `((inst ldq_u - temp - (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst extbl temp temp1 value)))) - (:short - (if signed - `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst extwl temp temp1 temp) - (inst sll temp 48 temp) - (inst sra temp 48 value)) - `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst extwl temp temp1 value))))))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:generator 4 - ,@(ecase size - (:byte - (if signed - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag)) - object) - (inst extqh temp temp1 temp) - (inst sra temp 56 value)) - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extbl temp temp1 value)))) - (:short - (if signed - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extwl temp temp1 temp) - (inst sll temp 48 temp) - (inst sra temp 48 value)) - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extwl temp temp1 value)))))))))) - -(defmacro define-partial-setter (name type size offset lowtag scs el-type - &optional translate) - (let ((scale (ecase size (:byte 1) (:short 2)))) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type positive-fixnum ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:temporary (:sc non-descriptor-reg) temp2) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst addq object index lip) - ,@(when (eq size :short) - '((inst addq lip index lip))) - ,@(ecase size - (:byte - `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst insbl value temp temp2) - (inst mskbl temp1 temp temp1) - (inst bis temp1 temp2 temp1) - (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip))) - (:short - `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst mskwl temp1 temp temp1) - (inst inswl value temp temp2) - (inst bis temp1 temp2 temp) - (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip)))) - (move value result))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs :target result)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:temporary (:sc non-descriptor-reg) temp2) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 4 - ,@(ecase size - (:byte - `((inst lda temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) - object) - (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) - object) - (inst insbl value temp temp2) - (inst mskbl temp1 temp temp1) - (inst bis temp1 temp2 temp1) - (inst stq_u temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) object))) - (:short - `((inst lda temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) - object) - (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) - object) - (inst mskwl temp1 temp temp1) - (inst inswl value temp temp2) - (inst bis temp1 temp2 temp) - (inst stq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) object)))) - (move value result)))))) diff -Nru sbcl-2.0.6/src/compiler/alpha/memory.lisp sbcl-2.1.1/src/compiler/alpha/memory.lisp --- sbcl-2.0.6/src/compiler/alpha/memory.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/memory.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -;;;; the Alpha definitions of some general purpose memory reference -;;;; VOPs inherited by basic memory reference operations - -;;;; 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") - -;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the -;;; offset to be read or written is a property of the VOP used. -(define-vop (cell-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (loadw value object offset lowtag))) -(define-vop (cell-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg null zero))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (storew value object offset lowtag))) diff -Nru sbcl-2.0.6/src/compiler/alpha/move.lisp sbcl-2.1.1/src/compiler/alpha/move.lisp --- sbcl-2.0.6/src/compiler/alpha/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/move.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,317 +0,0 @@ -;;;; the Alpha VM definition of operand loading/saving and the Move VOP - -;;;; 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") - -(define-move-fun (load-immediate 1) (vop x y) - ((null zero immediate) - (any-reg descriptor-reg)) - (let ((val (tn-value x))) - (etypecase val - (integer - (inst li (fixnumize val) y)) - (null - (move null-tn y)) - (symbol - (load-symbol y val)) - (character - (inst li (logior (ash (char-code val) n-widetag-bits) character-widetag) - y))))) - -(define-move-fun (load-number 1) (vop x y) - ((zero immediate) - (signed-reg unsigned-reg)) - (inst li (tn-value x) y)) - -(define-move-fun (load-character 1) (vop x y) - ((immediate) (character-reg)) - (inst li (char-code (tn-value x)) y)) - -(define-move-fun (load-system-area-pointer 1) (vop x y) - ((immediate) (sap-reg)) - (inst li (sap-int (tn-value x)) y)) - -(define-move-fun (load-constant 5) (vop x y) - ((constant) (descriptor-reg any-reg)) - (loadw y code-tn (tn-offset x) other-pointer-lowtag)) - -(define-move-fun (load-stack 5) (vop x y) - ((control-stack) (any-reg descriptor-reg)) - (load-stack-tn y x)) - -(define-move-fun (load-number-stack 5) (vop x y) - ((character-stack) (character-reg)) - (let ((nfp (current-nfp-tn vop))) - (loadw y nfp (tn-offset x)))) - -(define-move-fun (load-number-stack-64 5) (vop x y) - ((sap-stack) (sap-reg) - (signed-stack) (signed-reg) - (unsigned-stack) (unsigned-reg)) - (let ((nfp (current-nfp-tn vop))) - (loadq y nfp (tn-offset x)))) - -(define-move-fun (store-stack 5) (vop x y) - ((any-reg descriptor-reg null zero) (control-stack)) - (store-stack-tn y x)) - -(define-move-fun (store-number-stack 5) (vop x y) - ((character-reg) (character-stack)) - (let ((nfp (current-nfp-tn vop))) - (storew x nfp (tn-offset y)))) - -(define-move-fun (store-number-stack-64 5) (vop x y) - ((sap-reg) (sap-stack) - (signed-reg) (signed-stack) - (unsigned-reg) (unsigned-stack)) - (let ((nfp (current-nfp-tn vop))) - (storeq x nfp (tn-offset y)))) - -;;;; the MOVE VOP - -(define-vop (move) - (:args (x :target y - :scs (any-reg descriptor-reg zero null) - :load-if (not (location= x y)))) - (:results (y :scs (any-reg descriptor-reg control-stack) - :load-if (not (location= x y)))) - (:generator 0 - (unless (location= x y) - (sc-case y - ((any-reg descriptor-reg) - (inst move x y)) - (control-stack - (store-stack-tn y x)))))) - -(define-move-vop move :move - (any-reg descriptor-reg zero null) - (any-reg descriptor-reg)) - -;;; The MOVE-ARG VOP is used for moving descriptor values into -;;; another frame for argument or known value passing. -(define-vop (move-arg) - (:args (x :target y - :scs (any-reg descriptor-reg null zero)) - (fp :scs (any-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - ((any-reg descriptor-reg) - (move x y)) - (control-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-arg :move-arg - (any-reg descriptor-reg null zero) - (any-reg descriptor-reg)) - -;;;; moves and coercions -;;;; -;;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word -;;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw -;;;; integer to a tagged bignum or fixnum. - -;;; ARG is a fixnum, so just shift it. We need a type restriction -;;; because some possible arg SCs (control-stack) overlap with -;;; possible bignum arg SCs. -(define-vop (move-to-word/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:arg-types tagged-num) - (:note "fixnum untagging") - (:generator 1 - (inst sra x n-fixnum-tag-bits y))) -(define-move-vop move-to-word/fixnum :move - (any-reg descriptor-reg) (signed-reg unsigned-reg)) - -;;; ARG is a non-immediate constant, load it. -(define-vop (move-to-word-c) - (:args (x :scs (constant))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "constant load") - (:generator 1 - (cond ((sb-c::tn-leaf x) - (inst li (tn-value x) y)) - (t - (loadw y code-tn (tn-offset x) other-pointer-lowtag) - (inst sra y n-fixnum-tag-bits y))))) -(define-move-vop move-to-word-c :move - (constant) (signed-reg unsigned-reg)) - -;;; ARG is a fixnum or bignum, figure out which and load if necessary. -(define-vop (move-to-word/integer) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "integer to untagged word coercion") - (:temporary (:sc non-descriptor-reg) header) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 3 - (inst and x fixnum-tag-mask temp) - (inst sra x n-fixnum-tag-bits y) - (inst beq temp done) - - (loadw header x 0 other-pointer-lowtag) - (inst srl header (1+ n-widetag-bits) header) - (loadw y x bignum-digits-offset other-pointer-lowtag) - (inst beq header one) - - (loadw header x (1+ bignum-digits-offset) other-pointer-lowtag) - (inst sll header 32 header) - (inst mskll y 4 y) - (inst bis header y y) - (inst br zero-tn done) - ONE - (when (sc-is y unsigned-reg) - (inst mskll y 4 y)) - DONE)) -(define-move-vop move-to-word/integer :move - (descriptor-reg) (signed-reg unsigned-reg)) - -;;; RESULT is a fixnum, so we can just shift. We need the result type -;;; restriction because of the control-stack ambiguity noted above. -(define-vop (move-from-word/fixnum) - (:args (x :scs (signed-reg unsigned-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "fixnum tagging") - (:generator 1 - (inst sll x n-fixnum-tag-bits y))) -(define-move-vop move-from-word/fixnum :move - (signed-reg unsigned-reg) (any-reg descriptor-reg)) - -;;; RESULT may be a bignum, so we have to check. Use a worst-case cost -;;; to make sure people know they may be number consing. -(define-vop (move-from-signed) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - (:temporary (:sc non-descriptor-reg) header) - (:note "signed word to integer coercion") - (:generator 18 - (move arg x) - (inst sra x n-positive-fixnum-bits temp) - (inst sll x n-fixnum-tag-bits y) - (inst beq temp done) - (inst not temp temp) - (inst beq temp done) - - (inst li 2 header) - (inst sra x 31 temp) - (inst cmoveq temp 1 header) - (inst not temp temp) - (inst cmoveq temp 1 header) - (inst sll header n-widetag-bits header) - (inst bis header bignum-widetag header) - - (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) - (inst bis alloc-tn other-pointer-lowtag y) - (storew header y 0 other-pointer-lowtag) - (storew x y bignum-digits-offset other-pointer-lowtag) - (inst srl x 32 temp) - (storew temp y (1+ bignum-digits-offset) other-pointer-lowtag)) - DONE)) -(define-move-vop move-from-signed :move - (signed-reg) (descriptor-reg)) - -(define-vop (move-from-fixnum+1) - (:args (x :scs (signed-reg unsigned-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:generator 4 - (inst sra x n-positive-fixnum-bits temp) - (inst sll x n-fixnum-tag-bits y) - (inst beq temp done) - (inst not temp temp) - (inst beq temp done) - (load-constant vop (emit-constant (1+ sb-xc:most-positive-fixnum)) - y) - DONE)) - -(define-vop (move-from-fixnum-1 move-from-fixnum+1) - (:generator 4 - (inst sra x n-positive-fixnum-bits temp) - (inst sll x n-fixnum-tag-bits y) - (inst beq temp done) - (inst not temp temp) - (inst beq temp done) - (load-constant vop (emit-constant (1- sb-xc:most-negative-fixnum)) - y) - DONE)) - -;;; Check for fixnum, and possibly allocate one or two word bignum -;;; result. Use a worst-case cost to make sure people know they may be -;;; number consing. -(define-vop (move-from-unsigned) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:note "unsigned word to integer coercion") - (:generator 20 - (move arg x) - (inst srl x n-positive-fixnum-bits temp) - (inst sll x n-fixnum-tag-bits y) - (inst beq temp done) - - (inst li 3 temp) - (inst cmovge x 2 temp) - (inst srl x 31 temp1) - (inst cmoveq temp1 1 temp) - (inst sll temp n-widetag-bits temp) - (inst bis temp bignum-widetag temp) - - (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) - (inst bis alloc-tn other-pointer-lowtag y) - (storew temp y 0 other-pointer-lowtag) - (storew x y bignum-digits-offset other-pointer-lowtag) - (inst srl x 32 temp) - (storew temp y (1+ bignum-digits-offset) other-pointer-lowtag)) - DONE)) -(define-move-vop move-from-unsigned :move - (unsigned-reg) (descriptor-reg)) - -;;; Move untagged numbers. -(define-vop (word-move) - (:args (x :target y - :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:results (y :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:note "word integer move") - (:generator 0 - (move x y))) -(define-move-vop word-move :move - (signed-reg unsigned-reg) (signed-reg unsigned-reg)) - -;;; Move untagged number arguments/return-values. -(define-vop (move-word-arg) - (:args (x :target y - :scs (signed-reg unsigned-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y signed-reg unsigned-reg)))) - (:results (y)) - (:note "word integer argument move") - (:generator 0 - (sc-case y - ((signed-reg unsigned-reg) - (move x y)) - ((signed-stack unsigned-stack) - (storeq x fp (tn-offset y)))))) -(define-move-vop move-word-arg :move-arg - (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Use standard MOVE-ARG + coercion to move an untagged number -;;; to a descriptor passing location. -(define-move-vop move-arg :move-arg - (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff -Nru sbcl-2.0.6/src/compiler/alpha/nlx.lisp sbcl-2.1.1/src/compiler/alpha/nlx.lisp --- sbcl-2.0.6/src/compiler/alpha/nlx.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/nlx.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,261 +0,0 @@ -;;;; the definitions of VOPs used for non-local exit (THROW, lexical -;;;; exit, 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-VM") - -;;; 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 ocfp-offset)) - -;;;; save and restoring the dynamic environment -;;;; -;;;; These VOPs are used in the reentered function to restore the -;;;; appropriate dynamic environment. Currently we only save the -;;;; CURRENT-CATCH and binding stack pointer. We don't need to -;;;; save/restore the current UNWIND-PROTECT, since UNWIND-PROTECTS -;;;; are implicitly processed during unwinding. If there were any -;;;; additional stacks (as e.g. there was an interpreter "eval stack" -;;;; before sbcl-0.7.0), then this would be the place to restore the -;;;; top pointers. - -(define-vop (save-dynamic-state) - (:results (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg))) - (:vop-var vop) - (:generator 13 - (load-symbol-value catch *current-catch-block*) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst mskll cur-nfp 4 nfp))) - (inst mskll nsp-tn 4 nsp))) - -(define-vop (restore-dynamic-state) - (:args (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg))) - (:vop-var vop) - (:temporary (:sc any-reg) temp) - (:generator 10 - (store-symbol-value catch *current-catch-block*) - (inst mskll nsp-tn 0 temp) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst bis nfp temp cur-nfp))) - (inst bis nsp temp nsp-tn))) - -(define-vop (current-stack-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move csp-tn res))) - -(define-vop (current-binding-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move bsp-tn res))) - -(define-vop (current-nsp) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move res nsp-tn))) - -(define-vop (set-nsp) - (:args (nsp :scs (any-reg descriptor-reg))) - (:generator 1 - (move nsp-tn nsp))) - -;;;; unwind block hackery - -;;; Compute the address of the catch block from its TN, then store -;;; into the block the current Fp, Env, Unwind-Protect, and the entry PC. -(define-vop (make-unwind-block) - (:args (tn)) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 22 - (inst lda block (tn-byte-offset tn) cfp-tn) - (load-symbol-value temp *current-unwind-protect-block*) - (storew temp block unwind-block-uwp-slot) - (storew cfp-tn block unwind-block-cfp-slot) - (storew code-tn block unwind-block-code-slot) - (inst compute-lra-from-code temp code-tn entry-label ndescr) - (storew temp block catch-block-entry-pc-slot))) - - -;;; This is like Make-Unwind-Block, except that we also store in the -;;; specified tag, and link the block into the Current-Catch list. -(define-vop (make-catch-block) - (:args (tn) - (tag :scs (any-reg descriptor-reg))) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 44 - (inst lda result (tn-byte-offset tn) cfp-tn) - (load-symbol-value temp *current-unwind-protect-block*) - (storew temp result catch-block-uwp-slot) - (storew cfp-tn result catch-block-cfp-slot) - (storew code-tn result catch-block-code-slot) - (inst compute-lra-from-code temp code-tn entry-label ndescr) - (storew temp result catch-block-entry-pc-slot) - - (storew tag result catch-block-tag-slot) - (load-symbol-value temp *current-catch-block*) - (storew temp result catch-block-previous-catch-slot) - (store-symbol-value result *current-catch-block*) - - (move result block))) - -;;; Just set the current unwind-protect to UWP. This -;;; instantiates an unwind block as an unwind-protect. -(define-vop (set-unwind-protect) - (:args (uwp :scs (any-reg))) - (:generator 7 - (store-symbol-value uwp *current-unwind-protect-block*))) - -(define-vop (%catch-breakup) - (:args (current-block)) - (:ignore current-block) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:generator 17 - (load-symbol-value block *current-catch-block*) - (loadw block block catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) - -(define-vop (%unwind-protect-breakup) - (:args (current-block)) - (:ignore current-block) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:generator 17 - (load-symbol-value block *current-unwind-protect-block*) - (loadw block block unwind-block-uwp-slot) - (store-symbol-value block *current-unwind-protect-block*))) - -;;;; NLX entry VOPs - -(define-vop (nlx-entry) - (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. - (start) - (count)) - (:results (values :more t)) - (:temporary (:scs (descriptor-reg)) move-temp) - (:temporary (:sc non-descriptor-reg) temp) - (:info label nvals) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (cond ((zerop nvals)) - ((= nvals 1) - (let ((no-values (gen-label))) - (move null-tn (tn-ref-tn values)) - (inst beq count no-values) - (loadw (tn-ref-tn values) start) - (emit-label no-values))) - (t - (collect ((defaults)) - (do ((i 0 (1+ i)) - (tn-ref values (tn-ref-across tn-ref))) - ((null tn-ref)) - (let ((default-lab (gen-label)) - (tn (tn-ref-tn tn-ref))) - (defaults (cons default-lab tn)) - - (inst move count temp) - (inst lda count (fixnumize -1) count) - (inst beq temp default-lab) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start i)) - (control-stack - (loadw move-temp start i) - (store-stack-tn tn move-temp))))) - - (let ((defaulting-done (gen-label))) - - (emit-label defaulting-done) - - (assemble (:elsewhere) - (dolist (def (defaults)) - (emit-label (car def)) - (let ((tn (cdr def))) - (sc-case tn - ((descriptor-reg any-reg) - (move null-tn tn)) - (control-stack - (store-stack-tn tn null-tn))))) - (inst br zero-tn defaulting-done)))))) - (load-stack-tn csp-tn sp))) - -(define-vop (nlx-entry-multiple) - (:args (top :target dst) (start :target src) (count :target num)) - ;; Again, no SC restrictions for the args, 'cause the loading would - ;; happen before the entry label. - (:info label) - (:temporary (:scs (any-reg) :from (:argument 0)) dst) - (:temporary (:scs (any-reg) :from (:argument 1)) src) - (:temporary (:scs (any-reg) :from (:argument 2)) num) - (:temporary (:scs (descriptor-reg)) temp) - (:results (new-start) (new-count)) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (let ((loop (gen-label)) - (done (gen-label))) - - ;; Copy args. - (load-stack-tn dst top) - (move start src) - (move count num) - - ;; Establish results. - (sc-case new-start - (any-reg (move dst new-start)) - (control-stack (store-stack-tn new-start dst))) - (sc-case new-count - (any-reg (inst move num new-count)) - (control-stack (store-stack-tn new-count num))) - (inst beq num done) - - ;; Copy stuff on stack. - (emit-label loop) - (loadw temp src) - (inst lda src n-word-bytes src) - (storew temp dst) - (inst lda num (fixnumize -1) num) - (inst lda dst n-word-bytes dst) - (inst bne num loop) - - (emit-label done) - (inst move dst csp-tn)))) - -;;; This VOP is just to force the TNs used in the cleanup onto the stack. -(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) - (note-this-location vop :non-local-entry))) diff -Nru sbcl-2.0.6/src/compiler/alpha/parms.lisp sbcl-2.1.1/src/compiler/alpha/parms.lisp --- sbcl-2.0.6/src/compiler/alpha/parms.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/parms.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,190 +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-VM") - -(defconstant sb-assem:assem-scheduler-p nil) -(defconstant sb-assem:+inst-alignment-bytes+ 4) - -(defconstant +backend-fasl-file-implementation+ :alpha) - -(defconstant +backend-page-bytes+ 8192) - -(eval-when (:compile-toplevel :load-toplevel :execute) - -;;; number of bits per word where a word holds one lisp descriptor -(defconstant n-word-bits 32) - -;;; the natural width of a machine word (as seen in e.g. register width, -;;; address space) -(defconstant n-machine-word-bits 64) - -(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)) - -;;; These values are originally from the DEC Assembly Language -;;; Programmers guide. Where possible we read/write the software -;;; fp_control word, which apparently is necessary for the OS FPU -;;; completion (OS handler which fixes up non-IEEE answers that the -;;; hardware occasionally gives us) to work properly. The rounding -;;; mode, however, can't be set that way, so we have to deal with that -;;; directly. (FIXME: we actually don't suport setting the rounding mode -;;; at the moment anyway) - -;;; Short guide to floating point trap terminology: an "exception" is -;;; cheap and can happen at almost any time. An exception will only -;;; generate a trap if that trap is enabled, otherwise a default value -;;; will be substituted. A "trap" will end up somewhere in the -;;; kernel, which may play by its own rules, (on Alpha it allegedly -;;; actually fixes up some non-IEEE compliant results to get the -;;; _right_ answer) but if something is really wrong will eventually -;;; signal SIGFPE and let us sort it out. - -;;; Old comment follows: The active bits are actually in (byte 12 52) -;;; of the fpcr. (byte 6 52) contain the exception flags. Bit 63 is the -;;; bitwise logor of all exceptions. The enable and exception bytes -;;; are in a software control word manipulated via OS functions and the -;;; bits in the SCP match those defs. This mapping follows -;;; - -;;; trap enables are set in software (fp_control) -(defconstant float-inexact-trap-bit (ash 1 4)) ; rw -(defconstant float-underflow-trap-bit (ash 1 3)) ; rw -(defconstant float-overflow-trap-bit (ash 1 2)) ; ro -(defconstant float-divide-by-zero-trap-bit (ash 1 1)) ; ro -(defconstant float-invalid-trap-bit (ash 1 0)) ; ro -(defconstant-eqx float-traps-byte (byte 6 1) #'equalp) - -;;; exceptions are also read/written in software (by syscalls, no less). -;;; This is kind of dumb, but has to be done -(defconstant-eqx float-sticky-bits (byte 6 17) #'equalp) ; fp_control - -;;; (We don't actually _have_ "current exceptions" on Alpha; the -;;; hardware only ever sets bits. So, set this the same as accrued -;;; exceptions) -(defconstant-eqx float-exceptions-byte (byte 6 17) #'equalp) - -;;; Rounding modes can only be set by frobbing the hardware fpcr directly -(defconstant float-round-to-zero 0) -(defconstant float-round-to-negative 1) -(defconstant float-round-to-nearest 2) -(defconstant float-round-to-positive 3) -(defconstant-eqx float-rounding-mode (byte 2 58) #'equalp) - -;;; Miscellaneous stuff - I think it's far to say that you deserve -;;; what you get if you ask for fast mode. -(defconstant float-fast-bit 0) - -); eval-when - - - -;;;; Description of the target address space. - -;;; Where to put the different spaces. -;;; - -(defconstant linkage-table-space-start #x1000) -(defconstant linkage-table-space-end linkage-table-space-start) ; 0 size - -#+linux -(progn - (defconstant read-only-space-start #x20000000) - (defconstant read-only-space-end #x24000000)) - -(defconstant static-space-start #x28000000) -(defconstant static-space-end #x2c000000) - -(defparameter dynamic-0-space-start #x30000000) -(defparameter dynamic-0-space-end #x3fff0000) - -;;; FIXME nothing refers to either of these in alpha or x86 cmucl -;;; backend, so they could probably be removed. - -;; The space-register holding the lisp heap. -(defconstant lisp-heap-space 4) - -;; The space-register holding the C text segment. -(defconstant c-text-space 4) - - -;;;; other miscellaneous constants - -(defenum (:start 8) - halt-trap - pending-interrupt-trap - cerror-trap - breakpoint-trap - fun-end-breakpoint-trap - single-step-breakpoint-trap - ;; Stepper actually not implemented on Alpha, but these constants - ;; are still needed to avoid undefined variable warnings during sbcl - ;; build. - single-step-around-trap - single-step-before-trap - error-trap) - -;;;; static symbols - -;;; These symbols are loaded into static space directly after NIL so -;;; that the system can compute their address by adding a constant -;;; amount to NIL. -;;; -;;; The fdefn objects for the static functions are loaded into static -;;; space directly after the static symbols. That way, the raw-addr -;;; can be loaded directly out of them by indirecting relative to NIL. -;;; -(defconstant-eqx +static-symbols+ - `#(,@+common-static-symbols+) - #'equalp) - -(defconstant-eqx +static-fdefns+ - #(length - two-arg-+ - two-arg-- - two-arg-* - two-arg-/ - two-arg-< - two-arg-> - two-arg-= - ;; FIXME: Is this - ;; probably need the following as they are defined in - ;; arith.lisp: two-arg-<= two-arg->= two-arg-/= - ;; a comment from old CMU CL or old old CMU CL or - ;; the SBCL alpha port or what? Do we need to worry about it, - ;; or can we delete it? - two-arg-/= - eql - %negate - two-arg-and - two-arg-ior - two-arg-xor - two-arg-eqv - two-arg-gcd - two-arg-lcm) - #'equalp) diff -Nru sbcl-2.0.6/src/compiler/alpha/pred.lisp sbcl-2.1.1/src/compiler/alpha/pred.lisp --- sbcl-2.0.6/src/compiler/alpha/pred.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/pred.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -;;;; the VM definition of predicate VOPs for the Alpha - -;;;; 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") - -;;;; the Branch VOP - -;;; The unconditional branch, emitted when we can't drop through to -;;; the desired destination. Dest is the continuation we transfer -;;; control to. -(define-vop (branch) - (:info dest) - (:generator 5 - (inst br zero-tn dest))) - - -;;;; Generic conditional VOPs - -;;; The generic conditional branch, emitted immediately after test -;;; VOPs that only set flags. - -(define-vop (branch-if) - (:info dest flags not-p) - (:ignore dest flags not-p) - (:generator 0 - (error "BRANCH-IF not yet implemented"))) - -(defun convert-conditional-move-p (node dst-tn x-tn y-tn) - (declare (ignore node dst-tn x-tn y-tn)) - nil) - - -;;;; conditional VOPs - -(define-vop (if-eq) - (:args (x :scs (any-reg descriptor-reg zero null)) - (y :scs (any-reg descriptor-reg zero null))) - (:conditional) - (:temporary (:scs (non-descriptor-reg)) temp) - (:info target not-p) - (:policy :fast-safe) - (:translate eq) - (:generator 3 - (inst cmpeq x y temp) - (if not-p - (inst beq temp target) - (inst bne temp target)))) diff -Nru sbcl-2.0.6/src/compiler/alpha/sap.lisp sbcl-2.1.1/src/compiler/alpha/sap.lisp --- sbcl-2.0.6/src/compiler/alpha/sap.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/sap.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,355 +0,0 @@ -;;;; the Alpha VM definition of SAP operations - -;;;; 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") - -;;;; moves and coercions - -;;; Move a tagged SAP to an untagged representation. -(define-vop (move-to-sap) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (sap-reg))) - (:note "system area pointer indirection") - (:generator 1 - (loadq y x sap-pointer-slot other-pointer-lowtag))) -(define-move-vop move-to-sap :move - (descriptor-reg) (sap-reg)) - -;;; Move an untagged SAP to a tagged representation. -(define-vop (move-from-sap) - (:args (x :scs (sap-reg) :target sap)) - (:temporary (:scs (sap-reg) :from (:argument 0)) sap) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (y :scs (descriptor-reg))) - (:note "system area pointer allocation") - (:generator 20 - (move x sap) - (with-fixed-allocation (y ndescr sap-widetag sap-size) - (storeq sap y sap-pointer-slot other-pointer-lowtag)))) -(define-move-vop move-from-sap :move - (sap-reg) (descriptor-reg)) - -;;; Move untagged SAP values. -(define-vop (sap-move) - (:args (x :target y - :scs (sap-reg) - :load-if (not (location= x y)))) - (:results (y :scs (sap-reg) - :load-if (not (location= x y)))) - (:generator 0 - (move x y))) -(define-move-vop sap-move :move - (sap-reg) (sap-reg)) - -;;; Move untagged SAP arguments/return-values. -(define-vop (move-sap-arg) - (:args (x :target y - :scs (sap-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (sap-reg - (move x y)) - (sap-stack - (storeq x fp (tn-offset y)))))) -(define-move-vop move-sap-arg :move-arg - (descriptor-reg sap-reg) (sap-reg)) - -;;; Use standard MOVE-ARG + coercion to move an untagged sap to a -;;; descriptor passing location. -(define-move-vop move-arg :move-arg - (sap-reg) (descriptor-reg)) - -;;;; SAP-INT and INT-SAP - -(define-vop (sap-int) - (:args (sap :scs (sap-reg) :target int)) - (:arg-types system-area-pointer) - (:results (int :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate sap-int) - (:policy :fast-safe) - (:generator 1 - (move sap int))) - -(define-vop (int-sap) - (:args (int :scs (unsigned-reg) :target sap)) - (:arg-types unsigned-num) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate int-sap) - (:policy :fast-safe) - (:generator 1 - (move int sap))) - -;;;; POINTER+ and POINTER- - -(define-vop (pointer+) - (:translate sap+) - (:args (ptr :scs (sap-reg)) - (offset :scs (signed-reg immediate))) - (:arg-types system-area-pointer signed-num) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:policy :fast-safe) - (:generator 1 - (sc-case offset - (signed-reg - (inst addq offset ptr res)) - (immediate - (inst lda res (tn-value offset) ptr))))) - -(define-vop (pointer-) - (:translate sap-) - (:args (ptr1 :scs (sap-reg)) - (ptr2 :scs (sap-reg))) - (:arg-types system-area-pointer system-area-pointer) - (:policy :fast-safe) - (:results (res :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (inst subq ptr1 ptr2 res))) - -;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET - -(macrolet ((def-system-ref-and-set - (ref-name set-name sc type size &optional signed) - (let ((ref-name-c (symbolicate ref-name "-C")) - (set-name-c (symbolicate set-name "-C"))) - `(progn - (define-vop (,ref-name) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) - ,@(when (or (eq size :byte) (eq size :short)) - `((:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1))) - (:results (result :scs (,sc))) - (:result-types ,type) - (:temporary (:scs (sap-reg) :from (:argument 0)) sap) - (:generator 5 - (inst addq object offset sap) - ,@(ecase size - (:byte - (if signed - '((inst ldq_u temp 0 sap) - (inst lda temp1 1 sap) - (inst extqh temp temp1 temp) - (inst sra temp 56 result)) - '((inst ldq_u temp 0 sap) - (inst lda temp1 0 sap) - (inst extbl temp temp1 result)))) - (:short - (if signed - '((inst ldq_u temp 0 sap) - (inst lda temp1 0 sap) - (inst extwl temp temp1 temp) - (inst sll temp 48 temp) - (inst sra temp 48 result)) - '((inst ldq_u temp 0 sap) - (inst lda temp1 0 sap) - (inst extwl temp temp1 result)))) - (:long - `((inst ldl result 0 sap) - ,@(unless signed - '((inst mskll result 4 result))))) - (:quad - '((inst ldq result 0 sap))) - (:single - '((inst lds result 0 sap))) - (:double - '((inst ldt result 0 sap)))))) - (define-vop (,ref-name-c) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg))) - (:arg-types system-area-pointer - (:constant ,(if (eq size :double) - ;; We need to be able to add 4. - `(integer ,(- (ash 1 16)) - ,(- (ash 1 16) 5)) - '(signed-byte 16)))) - ,@(when (or (eq size :byte) (eq size :short)) - `((:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc non-descriptor-reg) temp1))) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 4 - ,@(ecase size - (:byte - (if signed - '((inst ldq_u temp offset object) - (inst lda temp1 (1+ offset) object) - (inst extqh temp temp1 temp) - (inst sra temp 56 result)) - '((inst ldq_u temp offset object) - (inst lda temp1 offset object) - (inst extbl temp temp1 result)))) - (:short - (if signed - '((inst ldq_u temp offset object) - (inst lda temp1 offset object) - (inst extwl temp temp1 temp) - (inst sll temp 48 temp) - (inst sra temp 48 result)) - '((inst ldq_u temp offset object) - (inst lda temp1 offset object) - (inst extwl temp temp1 result)))) - (:long - `((inst ldl result offset object) - ,@(unless signed - '((inst mskll result 4 result))))) - (:quad - '((inst ldq result offset object))) - (:single - '((inst lds result offset object))) - (:double - '((inst ldt result offset object)))))) - (define-vop (,set-name) - (:translate ,set-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (signed-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer signed-num ,type) - (:results (result :scs (,sc))) - (:result-types ,type) - (:temporary (:scs (sap-reg) :from (:argument 0)) sap) - ,@(when (or (eq size :byte) (eq size :short)) - `((:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:temporary (:sc non-descriptor-reg) temp2))) - (:generator 5 - (inst addq object offset sap) - ,@(ecase size - (:byte - '((inst lda temp 0 sap) - (inst ldq_u temp1 0 sap) - (inst insbl value temp temp2) - (inst mskbl temp1 temp temp1) - (inst bis temp1 temp2 temp1) - (inst stq_u temp1 0 sap) - (inst move value result))) - (:short - '((inst lda temp 0 sap) - (inst ldq_u temp1 0 sap) - (inst mskwl temp1 temp temp1) - (inst inswl value temp temp2) - (inst bis temp1 temp2 temp) - (inst stq_u temp 0 sap) - (inst move value result))) - (:long - '((inst stl value 0 sap) - (move value result))) - (:quad - '((inst stq value 0 sap) - (move value result))) - (:single - '((unless (location= result value) - (inst fmove value result)) - (inst sts value 0 sap))) - (:double - '((unless (location= result value) - (inst fmove value result)) - (inst stt value 0 sap)))))) - (define-vop (,set-name-c) - (:translate ,set-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer - (:constant ,(if (eq size :double) - ;; We need to be able to add 4. - `(integer ,(- (ash 1 16)) - ,(- (ash 1 16) 5)) - '(signed-byte 16))) - ,type) - ,@(when (or (eq size :byte) (eq size :short)) - `((:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:temporary (:sc non-descriptor-reg) temp2))) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - ,@(ecase size - (:byte - '((inst lda temp offset object) - (inst ldq_u temp1 offset object) - (inst insbl value temp temp2) - (inst mskbl temp1 temp temp1) - (inst bis temp1 temp2 temp1) - (inst stq_u temp1 offset object) - (inst move value result))) - (:short - '((inst lda temp offset object) - (inst ldq_u temp1 offset object) - (inst mskwl temp1 temp temp1) - (inst inswl value temp temp2) - (inst bis temp1 temp2 temp) - (inst stq_u temp offset object) - (inst move value result))) - (:long - '((inst stl value offset object) - (move value result))) - (:quad - '((inst stq value offset object) - (move value result))) - (:single - '((unless (location= result value) - (inst fmove value result)) - (inst sts value offset object))) - (:double - '((unless (location= result value) - (inst fmove value result)) - (inst stt value offset object)))))))))) - (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 - unsigned-reg positive-fixnum :byte nil) - (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 - signed-reg tagged-num :byte t) - (def-system-ref-and-set sap-ref-16 %set-sap-ref-16 - unsigned-reg positive-fixnum :short nil) - (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 - signed-reg tagged-num :short t) - (def-system-ref-and-set sap-ref-32 %set-sap-ref-32 - unsigned-reg unsigned-num :long nil) - (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 - signed-reg signed-num :long t) - (def-system-ref-and-set sap-ref-64 %set-sap-ref-64 - unsigned-reg unsigned-num :quad nil) - (def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64 - signed-reg signed-num :quad t) - (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap - sap-reg system-area-pointer :quad) - (def-system-ref-and-set sap-ref-lispobj %set-sap-ref-lispobj - descriptor-reg * :long) - (def-system-ref-and-set sap-ref-single %set-sap-ref-single - single-reg single-float :single) - (def-system-ref-and-set sap-ref-double %set-sap-ref-double - double-reg double-float :double)) - -;;; noise to convert normal Lisp data objects into SAPs - -(define-vop (vector-sap) - (:translate vector-sap) - (:policy :fast-safe) - (:args (vector :scs (descriptor-reg))) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst lda sap - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - vector))) diff -Nru sbcl-2.0.6/src/compiler/alpha/show.lisp sbcl-2.1.1/src/compiler/alpha/show.lisp --- sbcl-2.0.6/src/compiler/alpha/show.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/show.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -;;;; temporary printing utilities and similar noise - -;;;; 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") - -(define-vop (print) - (:args (object :scs (descriptor-reg) :target a0)) - (:results (result :scs (descriptor-reg))) - (:save-p t) - (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0)) - cfunc) - (:temporary (:sc descriptor-reg :offset nl0-offset :from (:argument 0)) a0) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:generator 0 - (let ((cur-nfp (current-nfp-tn vop))) - (move object a0) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (inst li (make-fixup "debug_print" :foreign) cfunc) - (inst li (make-fixup "call_into_c" :foreign) temp) - (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign)) - (when cur-nfp - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)) - (move cfunc result)))) diff -Nru sbcl-2.0.6/src/compiler/alpha/subprim.lisp sbcl-2.1.1/src/compiler/alpha/subprim.lisp --- sbcl-2.0.6/src/compiler/alpha/subprim.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/subprim.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -;;;; linkage information for standard static functions, and random 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") - -;;;; LENGTH - -(define-vop (length/list) - (:translate length) - (:args (object :scs (descriptor-reg) :target ptr)) - (:arg-types list) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (any-reg) :to (:result 0) :target result) - count) - (:results (result :scs (any-reg descriptor-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:generator 50 - (move object ptr) - (move zero-tn count) - - LOOP - - (inst cmpeq ptr null-tn temp) - (inst bne temp done) - - (inst and ptr lowtag-mask temp) - (inst xor temp list-pointer-lowtag temp) - (inst bne temp not-list) - - (loadw ptr ptr cons-cdr-slot list-pointer-lowtag) - (inst addq count (fixnumize 1) count) - (inst br zero-tn loop) - - NOT-LIST - (cerror-call vop 'object-not-list-error ptr) - - DONE - (move count result))) diff -Nru sbcl-2.0.6/src/compiler/alpha/system.lisp sbcl-2.1.1/src/compiler/alpha/system.lisp --- sbcl-2.0.6/src/compiler/alpha/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/system.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,208 +0,0 @@ -;;;; Alpha VM definitions of various system hacking operations - -;;;; 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") - -;;;; type frobbing VOPs - -(define-vop (widetag-of) - (:translate widetag-of) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - ;; Pick off objects with headers. - (inst and object lowtag-mask result) - (inst cmpeq result other-pointer-lowtag ndescr) - (inst bne ndescr other-ptr) - (inst cmpeq result fun-pointer-lowtag ndescr) - (inst bne ndescr function-ptr) - - ;; Pick off structure and list pointers. - (inst blbs object done) - - ;; Pick off fixnums. - (inst and object fixnum-tag-mask result) - (inst beq result done) - - ;; Must be an other immediate. - (inst and object widetag-mask result) - (inst br zero-tn done) - - FUNCTION-PTR - (load-type result object (- fun-pointer-lowtag)) - (inst br zero-tn done) - - OTHER-PTR - (load-type result object (- other-pointer-lowtag)) - - DONE)) - -(define-vop (%other-pointer-widetag) - (:translate %other-pointer-widetag) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (load-type result object (- other-pointer-lowtag)))) - -(define-vop (fun-subtype) - (:translate fun-subtype) - (:policy :fast-safe) - (:args (function :scs (descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (load-type result function (- fun-pointer-lowtag)))) - -(define-vop (get-header-data) - (:translate get-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 other-pointer-lowtag) - (inst srl res n-widetag-bits res))) - -(define-vop (set-header-data) - (:translate set-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res) - (data :scs (any-reg immediate zero))) - (:arg-types * positive-fixnum) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) t1 t2) - (:generator 6 - (loadw t1 x 0 other-pointer-lowtag) - (inst and t1 widetag-mask t1) - (sc-case data - (any-reg - (inst sll data (- n-widetag-bits n-fixnum-tag-bits) t2) - (inst bis t1 t2 t1)) - (immediate - (let ((c (ash (tn-value data) n-widetag-bits))) - (cond ((<= 0 c (1- (ash 1 8))) - (inst bis t1 c t1)) - (t - (inst li c t2) - (inst bis t1 t2 t1))))) - (zero)) - (storew t1 x 0 other-pointer-lowtag) - (move x res))) - -(define-vop (pointer-hash) - (:translate pointer-hash) - (:args (ptr :scs (any-reg descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:policy :fast-safe) - (:generator 1 - ;; FIXME: It would be better if this would mask the lowtag, - ;; and shift the result into a positive fixnum like on x86. - (inst sll ptr 35 res) - (inst srl res 33 res))) - - -;;;; allocation - -(define-vop (dynamic-space-free-pointer) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate dynamic-space-free-pointer) - (:policy :fast-safe) - (:generator 1 - (move alloc-tn int))) - -(define-vop (binding-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate binding-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move bsp-tn int))) - -(define-vop (control-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate control-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move csp-tn int))) - - -;;;; code object frobbing - -(define-vop (code-instructions) - (:translate code-instructions) - (:policy :fast-safe) - (:args (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 10 - (loadw ndescr code 0 other-pointer-lowtag) - (inst srl ndescr n-widetag-bits ndescr) - (inst sll ndescr word-shift ndescr) - (inst subq ndescr other-pointer-lowtag ndescr) - (inst addq code ndescr sap))) - -(define-vop (compute-fun) - (:args (code :scs (descriptor-reg)) - (offset :scs (signed-reg unsigned-reg))) - (:arg-types * positive-fixnum) - (:results (func :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 10 - (loadw ndescr code code-boxed-size-slot other-pointer-lowtag) - (inst addq ndescr offset ndescr) - (inst subq ndescr (- other-pointer-lowtag fun-pointer-lowtag) ndescr) - (inst addq code ndescr func))) - -;;;; other random VOPs. - -(defknown sb-unix::receive-pending-interrupt () (values)) -(define-vop (sb-unix::receive-pending-interrupt) - (:policy :fast-safe) - (:translate sb-unix::receive-pending-interrupt) - (:generator 1 - (inst gentrap pending-interrupt-trap))) - - -(define-vop (halt) - (:generator 1 - (inst gentrap halt-trap))) - -(define-vop (istream-memory-barrier) - (:generator 1 - (inst imb))) - -;;;; dynamic vop count collection support - -(define-vop (count-me) - (:args (count-vector :scs (descriptor-reg))) - (:info index) - (:temporary (:scs (non-descriptor-reg)) count) - (:generator 1 - (let ((offset - (- (* (+ index vector-data-offset) n-word-bytes) - other-pointer-lowtag))) - (inst ldl count offset count-vector) - (inst addq count 1 count) - (inst stl count offset count-vector)))) - -;;;; Dummy definition for a spin-loop hint VOP -(define-vop () - (:translate spin-loop-hint) - (:policy :fast-safe) - (:generator 0)) diff -Nru sbcl-2.0.6/src/compiler/alpha/target-insts.lisp sbcl-2.1.1/src/compiler/alpha/target-insts.lisp --- sbcl-2.0.6/src/compiler/alpha/target-insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/target-insts.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,38 +0,0 @@ -;;;; This file is for stuff which was in CMU CL's insts.lisp -;;;; file, but which in the SBCL build process can't be compiled -;;;; into code for the cross-compilation host. - -;;;; 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-ALPHA-ASM") - -(defun bugchk-trap-control (chunk inst stream dstate) - (declare (ignore inst)) - (flet ((nt (x) (if stream (note x dstate)))) - (let ((trap (bugchk-trap-code chunk dstate))) - (case trap - (#.halt-trap - (nt "Halt trap")) - (#.pending-interrupt-trap - (nt "Pending interrupt trap")) - (#.breakpoint-trap - (nt "Breakpoint trap")) - (#.fun-end-breakpoint-trap - (nt "Function end breakpoint trap")) - (#.single-step-breakpoint-trap - (nt "Single step breakpoint trap")) - (#.single-step-around-trap - (nt "Single step around trap")) - (#.single-step-before-trap - (nt "Single step before trap")) - (t - (when (or (and (= trap cerror-trap) (progn (nt "cerror trap") t)) - (>= trap-number error-trap)) - (handle-break-args #'snarf-error-junk trap stream dstate))))))) diff -Nru sbcl-2.0.6/src/compiler/alpha/type-vops.lisp sbcl-2.1.1/src/compiler/alpha/type-vops.lisp --- sbcl-2.0.6/src/compiler/alpha/type-vops.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/type-vops.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,189 +0,0 @@ -;;;; type testing and checking VOPs for the Alpha VM - -;;;; 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") - -(defun %test-fixnum (value temp target not-p) - (assemble () - (inst and value fixnum-tag-mask temp) - (if not-p - (inst bne temp target) - (inst beq temp target)))) - -(defun %test-fixnum-and-headers (value temp target not-p headers &key value-tn-ref) - (let ((drop-through (gen-label))) - (assemble () - (inst and value fixnum-tag-mask temp) - (inst beq temp (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))) - -(defun %test-immediate (value temp target not-p immediate) - (assemble () - (inst and value 255 temp) - (inst xor temp immediate temp) - (if not-p - (inst bne temp target) - (inst beq temp target)))) - -(defun %test-lowtag (value temp target not-p lowtag) - (assemble () - (inst and value lowtag-mask temp) - (inst xor temp lowtag temp) - (if not-p - (inst bne temp target) - (inst beq temp target)))) - -(defun %test-headers (value temp target not-p function-p headers - &key (drop-through (gen-label)) value-tn-ref) - (declare (ignore value-tn-ref)) - (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) - (multiple-value-bind - (when-true when-false) - ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when - ;; we know it's true and when we know it's false respectively. - (if not-p - (values drop-through target) - (values target drop-through)) - (assemble () - (%test-lowtag value temp when-false t lowtag) - (load-type temp value (- lowtag)) - (let ((delta 0)) - (do ((remaining headers (cdr remaining))) - ((null remaining)) - (let ((header (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom header) - (inst subq temp (- header delta) temp) - (setf delta header) - (if last - (if not-p - (inst bne temp target) - (inst beq temp target)) - (inst beq temp when-true))) - (t - (let ((start (car header)) - (end (cdr header))) - (unless (= start bignum-widetag) - (inst subq temp (- start delta) temp) - (setf delta start) - (inst blt temp when-false)) - (inst subq temp (- end delta) temp) - (setf delta end) - (if last - (if not-p - (inst bgt temp target) - (inst ble temp target)) - (inst ble temp when-true)))))))) - (emit-label drop-through))))) - -;;;; Other integer ranges. - -;;; A (signed-byte 32) can be represented with either fixnum or a bignum with -;;; exactly one digit. -(define-vop (signed-byte-32-p type-predicate) - (:translate signed-byte-32-p) - (:temporary (:scs (non-descriptor-reg)) temp1) - (:generator 45 - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - (assemble () - (inst and value fixnum-tag-mask temp) - (inst beq temp yep) - (inst and value lowtag-mask temp) - (inst xor temp other-pointer-lowtag temp) - (inst bne temp nope) - (loadw temp value 0 other-pointer-lowtag) - (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1) - (inst xor temp temp1 temp) - (if not-p - (inst bne temp target) - (inst beq temp target)))) - NOT-TARGET)) - -;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a -;;; bignum with exactly one positive digit, or a bignum with exactly two digits -;;; and the second digit all zeros. - -(define-vop (unsigned-byte-32-p type-predicate) - (:translate unsigned-byte-32-p) - (:temporary (:scs (non-descriptor-reg)) temp1) - (:generator 45 - (multiple-value-bind (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - (assemble () - ;; Is it a fixnum? - (inst and value fixnum-tag-mask temp1) - (inst move value temp) - (inst beq temp1 fixnum) - - ;; If not, is it an other pointer? - (inst and value lowtag-mask temp) - (inst xor temp other-pointer-lowtag temp) - (inst bne temp nope) - ;; Get the header. - (loadw temp value 0 other-pointer-lowtag) - ;; Is it one? - (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1) - (inst xor temp temp1 temp) - (inst beq temp single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst li (logxor (+ (ash 1 n-widetag-bits) bignum-widetag) - (+ (ash 2 n-widetag-bits) bignum-widetag)) - temp1) - (inst xor temp temp1 temp) - (inst bne temp nope) - ;; Get the second digit. - (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag) - ;; All zeros, its an (unsigned-byte 32). - (inst beq temp yep) - (inst br zero-tn nope) - - SINGLE-WORD - ;; Get the single digit. - (loadw temp value bignum-digits-offset other-pointer-lowtag) - - ;; positive implies (unsigned-byte 32). - FIXNUM - (if not-p - (inst blt temp target) - (inst bge temp target)))) - NOT-TARGET)) - -;;;; List/symbol types: -;;; -;;; symbolp (or symbol (eq nil)) -;;; consp (and list (not (eq nil))) - -(define-vop (symbolp type-predicate) - (:translate symbolp) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 12 - (inst cmpeq value null-tn temp) - (inst bne temp (if not-p drop-thru target)) - (test-type value temp target not-p (symbol-widetag)) - DROP-THRU)) - -(define-vop (consp type-predicate) - (:translate consp) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 8 - (inst cmpeq value null-tn temp) - (inst bne temp (if not-p target drop-thru)) - (test-type value temp target not-p (list-pointer-lowtag)) - DROP-THRU)) diff -Nru sbcl-2.0.6/src/compiler/alpha/values.lisp sbcl-2.1.1/src/compiler/alpha/values.lisp --- sbcl-2.0.6/src/compiler/alpha/values.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/values.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,156 +0,0 @@ -;;;; the Alpha implementation of unknown-values 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") - -(define-vop (reset-stack-pointer) - (:args (ptr :scs (any-reg))) - (:generator 1 - (move ptr csp-tn))) - -(define-vop (%%nip-values) - (:args (last-nipped-ptr :scs (any-reg) :target dest) - (last-preserved-ptr :scs (any-reg) :target src) - (moved-ptrs :scs (any-reg) :more t)) - (:results (r-moved-ptrs :scs (any-reg) :more t)) - (:temporary (:sc any-reg) src) - (:temporary (:sc any-reg) dest) - (:temporary (:sc non-descriptor-reg) cmp-temp) - (:temporary (:sc descriptor-reg) temp) - (:ignore r-moved-ptrs) - (:generator 1 - (move last-nipped-ptr dest) - (move last-preserved-ptr src) - (inst cmple csp-tn src cmp-temp) - (inst bne cmp-temp DONE) - LOOP - (loadw temp src) - (inst addq dest n-word-bytes dest) - (inst addq src n-word-bytes src) - (storew temp dest -1) - (inst cmple csp-tn src cmp-temp) - (inst beq cmp-temp LOOP) - DONE - (inst lda csp-tn 0 dest) - (inst subq src dest src) - (loop for moved = moved-ptrs then (tn-ref-across moved) - while moved - do (sc-case (tn-ref-tn moved) - ((descriptor-reg any-reg) - (inst subq (tn-ref-tn moved) src (tn-ref-tn moved))) - ((control-stack) - (load-stack-tn temp (tn-ref-tn moved)) - (inst subq temp src temp) - (store-stack-tn (tn-ref-tn moved) temp)))))) - -;;; Push some values onto the stack, returning the start and number of -;;; values pushed as results. It is assumed that the Vals are wired to -;;; the standard argument locations. Nvals is the number of values to -;;; push. -;;; -;;; The generator cost is pseudo-random. We could get it right by -;;; defining a bogus SC that reflects the costs of the -;;; memory-to-memory moves for each operand, but this seems -;;; unworthwhile. -(define-vop (push-values) - (:args - (vals :more t)) - (:results - (start :scs (any-reg)) - (count :scs (any-reg))) - (:info nvals) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) - :to (:result 0) - :target start) - start-temp) - (:generator 20 - (move csp-tn start-temp) - (inst lda csp-tn (* nvals n-word-bytes) csp-tn) - (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-temp i)) - (control-stack - (load-stack-tn temp tn) - (storew temp start-temp i))))) - (move start-temp start) - (inst li (fixnumize nvals) count))) - -;;; Push a list of values on the stack, returning Start and Count as -;;; used in unknown values continuations. -(define-vop (values-list) - (:args (arg :scs (descriptor-reg) :target list)) - (:arg-types list) - (:policy :fast-safe) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) list) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (move arg list) - (move csp-tn start) - - LOOP - (inst cmpeq list null-tn temp) - (inst bne temp done) - (loadw temp list cons-car-slot list-pointer-lowtag) - (loadw list list cons-cdr-slot list-pointer-lowtag) - (inst lda csp-tn n-word-bytes csp-tn) - (storew temp csp-tn -1) - (inst and list lowtag-mask ndescr) - (inst xor ndescr list-pointer-lowtag ndescr) - (inst beq ndescr loop) - (cerror-call vop 'bogus-arg-to-values-list-error list) - - DONE - (inst subq csp-tn start count))) - -;;; Copy the &MORE arg block to the top of the stack so we can use -;;; them as function arguments. -(define-vop (%more-arg-values) - (:args (context :scs (descriptor-reg any-reg) :target src) - (skip :scs (any-reg zero immediate)) - (num :scs (any-reg) :target count)) - (:arg-types * positive-fixnum positive-fixnum) - (:temporary (:sc any-reg :from (:argument 0)) src) - (:temporary (:sc any-reg :from (:argument 2)) dst) - (:temporary (:sc descriptor-reg :from (:argument 1)) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:generator 20 - (sc-case skip - (zero - (move context src)) - (immediate - (inst lda src (* (tn-value skip) n-word-bytes) context)) - (any-reg - (inst addq context skip src))) - (move num count) - (inst move csp-tn start) - (inst beq num done) - (inst move csp-tn dst) - (inst addq csp-tn count csp-tn) - LOOP - (inst ldl temp 0 src) - (inst addq src 4 src) - (inst addq dst 4 dst) - (inst stl temp -4 dst) - (inst cmpeq dst csp-tn temp1) - (inst beq temp1 loop) - DONE)) diff -Nru sbcl-2.0.6/src/compiler/alpha/vm.lisp sbcl-2.1.1/src/compiler/alpha/vm.lisp --- sbcl-2.0.6/src/compiler/alpha/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/alpha/vm.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,347 +0,0 @@ -;;;; miscellaneous VM definition noise for the Alpha - -;;;; 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") - -;;;; defining the registers - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *register-names* (make-array 32 :initial-element nil))) - -(macrolet ((defreg (name offset) - (let ((offset-sym (symbolicate name "-OFFSET"))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,offset-sym ,offset) - (setf (svref *register-names* ,offset-sym) - ,(symbol-name name))))) - (defregset (name &rest regs) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,name - (list ,@(mapcar (lambda (name) - (symbolicate name "-OFFSET")) - regs)))))) - ;; c.f. src/runtime/alpha-lispregs.h - - ;; Ra - (defreg lip 0) - ;; Caller saved 0-7 - (defreg a0 1) - (defreg a1 2) - (defreg a2 3) - (defreg a3 4) - (defreg a4 5) - (defreg a5 6) - (defreg l0 7) - (defreg nargs 8) - ;; Callee saved 0-6 - (defreg csp 9) - (defreg cfp 10) - (defreg ocfp 11) - (defreg bsp 12) - (defreg lexenv 13) - (defreg code 14) - (defreg null 15) - ;; Arg 0-5 - (defreg nl0 16) - (defreg nl1 17) - (defreg nl2 18) - (defreg nl3 19) - (defreg nl4 20) - (defreg nl5 21) - ;; Caller saved 8-11 - (defreg alloc 22) - (defreg fdefn 23) - (defreg cfunc 24) - (defreg nfp 25) - ;; Ra - (defreg lra 26) - ;; Caller saved 12 - (defreg l1 27) - ;; Assembler temp (at) - (defreg l2 28) - ;; Global pointer (gp) - (defreg gp 29) - ;; Stack pointer - (defreg nsp 30) - ;; Wired zero - (defreg zero 31) - - (defregset non-descriptor-regs - nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc) - - (defregset descriptor-regs - fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2) - - (defregset boxed-regs - code fdefn lexenv nargs ocfp lra - a0 a1 a2 a3 a4 a5 - l0 l1 l2) - - (defregset *register-arg-offsets* - a0 a1 a2 a3 a4 a5) - (defparameter register-arg-names '(a0 a1 a2 a3 a4 a5))) - -(!define-storage-bases -(define-storage-base registers :finite :size 32) -(define-storage-base float-registers :finite :size 64) -(define-storage-base control-stack :unbounded :size 8) -(define-storage-base non-descriptor-stack :unbounded :size 0) -(define-storage-base constant :non-packed) -(define-storage-base immediate-constant :non-packed) -) - -(!define-storage-classes - - ;; non-immediate constants in the constant pool - (constant constant) - - ;; ZERO and NULL are in registers. - (zero immediate-constant) - (null immediate-constant) - (fp-single-zero immediate-constant) - (fp-double-zero immediate-constant) - - ;; Anything else that can be an immediate. - (immediate immediate-constant) - - - ;; **** The stacks. - - ;; The control stack. (Scanned by GC) - (control-stack control-stack) - - ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER - ;; is small and therefore the error trap information is smaller. - ;; Moving them up here from their previous place down below saves - ;; ~250K in core file size. --njf, 2006-01-27 - - ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing - ;; bad will happen if they are. (fixnums, characters, header values, etc). - (any-reg - registers - :locations #.(append non-descriptor-regs descriptor-regs) - :constant-scs (zero immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Pointer descriptor objects. Must be seen by GC. - (descriptor-reg registers - :locations #.descriptor-regs - :constant-scs (constant null immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; The non-descriptor stacks. - (signed-stack non-descriptor-stack - :element-size 2 :alignment 2) ; (signed-byte 64) - (unsigned-stack non-descriptor-stack - :element-size 2 :alignment 2) ; (unsigned-byte 64) - (character-stack non-descriptor-stack) ; non-descriptor characters. - (sap-stack non-descriptor-stack - :element-size 2 :alignment 2) ; System area pointers. - (single-stack non-descriptor-stack) ; single-floats - (double-stack non-descriptor-stack - :element-size 2 :alignment 2) ; double floats. - (complex-single-stack non-descriptor-stack :element-size 2) - (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) - - - ;; **** Things that can go in the integer registers. - - ;; Non-Descriptor characters - (character-reg registers - :locations #.non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (character-stack)) - - ;; Non-Descriptor SAP's (arbitrary pointers into address space) - (sap-reg registers - :locations #.non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (sap-stack)) - - ;; Non-Descriptor (signed or unsigned) numbers. - (signed-reg registers - :locations #.non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (signed-stack)) - (unsigned-reg registers - :locations #.non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (unsigned-stack)) - - ;; Random objects that must not be seen by GC. Used only as temporaries. - (non-descriptor-reg registers - :locations #.non-descriptor-regs) - - ;; Pointers to the interior of objects. Used only as an temporary. - (interior-reg registers - :locations (#.lip-offset)) - - - ;; **** Things that can go in the floating point registers. - - ;; Non-Descriptor single-floats. - (single-reg float-registers - :locations #.(loop for i from 4 to 30 collect i) - :constant-scs (fp-single-zero) - :save-p t - :alternate-scs (single-stack)) - - ;; Non-Descriptor double-floats. - (double-reg float-registers - :locations #.(loop for i from 4 to 30 collect i) - :constant-scs (fp-double-zero) - :save-p t - :alternate-scs (double-stack)) - - (complex-single-reg float-registers - :locations #.(loop for i from 4 to 28 by 2 collect i) - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (complex-single-stack)) - - (complex-double-reg float-registers - :locations #.(loop for i from 4 to 28 by 2 collect i) - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (complex-double-stack)) - - (catch-block control-stack :element-size catch-block-size) - (unwind-block control-stack :element-size unwind-block-size)) - -;;; Make some random tns for important registers. -(macrolet ((defregtn (name sc) - (let ((offset-sym (symbolicate name "-OFFSET")) - (tn-sym (symbolicate name "-TN"))) - `(defparameter ,tn-sym - (make-random-tn :kind :normal - :sc (sc-or-lose ',sc) - :offset ,offset-sym))))) - - ;; These, we access by foo-TN only - - (defregtn zero any-reg) - (defregtn null descriptor-reg) - (defregtn code descriptor-reg) - (defregtn alloc any-reg) - (defregtn bsp any-reg) - (defregtn csp any-reg) - (defregtn cfp any-reg) - (defregtn nsp any-reg) - - ;; These alias regular locations, so we have to make sure we don't bypass - ;; the register allocator when using them. - (defregtn nargs any-reg) - (defregtn ocfp any-reg) - (defregtn lip interior-reg)) - -;; and some floating point values.. -(defparameter fp-single-zero-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'single-reg) - :offset 31)) -(defparameter fp-double-zero-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset 31)) - -;;; If value can be represented as an immediate constant, then return -;;; the appropriate SC number, otherwise return NIL. -(defun immediate-constant-sc (value) - (typecase value - ((integer 0 0) - zero-sc-number) - (null - null-sc-number) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) - character) - immediate-sc-number) - (symbol - (if (static-symbol-p value) - immediate-sc-number - nil)) - (single-float - (if (eql value $0f0) - fp-single-zero-sc-number - nil)) - (double-float - (if (eql value $0d0) - fp-double-zero-sc-number - nil)))) - -(defun boxed-immediate-sc-p (sc) - (or (eql sc zero-sc-number) - (eql sc null-sc-number) - (eql sc immediate-sc-number))) - - -;;;; function call parameters - -;;; the SC numbers for register and stack arguments/return values -(defconstant immediate-arg-scn any-reg-sc-number) -(defconstant control-stack-arg-scn control-stack-sc-number) - -(eval-when (:compile-toplevel :load-toplevel :execute) - -;;; offsets of special stack frame locations -(defconstant ocfp-save-offset 0) -(defconstant lra-save-offset 1) -(defconstant nfp-save-offset 2) - -;;; the number of arguments/return values passed in registers -(defconstant register-arg-count 6) - -;;; (Names to use for the argument registers would go here, but there -;;; are none.) - -); EVAL-WHEN - -;;; a list of TN's describing the register arguments -(defparameter *register-arg-tns* - (mapcar (lambda (n) - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset n)) - *register-arg-offsets*)) - -;;; This is used by the debugger. -(defconstant single-value-return-byte-offset 4) - -;;; This function is called by debug output routines that want a -;;; pretty name for a TN's location. It returns a thing that can be -;;; printed with PRINC. -(defun location-print-name (tn) -; (declare (type tn tn)) - (let ((sb (sb-name (sc-sb (tn-sc tn)))) - (offset (tn-offset tn))) - (ecase sb - (registers (or (svref *register-names* offset) - (format nil "R~D" offset))) - (float-registers (format nil "F~D" offset)) - (control-stack (format nil "CS~D" offset)) - (non-descriptor-stack (format nil "NS~D" offset)) - (constant (format nil "Const~D" offset)) - (immediate-constant "Immed")))) - -(defun combination-implementation-style (node) - (declare (type sb-c::combination node) (ignore node)) - (values :default nil)) - -(defun primitive-type-indirect-cell-type (ptype) - (declare (ignore ptype)) - nil) diff -Nru sbcl-2.0.6/src/compiler/arm/arith.lisp sbcl-2.1.1/src/compiler/arm/arith.lisp --- sbcl-2.0.6/src/compiler/arm/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -436,28 +436,22 @@ (inst bic result temp fixnum-tag-mask))) ;;; Only the lower 5 bits of the shift amount are significant. -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (: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)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (inst and temp amount #b11111) - (inst mov r (lsr num temp)))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (inst and temp amount #b11111) - (inst mov r (lsl num temp)))) +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (: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 #b11111) + (inst mov r (,operation num temp)))))) + (define shift-towards-start lsr) + (define shift-towards-end lsl)) (define-vop (signed-byte-32-len) (:translate integer-length) diff -Nru sbcl-2.0.6/src/compiler/arm/array.lisp sbcl-2.1.1/src/compiler/arm/array.lisp --- sbcl-2.0.6/src/compiler/arm/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -33,35 +33,14 @@ (allocation nil ndescr other-pointer-lowtag header :flag-tn pa-flag) ;; Now that we have the space allocated, compute the header ;; value. - (inst add ndescr rank (fixnumize (1- array-dimensions-offset))) - (inst mov ndescr (lsl ndescr (- n-widetag-bits n-fixnum-tag-bits))) - (inst orr ndescr ndescr (lsr type n-fixnum-tag-bits)) + ;; 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 mov ndescr (lsr ndescr n-fixnum-tag-bits)) ;; And store the header value. (storew ndescr header 0 other-pointer-lowtag)) (move result header))) - -(define-vop (make-array-header/c) - (:translate make-array-header) - (:policy :fast-safe) - (:arg-types (:constant t) (:constant t)) - (:info type rank) - (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) - (:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag) - (:results (result :scs (descriptor-reg))) - (:generator 4 - (let* ((header-size (+ rank - (1- array-dimensions-offset))) - (bytes (logandc2 (+ (* (1+ header-size) n-word-bytes) - lowtag-mask) - lowtag-mask)) - (header-bits (logior (ash header-size - n-widetag-bits) - type))) - (pseudo-atomic (pa-flag) - (allocation nil bytes other-pointer-lowtag header :flag-tn pa-flag) - (load-immediate-word pa-flag header-bits) - (storew pa-flag header 0 other-pointer-lowtag))) - (move result header))) ;;;; Additional accessors and setters for the array header. (define-full-reffer %array-dimension * @@ -72,17 +51,17 @@ array-dimensions-offset other-pointer-lowtag (any-reg) positive-fixnum sb-kernel:%set-array-dimension) -(define-vop (array-rank-vop) - (:translate sb-kernel:%array-rank) +(define-vop () + (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) (:generator 6 - (loadw temp x 0 other-pointer-lowtag) - (inst mov temp (asr temp n-widetag-bits)) - (inst sub temp temp (1- array-dimensions-offset)) - (inst mov res (lsl temp n-fixnum-tag-bits)))) + (inst ldrb res (@ x #+little-endian (- 2 other-pointer-lowtag) + #+big-endian (- 1 other-pointer-lowtag))) + (inst add res res 1) + (inst and res res array-rank-mask))) ;;;; Bounds checking routine. (define-vop (check-bound) diff -Nru sbcl-2.0.6/src/compiler/arm/insts.lisp sbcl-2.1.1/src/compiler/arm/insts.lisp --- sbcl-2.0.6/src/compiler/arm/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm/insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1283,6 +1283,9 @@ (define-instruction load-from-label (segment &rest args) (:vop-var vop) (:emitter + ;; ISTM this use of an interior-pointer is unnecessary. Since we know the + ;; displacement of the label from the base of the CODE, we could load + ;; either from [code+X] or [PC+X] where X is in an unsigned-reg. (with-condition-defaulted (args (condition dest lip label)) ;; We can load the word addressed by a label in a single ;; instruction if the overall offset puts it to within a 12-bit @@ -1734,3 +1737,26 @@ (define-two-reg-transfer-fp-instruction fmrrs :single :to-arm) (define-two-reg-transfer-fp-instruction fmdrr :double :from-arm) (define-two-reg-transfer-fp-instruction fmrrd :double :to-arm) + +(sb-assem::%def-inst-encoder + '.layout-id + (lambda (segment layout) + (sb-c:note-fixup segment :layout-id (sb-c:make-fixup layout :layout-id)))) + +(defun sb-vm:fixup-code-object (code offset value kind flavor) + (declare (type index offset) (ignore flavor)) + (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) + (error "Unaligned instruction? offset=#x~X." offset)) + (let ((sap (code-instructions code))) + (ecase kind + (:layout-id + (aver (typep value '(unsigned-byte 24))) + (setf (sap-ref-word sap offset) + (dpb (ldb (byte 8 16) value) (byte 8 0) (sap-ref-word sap offset)) + (sap-ref-word sap (+ offset 4)) + (dpb (ldb (byte 8 8) value) (byte 8 0) (sap-ref-word sap (+ offset 4))) + (sap-ref-word sap (+ offset 8)) + (dpb (ldb (byte 8 0) value) (byte 8 0) (sap-ref-word sap (+ offset 8))))) + (:absolute + (setf (sap-ref-32 sap offset) value)))) + nil) diff -Nru sbcl-2.0.6/src/compiler/arm/move.lisp sbcl-2.1.1/src/compiler/arm/move.lisp --- sbcl-2.0.6/src/compiler/arm/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -237,7 +237,7 @@ (inst adds temp x x) (inst adds :vc y temp temp) (inst b :vc DONE) - (load-constant vop (emit-constant (1+ sb-xc:most-positive-fixnum)) + (load-constant vop (emit-constant (1+ most-positive-fixnum)) y) DONE)) @@ -246,7 +246,7 @@ (inst adds temp x x) (inst adds :vc y temp temp) (inst b :vc DONE) - (load-constant vop (emit-constant (1- sb-xc:most-negative-fixnum)) + (load-constant vop (emit-constant (1- most-negative-fixnum)) y) DONE)) diff -Nru sbcl-2.0.6/src/compiler/arm/system.lisp sbcl-2.1.1/src/compiler/arm/system.lisp --- sbcl-2.0.6/src/compiler/arm/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -59,6 +59,32 @@ ;; And, finally, pick out the widetag from the header. (inst ldrb :ne result (@ object (- result))))) +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:policy :fast-safe) + (:conditional :eq) + (:info test-layout) + (: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) + (- instance-pointer-lowtag)))) + (inst ldr this-id (@ x offset)) + ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those. + (cond ((typep test-id '(and (unsigned-byte 8) (not (eql 0)))) + (inst cmp this-id test-id)) + (t + (inst .layout-id test-layout) + ;; The fixupper will rewrite these three instructions. + (inst eor this-id this-id (ash 255 16)) + (inst eor this-id this-id (ash 255 8)) + (inst cmp this-id 255)))))) + (define-vop (%other-pointer-widetag) (:translate %other-pointer-widetag) (:policy :fast-safe) diff -Nru sbcl-2.0.6/src/compiler/arm/vm.lisp sbcl-2.1.1/src/compiler/arm/vm.lisp --- sbcl-2.0.6/src/compiler/arm/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,7 @@ (in-package "SB-VM") +(defconstant-eqx +fixup-kinds+ #(:absolute :layout-id) #'equalp) ;;;; register specs @@ -229,7 +230,7 @@ (typecase value (null null-sc-number) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) (symbol diff -Nru sbcl-2.0.6/src/compiler/arm64/arith.lisp sbcl-2.1.1/src/compiler/arm64/arith.lisp --- sbcl-2.0.6/src/compiler/arm64/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -265,34 +265,44 @@ (:args (x :scs (signed-reg) :to :result) (y :scs (signed-reg) :to :result)) (:arg-types signed-num signed-num) + (:args-var args) (:results (quo :scs (signed-reg) :from :eval) (rem :scs (signed-reg) :from :eval)) + (:optional-results rem) (:result-types signed-num signed-num) (:note "inline (signed-byte 64) arithmetic") (:vop-var vop) (:save-p :compute-only) (:generator 33 - (let ((zero (generate-error-code vop 'division-by-zero-error x y))) - (inst cbz y zero)) + (when (types-equal-or-intersect (tn-ref-type (tn-ref-across args)) + (specifier-type '(eql 0))) + (let ((zero (generate-error-code vop 'division-by-zero-error x y))) + (inst cbz y zero))) (inst sdiv quo x y) - (inst msub rem quo y x))) + (unless (eq (tn-kind rem) :unused) + (inst msub rem quo y x)))) (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op) (:translate truncate) (:args (x :scs (unsigned-reg) :to :result) (y :scs (unsigned-reg) :to :result)) (:arg-types unsigned-num unsigned-num) + (:args-var args) (:results (quo :scs (unsigned-reg) :from :eval) (rem :scs (unsigned-reg) :from :eval)) + (:optional-results rem) (:result-types unsigned-num unsigned-num) (:note "inline (unsigned-byte 64) arithmetic") (:vop-var vop) (:save-p :compute-only) (:generator 33 - (let ((zero (generate-error-code vop 'division-by-zero-error x y))) - (inst cbz y zero)) + (when (types-equal-or-intersect (tn-ref-type (tn-ref-across args)) + (specifier-type '(eql 0))) + (let ((zero (generate-error-code vop 'division-by-zero-error x y))) + (inst cbz y zero))) (inst udiv quo x y) - (inst msub rem quo y x))) + (unless (eq (tn-kind rem) :unused) + (inst msub rem quo y x)))) ;;; (define-vop (fast-lognor/fixnum=>fixnum fast-fixnum-binop) @@ -522,28 +532,22 @@ (:translate ash-left-mod64)) ;;; Only the lower 6 bits of the shift amount are significant. -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (: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)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (inst and temp amount #b111111) - (inst lsr r num temp))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (inst and temp amount #b111111) - (inst lsl r num temp))) +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (: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))))) + (define shift-towards-start lsr) + (define shift-towards-end lsl)) (define-vop (signed-byte-64-len) (:translate integer-length) @@ -575,46 +579,35 @@ (inst mov res (fixnumize 64)) (inst sub res res (lsl temp n-fixnum-tag-bits)))) + (define-vop (unsigned-byte-64-count) (:translate logcount) (:note "inline (unsigned-byte 64) logcount") (:policy :fast-safe) - (:args (arg :scs (unsigned-reg) :target num)) + (:args (arg :scs (unsigned-reg))) (:arg-types unsigned-num) (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) - :target res) num) - (:temporary (:scs (non-descriptor-reg)) mask temp) + (:temporary (:scs (double-reg)) v) (:variant-vars signed) (:generator 30 - (when signed - (inst cmp arg 0) - (inst csinv num arg arg :ge) - (setf arg num)) - (load-immediate-word mask #x5555555555555555) - (inst and temp mask (lsr arg 1)) - (inst and num arg mask) - (inst add num num temp) - (load-immediate-word mask #x3333333333333333) - (inst and temp mask (lsr num 2)) - (inst and num num mask) - (inst add num num temp) - (load-immediate-word mask #x0f0f0f0f0f0f0f0f) - (inst and temp mask (lsr num 4)) - (inst and num num mask) - (inst add num num temp) - (inst add num num (lsr num 8)) - (inst add num num (lsr num 16)) - (inst add num num (lsr num 32)) - (inst and res num #xff))) + (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))) (define-vop (signed-byte-64-count unsigned-byte-64-count) - (:note "inline (signed-byte 64) logcount") - (:args (arg :scs (signed-reg) :target num)) - (:arg-types signed-num) - (:variant t) - (:variant-cost 29)) + (:note "inline (signed-byte 64) logcount") + (:args (arg :scs (signed-reg))) + (:arg-types signed-num) + (:variant t) + (:variant-cost 29)) (defknown %%ldb (integer unsigned-byte unsigned-byte) unsigned-byte (movable foldable flushable always-translatable)) @@ -1057,11 +1050,13 @@ (:arg-types unsigned-num unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg)) (carry :scs (unsigned-reg) :from :eval)) + (:optional-results carry) (:result-types unsigned-num positive-fixnum) (:generator 3 (inst cmp c 1) ;; Set carry if (fixnum 0 or 1) c=0, else clear. (inst adcs result a b) - (inst cset carry :cs))) + (unless (eq (tn-kind carry) :unused) + (inst cset carry :cs)))) (define-vop (sub-w/borrow) (:translate sb-bignum:%subtract-with-borrow) @@ -1072,11 +1067,13 @@ (:arg-types unsigned-num unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg)) (borrow :scs (unsigned-reg) :from :eval)) + (:optional-results borrow) (:result-types unsigned-num positive-fixnum) (:generator 4 (inst cmp c 1) ;; Set carry if (fixnum 0 or 1) c=0, else clear. (inst sbcs result a b) - (inst cset borrow :cs))) + (unless (eq (tn-kind borrow) :unused) + (inst cset borrow :cs)))) (define-vop (bignum-mult-and-add-3-arg) (:translate sb-bignum:%multiply-and-add) @@ -1150,6 +1147,17 @@ (inst umulh temp x y) (inst and hi temp (bic-mask fixnum-tag-mask)))) +(define-vop () + (:translate %signed-multiply-high) + (:policy :fast-safe) + (:args (x :scs (signed-reg)) + (y :scs (signed-reg))) + (:arg-types signed-num signed-num) + (:results (hi :scs (signed-reg))) + (:result-types signed-num) + (:generator 20 + (inst smulh hi x y))) + (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned) (:translate sb-bignum:%lognot)) @@ -1208,4 +1216,3 @@ (:translate sb-bignum:%ashl) (:generator 1 (inst lsl result digit count))) - diff -Nru sbcl-2.0.6/src/compiler/arm64/array.lisp sbcl-2.1.1/src/compiler/arm64/array.lisp --- sbcl-2.0.6/src/compiler/arm64/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -34,36 +34,14 @@ (allocation nil ndescr other-pointer-lowtag header :flag-tn pa-flag :lip lip) ;; Now that we have the space allocated, compute the header ;; value. - (inst lsl ndescr rank (- n-widetag-bits n-fixnum-tag-bits)) - (inst add ndescr ndescr (ash (1- array-dimensions-offset) n-widetag-bits)) - (inst orr ndescr ndescr (lsr type n-fixnum-tag-bits)) + ;; 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 lsr ndescr ndescr n-fixnum-tag-bits) ;; And store the header value. (storew ndescr header 0 other-pointer-lowtag)) (move result header))) - -(define-vop (make-array-header/c) - (:translate make-array-header) - (:policy :fast-safe) - (:arg-types (:constant t) (:constant t)) - (:info type rank) - (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) - (:temporary (:sc non-descriptor-reg) pa-flag) - (:temporary (:scs (interior-reg)) lip) - (:results (result :scs (descriptor-reg))) - (:generator 4 - (let* ((header-size (+ rank - (1- array-dimensions-offset))) - (bytes (logandc2 (+ (* (1+ header-size) n-word-bytes) - lowtag-mask) - lowtag-mask)) - (header-bits (logior (ash header-size - n-widetag-bits) - type))) - (pseudo-atomic (pa-flag) - (allocation nil bytes other-pointer-lowtag header :flag-tn pa-flag :lip lip) - (load-immediate-word pa-flag header-bits) - (storew pa-flag header 0 other-pointer-lowtag))) - (move result header))) ;;;; Additional accessors and setters for the array header. (define-full-reffer %array-dimension * @@ -74,17 +52,17 @@ array-dimensions-offset other-pointer-lowtag (any-reg) positive-fixnum sb-kernel:%set-array-dimension) -(define-vop (array-rank-vop) - (:translate sb-kernel:%array-rank) +(define-vop () + (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) (:generator 6 - (loadw temp x 0 other-pointer-lowtag) - (inst asr temp temp n-widetag-bits) - (inst sub temp temp (1- array-dimensions-offset)) - (inst lsl res temp n-fixnum-tag-bits))) + (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))) ;;;; Bounds checking routine. (define-vop (check-bound) diff -Nru sbcl-2.0.6/src/compiler/arm64/cell.lisp sbcl-2.1.1/src/compiler/arm64/cell.lisp --- sbcl-2.0.6/src/compiler/arm64/cell.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/cell.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -466,6 +466,16 @@ (:translate %instance-cas) (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types instance tagged-num * *)) +(define-vop (%raw-instance-cas/word %instance-cas) + (:args (object) + (index) + (old-value :scs (unsigned-reg)) + (new-value :scs (unsigned-reg))) + (:arg-types * tagged-num unsigned-num unsigned-num) + (:results (result :scs (unsigned-reg) :from :load)) + (:result-types unsigned-num) + (:translate %raw-instance-cas/word)) + ;;;; Code object frobbing. diff -Nru sbcl-2.0.6/src/compiler/arm64/float.lisp sbcl-2.1.1/src/compiler/arm64/float.lisp --- sbcl-2.0.6/src/compiler/arm64/float.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/float.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -694,7 +694,7 @@ (complex-single-reg (unless (eql (tn-offset r) (tn-offset real)) (inst s-mov r real)) - (inst s-ins r 1 imag 0 :s)) + (inst ins r 1 imag 0 :s)) (complex-single-stack (let ((nfp (current-nfp-tn vop)) (offset (tn-offset r))) @@ -725,7 +725,7 @@ (complex-double-reg (unless (eql (tn-offset r) (tn-offset real)) (inst s-mov r real)) - (inst s-ins r 1 imag 0 :d)) + (inst ins r 1 imag 0 :d)) (complex-double-stack (let ((nfp (current-nfp-tn vop)) (offset (tn-offset r))) @@ -750,7 +750,7 @@ (:generator 3 (sc-case x (complex-single-reg - (inst s-ins r 0 x (ecase slot + (inst ins r 0 x (ecase slot (:real 0) (:imag 1)) :s)) @@ -785,7 +785,7 @@ (:generator 3 (sc-case x (complex-double-reg - (inst s-ins r 0 x (ecase slot + (inst ins r 0 x (ecase slot (:real 0) (:imag 1)) :d)) @@ -802,3 +802,33 @@ (:translate imagpart) (:note "complex double float imagpart") (:variant :imag)) + +(define-vop () + (:translate round-double) + (:policy :fast-safe) + (:args (x :scs (double-reg) :target r)) + (:arg-types double-float (:constant symbol)) + (:info mode) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:generator 2 + (ecase mode + (:round (inst frintn r x)) + (:floor (inst frintm r x)) + (:ceiling (inst frintp r x)) + (:truncate (inst frintz r x))))) + +(define-vop () + (:translate round-single) + (:policy :fast-safe) + (:args (x :scs (single-reg) :target r)) + (:arg-types single-float (:constant symbol)) + (:info mode) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:generator 2 + (ecase mode + (:round (inst frintn r x)) + (:floor (inst frintm r x)) + (:ceiling (inst frintp r x)) + (:truncate (inst frintz r x))))) diff -Nru sbcl-2.0.6/src/compiler/arm64/insts.lisp sbcl-2.1.1/src/compiler/arm64/insts.lisp --- sbcl-2.0.6/src/compiler/arm64/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -99,9 +99,14 @@ (define-arg-type reg-sp :printer #'print-reg-sp) + (define-arg-type sized-reg :printer #'print-sized-reg) + (define-arg-type reg-float-reg :printer #'print-reg-float-reg) (define-arg-type float-reg :printer #'print-float-reg) + (define-arg-type vbhs :printer #'print-vbhs) + (define-arg-type vhsd :printer #'print-vhsd) + (define-arg-type vx.t :printer #'print-vx.t) (define-arg-type simd-reg :printer #'print-simd-reg) @@ -150,15 +155,6 @@ (:emitter (emit-byte segment byte))) -(define-instruction word (segment word) - (:emitter - (etypecase word - (fixup - (note-fixup segment :absolute word) - (emit-word segment 0)) - (integer - (emit-word segment word))))) - (define-instruction dword (segment word) (:emitter (etypecase word @@ -1299,7 +1295,8 @@ (let* ((base (memory-operand-base address)) (offset (memory-operand-offset address)) (mode (memory-operand-mode address)) - (index-encoding (position mode '(:offset :post-index 0 :pre-index))) + (index-encoding (or (position mode '(:offset :post-index 0 :pre-index)) + (error "Bad addressing mode"))) (fp (fp-register-p dst)) (v (if fp 1 @@ -2322,7 +2319,8 @@ 3)))))) (one-instruction-emitter (segment position) (emit-ldr-literal segment - #b01 0 + (if (sc-is dest 32-bit-reg) #b00 #b01) + 0 (ldb (byte 19 0) (ash (compute-delta position) -2)) (tn-offset dest))) @@ -2420,7 +2418,7 @@ (rn 5 5) (rd 5 0)) -(define-instruction s-ext (segment rd rn rm index &optional (size :16b)) +(define-instruction ext (segment rd rn rm index &optional (size :16b)) (:emitter (emit-simd-extract segment (decode-vector-size size) @@ -2449,24 +2447,151 @@ (q :field (byte 1 30)) (op :field (byte 1 29)) (op4 :field (byte 8 21) :value #b01110000) + (imm5 :field (byte 5 16)) (op5 :field (byte 1 15) :value #b0) + (imm4 :field (byte 4 11)) (op6 :field (byte 1 10) :value #b1) (rn :fields (list (byte 5 5) (byte 5 16) (byte 4 11)) :type 'simd-copy-reg) (rd :fields (list (byte 5 0) (byte 5 16)) :type 'simd-copy-reg)) -(define-instruction s-ins (segment rd index1 rn index2 size) - (:printer simd-copy ((q 1) (op 1)) - '('ins :tab rd ", " rn)) +(define-instruction ins (segment rd index1 rn index2 size) + (:printer simd-copy ((q 1) (op 1))) (:emitter (let ((size (position size '(:B :H :S :D)))) (emit-simd-copy segment - 1 - 1 - (logior (ash index1 (1+ size)) - (ash 1 size)) - (ash index2 size) - (tn-offset rn) - (tn-offset rd))))) + 1 + 1 + (logior (ash index1 (1+ size)) + (ash 1 size)) + (ash index2 size) + (tn-offset rn) + (tn-offset rd))))) + +(define-instruction-format (simd-copy-to-general 32 + :include simd-copy + :default-printer '(:name :tab rd ", " rn)) + (rn :fields (list (byte 5 5) (byte 5 16)) :type 'simd-copy-reg) + (rd :fields (list (byte 1 30) (byte 5 0)) :type 'sized-reg)) + +(define-instruction umov (segment rd rn index size) + (:printer simd-copy-to-general ((op 0) (imm4 #b0111))) + (:emitter + (let ((size (position size '(:B :H :S :D)))) + (emit-simd-copy segment + (case size + (:d 1) + (t 0)) + 0 + (logior (ash index (1+ size)) + (ash 1 size)) + #b0111 + (tn-offset rn) + (tn-offset rd))))) + +(def-emitter simd-across-lanes + (#b0 1 31) + (q 1 30) + (u 1 29) + (#b01110 5 24) + (size 2 22) + (#b11000 5 17) + (op 5 12) + (#b10 2 10) + (rn 5 5) + (rd 5 0)) + +(define-instruction-format (simd-across-lanes 32 + :default-printer '(:name :tab rd ", " rn)) + (o1 :field (byte 1 31) :value #b0) + (q :field (byte 1 30)) + (u :field (byte 1 29)) + (op2 :field (byte 5 24) :value #b01110) + (size :field (byte 2 22)) + (op3 :field (byte 5 17) :value #b11000) + (op :field (byte 4 12)) + (op4 :field (byte 2 10) :value #b10) + (rn :fields (list (byte 1 30) (byte 2 22) (byte 5 5)) :type 'vx.t) + (rd :fields (list (byte 2 22) (byte 5 0)) :type 'vbhs)) + + +(def-emitter simd-two-misc + (#b0 1 31) + (q 1 30) + (u 1 29) + (#b01110 5 24) + (size 2 22) + (#b10000 5 17) + (op 5 12) + (#b10 2 10) + (rn 5 5) + (rd 5 0)) + +(define-instruction addv (segment rd sized rn sizen) + (:printer simd-across-lanes ((u 0) (op #b11011))) + (:emitter + (emit-simd-across-lanes + segment + (ecase sizen + (:8b 0) + (:16b 1) + (:4h 0) + (:8h 1) + (:4s 1)) + 0 + (ecase sized + (:b 0) + (:h 1) + (:s 2)) + #b11011 + (tn-offset rn) + (tn-offset rd)))) + +(define-instruction uaddlv (segment rd sized rn sizen) + (:printer simd-across-lanes ((u 1) (op #b00011) + (rd nil :type 'vhsd))) + (:emitter + (emit-simd-across-lanes + segment + (ecase sizen + (:8b 0) + (:16b 1) + (:4h 0) + (:8h 1) + (:4s 1)) + 1 + (ecase sized + (:h 0) + (:s 1) + (:d 2)) + #b00011 + (tn-offset rn) + (tn-offset rd)))) + +(define-instruction-format (simd-two-misc 32 + :default-printer '(:name :tab rd ", " rn)) + (o1 :field (byte 1 31) :value #b0) + (q :field (byte 1 30)) + (u :field (byte 1 29)) + (op2 :field (byte 5 24) :value #b01110) + (size :field (byte 2 22)) + (op3 :field (byte 5 17) :value #b10000) + (op :field (byte 4 12)) + (op4 :field (byte 2 10) :value #b10) + (rn :fields (list (byte 1 30) (byte 5 5)) :type 'simd-reg) + (rd :fields (list (byte 1 30) (byte 5 0)) :type 'simd-reg)) + +(define-instruction cnt (segment rd rn size) + (:printer simd-two-misc ((u 0) (op #b00101))) + (:emitter + (emit-simd-two-misc segment + (ecase size + (:8b 0) + (:16b 1)) + 0 + 00 + #b00101 + (tn-offset rn) + (tn-offset rd)))) ;;; Inline constants (defun canonicalize-inline-constant (constant) @@ -2495,8 +2620,9 @@ (destructuring-bind (type value) constant (ecase type ((:byte :word :dword :qword) - (aver (integerp value)) - (cons type value)) + (etypecase value + ((or integer (cons (eql :layout-id))) + (cons type value)))) (:base-char #+sb-unicode (aver (typep value 'base-char)) (cons :byte (char-code value))) @@ -2536,6 +2662,9 @@ (defun size-nbyte (size) (ecase size (:byte 1) + ;; These keywords are completely wrong for AARCH64 but I don't want to touch them. + ;; The correct definitions would have :HWORD (halfword) for 2 bytes, :WORD for 4, + ;; :DWORD for 8, and :QWORD for 16. (:word 2) (:dword 4) ((:qword :fixup) 8) @@ -2545,20 +2674,46 @@ (stable-sort constants #'> :key (lambda (constant) (size-nbyte (caar constant))))) +(sb-assem::%def-inst-encoder + '.layout-id + (lambda (segment layout) + (sb-c:note-fixup segment :layout-id (sb-c:make-fixup layout :layout-id)) + (sb-assem::%emit-skip segment 4))) + (defun emit-inline-constant (section constant label) (let* ((type (car constant)) + (val (cdr constant)) (size (size-nbyte type))) (emit section `(.align ,(integer-length (1- size))) label - (let ((val (cdr constant))) - (case type - (:fixup - ;; Use the WORD emitter which knows how to emit fixups - `(word ,(apply #'make-fixup val))) - (t + (cond ((typep val '(cons (eql :layout-id))) + `(.layout-id ,(cadr val))) + ((eql type :fixup) + ;; Use the DWORD emitter which knows how to emit fixups + `(dword ,(apply #'make-fixup val))) + (t ;; Could add pseudo-ops for .WORD, .INT, .QUAD, .OCTA just like gcc has. ;; But it works fine to emit as a sequence of bytes + ;; FIXME: missing support for big-endian. Do we care? `(.byte ,@(loop repeat size collect (prog1 (ldb (byte 8 0) val) - (setf val (ash val -8))))))))))) + (setf val (ash val -8)))))))))) + +(defun sb-vm:fixup-code-object (code offset value kind flavor) + (declare (type index offset) (ignore flavor)) + (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) + (error "Unaligned instruction? offset=#x~X." offset)) + (let ((sap (code-instructions code))) + (ecase kind + (:absolute + (setf (sap-ref-word sap offset) value)) + (:layout-id + (setf (signed-sap-ref-32 sap offset) value)) + (:cond-branch + (setf (ldb (byte 19 5) (sap-ref-32 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))))) + nil) diff -Nru sbcl-2.0.6/src/compiler/arm64/macros.lisp sbcl-2.1.1/src/compiler/arm64/macros.lisp --- sbcl-2.0.6/src/compiler/arm64/macros.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/macros.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -232,7 +232,7 @@ (inst add result-tn result-tn size) (inst cmp result-tn flag-tn) (inst b :hi ALLOC) - #-sb-thread (inst str result-tn (@ null-tn (- boxed-region nil-value))) + #-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 diff -Nru sbcl-2.0.6/src/compiler/arm64/move.lisp sbcl-2.1.1/src/compiler/arm64/move.lisp --- sbcl-2.0.6/src/compiler/arm64/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -408,7 +408,7 @@ (:generator 4 (inst adds y x x) (inst b :vc DONE) - (load-constant vop (emit-constant (1+ sb-xc:most-positive-fixnum)) + (load-constant vop (emit-constant (1+ most-positive-fixnum)) y) DONE)) @@ -416,7 +416,7 @@ (:generator 4 (inst adds y x x) (inst b :vc DONE) - (load-constant vop (emit-constant (1- sb-xc:most-negative-fixnum)) + (load-constant vop (emit-constant (1- most-negative-fixnum)) y) DONE)) diff -Nru sbcl-2.0.6/src/compiler/arm64/parms.lisp sbcl-2.1.1/src/compiler/arm64/parms.lisp --- sbcl-2.0.6/src/compiler/arm64/parms.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/parms.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -109,7 +109,8 @@ (defparameter dynamic-0-space-end #x66fff000))) #+gencgc -(!gencgc-space-setup #xF0000000 :dynamic-space-start #x1000000000) +(!gencgc-space-setup #+(or linux openbsd) #xF0000000 #+netbsd #x2F0000000 + :dynamic-space-start #x1000000000) (defconstant linkage-table-growth-direction :up) (defconstant linkage-table-entry-size 16) diff -Nru sbcl-2.0.6/src/compiler/arm64/system.lisp sbcl-2.1.1/src/compiler/arm64/system.lisp --- sbcl-2.0.6/src/compiler/arm64/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -74,6 +74,39 @@ word-shift)) instance-pointer-lowtag)))))) +;;; This could be split into two vops to avoid wasting an allocation for 'temp' +;;; when the immediate form is used. +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:policy :fast-safe) + (:conditional :eq) + (:info test-layout) + (: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) + (- instance-pointer-lowtag)))) + (declare (ignorable test-id)) + (inst ldr (32-bit-reg this-id) (@ x offset)) + ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those. + (cond ((typep test-id '(and (signed-byte 8) (not (eql 0)))) + (if (minusp test-id) + (inst cmn (32-bit-reg this-id) (- test-id)) + (inst cmp (32-bit-reg this-id) test-id))) + (t + (destructuring-bind (size . label) + ;; This uses the bogus definition of :dword, the one which + ;; emits 4 bytes. _technically_ dword should be 8 bytes. + (register-inline-constant :dword `(:layout-id ,test-layout)) + (declare (ignore size)) + (inst load-from-label (32-bit-reg temp) label)) + (inst cmp (32-bit-reg this-id) (32-bit-reg temp))))))) + (define-vop (%other-pointer-widetag) (:translate %other-pointer-widetag) (:policy :fast-safe) diff -Nru sbcl-2.0.6/src/compiler/arm64/target-insts.lisp sbcl-2.1.1/src/compiler/arm64/target-insts.lisp --- sbcl-2.0.6/src/compiler/arm64/target-insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/target-insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -178,6 +178,13 @@ (princ "NSP" stream) (princ (aref *register-names* value) stream))) +(defun print-sized-reg (value stream dstate) + (declare (ignore dstate)) + (destructuring-bind (size reg) value + (when (zerop size) + (princ "W" stream)) + (princ (svref *register-names* reg) stream))) + (defun print-reg-float-reg (value stream dstate) (let* ((inst (current-instruction dstate)) (v (ldb (byte 1 26) inst))) @@ -232,6 +239,47 @@ "8B" "16B")))) +(defun print-vbhs (value stream dstate) + (declare (ignore dstate)) + (destructuring-bind (size offset) value + (format stream "~a~d" + (case size + (#b00 "B") + (#b01 "H") + (#b10 "S")) + offset))) + +(defun print-vhsd (value stream dstate) + (declare (ignore dstate)) + (destructuring-bind (size offset) value + (format stream "~a~d" + (case size + (#b00 "H") + (#b01 "S") + (#b10 "D")) + offset))) + +(defun print-vx.t (value stream dstate) + (declare (ignore dstate)) + (destructuring-bind (q size offset) value + (format stream "V~d.~a" + offset + (cond ((and (= size 0) + (= q 0)) + "8B") + ((and (= size 0) + (= q 1)) + "16B") + ((and (= size 1) + (= q 0)) + "4H") + ((and (= size 1) + (= q 1)) + "8H") + ((and (= size 2) + (= q 1)) + "4S"))))) + (defun lowest-set-bit-index (integer-value) (max 0 (1- (integer-length (logand integer-value (- integer-value)))))) diff -Nru sbcl-2.0.6/src/compiler/arm64/vm.lisp sbcl-2.1.1/src/compiler/arm64/vm.lisp --- sbcl-2.0.6/src/compiler/arm64/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/arm64/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,9 @@ (in-package "SB-VM") +(defconstant-eqx +fixup-kinds+ #(:absolute :cond-branch :uncond-branch :layout-id) + #'equalp) + ;;;; register specs @@ -248,7 +251,7 @@ (typecase value (null (values descriptor-reg-sc-number null-offset)) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) (symbol diff -Nru sbcl-2.0.6/src/compiler/array-tran.lisp sbcl-2.1.1/src/compiler/array-tran.lisp --- sbcl-2.0.6/src/compiler/array-tran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/array-tran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -312,7 +312,7 @@ (lvar-value element-type)))) (cond ((or (null ctype) (contains-unknown-type-p ctype)) '*) - (t (sb-xc:upgraded-array-element-type + (t (upgraded-array-element-type (lvar-value element-type)))))) (t '*)) @@ -381,10 +381,18 @@ ;;; Just convert it into a MAKE-ARRAY. (deftransform make-string ((length &key - (element-type 'character) + 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 element-type + :element-type (or element-type 'character) ,@(when initial-element '(:initial-element initial-element))))) @@ -405,7 +413,7 @@ ;; optimizing `#(#(foo bar) #(,x ,y)) we convert the whole expression ;; into (VECTOR 'FOO 'BAR X Y), whereas in the unidimensional case ;; it never makes sense to turn #(FOO BAR) into (VECTOR 'FOO 'BAR). - (when (or (and (= rank 1) (sb-xc:constantp initial-contents env)) + (when (or (and (= rank 1) (constantp initial-contents env)) ;; If you inhibit inlining these - game over. (fun-lexically-notinline-p 'vector env) (fun-lexically-notinline-p 'list env) @@ -413,12 +421,12 @@ (return-from rewrite-initial-contents (values nil nil))) (let ((dimensions (make-array rank :initial-element nil)) (output)) - (named-let recurse ((form (handler-case (sb-xc:macroexpand initial-contents env) + (named-let recurse ((form (handler-case (macroexpand initial-contents env) (error () (return-from rewrite-initial-contents)))) (axis 0)) (flet ((make-list-ctor (tail &optional (prefix nil prefixp) &aux val) - (when (and (sb-xc:constantp tail) + (when (and (constantp tail) (or (proper-list-p (setq val (constant-form-value tail env))) (and (vectorp val) (not prefixp)))) (setq form @@ -435,7 +443,7 @@ (unless (and (typep form '(cons (member list vector))) (do ((items (cdr form)) (length 0 (1+ length)) - (fun (let ((axis (the (mod #.sb-xc:array-rank-limit) (1+ axis)))) + (fun (let ((axis (the (mod #.array-rank-limit) (1+ axis)))) (if (= axis rank) (lambda (item) (push item output)) (lambda (item) (recurse item axis)))))) @@ -458,16 +466,16 @@ ;; If the unaltered INITIAL-CONTENTS were constant, then the flattened ;; form must be too. Turning it back to a self-evaluating object ;; is essential to avoid compile-time blow-up on huge vectors. - (if (sb-xc:constantp initial-contents env) + (if (constantp initial-contents env) (map 'vector (lambda (x) (constant-form-value x env)) output) (let ((f (if (singleton-p output) 'list 'vector))) `(locally (declare (notinline ,f)) (,f ,@(mapcar (lambda (x) (cond ((and (symbolp x) (not (nth-value - 1 (sb-xc:macroexpand-1 x env)))) + 1 (macroexpand-1 x env)))) x) - ((sb-xc:constantp x env) + ((constantp x env) `',(constant-form-value x env)) (t `(locally (declare (inline ,f)) ,x)))) @@ -484,13 +492,13 @@ ;;; in this path, mainly due to complications in picking the right widetag. (define-source-transform make-array (dims-form &rest rest &environment env &aux dims dims-constp) - (cond ((and (sb-xc:constantp dims-form env) + (cond ((and (constantp dims-form env) (proper-list-p (setq dims (constant-form-value dims-form env))) (not (singleton-p dims)) (every (lambda (x) (typep x 'index)) dims)) (setq dims-constp t)) ((and (cond ((typep (setq dims (handler-case - (sb-xc:macroexpand dims-form env) + (macroexpand dims-form env) (error () (return-from make-array (values nil t))))) '(cons (eql list))) @@ -499,7 +507,7 @@ ;; `(,X 2 1) -> (LIST* X '(2 1)) for example ((typep dims '(cons (eql list*) cons)) (let ((last (car (last dims)))) - (when (sb-xc:constantp last env) + (when (constantp last env) (let ((lastval (constant-form-value last env))) (when (listp lastval) (setq dims (append (butlast (cdr dims)) lastval)) @@ -507,7 +515,7 @@ (proper-list-p dims) (not (singleton-p dims))) ;; If you spell '(2 2) as (LIST 2 2), it is constant for purposes of MAKE-ARRAY. - (when (every (lambda (x) (sb-xc:constantp x env)) dims) + (when (every (lambda (x) (constantp x env)) dims) (let ((values (mapcar (lambda (x) (constant-form-value x env)) dims))) (when (every (lambda (x) (typep x 'index)) values) (setq dims values dims-constp t))))) @@ -539,7 +547,7 @@ (case k (:element-type (unless (eq et unsupplied) (return nil)) - (setq et (car v) et-constp (sb-xc:constantp et env))) + (setq et (car v) et-constp (constantp et env))) (:initial-element (when (or contents element) (return nil)) (setq element v)) @@ -589,6 +597,7 @@ (t '*)) ,(if dims-constp dims (length dims))) (make-array-header* + sb-vm:simple-array-widetag ,@(sb-vm::make-array-header-inits `(make-array ,size ,@keys) size dims))))) `(let* (,@axis-bindings ,@et-binding (,size (the index (* ,@dims)))) @@ -608,13 +617,13 @@ `(fill-array ,(car contents) ,alloc-form))))))) (define-source-transform coerce (x type &environment env) - (if (and (sb-xc:constantp type env) + (if (and (constantp type env) (proper-list-p x) (memq (car x) '(sb-impl::|List| list sb-impl::|Vector| vector))) (let* ((type (constant-form-value type env)) (length (1- (length x))) - (ctype (careful-values-specifier-type type))) + (ctype (careful-specifier-type type))) (if (and ctype (neq ctype *empty-type*) (csubtypep ctype (specifier-type '(array * (*))))) @@ -645,22 +654,16 @@ (let* ((c-length (if (lvar-p length) (if (constant-lvar-p length) (lvar-value length)) length)) - (complex (cond ((and (or - (not fill-pointer) - (and (constant-lvar-p fill-pointer) - (null (lvar-value fill-pointer)))) - (or - (not adjustable) - (and - (constant-lvar-p adjustable) - (null (lvar-value adjustable))))) - nil) - ((and (constant-lvar-p adjustable) - (lvar-value adjustable))) - ((and fill-pointer - (constant-lvar-p fill-pointer) - (lvar-value fill-pointer))) - (t + (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) + ((numeric-type-p (lvar-type fill-pointer)) t) + ((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)))) @@ -724,7 +727,8 @@ (abort-ir1-transform "Invalid fill-pointer ~s for a vector of length ~s." (type-specifier (lvar-type fill-pointer)) c-length)) - (flet ((eliminate-keywords () + (labels + ((eliminate-keywords () (eliminate-keyword-args call 1 '((:element-type element-type) @@ -732,47 +736,46 @@ (: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)))) + (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)))) - (truly-the - ,result-spec - (make-array-header* ,(or (sb-vm:saetp-complex-typecode saetp) - sb-vm:complex-vector-widetag) - ;; fill-pointer - ,(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)) - ;; fill-pointer-p - ,(and fill-pointer - `(and fill-pointer t)) - ;; elements - %length - ;; data - (let ((data ,data-alloc-form)) - ,(or data-wrapper 'data)) - ;; displacement - 0 - ;; displaced-p - nil - ;; displaced-from - nil - ;; dimensions - %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 @@ -861,7 +864,16 @@ #-sb-xc-host (and (and (testable-type-p elt-ctype) (neq elt-ctype *empty-type*) - (not (ctypep default-initial-element elt-ctype))) + ;; 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 @@ -874,9 +886,10 @@ ;; didn't realize this. (cond (initial-element - (compiler-warn "~S ~S is not a ~S" - :initial-element default-initial-element - elt-spec)) + (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)) @@ -884,9 +897,9 @@ ;; then fill-array means it was supplied initial-contents (not (lvar-matches-calls (combination-lvar call) '(make-array-header* fill-array)))) - (compiler-style-warn "The default initial element ~S is not a ~S." - default-initial-element - elt-spec)))) + (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)) @@ -995,8 +1008,9 @@ ((not (ctypep value eltype-type)) ;; this case will not cause an error at runtime, but ;; it's still worth STYLE-WARNing about. - (compiler-style-warn "~S is not a ~S." - value eltype))))) + (compiler-style-warn 'initial-element-mismatch-style-warning + :format-control "~S is not a ~S." + :format-arguments (list value eltype)))))) `(let ((array ,creation-form)) (multiple-value-bind (vector) (%data-vector-and-index array 0) @@ -1075,7 +1089,7 @@ 'simple-array) ,(cond ((null element-type) t) (element-type-ctype - (sb-xc:upgraded-array-element-type + (upgraded-array-element-type (lvar-value element-type))) (t '*)) ,(make-list rank :initial-element '*)))) @@ -1085,8 +1099,6 @@ sb-vm:simple-array-widetag) ;; fill-pointer ,total-size - ;; fill-pointer-p - nil ;; elements ,total-size ;; data @@ -1158,7 +1170,7 @@ ;;;; miscellaneous properties of arrays -;;; Transforms for various array properties. If the property is know +;;; Transforms for various array properties. If the property is known ;;; at compile time because of a type spec, use that constant value. ;;; Most of this logic may end up belonging in code/late-type.lisp; @@ -1233,14 +1245,22 @@ ;; reduction. (deftransform array-rank ((array) (array) * :node node) (let ((array-type (lvar-type array))) - (cond ((eq t (and (array-type-p array-type) - (array-type-complexp array-type))) + (cond ((and (array-type-p array-type) + (listp (array-type-dimensions array-type))) + (length (array-type-dimensions array-type))) + ;; We need an extra case in here to best handle a known vector, because + ;; if we try to add a transform on ARRAY-HEADER-P (returning false for + ;; known simple-array of rank 1), that would fail to optimize where we know + ;; the thing is a vector but possibly non-simple. So then the IF below + ;; would still have both if its consequents considered plausible. + ((csubtypep array-type (specifier-type 'vector)) + 1) + ((and (array-type-p array-type) + (eq (array-type-complexp array-type) t)) '(%array-rank array)) (t - (delay-ir1-transform node :constraint) - `(if (array-header-p array) - (%array-rank array) - 1))))) + (delay-ir1-transform node :constraint) ; Why? + `(%array-rank array))))) (defun derive-array-rank (ctype) (let ((array (specifier-type 'array))) @@ -1357,12 +1377,11 @@ ;;; compile-time constant. (deftransform vector-length ((vector)) (let* ((vtype (lvar-type vector)) - (dim (first (array-type-dimensions-or-give-up vtype)))) - (when (eq dim '*) - (give-up-ir1-transform)) - (when (conservative-array-type-complexp vtype) + (dim (array-type-dimensions-or-give-up vtype))) + (when (or (not (typep dim '(cons integer))) + (conservative-array-type-complexp vtype)) (give-up-ir1-transform)) - dim)) + (first dim))) (defoptimizer (vector-length derive-type) ((vector)) (let ((array-type (lvar-conservative-type vector)) @@ -1403,21 +1422,30 @@ (t `(%array-available-elements array))))) -;;; Only complex vectors have fill pointers. -(deftransform array-has-fill-pointer-p ((array)) +;;; Any array can be tested for a fill-pointer now, using the header bit. +;;; Only a non-simple vector could possibly return true. +;;; If the input is known simple, we have to avoid doing the logtest because there's +;;; no constraint that says that the logtest will return false, and style-warnings +;;; will result from MAP-INTO and other things which have +;; (if (array-has-fill-pointer-p a) (setf (fill-pointer a) ...)) +;; where the compiler knows that the input is simple. +(deftransform array-has-fill-pointer-p ((array) * * :node node) (let* ((array-type (lvar-type array)) - (dims (array-type-dimensions-or-give-up array-type))) - (if (and (listp dims) (not (= (length dims) 1))) - nil - (ecase (conservative-array-type-complexp array-type) - ((t) - t) - ((nil) - nil) - ((:maybe) - (give-up-ir1-transform - "The array type is ambiguous; must call ~ - ARRAY-HAS-FILL-POINTER-P at runtime.")))))) + (dims (array-type-dimensions-or-give-up array-type)) + complexp) + ;; If a vector and possibly non-simple, then perform the bit test, + ;; otherwise the answer is definitely NIL. + (cond ((and (listp dims) (/= (length dims) 1)) nil) ; dims = * is possibly a vector + ((eq (setf complexp (conservative-array-type-complexp array-type)) nil) nil) + (t + (when (eq complexp :maybe) + ;; Delay as much as possible so that this transform and + ;; the CONSTRAINT-PROPAGATE-IF optimizer have the most + ;; 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+)))))) (deftransform %check-bound ((array dimension index) ((simple-array * (*)) * *)) (let ((array-ref (lvar-uses array)) @@ -1887,7 +1915,9 @@ (declare (ignore gen)) (values array (specifier-type '(and array (not (simple-array * (*))))))) -(defoptimizer (%array-fill-pointer-p constraint-propagate-if) +;;; If ARRAY-HAS-FILL-POINTER-P returns true, then ARRAY +;;; is of the specified type. +(defoptimizer (array-has-fill-pointer-p constraint-propagate-if) ((array) node gen) (declare (ignore gen)) (values array (specifier-type '(and vector (not simple-array))))) diff -Nru sbcl-2.0.6/src/compiler/assem.lisp sbcl-2.1.1/src/compiler/assem.lisp --- sbcl-2.0.6/src/compiler/assem.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/assem.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1346,11 +1346,22 @@ ;;;; interface to the rest of the compiler +;;; Map of opcode symbol to function that emits it into the byte stream +;;; (or with the schedulding assembler, into the queue) +;;; Key is a symbol. Value is either # or (#), +;;; the latter if function wants to receive prefix arguments. +(defglobal *inst-encoder* (make-hash-table)) ; keys are symbols + ;;; Return T only if STATEMENT has a label which is potentially a branch ;;; target, and not merely labeled to store a location of interest. (defun labeled-statement-p (statement &aux (labels (stmt-labels statement))) (if (listp labels) (some #'label-usedp labels) (label-usedp labels))) +#-x86-64 +(progn + (defun extract-prefix-keywords (x) x) + (defun decode-prefix (args) args)) + (defun dump-symbolic-asm (section stream &aux last-vop all-labels (n 0)) (format stream "~2&Assembler input:~%") (do ((statement (stmt-next (section-start section)) (stmt-next statement)) @@ -1376,7 +1387,11 @@ (if (functionp op) (format stream "# postit ~S~A~%" op eol-comment) (format stream " ~:@(~A~) ~{~A~^, ~}~A~%" - op (stmt-operands statement) eol-comment)))) + op + (if (consp (gethash op *inst-encoder*)) + (decode-prefix (stmt-operands statement)) + (stmt-operands statement)) + eol-comment)))) (let ((*print-length* nil) (*print-pretty* t) (*print-right-margin* 80)) @@ -1400,10 +1415,6 @@ (setf (section-tail first) last-stmt)) first) -;;; Map of opcode symbol to function that emits it into the byte stream -;;; (or with the schedulding assembler, into the queue) -(defglobal *inst-encoder* (make-hash-table)) ; keys are symbols - ;;; Combine INPUTS into one assembly stream and assemble into SEGMENT (defun %assemble (segment section) (let ((**current-vop** nil) @@ -1454,9 +1465,10 @@ ((nil)) ; ignore (t (let ((encoder (gethash mnemonic *inst-encoder*))) - (cond ((functionp encoder) + (cond (encoder (instruction-hooks segment) - (apply encoder segment + (apply (the function (if (listp encoder) (car encoder) encoder)) + segment (perform-operand-lowering operands))) (t (bug "No encoder for ~S" mnemonic)))))))))) @@ -1596,13 +1608,15 @@ *backend-instruction-set-package*) action (gethash mnemonic *inst-encoder*)) (aver action)) + (when (listp action) (setq operands (extract-prefix-keywords operands))) (typecase dest (cons ; streaming in to the assembler (trace-inst dest mnemonic operands) (emit dest (cons mnemonic operands))) (segment ; streaming out of the assembler (instruction-hooks dest) - (apply action dest (perform-operand-lowering operands)))))) + (apply (the function (if (listp action) (car action) action)) + dest (perform-operand-lowering operands)))))) (defun emit-label (label) "Emit LABEL at this location in the current section." @@ -1765,9 +1779,16 @@ (:little-endian (nreverse forms)) (:big-endian forms))))))) -(defun %def-inst-encoder (symbol &optional thing) - (setf (gethash symbol *inst-encoder*) - (or thing (gethash symbol *inst-encoder*)))) +(defun %def-inst-encoder (symbol thing &optional accept-prefixes) + (let ((function + (or thing ; load-time effect passes the definition + ;; (where compile-time doesn't). + ;; Otherwise, take what we already had so that a compile-time + ;; effect doesn't clobber an already-working hash-table entry + ;; if re-evaluating a define-instruction form. + (car (ensure-list (gethash symbol *inst-encoder*)))))) + (setf (gethash symbol *inst-encoder*) + (if accept-prefixes (cons function t) function)))) (defmacro define-instruction (name lambda-list &rest options) (binding* ((fun-name (intern (symbol-name name) *backend-instruction-set-package*)) @@ -1865,13 +1886,18 @@ (setf (get ',fun-name 'sb-disassem::instruction-flavors) (list ,@pdefs)) ,@(when emitter - `((eval-when (:compile-toplevel) (%def-inst-encoder ',fun-name)) - (%def-inst-encoder - ',fun-name - (named-lambda ,(string fun-name) (,segment-name ,@(cdr lambda-list)) - (declare ,@decls) - (let ,(and vop-name `((,vop-name **current-vop**))) - (block ,fun-name ,@emitter)))))) + (let* ((operands (cdr lambda-list)) + (accept-prefixes (eq (car operands) '&prefix))) + (when accept-prefixes (setf operands (cdr operands))) + `((eval-when (:compile-toplevel) + (%def-inst-encoder ',fun-name nil ',accept-prefixes)) + (%def-inst-encoder + ',fun-name + (named-lambda ,(string fun-name) (,segment-name ,@operands) + (declare ,@decls) + (let ,(and vop-name `((,vop-name **current-vop**))) + (block ,fun-name ,@emitter))) + ',accept-prefixes)))) ',fun-name))) (defun instruction-hooks (segment) diff -Nru sbcl-2.0.6/src/compiler/backend.lisp sbcl-2.1.1/src/compiler/backend.lisp --- sbcl-2.0.6/src/compiler/backend.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/backend.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -45,10 +45,6 @@ (defglobal *backend-sbs* #()) (declaim (type simple-vector *backend-sbs*)) -;;; translation from template names to template structures -(defglobal *backend-template-names* (make-hash-table)) ; keys are symbols -(declaim (type hash-table *backend-template-names*)) - ;;; hashtables mapping from SC and SB names to the corresponding structures (defglobal *backend-sc-names* (make-hash-table)) (declaim (type hash-table *backend-sc-names*)) diff -Nru sbcl-2.0.6/src/compiler/bit-util.lisp sbcl-2.1.1/src/compiler/bit-util.lisp --- sbcl-2.0.6/src/compiler/bit-util.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/bit-util.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -12,7 +12,6 @@ (in-package "SB-C") -#-sb-fluid (declaim (inline clear-bit-vector set-bit-vector bit-vector-replace bit-vector-copy)) diff -Nru sbcl-2.0.6/src/compiler/callable-args.lisp sbcl-2.1.1/src/compiler/callable-args.lisp --- sbcl-2.0.6/src/compiler/callable-args.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/callable-args.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -51,7 +51,8 @@ (incf arg-position)) (handle-keys (options) (loop for (key value*) on options by #'cddr - for value = (if (eq key :key) + for value = (if (or (eq key :key) + (eq key :value)) (let ((lvar (getf (nthcdr positional-count lvars) value*))) (and lvar (record-lvar lvar))) @@ -294,9 +295,16 @@ (labels ((%process-arg (spec) (destructuring-bind (nth-arg . options) spec (let* ((arg (nth nth-arg deps)) + (value-nth (getf options :value)) (key-nth (getf options :key)) + (value (and value-nth + (nth value-nth deps))) (key (and key-nth (nth key-nth deps))) - (key-return-type (cond ((not key) + (key-return-type (cond (value-nth + (if (lvar-p value) + (lvar-type value) + *universal-type*)) + ((not key) nil) ((lvar-p key) (multiple-value-bind (type name) (lvar-fun-type key) diff -Nru sbcl-2.0.6/src/compiler/codegen.lisp sbcl-2.1.1/src/compiler/codegen.lisp --- sbcl-2.0.6/src/compiler/codegen.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/codegen.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -125,19 +125,23 @@ ;;; to get handles (as returned by sb-vm:inline-constant-value) from constant ;;; descriptors. ;;; -#+(or x86 x86-64 arm64 ppc ppc64) +#+(or arm arm64 mips ppc ppc64 x86 x86-64) (defun register-inline-constant (&rest constant-descriptor) - (declare (dynamic-extent 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 + ;; return it as the key to the hash-table in the most trivial possible implementation. + ;; The cost of listifying a &REST arg is unnoticeable here. (let ((asmstream *asmstream*) (constant (sb-vm:canonicalize-inline-constant constant-descriptor))) - (ensure-gethash - constant - (asmstream-constant-table asmstream) - (multiple-value-bind (label value) (sb-vm:inline-constant-value constant) - (vector-push-extend (cons constant label) - (asmstream-constant-vector asmstream)) - value)))) -#-(or x86 x86-64 arm64 ppc ppc64) + (values ; kill the second value + (ensure-gethash + constant + (asmstream-constant-table asmstream) + (multiple-value-bind (label value) (sb-vm:inline-constant-value constant) + (vector-push-extend (cons constant label) + (asmstream-constant-vector asmstream)) + value))))) +#-(or arm 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))) @@ -270,6 +274,9 @@ "~|~%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)) (*asmstream* asmstream)) @@ -294,7 +301,8 @@ (not (loop-info cloop))) ;; Mark the loop as aligned by saving the IR1 block aligned. (setf (loop-info cloop) 1block) - t)))) + filler-pattern)))) + (setf filler-pattern :long-nop) (emit-block-header (block-label 1block) (ir2-block-%trampoline-label block) (ir2-block-dropped-thru-to block) diff -Nru sbcl-2.0.6/src/compiler/constraint.lisp sbcl-2.1.1/src/compiler/constraint.lisp --- sbcl-2.0.6/src/compiler/constraint.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/constraint.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -547,7 +547,7 @@ ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL. -#-sb-fluid (declaim (inline ok-ref-lambda-var)) +(declaim (inline ok-ref-lambda-var)) (defun ok-ref-lambda-var (ref) (declare (type ref ref)) (let ((leaf (ref-leaf ref))) diff -Nru sbcl-2.0.6/src/compiler/copyprop.lisp sbcl-2.1.1/src/compiler/copyprop.lisp --- sbcl-2.0.6/src/compiler/copyprop.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/copyprop.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -86,7 +86,11 @@ ;; performed based on the SC. (and reads (null (tn-ref-next reads)) - (eq (vop-name (tn-ref-vop reads)) 'move))) + (eq (vop-name (tn-ref-vop reads)) 'move) + ;; 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 diff -Nru sbcl-2.0.6/src/compiler/ctype.lisp sbcl-2.1.1/src/compiler/ctype.lisp --- sbcl-2.0.6/src/compiler/ctype.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ctype.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -207,7 +207,7 @@ (dsd-default slot)))) ;; Return T if value-form definitely does not satisfy ;; the type-check for DSD. Return NIL if we can't decide. - (when (if (sb-xc:constantp initform) + (when (if (constantp initform) (not (sb-xc:typep (constant-form-value initform) (dsd-type slot))) ;; Find uses of nil-returning functions as defaults, @@ -392,10 +392,10 @@ (defstruct (approximate-fun-type (:copier nil)) ;; the smallest and largest numbers of arguments that this function ;; has been called with. - (min-args sb-xc:call-arguments-limit - :type (integer 0 #.sb-xc:call-arguments-limit)) + (min-args call-arguments-limit + :type (integer 0 #.call-arguments-limit)) (max-args 0 - :type (integer 0 #.sb-xc:call-arguments-limit)) + :type (integer 0 #.call-arguments-limit)) ;; a list of lists of the all the types that have been used in each ;; argument position (types () :type list) @@ -413,7 +413,7 @@ ;; The position at which this keyword appeared. 0 if it appeared as the ;; first argument, etc. (position (missing-arg) - :type (integer 0 #.sb-xc:call-arguments-limit)) + :type (integer 0 #.call-arguments-limit)) ;; a list of all the argument types that have been used with this keyword (types nil :type list) ;; true if this keyword has appeared only in calls with an obvious @@ -647,20 +647,10 @@ ;;; defaults. Returning the actual vars allows us to use the right ;;; variable name in warnings. ;;; -;;; A slightly subtle point: with keywords and optionals, the type in -;;; the function type is only an assertion on calls --- it doesn't -;;; constrain the type of default values. So we have to union in the -;;; type of the default. With optionals, we can't do any assertion -;;; unless the default is constant. -;;; -;;; With keywords, we exploit our knowledge about how hairy keyword -;;; defaulting is done when computing the type assertion to put on the -;;; main-entry argument. In the case of hairy keywords, the default -;;; has been clobbered with NIL, which is the value of the main-entry -;;; arg in the unsupplied case, whatever the actual default value is. -;;; So we can just assume the default is constant, effectively -;;; unioning in NULL, and not totally blow off doing any type -;;; assertion. +;; Despite FTYPE proclamations affecting only the calls and not the +;; function itself, it would be very weird to see a default of &key or +;; &optional be different from the proclaimed type. Accept NULL only +;; when there's no default form. (defun find-optional-dispatch-types (od type where) (declare (type optional-dispatch od) (type fun-type type) @@ -711,47 +701,50 @@ (arglist (optional-dispatch-arglist od))) (dolist (arg arglist) (cond - ((lambda-var-arg-info arg) - (let* ((info (lambda-var-arg-info arg)) - (default (arg-info-default info)) - (def-type (when (sb-xc:constantp default) - (ctype-of (constant-form-value default))))) - (ecase (arg-info-kind info) - (:keyword - (let* ((key (arg-info-key info)) - (kinfo (find key keys :key #'key-info-name))) - (cond - (kinfo - (res (type-union (key-info-type kinfo) - (or def-type (specifier-type 'null))))) - (t - (note-lossage - "Defining a ~S keyword not present in ~A." - key where) - (res *universal-type*))))) - (:required (res (pop type-required))) - (:optional - ;; We can exhaust TYPE-OPTIONAL when the type was - ;; simplified as described above. - (res (type-union (or (pop type-optional) - *universal-type*) - (or def-type *universal-type*)))) - (:rest - (when (fun-type-rest type) - (res (specifier-type 'list)))) - (:more-context - (when (fun-type-rest type) - (res *universal-type*))) - (:more-count - (when (fun-type-rest type) - (res (specifier-type 'fixnum))))) - (vars arg) - (when (arg-info-supplied-p info) - (res *universal-type*) - (vars (arg-info-supplied-p info))))) - (t - (res (pop type-required)) - (vars arg)))) + ((lambda-var-arg-info arg) + (let* ((info (lambda-var-arg-info arg)) + (default-p (arg-info-default-p info))) + (ecase (arg-info-kind info) + (:keyword + (let* ((key (arg-info-key info)) + (kinfo (find key keys :key #'key-info-name))) + (cond + (kinfo + (res (if default-p + (key-info-type kinfo) + (type-union (key-info-type kinfo) + (specifier-type 'null))))) + (t + (note-lossage + "Defining a ~S keyword not present in ~A." + key where) + (res *universal-type*))))) + (:required (res (pop type-required))) + (:optional + ;; We can exhaust TYPE-OPTIONAL when the type was + ;; simplified as described above. + (res (let ((type (or (pop type-optional) + *universal-type*))) + (if default-p + type + (type-union type + (specifier-type 'null)))))) + (:rest + (when (fun-type-rest type) + (res (specifier-type 'list)))) + (:more-context + (when (fun-type-rest type) + (res *universal-type*))) + (:more-count + (when (fun-type-rest type) + (res (specifier-type 'fixnum))))) + (vars arg) + (when (arg-info-supplied-p info) + (res *universal-type*) + (vars (arg-info-supplied-p info))))) + (t + (res (pop type-required)) + (vars arg)))) (dolist (key keys) (unless (find (key-info-name key) arglist diff -Nru sbcl-2.0.6/src/compiler/debug-dump.lisp sbcl-2.1.1/src/compiler/debug-dump.lisp --- sbcl-2.0.6/src/compiler/debug-dump.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/debug-dump.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -77,7 +77,7 @@ (- posn (segment-header-skew segment)))))) (values)) -#-sb-fluid (declaim (inline ir2-block-physenv)) +(declaim (inline ir2-block-physenv)) (defun ir2-block-physenv (2block) (declare (type ir2-block 2block)) (block-physenv (ir2-block-block 2block))) @@ -407,12 +407,12 @@ (if (zerop length) #() (logically-readonlyize - (sb-xc:coerce seq - `(simple-array - ,(smallest-element-type (max max-positive - (1- max-negative)) - (plusp max-negative)) - 1))))))) + (coerce seq + `(simple-array + ,(smallest-element-type (max max-positive + (1- max-negative)) + (plusp max-negative)) + 1))))))) (defun compact-vector (sequence) (cond ((and (= (length sequence) 1) @@ -450,7 +450,7 @@ (neq (lambda-physenv fun) (lambda-physenv (lambda-var-home var))))) ;; Keep this condition in sync with PARSE-COMPILED-DEBUG-VARS - (large-fixnums (>= (integer-length sb-xc:most-positive-fixnum) 62)) + (large-fixnums (>= (integer-length most-positive-fixnum) 62)) more) (declare (type index flags)) (when minimal diff -Nru sbcl-2.0.6/src/compiler/debug.lisp sbcl-2.1.1/src/compiler/debug.lisp --- sbcl-2.0.6/src/compiler/debug.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/debug.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -107,7 +107,7 @@ (barf "strange CONSTANTS entry: ~S" v)) (dolist (n (leaf-refs v)) (check-node-reached n))) - (eq-constants ns)) + (eql-constants ns)) (maphash (lambda (k v) (declare (ignore k)) @@ -756,8 +756,7 @@ (defun check-block-conflicts (component) (do-ir2-blocks (block component) (do ((conf (ir2-block-global-tns block) - (global-conflicts-next-blockwise conf)) - (prev nil conf)) + (global-conflicts-next-blockwise conf))) ((null conf)) (unless (find-in #'global-conflicts-next-tnwise conf @@ -1079,6 +1078,7 @@ ((null ref)) (let ((tn (tn-ref-tn ref)) (ltn (tn-ref-load-tn ref))) + (awhen (tn-ref-memory-access ref) (format t "@~A" it)) (cond ((not ltn) (print-tn-guts tn)) (t diff -Nru sbcl-2.0.6/src/compiler/deftype.lisp sbcl-2.1.1/src/compiler/deftype.lisp --- sbcl-2.0.6/src/compiler/deftype.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/deftype.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -41,7 +41,7 @@ (let ((expr `(progn ,@forms))) ;; While CONSTANTP works early, %MACROEXPAND does not, ;; so we can't pass ENV because it'd try to macroexpand. - (if (sb-xc:constantp expr) expr))) + (if (constantp expr) expr))) #-sb-xc-host (check-deprecated-type (constant-form-value it)) (values `(constant-type-expander ',name ,it) doc diff -Nru sbcl-2.0.6/src/compiler/disassem.lisp sbcl-2.1.1/src/compiler/disassem.lisp --- sbcl-2.0.6/src/compiler/disassem.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/disassem.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -67,7 +67,6 @@ ;;;; KLUDGE: It's not clear that using bit-vectors would be any more efficient. ;;;; Perhaps the abstraction could go away. -- WHN 19991124 -#-sb-fluid (declaim (inline dchunk-or dchunk-and dchunk-clear dchunk-not dchunk-make-mask dchunk-make-field dchunk-extract @@ -559,7 +558,7 @@ `((lookup-label ,(maybe-listify numeric-forms))) numeric-forms))))) -#-sb-fluid (declaim (inline bytes-to-bits)) +(declaim (inline bytes-to-bits)) (defun bytes-to-bits (bytes) (declare (type disassem-length bytes)) diff -Nru sbcl-2.0.6/src/compiler/dump.lisp sbcl-2.1.1/src/compiler/dump.lisp --- sbcl-2.0.6/src/compiler/dump.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/dump.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -39,8 +39,14 @@ ;; performance pathologies with objects for which EQUAL degenerates ;; to EQL. Everything entered in the SIMILAR table is also entered in ;; the EQ table. - (similar-table (make-hash-table :test 'equal) :type hash-table) - (eq-table (make-hash-table :test 'eq) :type hash-table) + (similar-table (make-similarity-table) :type hash-table :read-only t) + (eq-table (make-hash-table :test 'eq) :type hash-table :read-only t) + ;; the INSTANCE table maps dumpable instances to unique IDs for calculating + ;; a similarity hash of composite objects that contain instances. + ;; A user-defined hash function can not use address-based hashing, and it is + ;; better not to add a new lazy stable hash slot to instances as a + ;; side-effect of compiling. + (instance-id-table (make-hash-table :test 'eq) :type hash-table :read-only t) ;; the CONS table is an additional EQ table, used for storing CDRs ;; of dumped lists which will not have their own direct identity as ;; a dumped constant, but which might nevertheless be EQ to some @@ -48,13 +54,13 @@ ;; The hash table entry, if present, is a reference to its parent ;; list object (which will have a direct entity as a dumped ;; constant) along with an index of how many CDRs to take. - (cons-table (make-hash-table :test 'eq) :type hash-table) + (cons-table (make-hash-table :test 'eq) :type hash-table :read-only t) ;; Hashtable mapping a string to a list of fop-table indices of ;; symbols whose name is that string. For any name as compared ;; by STRING= there can be a symbol whose name is a base string ;; and/or a symbol whose name is not a base string. (string=-table (make-hash-table :test 'equal) :type hash-table) - ;; the table's current free pointer: the next offset to be used + ;; the fasloader table's current free pointer: the next offset to be used (table-free 0 :type index) ;; an alist (PACKAGE . OFFSET) of the table offsets for each package ;; we have currently located. @@ -84,6 +90,119 @@ (source-info nil :type (or null sb-c::debug-source))) (declaim (freeze-type fasl-output)) +;;; Similarity hash table logic. +;;; It really seems bogus to me that we do similarity checking in both +;;; the IR1 namespace and the fasl dumper, even going so far as to use +;;; two different ways to decide that an object is "harmless" to look up +;;; (i.e. has no cyclic references). + +#-sb-xc-host +(progn +(defun similarp (x y) + ;; Do almost the same thing that EQUAL does, but: + ;; - consider strings to be dissimilar if their element types differ. + ;; - scan elements of all specialized numeric vectors (BIT is done by EQUAL) + (named-let recurse ((x x) (y y)) + (or (%eql x y) + (typecase x + (cons + (and (consp y) + (recurse (car x) (car y)) + (recurse (cdr x) (cdr y)))) + (string + ;; Incidentally, if we want to preserve non-simpleness of dumped arrays + ;; (which is permissible but not required), this case (and below for arrays) + ;; would be where to do it by returning non-similar. + (and (stringp y) + ;; (= (widetag-of ...)) would be too strict, because a simple string + ;; can be be similar to a non-simple string. + (eq (array-element-type x) + (array-element-type y)) + (string= x y))) + ((or pathname bit-vector) ; fall back to EQUAL + ;; This could be slightly wrong, but so it always was, because we use + ;; (and have used) EQUAL for PATHNAME in SB-C::FIND-CONSTANT, but: + ;; "Two pathnames S and C are similar if all corresponding pathname components are similar." + ;; and we readily admit that similarity of strings requires equal element types. + ;; So this is slightly dubious: + ;; (EQUAL (MAKE-PATHNAME :NAME (COERCE "A" 'SB-KERNEL:SIMPLE-CHARACTER-STRING)) + ;; (MAKE-PATHNAME :NAME (COERCE "A" 'BASE-STRING))) => T + ;; On the other hand, nothing says that the pathname constructors such as + ;; MAKE-PATHNAME and MERGE-PATHNAMES don't convert to a canonical representation + ;; which renders them EQUAL when all strings are STRING=. + ;; This area of the language spec seems to have been a clusterfsck. + (equal x y)) + ;; We would need to enhance COALESCE-TREE-P to detect cycles involving + ;; SIMPLE-VECTOR before recursing, otherwise this could exhaust stack. + ((unboxed-array (*)) + (and (sb-xc:typep y '(simple-array * 1)) + (= (length x) (length y)) + (equal (sb-xc:array-element-type x) (sb-xc:array-element-type y)) + (or (typep x '(array nil (*))) + (dotimes (i (length x) t) + (unless (= (aref x i) (aref y i)) (return nil)))))) + ;; How do SIMPLE-VECTOR and other array types get here? + ;; Answer: COALESCE-TREE-P is "weaker than" the the local COALESCE-P function in FIND-CONSTANT, + ;; so it may return T on trees that contain atoms that COALESCE-P would have returned NIL on. + ;; Therefore DUMP-NON-IMMEDIATE-OBJECT may call SIMILARP on an object for which COALESCE-P + ;; would have said NIL. + ;; As mentioned at the top of this file, this seems incredibly bad, + ;; But users do not tend to have object cycles involving SIMPLE-VECTOR and such, I guess? + ;; Anyway, the answer has to be "no" for everything else: un-EQL objects are not similar. + (t nil))))) +;; This hash function is an amalgam of SXHASH and PSHASH with the following properties: +;; - numbers must have the same type to be similar (same as SXHASH) +;; - instances must be EQ to be similar (same as SXHASH) +;; - strings and characters are compared case-sensitively (same as SXHASH) +;; - arrays must have the same type to be similar +;; Unlike EQUAL-HASH, we never call EQ-HASH, because there is generally no reason +;; to try to look up an object that lacks a content-based hash value. +(defun similar-hash (x) + (named-let recurse ((x x)) + ;; There is no depth cutoff - X must not be circular, + ;; which was already determined as a precondition to calling this, + ;; except that as pointed out, we must not descend into simple-vector + ;; because there was no circularity checking done for arrays. + (typecase x + (list (do ((hash 0)) + ((atom x) (mix (if x (recurse x) #xD00F) hash)) + ;; mix the hash of the CARs only, without consuming stack + ;; proportional to list length. + (setf hash (mix (recurse (car x)) hash) + x (cdr x)))) + (symbol (sxhash x)) + (number (sb-impl::number-sxhash x)) + (pathname (sb-impl::pathname-sxhash x)) + (instance + (let ((idmap (fasl-output-instance-id-table sb-c::*compile-object*))) + (values (ensure-gethash x idmap + (let ((c (1+ (hash-table-count idmap)))) + (mix c c)))))) + ;; Arrays disregard simplicity. + ((array nil (*)) #xdead) ; don't access the data in these bastards + ((unboxed-array (*)) + (let* ((simple-array (coerce x '(simple-array * (*)))) + (widetag (%other-pointer-widetag simple-array)) + (saetp (find widetag sb-vm:*specialized-array-element-type-properties* + :key #'sb-vm:saetp-typecode)) + (n-data-words (ceiling (sb-vm::vector-n-data-octets simple-array saetp) + sb-vm:n-word-bytes)) + (hash (word-mix (length x) widetag))) + (declare (word hash)) + (dotimes (i n-data-words (logand hash most-positive-fixnum)) + (setq hash (word-mix hash (%vector-raw-bits x i)))))) + (character (char-code x)) + (t 0)))) +(defun make-similarity-table () + (make-hash-table :hash-function #'similar-hash :test #'similarp)) +) ; end PROGN + +;;; When cross-compiling, it's good enough to approximate similarity as EQUAL. +#+sb-xc-host +(defun make-similarity-table () (make-hash-table :test 'equal)) + +(defmacro get-similar (key table) `(gethash ,key ,table)) + ;;; This structure holds information about a circularity. (defstruct (circularity (:copier nil)) ;; the kind of modification to make to create circularity @@ -197,13 +316,9 @@ ;;; otherwise NIL. (defun similar-check-table (x fasl-output) (declare (type fasl-output fasl-output)) - (let ((handle - (dolist (candidate (gethash x (fasl-output-similar-table fasl-output))) - (when (sb-c::similarp (car candidate) x) - (return (cdr candidate)))))) - (cond - (handle (dump-push handle fasl-output) t) - (t nil)))) + (awhen (get-similar x (fasl-output-similar-table fasl-output)) + (dump-push it fasl-output) + t)) ;;; These functions are called after dumping an object to save the ;;; object in the table. The object (also passed in as X) must already @@ -216,7 +331,7 @@ (defun similar-save-object (x fasl-output) (declare (type fasl-output fasl-output)) (let ((handle (dump-to-table fasl-output))) - (push (cons x handle) (gethash x (fasl-output-similar-table fasl-output))) + (setf (get-similar x (fasl-output-similar-table fasl-output)) handle) (setf (gethash x (fasl-output-eq-table fasl-output)) handle)) (values)) ;;; Record X in File's CIRCULARITY-TABLE. This is called on objects @@ -272,8 +387,8 @@ compiled from ~S~% ~ using ~A version ~A~%" where - (sb-xc:lisp-implementation-type) - (sb-xc:lisp-implementation-version)))) + (lisp-implementation-type) + (lisp-implementation-version)))) stream) (dump-byte +fasl-header-string-stop-char-code+ res) ;; Finish the header by outputting fasl file implementation, @@ -289,7 +404,7 @@ (dump-byte (char-code (aref string i)) res)))) (dump-counted-string (symbol-name +backend-fasl-file-implementation+)) (dump-word +fasl-file-version+ res) - (dump-counted-string (sb-xc:lisp-implementation-version)) + (dump-counted-string (lisp-implementation-version)) (dump-counted-string (compute-features-affecting-fasl-format))) res))) @@ -348,8 +463,12 @@ ((eq x sb-c::*debug-name-ellipsis*) 2) (t (bug "Bogus debug name marker"))))) (instance - (dump-structure x file) - (eq-save-object x file)) + (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.)) + (dump-load-time-symbol-global-value c file)) + (t + (dump-structure x file) + (eq-save-object x file))))) (array ;; DUMP-ARRAY (and its callees) are responsible for ;; updating the EQ and EQUAL hash tables. @@ -409,7 +528,12 @@ (dump-fop 'fop-truth file) (dump-non-immediate-object x file))) ((fixnump x) (dump-integer x file)) - ((characterp x) (dump-character x file)) + ((characterp x) + (dump-fop 'fop-character file (sb-xc:char-code x))) + #-sb-xc-host + ((system-area-pointer-p x) + (dump-fop 'fop-word-pointer file) + (dump-integer-as-n-bytes (sap-int x) sb-vm:n-word-bytes file)) (t (dump-non-immediate-object x file)))) @@ -724,9 +848,9 @@ ;;; tables. (defun dump-vector (x file) (let ((simple-version (if (array-header-p x) - (sb-xc:coerce x `(simple-array - ,(array-element-type x) - (*))) + (coerce x `(simple-array + ,(array-element-type x) + (*))) x))) (typecase simple-version ;; On the host, take all strings to be simple-base-string. @@ -809,10 +933,7 @@ (ceiling (* length bits-per-length) sb-vm:n-byte-bits) #+sb-xc-host bits-per-length)))) -;;; Dump characters and string-ish things. - -(defun dump-character (char file) - (dump-fop 'fop-character file (sb-xc:char-code char))) +;;; Dump string-ish things. ;;; Dump a SIMPLE-STRING. (defun dump-chars (s fasl-output base-string-p) @@ -891,7 +1012,8 @@ :symbol-tls-index :foreign :foreign-dataref :code-object :layout :immobile-symbol :named-call :static-call - :symbol-value) + :symbol-value + :layout-id) #'equalp) ;;; Pack the aspects of a fixup into an integer. @@ -931,7 +1053,9 @@ (operand (ecase flavor (:code-object (the null name)) - (:layout (if (symbolp name) name (layout-classoid-name name))) + (:layout + (if (symbolp name) name (layout-classoid-name name))) + (:layout-id (the layout name)) ((:assembly-routine :assembly-routine* :asm-routine-nil-offset :symbol-tls-index ;; Only #+immobile-space can use the following two flavors. @@ -941,12 +1065,17 @@ ;; but its global value must be an immobile object. :immobile-symbol :symbol-value) (the symbol name)) - ((:foreign #+linkage-table :foreign-dataref) (the string name)) + ((:foreign :foreign-dataref) (the string name)) ((:named-call :static-call) name)))) (dump-object operand fasl-output) (dump-integer info fasl-output)) (incf n))) +(defun dump-load-time-symbol-global-value (constant fasl-output) + (dump-object 'symbol-global-value fasl-output) + (dump-object (sb-c::leaf-source-name constant) fasl-output) + (dump-fop 'fop-funcall fasl-output 1)) + ;;; Dump out the constant pool and code-vector for component, push the ;;; result in the table, and return the offset. ;;; @@ -975,7 +1104,10 @@ (let ((entry (aref constants i))) (etypecase entry (constant - (dump-object (sb-c::constant-value entry) fasl-output)) + (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)))) (cons (ecase (car entry) (:constant ; anything that has not been wrapped in a # @@ -1167,6 +1299,9 @@ ;;; which gets multiply expanded exactly as described above. (defun load-form-is-default-mlfss-p (struct) + ;; FIXME? this is called while writing a fasl and so might need + ;; to invoke MAKE-LOAD-FORM, long after IR1 conversion has happened. + ;; Surely this is not the best design. (eq (nth-value 1 (sb-c::%make-load-form struct)) 'fop-struct)) ;; Having done nothing more than load all files in obj/from-host, the diff -Nru sbcl-2.0.6/src/compiler/early-c.lisp sbcl-2.1.1/src/compiler/early-c.lisp --- sbcl-2.0.6/src/compiler/early-c.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/early-c.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -26,25 +26,18 @@ (declaim (freeze-type opaque-box)) ;;; ANSI limits on compilation -(defconstant sb-xc:call-arguments-limit sb-xc:most-positive-fixnum +(defconstant call-arguments-limit most-positive-fixnum "The exclusive upper bound on the number of arguments which may be passed to a function, including &REST args.") -(defconstant sb-xc:lambda-parameters-limit sb-xc:most-positive-fixnum +(defconstant lambda-parameters-limit most-positive-fixnum "The exclusive upper bound on the number of parameters which may be specified in a given lambda list. This is actually the limit on required and &OPTIONAL parameters. With &KEY and &AUX you can get more.") -(defconstant sb-xc:multiple-values-limit sb-xc:most-positive-fixnum +(defconstant multiple-values-limit most-positive-fixnum "The exclusive upper bound on the number of multiple VALUES that you can return.") -;;;; cross-compiler-only versions of CL special variables, so that we -;;;; don't have weird interactions with the host compiler -(defvar sb-xc:*compile-file-pathname*) -(defvar sb-xc:*compile-file-truename*) -(defvar sb-xc:*compile-print*) -(defvar sb-xc:*compile-verbose*) - ;;;; miscellaneous types used both in the cross-compiler and on the target ;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong @@ -56,10 +49,9 @@ ;;; otherwise a slot unto itself. (def!type layout-depthoid () '(integer -1 #x7FFF)) (def!type layout-length () '(integer 0 #xFFFF)) -(def!type layout-bitmap () - ;; FIXME: Probably should exclude negative bignum - #+compact-instance-header 'integer - #-compact-instance-header '(and integer (not (eql 0)))) +(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: @@ -96,15 +88,17 @@ (free-funs (make-hash-table :test 'equal) :read-only t :type hash-table) ;; These hashtables translate from constants to the LEAFs that ;; represent them. - ;; Table 1: one entry for each distinct constant (according to object identity) - (eq-constants (make-hash-table :test 'eq) :read-only t :type hash-table) - ;; Table 2: one hash-table entry per EQUAL constant, + ;; Table 1: one entry per named constant + (named-constants (make-hash-table :test 'eq) :read-only t :type hash-table) + ;; Table 2: one entry for each unnamed constant as compared by EQL + (eql-constants (make-hash-table :test 'eql) :read-only t :type hash-table) + ;; Table 3: one key per EQUAL constant, ;; with the caveat that lookups must discriminate amongst constants that ;; are EQUAL but not similar. The value in the hash-table is a list of candidates ;; (# # ... #) such that CONSTANT-VALUE ;; of each is EQUAL to the key for the hash-table entry, but dissimilar ;; from each other. Notably, strings of different element types can't be similar. - (similar-constants (make-hash-table :test 'equal) :read-only t :type hash-table)) + (similar-constants (sb-fasl::make-similarity-table) :read-only t :type hash-table)) (declaim (freeze-type ir1-namespace)) (sb-impl::define-thread-local *ir1-namespace*) @@ -408,18 +402,6 @@ (sb-impl::define-thread-local *compilation*) (declaim (type compilation *compilation*)) -(in-package "SB-ALIEN") - -;;; Information describing a heap-allocated alien. -(def!struct (heap-alien-info (:copier nil)) - ;; The type of this alien. - (type (missing-arg) :type alien-type) - ;; Its name. - (alien-name (missing-arg) :type simple-string) - ;; Data or code? - (datap (missing-arg) :type boolean)) -(!set-load-form-method heap-alien-info (:xc :target)) - ;; from 'llvm/projects/compiler-rt/lib/msan/msan.h': ;; "#define MEM_TO_SHADOW(mem) (((uptr)(mem)) ^ 0x500000000000ULL)" #+linux ; shadow space differs by OS diff -Nru sbcl-2.0.6/src/compiler/early-constantp.lisp sbcl-2.1.1/src/compiler/early-constantp.lisp --- sbcl-2.0.6/src/compiler/early-constantp.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/early-constantp.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -15,15 +15,15 @@ (defstruct (abstract-lexenv (:constructor nil) (:copier nil) (:predicate nil))) -#-sb-fluid (declaim (inline sb-xc:constantp)) -(defun sb-xc:constantp (form &optional (environment nil envp)) +(declaim (inline constantp)) +(defun constantp (form &optional (environment nil envp)) "True of any FORM that has a constant value: self-evaluating objects, keywords, defined constants, quote forms. Additionally the constant-foldability of some function calls and special forms is recognized. If ENVIRONMENT is provided, the FORM is first macroexpanded in it." (%constantp form environment envp)) -#-sb-fluid (declaim (inline constant-form-value)) +(declaim (inline constant-form-value)) (defun constant-form-value (form &optional (environment nil envp)) "Returns the value of the constant FORM in ENVIRONMENT. Behaviour is undefined unless CONSTANTP has been first used to determine the diff -Nru sbcl-2.0.6/src/compiler/early-globaldb.lisp sbcl-2.1.1/src/compiler/early-globaldb.lisp --- sbcl-2.0.6/src/compiler/early-globaldb.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/early-globaldb.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -21,7 +21,7 @@ ((or (atom result) (not (eq (car result) 'values))) `(values ,result &optional)) - ((intersection (cdr result) sb-xc:lambda-list-keywords) + ((intersection (cdr result) lambda-list-keywords) result) (t `(values ,@(cdr result) &optional))))) `(function ,args ,result))) @@ -92,19 +92,13 @@ ;;; ;;; Define SYMBOL-INFO-VECTOR as an inline function unless a vop translates it. ;;; (Inlining occurs first, which would cause the vop not to be used.) -;;; Also note that we have to guard the appearance of VOP-TRANSLATES here -;;; so that it does not get tested when building the cross-compiler. -;;; This was the best way I could see to work around a spurious warning -;;; about a wrongly ordered VM definition in make-host-1. -;;; The #+/- reader can't see that a VOP-TRANSLATES term is not for the -;;; host compiler unless the whole thing is one expression. -#-(or sb-xc-host (vop-translates sb-kernel:symbol-info-vector)) -(progn -(declaim (inline symbol-info-vector)) -(defun symbol-info-vector (symbol) - (let ((info-holder (symbol-info symbol))) - (truly-the (or null simple-vector) - (if (listp info-holder) (cdr info-holder) info-holder))))) +#-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) + (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. @@ -313,8 +307,8 @@ "Automagically generated boolean attribute setter. See !DEF-BOOLEAN-ATTRIBUTE." (multiple-value-bind (temps values stores setter getter) - (#+sb-xc-host get-setf-expansion - #-sb-xc-host sb-xc:get-setf-expansion place env) + (#+sb-xc-host cl:get-setf-expansion + #-sb-xc-host get-setf-expansion place env) (when (cdr stores) (error "multiple store variables for ~S" place)) (let ((newval (sb-xc:gensym)) @@ -349,6 +343,6 @@ `(the attributes (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (declaim (ftype (function (attributes attributes) boolean) attributes=)) -#-sb-fluid (declaim (inline attributes=)) +(declaim (inline attributes=)) (defun attributes= (attr1 attr2) (eql attr1 attr2)) diff -Nru sbcl-2.0.6/src/compiler/early-lexenv.lisp sbcl-2.1.1/src/compiler/early-lexenv.lisp --- sbcl-2.0.6/src/compiler/early-lexenv.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/early-lexenv.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -69,7 +69,7 @@ ;;; The LEXENV represents the lexical environment used for IR1 conversion. ;;; (This is also what shows up as an ENVIRONMENT value in macroexpansion.) -#-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place +(declaim (inline internal-make-lexenv)) ; only called in one place (defstruct (lexenv (:include abstract-lexenv) (:print-function @@ -164,3 +164,65 @@ (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.0.6/src/compiler/equality-constraints.lisp sbcl-2.1.1/src/compiler/equality-constraints.lisp --- sbcl-2.0.6/src/compiler/equality-constraints.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/equality-constraints.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -204,3 +204,28 @@ (equality-constraint eql inverse) (equality-constraint = inverse)) result)) + +(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)) + (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)))))))) + (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)))) + DONE)))) + :give-up) diff -Nru sbcl-2.0.6/src/compiler/fixup.lisp sbcl-2.1.1/src/compiler/fixup.lisp --- sbcl-2.0.6/src/compiler/fixup.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/fixup.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -20,6 +20,10 @@ ;; assumptions about the contents of these fields; their semantics ;; are imposed by the dumper. (name nil :read-only t) + ;; FIXME: "-flavor" and "-kind" are completedly devoid of meaning. + ;; They former should probably be "fixup-referent-type" or "fixup-source" + ;; to indicate that it denotes a namespace for NAME, and latter should be + ;; "fixup-how" as it conveys a manner in which to modify encoded bytes. (flavor nil :read-only t) ;; OFFSET is an optional offset from whatever external label this ;; fixup refers to. Or in the case of the :CODE-OBJECT flavor of diff -Nru sbcl-2.0.6/src/compiler/float-tran.lisp sbcl-2.1.1/src/compiler/float-tran.lisp --- sbcl-2.0.6/src/compiler/float-tran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/float-tran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -147,16 +147,15 @@ ;;; when given a signaling NaN. (deftransform float-sign ((float &optional float2) (single-float &optional single-float) *) - #+(vop-translates sb-kernel:single-float-copysign) - (if float2 - `(single-float-copysign float float2) - `(single-float-sign float)) - #-(vop-translates sb-kernel:single-float-copysign) - (if float2 - (let ((temp (gensym))) - `(let ((,temp (abs float2))) - (if (minusp (single-float-bits float)) (- ,temp) ,temp))) - '(if (minusp (single-float-bits float)) $-1f0 $1f0))) + (if (vop-existsp :translate single-float-copysign) + (if float2 + `(single-float-copysign float float2) + `(single-float-sign float)) + (if float2 + (let ((temp (gensym))) + `(let ((,temp (abs float2))) + (if (minusp (single-float-bits float)) (- ,temp) ,temp))) + '(if (minusp (single-float-bits float)) $-1f0 $1f0)))) (deftransform float-sign ((float &optional float2) (double-float &optional double-float) *) @@ -169,6 +168,21 @@ `(let ((,temp (abs float2))) (if (minusp ,bits) (- ,temp) ,temp))) `(if (minusp ,bits) $-1d0 $1d0)))) + +;;; This doesn't deal with complex at the moment. +(deftransform signum ((x) (number)) + (let* ((ctype (lvar-type x)) + (result-type + (dolist (x '(single-float double-float rational)) + (when (csubtypep ctype (specifier-type x)) + (return x))))) + ;; SB-XC:COERCE doesn't like RATIONAL for some reason. + (when (eq result-type 'rational) (setq result-type 'integer)) + (if result-type + `(cond ((zerop x) x) + ((plusp x) ,(sb-xc:coerce 1 result-type)) + (t ,(sb-xc:coerce -1 result-type))) + (give-up-ir1-transform)))) ;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, and SCALE-FLOAT @@ -225,7 +239,7 @@ ;;; Given a number X, create a form suitable as a bound for an ;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL. ;;; FIXME: as this is a constructor, shouldn't it be named MAKE-BOUND? -#-sb-fluid (declaim (inline set-bound)) +(declaim (inline set-bound)) (defun set-bound (x open-p) (if (and x open-p) (list x) x)) @@ -305,9 +319,9 @@ (type-error () nil))))))) (frob %single-float single-float - sb-xc:most-negative-single-float sb-xc:most-positive-single-float) + most-negative-single-float most-positive-single-float) (frob %double-float double-float - sb-xc:most-negative-double-float sb-xc:most-positive-double-float)) + most-negative-double-float most-positive-double-float)) ;;;; float contagion @@ -329,28 +343,58 @@ ;;; 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. -(deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node) - (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))) -(deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node) - (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))) - -(dolist (x '(+ * / -)) - (%deftransform x '(function (rational float) *) #'float-contagion-arg1) - (%deftransform x '(function (float rational) *) #'float-contagion-arg2)) - -(dolist (x '(= < > <= >= + * / -)) - (%deftransform x '(function (single-float double-float) *) - #'float-contagion-arg1) - (%deftransform x '(function (double-float single-float) *) - #'float-contagion-arg2)) +(progn + (deftransform real-float-contagion-arg1 ((x y) * * :defun-only t :node node) + (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) + (if (or (not (types-equal-or-intersect + (lvar-type y) (specifier-type '(complex single-float)))) + (safe-ctype-for-single-coercion-p (lvar-type x))) + `(,(lvar-fun-name (basic-combination-fun node)) + (float x (realpart y)) y) + (give-up-ir1-transform #1#))) + (deftransform real-float-contagion-arg2 ((x y) * * :defun-only t :node node) + (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) + (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)) + x (float y (realpart x))) + (give-up-ir1-transform #2#)))) + +(flet ((def (operator float-type other-type complexp argument) + (multiple-value-bind (type1 type2 function) + (ecase argument + (1 (if complexp + (values other-type `(complex ,float-type) #'complex-float-contagion-arg1) + (values other-type float-type #'real-float-contagion-arg1))) + (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))))) + + (dolist (operator '(+ * / -)) + (def operator 'float 'rational nil 1) + (def operator 'float 'rational nil 2) + (def operator 'float 'rational t 1) + (def operator 'float 'rational t 2)) + + (dolist (operator '(= < > <= >= + * / -)) + (def operator 'double-float 'single-float nil 1) + (def operator 'double-float 'single-float nil 2) + (when (member operator '(= + * / -)) + (def operator 'double-float 'single-float t 1) + (def operator 'double-float 'single-float t 2)))) (macrolet ((def (type &rest args) `(deftransform * ((x y) (,type (constant-arg (member ,@args))) * @@ -513,15 +557,15 @@ (deftransform atan ((x y) (double-float double-float) *) `(%atan2 x y)) -(deftransform expt ((x y) ((single-float $0f0) single-float) *) +(deftransform expt ((x y) (single-float single-float) single-float) `(coerce (%pow (coerce x 'double-float) (coerce y 'double-float)) - 'single-float)) -(deftransform expt ((x y) ((double-float $0d0) double-float) *) + 'single-float)) +(deftransform expt ((x y) (double-float double-float) double-float) `(%pow x y)) -(deftransform expt ((x y) ((single-float $0f0) (signed-byte 32)) *) +(deftransform expt ((x y) (single-float integer) double-float) `(coerce (%pow (coerce x 'double-float) (coerce y 'double-float)) 'single-float)) -(deftransform expt ((x y) ((double-float $0d0) (signed-byte 32)) *) +(deftransform expt ((x y) (double-float integer) double-float) `(%pow x (coerce y 'double-float))) ;;; ANSI says log with base zero returns zero. @@ -548,7 +592,7 @@ (deftransform phase ((x) ((float)) float) '(if (minusp (float-sign x)) - (float sb-xc:pi x) + (float pi x) (float 0 x))) ;;; The number is of type REAL. @@ -733,10 +777,10 @@ ;; These functions are only defined for part of the real line. The ;; condition selects the desired part of the line. - (frob asin $-1d0 $1d0 (sb-xc:- (sb-xc:/ sb-xc:pi 2)) (sb-xc:/ sb-xc:pi 2)) + (frob asin $-1d0 $1d0 (sb-xc:- (sb-xc:/ pi 2)) (sb-xc:/ pi 2)) ;; Acos is monotonic decreasing, so we need to swap the function ;; values at the lower and upper bounds of the input domain. - (frob acos $-1d0 $1d0 0 sb-xc:pi :increasingp nil) + (frob acos $-1d0 $1d0 0 pi :increasingp nil) (frob acosh $1d0 nil nil nil) (frob atanh $-1d0 $1d0 -1 1) ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that @@ -853,11 +897,20 @@ ;; Positive integer to an integer power is either an ;; integer or a rational. (let ((lo (or (interval-low bnd) '*)) - (hi (or (interval-high bnd) '*))) - (if (and (interval-low y-int) - (>= (type-bound-number (interval-low y-int)) 0)) - (specifier-type `(integer ,lo ,hi)) - (specifier-type `(rational ,lo ,hi))))) + (hi (or (interval-high bnd) '*)) + (y-lo (interval-low y-int)) + (y-hi (interval-high y-int))) + (cond ((and (eq lo '*) + (eql y-lo y-hi) + (typep y-lo 'unsigned-byte) + (evenp y-lo)) + (specifier-type `(integer 0 ,hi))) + ((and (interval-low y-int) + (>= (type-bound-number y-lo) 0)) + + (specifier-type `(integer ,lo ,hi))) + (t + (specifier-type `(rational ,lo ,hi)))))) (rational ;; Positive integer to rational power is either a rational ;; or a single-float. @@ -959,19 +1012,27 @@ (fixup-interval-expt type x-int y-int x y)) (flatten-list (interval-expt x-int y-int))))) +(defun integer-float-p (float) + (and (floatp float) + (or + #-sb-xc-host + (multiple-value-bind (significand exponent) (integer-decode-float float) + (or (plusp exponent) + (<= (- exponent) (sb-kernel::first-bit-set significand))))))) + (defun expt-derive-type-aux (x y same-arg) (declare (ignore same-arg)) (cond ((or (not (numeric-type-real-p x)) (not (numeric-type-real-p y))) ;; Use numeric contagion if either is not real. (numeric-contagion x y)) - ((csubtypep y (specifier-type 'integer)) + ((or (csubtypep y (specifier-type 'integer)) + (integer-float-p (nth-value 1 (type-singleton-p y)))) ;; A real raised to an integer power is well-defined. (merged-interval-expt x y)) ;; A real raised to a non-integral power can be a float or a ;; complex number. - ((or (csubtypep x (specifier-type '(rational 0))) - (csubtypep x (specifier-type '(float ($0d0))))) + ((csubtypep x (specifier-type '(real 0))) ;; But a positive real to any power is well-defined. (merged-interval-expt x y)) ((and (csubtypep x (specifier-type 'rational)) @@ -1009,7 +1070,7 @@ (one-arg-derive-type x #'log-derive-type-aux-1 #'log))) (defun atan-derive-type-aux-1 (y) - (elfun-derive-type-simple y #'atan nil nil (sb-xc:- (sb-xc:/ sb-xc:pi 2)) (sb-xc:/ sb-xc:pi 2))) + (elfun-derive-type-simple y #'atan nil nil (sb-xc:- (sb-xc:/ pi 2)) (sb-xc:/ pi 2))) (defun atan-derive-type-aux-2 (y x same-arg) (declare (ignore same-arg)) @@ -1026,8 +1087,8 @@ (make-numeric-type :class 'float :format format :complexp :real - :low (coerce (sb-xc:- sb-xc:pi) bound-format) - :high (coerce sb-xc:pi bound-format)))) + :low (coerce (sb-xc:- pi) bound-format) + :high (coerce pi bound-format)))) (t ;; The result is a float or a complex number (float-or-complex-float-type result-type))))) @@ -1067,8 +1128,8 @@ (make-numeric-type :class 'float :format format :complexp :real - :low (coerce sb-xc:pi bound-type) - :high (coerce sb-xc:pi bound-type))) + :low (coerce pi bound-type) + :high (coerce pi bound-type))) (t ;; We can't tell. The result is 0 or pi. Use a union ;; type for this. @@ -1081,16 +1142,16 @@ (make-numeric-type :class 'float :format format :complexp :real - :low (coerce sb-xc:pi bound-type) - :high (coerce sb-xc:pi bound-type)))))) + :low (coerce pi bound-type) + :high (coerce pi bound-type)))))) (t ;; We have a complex number. The answer is the range -pi ;; to pi. (-pi is included because we have -0.) (make-numeric-type :class 'float :format format :complexp :real - :low (coerce (sb-xc:- sb-xc:pi) bound-type) - :high (coerce sb-xc:pi bound-type)))))) + :low (coerce (sb-xc:- pi) bound-type) + :high (coerce pi bound-type)))))) (defoptimizer (phase derive-type) ((num)) (one-arg-derive-type num #'phase-derive-type-aux #'phase)) @@ -1227,8 +1288,7 @@ ;; of whether all the operations below are translated by vops. ;; We could be more fine-grained, but it seems reasonable that ;; they be implemented on an all-or-none basis. - #-(vop-named sb-vm::%negate/complex-double-float) - (progn + (unless (vop-existsp :named sb-vm::%negate/complex-double-float) ;; negation (deftransform %negate ((z) ((complex ,type)) *) '(complex (%negate (realpart z)) (%negate (imagpart z)))) @@ -1284,55 +1344,53 @@ ;; Divide two complex numbers. (deftransform / ((x y) ((complex ,type) (complex ,type)) *) - #-(vop-translates sb-vm::swap-complex) - '(let* ((rx (realpart x)) - (ix (imagpart x)) - (ry (realpart y)) - (iy (imagpart y))) - (if (> (abs ry) (abs iy)) - (let* ((r (/ iy ry)) - (dn (+ ry (* r iy)))) - (complex (/ (+ rx (* ix r)) dn) - (/ (- ix (* rx r)) dn))) - (let* ((r (/ ry iy)) - (dn (+ iy (* r ry)))) - (complex (/ (+ (* rx r) ix) dn) - (/ (- (* ix r) rx) dn))))) - #+(vop-translates sb-vm::swap-complex) - `(let* ((cs (conjugate (sb-vm::swap-complex x))) - (ry (realpart y)) - (iy (imagpart y))) - (if (> (abs ry) (abs iy)) - (let* ((r (/ iy ry)) - (dn (+ ry (* r iy)))) - (/ (+ x (* cs r)) dn)) - (let* ((r (/ ry iy)) - (dn (+ iy (* r ry)))) - (/ (+ (* x r) cs) dn))))) + (if (vop-existsp :translate sb-vm::swap-complex) + '(let* ((cs (conjugate (sb-vm::swap-complex x))) + (ry (realpart y)) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (+ ry (* r iy)))) + (/ (+ x (* cs r)) dn)) + (let* ((r (/ ry iy)) + (dn (+ iy (* r ry)))) + (/ (+ (* x r) cs) dn)))) + '(let* ((rx (realpart x)) + (ix (imagpart x)) + (ry (realpart y)) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (+ ry (* r iy)))) + (complex (/ (+ rx (* ix r)) dn) + (/ (- ix (* rx r)) dn))) + (let* ((r (/ ry iy)) + (dn (+ iy (* r ry)))) + (complex (/ (+ (* rx r) ix) dn) + (/ (- (* ix r) rx) dn))))))) ;; Divide a real by a complex. (deftransform / ((x y) (,type (complex ,type)) *) - #-(vop-translates sb-vm::swap-complex) - '(let* ((ry (realpart y)) - (iy (imagpart y))) - (if (> (abs ry) (abs iy)) - (let* ((r (/ iy ry)) - (dn (+ ry (* r iy)))) - (complex (/ x dn) - (/ (- (* x r)) dn))) - (let* ((r (/ ry iy)) - (dn (+ iy (* r ry)))) - (complex (/ (* x r) dn) - (/ (- x) dn))))) - #+(vop-translates sb-vm::swap-complex) - '(let* ((ry (realpart y)) - (iy (imagpart y))) - (if (> (abs ry) (abs iy)) - (let* ((r (/ iy ry)) - (dn (+ ry (* r iy)))) - (/ (complex x (- (* x r))) dn)) - (let* ((r (/ ry iy)) - (dn (+ iy (* r ry)))) - (/ (complex (* x r) (- x)) dn))))) + (if (vop-existsp :translate sb-vm::swap-complex) + '(let* ((ry (realpart y)) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (+ ry (* r iy)))) + (/ (complex x (- (* x r))) dn)) + (let* ((r (/ ry iy)) + (dn (+ iy (* r ry)))) + (/ (complex (* x r) (- x)) dn)))) + '(let* ((ry (realpart y)) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (+ ry (* r iy)))) + (complex (/ x dn) + (/ (- (* x r)) dn))) + (let* ((r (/ ry iy)) + (dn (+ iy (* r ry)))) + (complex (/ (* x r) dn) + (/ (- x) dn))))))) ;; CIS (deftransform cis ((z) ((,type)) *) '(complex (cos z) (sin z))) @@ -1395,7 +1453,7 @@ ;; Derive the bounds if the arg is in [-pi/2, pi/2]. (trig-derive-type-aux arg - (specifier-type `(float ,(sb-xc:- (sb-xc:/ sb-xc:pi 2)) ,(sb-xc:/ sb-xc:pi 2))) + (specifier-type `(float ,(sb-xc:- (sb-xc:/ pi 2)) ,(sb-xc:/ pi 2))) #'sin -1 1)) #'sin)) @@ -1406,7 +1464,7 @@ (lambda (arg) ;; Derive the bounds if the arg is in [0, pi]. (trig-derive-type-aux arg - (specifier-type `(float $0d0 ,sb-xc:pi)) + (specifier-type `(float $0d0 ,pi)) #'cos -1 1 nil)) @@ -1418,8 +1476,8 @@ (lambda (arg) ;; Derive the bounds if the arg is in [-pi/2, pi/2]. (trig-derive-type-aux arg - (specifier-type `(float ,(sb-xc:- (sb-xc:/ sb-xc:pi 2)) - ,(sb-xc:/ sb-xc:pi 2))) + (specifier-type `(float ,(sb-xc:- (sb-xc:/ pi 2)) + ,(sb-xc:/ pi 2))) #'tan nil nil)) #'tan)) @@ -1518,62 +1576,62 @@ (def single-float ()) (def double-float (single-float))) -(defknown %unary-ftruncate (real) float (movable foldable flushable)) -(defknown %unary-ftruncate/single (single-float) single-float - (movable foldable flushable)) -(defknown %unary-ftruncate/double (double-float) double-float - (movable foldable flushable)) - -#-sb-xc-host -(defun %unary-ftruncate/single (x) - (declare (muffle-conditions compiler-note)) - (declare (type single-float x)) - (declare (optimize speed (safety 0))) - (let* ((bits (single-float-bits x)) - (exp (ldb sb-vm:single-float-exponent-byte bits)) - (biased (the single-float-exponent - (- exp sb-vm:single-float-bias)))) - (declare (type (signed-byte 32) bits)) - (cond - ((= exp sb-vm:single-float-normal-exponent-max) x) - ((<= biased 0) (* x $0f0)) - ((>= biased (float-digits x)) x) - (t - (let ((frac-bits (- (float-digits x) biased))) - (setf bits (logandc2 bits (- (ash 1 frac-bits) 1))) - (make-single-float bits)))))) +#-round-float +(progn + (defknown %unary-ftruncate (real) float (movable foldable flushable)) + (defknown %unary-ftruncate/single (single-float) single-float + (movable foldable flushable)) + (defknown %unary-ftruncate/double (double-float) double-float + (movable foldable flushable)) + + (deftransform %unary-ftruncate ((x) (single-float)) + `(cond ((or (typep x '(single-float ($-1f0) ($0f0))) + (eql x $-0f0)) + $-0f0) + ((typep x '(single-float ,(float (- (expt 2 sb-vm:single-float-digits)) $1f0) + ,(float (1- (expt 2 sb-vm:single-float-digits)) $1f0))) + (float (truncate x) $1f0)) + (t + x))) -#-sb-xc-host -(defun %unary-ftruncate/double (x) - (declare (muffle-conditions compiler-note)) - (declare (type double-float x)) - (declare (optimize speed (safety 0))) - (let* ((high (double-float-high-bits x)) - (low (double-float-low-bits x)) - (exp (ldb sb-vm:double-float-exponent-byte high)) - (biased (the double-float-exponent - (- exp sb-vm:double-float-bias)))) - (declare (type (signed-byte 32) high) - (type (unsigned-byte 32) low)) - (cond - ((= exp sb-vm:double-float-normal-exponent-max) x) - ((<= biased 0) (* x $0d0)) - ((>= biased (float-digits x)) x) - (t - (let ((frac-bits (- (float-digits x) biased))) - (cond ((< frac-bits 32) - (setf low (logandc2 low (- (ash 1 frac-bits) 1)))) - (t - (setf low 0) - (setf high (logandc2 high (- (ash 1 (- frac-bits 32)) 1))))) - (make-double-float high low)))))) + #-32-bit + (deftransform %unary-ftruncate ((x) (double-float)) + `(cond ((or (typep x '(double-float ($-1d0) ($0d0))) + (eql x $-0d0)) + $-0d0) + ((typep x '(double-float ,(float (- (expt 2 sb-vm:double-float-digits)) $1d0) + ,(float (1- (expt 2 sb-vm:double-float-digits)) $1d0))) + (float (truncate x) $1d0)) + (t + x))) -(macrolet - ((def (float-type fun) - `(deftransform %unary-ftruncate ((x) (,float-type)) - '(,fun x)))) - (def single-float %unary-ftruncate/single) - (def double-float %unary-ftruncate/double)) + #+(and (not sb-xc-host) 32-bit) + (defun %unary-ftruncate/double (x) + (declare (muffle-conditions compiler-note)) + (declare (type double-float x)) + (declare (optimize speed (safety 0))) + (let* ((high (double-float-high-bits x)) + (low (double-float-low-bits x)) + (exp (ldb sb-vm:double-float-exponent-byte high)) + (biased (the double-float-exponent + (- exp sb-vm:double-float-bias)))) + (declare (type (signed-byte 32) high) + (type (unsigned-byte 32) low)) + (cond + ((= exp sb-vm:double-float-normal-exponent-max) x) + ((<= biased 0) (* x $0d0)) + ((>= biased (float-digits x)) x) + (t + (let ((frac-bits (- (float-digits x) biased))) + (cond ((< frac-bits 32) + (setf low (logandc2 low (- (ash 1 frac-bits) 1)))) + (t + (setf low 0) + (setf high (logandc2 high (- (ash 1 (- frac-bits 32)) 1))))) + (make-double-float high low)))))) + #+32-bit + (deftransform %unary-ftruncate ((x) (double-float)) + `(%unary-ftruncate/double x))) ;;;; TESTS @@ -1585,8 +1643,8 @@ ;;; For 32-bit big-endian machines, the bit patterns were those of subnormals. ;;; So thank goodness for that - it allowed detection of the problem. (defun test-ctype-involving-double-float () - (specifier-type '(double-float #.sb-xc:pi))) -(assert (sb-xc:= (numeric-type-low (test-ctype-involving-double-float)) sb-xc:pi)) + (specifier-type '(double-float #.pi))) +(assert (sb-xc:= (numeric-type-low (test-ctype-involving-double-float)) pi)) ;;; Dummy functions to test that complex number are dumped correctly in genesis. (defun try-folding-complex-single () diff -Nru sbcl-2.0.6/src/compiler/fndb.lisp sbcl-2.1.1/src/compiler/fndb.lisp --- sbcl-2.0.6/src/compiler/fndb.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/fndb.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -37,7 +37,7 @@ (foldable flushable)) ;;; These can be affected by type definitions, so they're not FOLDABLE. -(defknown (sb-xc:upgraded-complex-part-type sb-xc:upgraded-array-element-type) +(defknown (upgraded-complex-part-type upgraded-array-element-type) (type-specifier &optional lexenv-designator) (or list symbol) (unsafely-flushable)) @@ -99,8 +99,10 @@ (or classoid null) ()) (defknown classoid-of (t) classoid (flushable)) (defknown layout-of (t) layout (flushable)) -#+64-bit (defknown layout-depthoid (layout) fixnum (flushable always-translatable)) -(defknown layout-depthoid-gt (layout integer) boolean (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 %structure-is-a (instance t) boolean (foldable flushable)) (defknown copy-structure (structure-object) structure-object (flushable) :derive-type #'result-type-first-arg) @@ -279,7 +281,7 @@ (defknown gcd (&rest integer) unsigned-byte (movable foldable flushable)) -(defknown sb-kernel::fixnum-gcd (fixnum fixnum) (integer 0 #.(1+ sb-xc:most-positive-fixnum)) +(defknown sb-kernel::fixnum-gcd (fixnum fixnum) (integer 0 #.(1+ most-positive-fixnum)) (movable foldable flushable)) (defknown lcm (&rest integer) unsigned-byte @@ -341,8 +343,11 @@ (defknown %multiply-high (word word) word (movable foldable flushable)) +(defknown %signed-multiply-high (sb-vm:signed-word sb-vm:signed-word) sb-vm:signed-word + (movable foldable flushable)) + (defknown (mod rem) (real real) real - (movable foldable flushable)) + (movable foldable flushable)) (defknown (ffloor fceiling fround ftruncate) (real &optional real) (values float real) @@ -562,7 +567,7 @@ (defknown (every notany notevery) (function-designator proper-sequence &rest proper-sequence) boolean (foldable unsafely-flushable call)) -(defknown reduce ((function-designator ((nth-arg 1 :sequence t :key :key) +(defknown reduce ((function-designator ((nth-arg 1 :sequence t :key :key :value :initial-value) (nth-arg 1 :sequence t :key :key))) proper-sequence &rest t &key (:from-end t) (:start (inhibit-flushing index 0)) @@ -726,7 +731,7 @@ (:end (inhibit-flushing sequence-end nil)) (:from-end t) (:key (function-designator ((nth-arg 1 :sequence t))))) - (or (mod #.(1- sb-xc:array-dimension-limit)) null) + (or (mod #.(1- array-dimension-limit)) null) (foldable flushable call)) (defknown (position-if position-if-not) @@ -735,21 +740,21 @@ (:start (inhibit-flushing index 0)) (:end (inhibit-flushing sequence-end nil)) (:key (function-designator ((nth-arg 1 :sequence t))))) - (or (mod #.(1- sb-xc:array-dimension-limit)) null) + (or (mod #.(1- array-dimension-limit)) null) (foldable flushable call)) (defknown (%bit-position/0 %bit-position/1) (simple-bit-vector t index index) - (or (mod #.(1- sb-xc:array-dimension-limit)) null) + (or (mod #.(1- array-dimension-limit)) null) (foldable flushable)) (defknown (%bit-pos-fwd/0 %bit-pos-fwd/1 %bit-pos-rev/0 %bit-pos-rev/1) (simple-bit-vector index index) - (or (mod #.(1- sb-xc:array-dimension-limit)) null) + (or (mod #.(1- array-dimension-limit)) null) (foldable flushable)) (defknown %bit-position (t simple-bit-vector t index index) - (or (mod #.(1- sb-xc:array-dimension-limit)) null) + (or (mod #.(1- array-dimension-limit)) null) (foldable flushable)) (defknown (%bit-pos-fwd %bit-pos-rev) (t simple-bit-vector index index) - (or (mod #.(1- sb-xc:array-dimension-limit)) null) + (or (mod #.(1- array-dimension-limit)) null) (foldable flushable)) (defknown count @@ -887,10 +892,10 @@ (movable flushable)) (defknown %make-list ((integer 0 (#.make-list-limit)) t) list (movable flushable)) -(defknown sb-impl::|List| (&rest t) list (movable flushable foldable)) -(defknown sb-impl::|List*| (t &rest t) t (movable flushable foldable)) -(defknown sb-impl::|Append| (&rest t) t (flushable foldable)) -(defknown sb-impl::|Vector| (&rest t) simple-vector (flushable foldable)) +(defknown sb-impl::|List| (&rest t) list (movable flushable)) +(defknown sb-impl::|List*| (t &rest t) t (movable flushable)) +(defknown sb-impl::|Append| (&rest t) t (movable flushable)) +(defknown sb-impl::|Vector| (&rest t) simple-vector (movable flushable)) ;;; All but last must be of type LIST, but there seems to be no way to ;;; express that in this syntax. @@ -1675,7 +1680,7 @@ &key (:stream stream) (:use-labels t)) null) -(defknown describe (t &optional (or stream (member t nil))) (values)) +(defknown describe (t &optional stream-designator) (values)) (defknown function-lambda-expression (function) (values t boolean t)) (defknown inspect (t) (values)) (defknown room (&optional (member t nil :default)) (values)) @@ -1963,7 +1968,6 @@ (defknown sb-vm::touch-object (t) (values) (always-translatable)) -#+linkage-table (defknown foreign-symbol-dataref-sap (simple-string) system-area-pointer (movable flushable)) @@ -2086,10 +2090,31 @@ (defknown class-name (class) symbol (flushable)) (defknown finalize - (t (function-designator () * :no-function-conversion t) &key (:dont-save t)) + (t (function-designator () *) &key (:dont-save t)) *) +(defknown (sb-impl::%with-standard-io-syntax + sb-impl::%with-rebound-io-syntax + sb-impl::call-with-sane-io-syntax) + (function) *) +(defknown sb-debug::funcall-with-debug-io-syntax (function &rest t) *) +(defknown sb-impl::%print-unreadable-object (t t t &optional function) null) + #+sb-thread -(defknown sb-thread::call-with-recursive-lock (function t t t) *) -#+sb-thread -(defknown sb-thread::call-with-mutex (function t t t t) *) +(progn +(defknown (sb-thread::call-with-mutex sb-thread::call-with-recursive-lock) + (function t t t) *) +(defknown (sb-thread::call-with-system-mutex + sb-thread::call-with-system-mutex/allow-with-interrupts + sb-thread::call-with-system-mutex/without-gcing + sb-thread::call-with-recursive-system-lock) + (function t) *)) + +#+round-float +(progn + (defknown round-double (double-float #1=(member :round :floor :ceiling :truncate)) + double-float + (foldable flushable movable always-translatable)) + + (defknown round-single (single-float #1#) single-float + (foldable flushable movable always-translatable))) diff -Nru sbcl-2.0.6/src/compiler/fopcompile.lisp sbcl-2.1.1/src/compiler/fopcompile.lisp --- sbcl-2.0.6/src/compiler/fopcompile.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/fopcompile.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -258,12 +258,22 @@ (defun dumpable-leaflike-p (obj) (or (sb-xc:typep obj '(or symbol number character unboxed-array debug-name-marker + system-area-pointer #+sb-simd-pack simd-pack #+sb-simd-pack-256 simd-pack-256)) + ;; 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))) ;; 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))) - (sb-fasl:dumpable-layout-p obj))) + ;; FIXME: The target compiler wants to dump NAMED-TYPE instances, + ;; or maybe it doesn't, but we're forgetting to OPAQUELY-QUOTE them. + ;; For the moment I've worked around this with a backward-compatibility + ;; hack in FIND-CONSTANT which causes anonymous uses of # + ;; to be dumped as *UNIVERSAL-TYPE*. + ;; #+sb-xc (named-type-p obj) + )) ;;; Check that a literal form is fopcompilable. It would not be, for example, ;;; when the form contains structures with funny MAKE-LOAD-FORMS. diff -Nru sbcl-2.0.6/src/compiler/fun-info.lisp sbcl-2.1.1/src/compiler/fun-info.lisp --- sbcl-2.0.6/src/compiler/fun-info.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/fun-info.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -87,6 +87,8 @@ ;; as a consistency checking mechanism inside the compiler during IR2 ;; transformation. always-translatable + ;; Function's funarg can safely skip its argument count check. + callee-omit-arg-count-check ;; If a function is called with two arguments and the first one is a ;; constant, then the arguments will be swapped. commutative) diff -Nru sbcl-2.0.6/src/compiler/generic/early-objdef.lisp sbcl-2.1.1/src/compiler/generic/early-objdef.lisp --- sbcl-2.0.6/src/compiler/generic/early-objdef.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/early-objdef.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -109,8 +109,8 @@ ;; 8 is the number of words to reserve at the beginning of static space ;; prior to the words of NIL. ;; If you change this, then also change MAKE-NIL-DESCRIPTOR in genesis. - #+(and (not x86-64) gencgc (not sb-thread)) (ash 8 word-shift) - #+x86-64 #x100 + #+(and gencgc (not sb-thread) (not 64-bit)) (ash 8 word-shift) + #+64-bit #x100 (* 2 n-word-bytes) list-pointer-lowtag)) @@ -160,7 +160,7 @@ ;;; ;;; * SIMPLE-ARRAY-* = (SIMPLE-ARRAY * (*)) ;;; -;;; * SIMPLE-ARRAY-NIL + SIMPLE-BASE-STRING = SIMPLE-STRING +;;; * SIMPLE-CHARACTER-STRING + SIMPLE-BASE-STRING = SIMPLE-STRING ;;; ;;; * SIMPLE-ARRAY + COMPLEX-ARRAYOID = (SATISFIES ARRAY-HEADER-P) ;;; @@ -180,7 +180,6 @@ ;;; At present on 64-bit target with unicode we have: ;;; (logcount (logxor complex-character-string-widetag simple-character-string-widetag)) = 2 ;;; (logcount (logxor complex-base-string-widetag simple-base-string-widetag)) = 2 -;;; (logcount (logxor complex-vector-nil-widetag simple-array-nil-widetag)) = 3 ;;; (logcount (logxor complex-bit-vector-widetag simple-bit-vector-widetag)) = 1 ;;; and we have one winner. The situation is slightly different for 32-bit. @@ -199,7 +198,7 @@ ;; SIMPLE-VECTOR means the latter doesn't make it right for SBCL internals. (defconstant widetag-spacing 4) -#+x86-64 (defconstant unbound-marker-widetag 9) +#+64-bit (defconstant unbound-marker-widetag 9) (eval-when (:compile-toplevel :load-toplevel :execute) (defenum (;; The first widetag must be greater than SB-VM:LOWTAG-LIMIT ;; otherwise code in generic/early-type-vops will suffer @@ -233,8 +232,8 @@ value-cell-widetag ; 3E 45 3E 45 character-widetag ; 42 49 42 49 sap-widetag ; 46 4D 46 4D - #-x86-64 unbound-marker-widetag ; 4A 51 4A 51 - #+x86-64 unused00-widetag + #-64-bit unbound-marker-widetag ; 4A 51 4A 51 + #+64-bit unused00-widetag weak-pointer-widetag ; 4E 55 4E 55 instance-widetag ; 52 59 52 59 fdefn-widetag ; 56 5D 56 5D @@ -253,76 +252,69 @@ #-64-bit unused09-widetag ; 7E 7E simple-array-widetag ; 82 81 82 81 - simple-array-unsigned-byte-2-widetag ; 86 85 86 85 - simple-array-unsigned-byte-4-widetag ; 8A 89 8A 89 - simple-array-unsigned-byte-7-widetag ; 8E 8D 8E 8D - simple-array-unsigned-byte-8-widetag ; 92 91 92 91 - simple-array-unsigned-byte-15-widetag ; 96 95 96 95 - simple-array-unsigned-byte-16-widetag ; 9A 99 9A 99 + simple-vector-widetag ; + simple-bit-vector-widetag ; + simple-array-unsigned-byte-2-widetag ; + simple-array-unsigned-byte-4-widetag ; + simple-array-unsigned-byte-7-widetag ; + simple-array-unsigned-byte-8-widetag ; + simple-array-unsigned-byte-15-widetag ; + simple-array-unsigned-byte-16-widetag ; #-64-bit - simple-array-unsigned-fixnum-widetag ; 9E A5 9E A5 - simple-array-unsigned-byte-31-widetag ; A2 9D A2 9D - simple-array-unsigned-byte-32-widetag ; A6 A1 A6 A1 + simple-array-unsigned-fixnum-widetag ; + simple-array-unsigned-byte-31-widetag ; + simple-array-unsigned-byte-32-widetag ; #+64-bit - simple-array-unsigned-fixnum-widetag ; 9E A5 9E A5 + simple-array-unsigned-fixnum-widetag ; #+64-bit - simple-array-unsigned-byte-63-widetag ; A9 A9 + simple-array-unsigned-byte-63-widetag ; #+64-bit - simple-array-unsigned-byte-64-widetag ; AD AD - simple-array-signed-byte-8-widetag ; AA B1 AA B1 - simple-array-signed-byte-16-widetag ; AE B5 AE B5 + simple-array-unsigned-byte-64-widetag ; + simple-array-signed-byte-8-widetag ; + simple-array-signed-byte-16-widetag ; #-64-bit - simple-array-fixnum-widetag ; B2 BD B2 BD - simple-array-signed-byte-32-widetag ; B6 B9 B6 B9 + simple-array-fixnum-widetag ; + simple-array-signed-byte-32-widetag ; #+64-bit - simple-array-fixnum-widetag ; B2 BD B2 BD + simple-array-fixnum-widetag ; #+64-bit - simple-array-signed-byte-64-widetag ; C1 C1 - simple-array-single-float-widetag ; BA C5 BA C5 - simple-array-double-float-widetag ; BE C9 BE C9 - simple-array-complex-single-float-widetag ; C2 CD C2 CD - simple-array-complex-double-float-widetag ; C6 D1 C6 D1 - simple-bit-vector-widetag ; CA D5 CA D5 - simple-vector-widetag ; CE D9 CE D9 - - ;; Strings - simple-array-nil-widetag ; D2 DD D2 DD - simple-base-string-widetag ; D6 E1 D6 E1 - #+sb-unicode - simple-character-string-widetag ; DA E5 - #+sb-unicode - complex-character-string-widetag ; DE E9 - complex-base-string-widetag ; E2 ED DA E5 - complex-vector-nil-widetag ; E6 F1 DE E9 - - complex-bit-vector-widetag ; EA F5 E2 ED - complex-vector-widetag ; EE F9 E6 F1 - complex-array-widetag ; F2 FD EA F5 + simple-array-signed-byte-64-widetag ; + simple-array-single-float-widetag ; + simple-array-double-float-widetag ; + 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 + ;; From here down commence the non-simple array types | + complex-base-string-widetag ; DE E9 DA E5 | + #+sb-unicode ; | + complex-character-string-widetag ; E2 ED / + + complex-bit-vector-widetag ; E6 F1 DE E9 + complex-vector-widetag ; EA F5 E2 ED + complex-array-widetag ; EE F9 E6 F1 + unused-array-widetag ; F2 FD EA F5 )) (defconstant-eqx +function-widetags+ '#.(list funcallable-instance-widetag simple-fun-widetag closure-widetag) #'equal) -;;; the different vector subtypes, can be ORed together. -;;; N.B.: These are not "types" in the lisp sense. -;; Weak vectors that are NOT hash-table backing vectors use this bit to track -;; whether we've already recorded the vector for deferred scavenging. -;; Hash-tables use an entirely different mechanism. Flag bit used only in C. -(defconstant vector-weak-visited-subtype 8) -;; All hash-table backing vectors are marked with this bit. -;; Essentially it informs GC that the vector has a high-water mark. -(defconstant vector-hashing-subtype 4) -;; Set if hash-table contains address-sensitive keys and possibly -;; an associated vector of 32-bit hashes. -;; When upsizing a table, both the old and new vector may have this bit set. -(defconstant vector-addr-hashing-subtype 2) -;; Set if vector is weak. Weak hash tables have both this AND the hashing bit. -(defconstant vector-weak-subtype 1) +;;; the different vector flags can be ORed together. + +;;; Byte index: 3 2 1 0 +;;; +-----------------------------------+-----------+ +;;; | unused | rank | flags | widetag | +;;; +-----------+-----------+-----------+-----------+ +;;; |<---------- HEADER DATA ---------->| -;;; These next two constants must not occupy the same byte of a -;;; vector header word as the values in the preceding defenum. +(defconstant +array-fill-pointer-p+ #x80) ;; A vector tagged as +VECTOR-SHAREABLE+ is logically readonly, ;; and permitted to be shared with another vector per the CLHS standard @@ -330,7 +322,7 @@ ;; often the print-name of a symbol, or was a literal in source code ;; and loaded from a fasl, or used in a few others situations ;; which warrant sharing. -(defconstant +vector-shareable+ #x100) +(defconstant +vector-shareable+ #x20) ;; A vector tagged as +VECTOR-SHAREABLE-NONSTD+ is logically readonly, ;; and *not* technically permitted by the standard to be shared. @@ -339,7 +331,21 @@ ;; into memory, where the requirement is that the machine code ;; reference "the same" object as appeared in source, but where, ;; nonetheless, opportunities for sharing abound. -(defconstant +vector-shareable-nonstd+ #x200) +(defconstant +vector-shareable-nonstd+ #x10) + +;; Weak vectors that are not hash-table backing vectors use this bit to track +;; whether we've already recorded the vector for deferred scavenging. +;; Hash-tables use an entirely different mechanism. Flag bit used only in C. +(defconstant vector-weak-visited-flag #x08) +;; All hash-table backing vectors are marked with this bit. +;; Essentially it informs GC that the vector has a high-water mark. +(defconstant vector-hashing-flag #x04) +;; Set if hash-table contains address-sensitive keys and possibly +;; an associated vector of 32-bit hashes. +;; When upsizing a table, both the old and new vector may have this bit set. +(defconstant vector-addr-hashing-flag #x02) +;; Set if vector is weak. Weak hash tables have both this AND the hashing bit. +(defconstant vector-weak-flag #x01) ;;; This header bit is set for symbols which were present in the pristine core. ;;; The backend may emit different code when referencing such symbols. @@ -361,7 +367,7 @@ (defglobal function-layout 0)) ; set by genesis #| -;; Run this in the SB-VM or SB-VM package once for each target feature combo. +;; Run this in the SB-VM package once for each target feature combo. (defun rewrite-widetag-comments () (rename-file "src/compiler/generic/early-objdef.lisp" "early-objdef.old") (with-open-file (in "src/compiler/generic/early-objdef.old") diff -Nru sbcl-2.0.6/src/compiler/generic/early-type-vops.lisp sbcl-2.1.1/src/compiler/generic/early-type-vops.lisp --- sbcl-2.0.6/src/compiler/generic/early-type-vops.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/early-type-vops.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -81,8 +81,14 @@ (member lowtag type-codes)) '#.(mapcar #'symbol-value fixnum-lowtags)) t)) - (lowtags (remove lowtag-limit type-codes :test #'<)) - (extended (remove lowtag-limit type-codes :test #'>)) + ;; 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. diff -Nru sbcl-2.0.6/src/compiler/generic/early-vm.lisp sbcl-2.1.1/src/compiler/generic/early-vm.lisp --- sbcl-2.0.6/src/compiler/generic/early-vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/early-vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -61,10 +61,10 @@ ;;; a mask to extract the type from a data block header word (defconstant widetag-mask (1- (ash 1 n-widetag-bits))) -(defconstant sb-xc:most-positive-fixnum +(defconstant most-positive-fixnum (1- (ash 1 n-positive-fixnum-bits)) "the fixnum closest in value to positive infinity") -(defconstant sb-xc:most-negative-fixnum +(defconstant most-negative-fixnum (ash -1 n-positive-fixnum-bits) "the fixnum closest in value to negative infinity") @@ -76,7 +76,7 @@ ;; leaving one bit for a GC mark bit. (ldb (byte (- n-word-bits n-widetag-bits 1) 0) -1)) -(defconstant sb-xc:char-code-limit #-sb-unicode 256 #+sb-unicode #x110000 +(defconstant char-code-limit #-sb-unicode 256 #+sb-unicode #x110000 "the upper exclusive bound on values produced by CHAR-CODE") (defconstant base-char-code-limit #-sb-unicode 256 #+sb-unicode 128) @@ -94,13 +94,13 @@ (defconstant sb-kernel::internal-time-bits 61) (defconstant most-positive-exactly-single-float-fixnum - (min (expt 2 single-float-digits) sb-xc:most-positive-fixnum)) + (min (expt 2 single-float-digits) most-positive-fixnum)) (defconstant most-negative-exactly-single-float-fixnum - (max (- (expt 2 single-float-digits)) sb-xc:most-negative-fixnum)) + (max (- (expt 2 single-float-digits)) most-negative-fixnum)) (defconstant most-positive-exactly-double-float-fixnum - (min (expt 2 double-float-digits) sb-xc:most-positive-fixnum)) + (min (expt 2 double-float-digits) most-positive-fixnum)) (defconstant most-negative-exactly-double-float-fixnum - (max (- (expt 2 double-float-digits)) sb-xc:most-negative-fixnum)) + (max (- (expt 2 double-float-digits)) most-negative-fixnum)) ;;;; Point where continuous area starting at dynamic-space-start bumps into ;;;; next space. Computed for genesis/constants.h, not used in Lisp. @@ -109,7 +109,6 @@ (let ((stop (1- (ash 1 n-word-bits))) (start dynamic-space-start)) (dolist (other-start (list read-only-space-start static-space-start - #+linkage-table linkage-table-space-start)) (declare (notinline <)) ; avoid dead code note (when (< start other-start) @@ -141,31 +140,36 @@ #+sb-xc-host (defun fixnump (x) (and (integerp x) - (<= sb-xc:most-negative-fixnum x sb-xc:most-positive-fixnum))) + (<= most-negative-fixnum x most-positive-fixnum))) -;;; Helper macro for defining FIXUP-CODE-OBJECT so that its body -;;; can be the same between the host and target. -;;; In the target, the byte offset supplied is relative to CODE-INSTRUCTIONS. -;;; Genesis works differently - it adjusts the offset so that it is relative -;;; to the containing gspace since that's what bvref requires. -(defmacro !with-bigvec-or-sap (&body body) - `(macrolet #-sb-xc-host () - #+sb-xc-host - ((code-instructions (code) `(sb-fasl::descriptor-mem ,code)) - (sap-int (sap) - ;; KLUDGE: SAP is a bigvec; it doesn't know its address. - ;; Note that this shadows the uncallable stub function for SAP-INT - ;; that placates the host when compiling 'compiler/*/move.lisp'. - (declare (ignore sap)) - `(locally - (declare (notinline sb-fasl::descriptor-gspace)) ; fwd ref - (sb-fasl::gspace-byte-address - (sb-fasl::descriptor-gspace code)))) ; use CODE, not SAP - (sap-ref-8 (sap offset) `(sb-fasl::bvref-8 ,sap ,offset)) - (sap-ref-32 (sap offset) `(sb-fasl::bvref-32 ,sap ,offset)) - (sap-ref-64 (sap offset) `(sb-fasl::bvref-64 ,sap ,offset)) - (sap-ref-word (sap offset) `(sb-fasl::bvref-word ,sap ,offset))) - ,@body)) +;;; Helper macro for defining FIXUP-CODE-OBJECT with emulation of SAP +;;; accessors so that the host and target can use the same fixup logic. +#+(or x86 x86-64) +(defmacro with-code-instructions ((sap-var code-var) &body body) + #+sb-xc-host + `(macrolet ((self-referential-code-fixup-p (value self) + `(let* ((base (sb-fasl::descriptor-base-address ,self)) + (limit (+ base (1- (code-object-size ,self))))) + (<= base ,value limit))) + (containing-memory-space (code) + `(sb-fasl::descriptor-gspace-name ,code))) + (let ((,sap-var (code-instructions ,code-var))) + ,@body)) + #-sb-xc-host + `(macrolet ((self-referential-code-fixup-p (value self) + ;; Using SAPs keeps all the arithmetic machine-word-sized. + ;; Otherwise it would potentially involve bignums on 32-bit + ;; if code starts at #x20000000 and up. + `(let* ((base (sap+ (int-sap (get-lisp-obj-address ,self)) + (- sb-vm:lowtag-mask))) + (limit (sap+ base (1- (code-object-size ,self)))) + (value-sap (int-sap ,value))) + (and (sap>= value-sap base) (sap<= value-sap limit)))) + (containing-memory-space (code) + (declare (ignore code)) + :dynamic)) + (let ((,sap-var (code-instructions ,code-var))) + ,@body))) #+sb-safepoint ;;; The offset from the fault address reported to the runtime to the diff -Nru sbcl-2.0.6/src/compiler/generic/genesis.lisp sbcl-2.1.1/src/compiler/generic/genesis.lisp --- sbcl-2.0.6/src/compiler/generic/genesis.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/genesis.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -29,7 +29,7 @@ (in-package "SB-FASL") (eval-when (:compile-toplevel :load-toplevel :execute) - (use-package "SB-COREFILE")) ; not SB-COREFILE + (use-package "SB-COREFILE")) (defun round-up (number size) "Round NUMBER up to be an integral multiple of SIZE." @@ -155,19 +155,21 @@ for i from 0 collect `(ash (bvref bigvec ,index) ,(* i 8))))) (defun (setf ,name) (new-value bigvec byte-index) - ;; We don't carefully distinguish between signed and unsigned, - ;; since there's only one setter function per byte size. - (declare (type (or (signed-byte ,n) (unsigned-byte ,n)) - new-value)) + (declare (type (unsigned-byte ,n) new-value)) (setf ,@(loop for index in le-octet-indices for i from 0 append `((bvref bigvec ,index) - (ldb (byte 8 ,(* i 8)) new-value))))))))) + (ldb (byte 8 ,(* i 8)) new-value)))) + new-value))))) (make-bvref-n 8) (make-bvref-n 16) (make-bvref-n 32) (make-bvref-n 64)) +(defun (setf bvref-s32) (newval bv index) + (setf (bvref-32 bv index) (ldb (byte 32 0) (the (signed-byte 32) newval))) + newval) + ;; lispobj-sized word, whatever that may be ;; hopefully nobody ever wants a 128-bit SBCL... (macrolet ((acc (bv index) `(#+64-bit bvref-64 #-64-bit bvref-32 ,bv ,index))) @@ -252,6 +254,28 @@ (/ sb-vm:immobile-card-bytes sb-vm:n-word-bytes)) (t 0)))) + +(defstruct (model-sap (:constructor make-model-sap (address gspace))) + (address 0 :type sb-vm:word) + (gspace nil :type gspace)) +(defun sap-int (x) (model-sap-address x)) +(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-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-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))) ;;;; representation of descriptors @@ -286,32 +310,33 @@ "the lowtag bits for DES" (logand (descriptor-bits des) sb-vm:lowtag-mask)) +(defun descriptor-base-address (des) + (logandc2 (descriptor-bits des) sb-vm:lowtag-mask)) (defmethod print-object ((des descriptor) stream) - (let ((gspace (descriptor-gspace des)) - (bits (descriptor-bits des)) - (lowtag (descriptor-lowtag des))) - (print-unreadable-object (des stream :type t) - (cond ((is-fixnum-lowtag lowtag) - (format stream "for fixnum: ~W" (descriptor-fixnum des))) - ((is-other-immediate-lowtag lowtag) - (format stream - "for other immediate: #X~X, type #b~8,'0B" - (ash bits (- sb-vm:n-widetag-bits)) - (logand bits sb-vm:widetag-mask))) - (t - (format stream - "for pointer: #X~X, lowtag #b~v,'0B, ~A" - (logandc2 bits sb-vm:lowtag-mask) - sb-vm:n-lowtag-bits lowtag - (if gspace (gspace-name gspace) "unknown"))))))) + (print-unreadable-object (des stream :type t) + (let ((lowtag (descriptor-lowtag des)) + (bits (descriptor-bits des))) + (multiple-value-call 'format stream + (cond ((is-fixnum-lowtag lowtag) + (values "for fixnum: ~W" (descriptor-fixnum des))) + ((is-other-immediate-lowtag lowtag) + (values "for other immediate: #X~X, type #b~8,'0B" + (ash bits (- sb-vm:n-widetag-bits)) + (logand bits sb-vm:widetag-mask))) + ((descriptor-gspace des) + (values "for pointer: #X~X, lowtag #b~v,'0B, ~A" + (descriptor-base-address des) + sb-vm:n-lowtag-bits lowtag + (gspace-name (descriptor-gspace des)))) + (t + (format stream "bits: #X~X" bits))))))) ;;; 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-attributes) - (let* ((word-index - (gspace-claim-n-bytes gspace length page-attributes)) +(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 @@ -418,46 +443,32 @@ (assign-page-types page-type word-index n-words) (note-it word-index))))) -;; layoutp is true if we need to force objects on this page to LAYOUT-ALIGN -;; boundaries. This doesn't need to be generalized - everything of type -;; INSTANCE is either on its natural alignment, or the layout alignment. -;; [See doc/internals-notes/compact-instance for why you might want it at all] -;; PAGE-KIND is a heuristic for placement of symbols -;; based on being interned/uninterned/likely-special-variable. -(defun make-page-attributes (layoutp page-kind) - (declare (type (or null (integer 0 3)) page-kind)) - (logior (ash (or page-kind 0) 1) (if layoutp 1 0))) - -(defun gspace-claim-n-bytes (gspace specified-n-bytes page-attributes) - (declare (ignorable page-attributes)) +(defun gspace-claim-n-bytes (gspace specified-n-bytes &optional (page-type :mixed)) + (declare (ignorable page-type)) (let* ((n-bytes (round-up specified-n-bytes (ash 1 sb-vm:n-lowtag-bits))) (n-words (ash n-bytes (- sb-vm:word-shift)))) (aver (evenp n-words)) (cond #+immobile-space ((eq gspace *immobile-fixedobj*) - (aver page-attributes) - ;; An immobile fixedobj page can only have one value of object-spacing - ;; and size for all objects on it. Different widetags are ok. - (let* ((key (cons specified-n-bytes page-attributes)) - (found (cdr (assoc key *immobile-space-map* :test 'equal))) - (page-n-words (/ sb-vm:immobile-card-bytes sb-vm:n-word-bytes))) + ;; There can be at most 1 page in progress for each distinct N-WORDS. + ;; Try to find the one which matches. + (let* ((found (cdr (assoc n-words *immobile-space-map*))) + (words-per-page (/ sb-vm:immobile-card-bytes sb-vm:n-word-bytes))) (unless found ; grab one whole GC page from immobile space - (let ((free-word-index - (gspace-claim-n-words gspace page-n-words))) + (let ((free-word-index (gspace-claim-n-words gspace words-per-page))) (setf found (cons 0 free-word-index)) - (push (cons key found) *immobile-space-map*))) + (push (cons n-words found) *immobile-space-map*))) (destructuring-bind (page-word-index . page-base-index) found (let ((next-word (+ page-word-index n-words))) - (if (> next-word (- page-n-words n-words)) - ;; no more objects fit on this page + (if (> next-word (- words-per-page n-words)) + ;; no more objects will fit on this page (setf *immobile-space-map* - (delete key *immobile-space-map* :key 'car :test 'equal)) + (delete n-words *immobile-space-map* :key 'car)) (setf (car found) next-word))) (+ page-word-index page-base-index)))) #+gencgc ((eq gspace *dynamic*) - (dynamic-space-claim-n-words - gspace n-words (if (eq page-attributes :code) :code :mixed))) + (dynamic-space-claim-n-words gspace n-words page-type)) (t (gspace-claim-n-words gspace n-words))))) @@ -470,13 +481,12 @@ (logior bits (ash -1 (1+ sb-vm:n-positive-fixnum-bits))) bits))) -(defun descriptor-word-sized-integer (des) - ;; Extract an (unsigned-byte 32), from either its fixnum or bignum - ;; representation. - (let ((lowtag (descriptor-lowtag des))) - (if (is-fixnum-lowtag lowtag) - (make-random-descriptor (descriptor-fixnum des)) - (read-wordindexed des 1)))) +(defun descriptor-integer (des) + (cond ((is-fixnum-lowtag (descriptor-lowtag des)) + (descriptor-fixnum des)) + ((= (logand (read-bits-wordindexed des 0) sb-vm:widetag-mask) + sb-vm:bignum-widetag) + (bignum-from-core des)))) ;;; common idioms (defun descriptor-mem (des) @@ -520,6 +530,9 @@ (- abs-word-addr (gspace-word-address gspace))) (return (setf (descriptor-gspace des) gspace))))))) +(defun descriptor-gspace-name (des) + (gspace-name (descriptor-intuit-gspace des))) + (defun %fixnum-descriptor-if-possible (num) (and (typep num `(signed-byte ,sb-vm:n-fixnum-bits)) (make-random-descriptor (ash num sb-vm:n-fixnum-tag-bits)))) @@ -652,19 +665,17 @@ ;;; the length. ;;; * Vector objects: There is a header word with the type, then a word for ;;; the length, then the data. -(defun allocate-object (gspace length lowtag &optional layoutp) +(defun allocate-object (gspace length lowtag) "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 - (make-page-attributes layoutp 0))) + (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 - (make-page-attributes nil 0)))) + 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)) @@ -684,8 +695,11 @@ (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 +;;; them out of the core to compare cold layouts for validity. (defstruct (cold-layout (:constructor %make-cold-layout)) - depthoid length bitmap flags inherits descriptor) + id name depthoid length bitmap flags inherits descriptor) ;;; the hosts's representation of LAYOUT-of-LAYOUT (defvar *host-layout-of-layout* (find-layout 'layout)) @@ -700,10 +714,9 @@ ;; 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*) is-layout) +(defun allocate-struct (nwords type &optional (gspace *dynamic*)) ;; Add +1 for the header word when allocating. - (let* ((object (allocate-object gspace (1+ nwords) - sb-vm:instance-pointer-lowtag is-layout)) + (let* ((object (allocate-object gspace (1+ nwords) sb-vm:instance-pointer-lowtag)) (layout (if (symbolp type) (let ((layout (gethash type *cold-layouts*))) @@ -759,21 +772,25 @@ (* sb-vm:vector-data-offset sb-vm:n-word-bytes) 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)) + (declare (fixnum nwords)) + (do ((index 1 (1+ index)) + (remainder int (ash remainder (- sb-vm:n-word-bits)))) + ((> index nwords) + (unless (zerop (integer-length remainder)) + (error "Nonzero remainder after writing ~D using ~D words" int nwords))) + (write-wordindexed/raw descriptor + (+ index offset) + (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))) - (declare (fixnum words)) - (do ((index 1 (1+ index)) - (remainder n (ash remainder (- sb-vm:n-word-bits)))) - ((> index words) - (unless (zerop (integer-length remainder)) - ;; FIXME: Shouldn't this be a fatal error? - (warn "~W words of ~W were written, but ~W bits were left over." - words n remainder))) - (write-wordindexed/raw handle index - (ldb (byte sb-vm:n-word-bits 0) remainder))) + (integer-bits-to-core handle n words) handle)) (defun bignum-from-core (descriptor) @@ -851,8 +868,8 @@ #-64-bit sb-vm:complex-single-float-real-slot (descriptor-word-offset des)) sb-vm:word-shift))) - (setf (bvref-32 (descriptor-mem des) where) (single-float-bits r) - (bvref-32 (descriptor-mem des) (+ where 4)) (single-float-bits i)) + (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* @@ -1002,10 +1019,10 @@ (etypecase host-val (number ;; This case is intended to handle - ;; (DEFCONSTANT SB-XC:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT - ;; SB-XC:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT) ; etc + ;; (DEFCONSTANT LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT + ;; LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT) ; etc ;; Several uses of MOST-POSITIVE-FIXNUM come through here as well - ;; due to (DEFCONSTANT SB-XC:mumble-LIMIT sb-xc:most-positive-fixnum). + ;; due to (DEFCONSTANT mumble-LIMIT most-positive-fixnum). ;; That seems weird but doesn't seem to be a problem. ;; (i.e. why don't we just dump the fixnum?) (number-to-core host-val)) @@ -1027,9 +1044,9 @@ ;;; WHN 19990816] is initializing layout's layout, which must point to ;;; itself. -;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting -;;; mapping -(defvar *cold-layout-names*) +;;; a map from DESCRIPTOR-BITS of cold layouts (as descriptors) +;;; 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*) @@ -1121,14 +1138,47 @@ (defvar *simple-vector-0-descriptor*) (defvar *vacuous-slot-table*) (defvar *cold-layout-gspace* (or #+immobile-space '*immobile-fixedobj* '*dynamic*)) -(declaim (ftype (function (symbol layout-depthoid integer index descriptor descriptor) +(declaim (ftype (function (symbol layout-depthoid integer index integer descriptor) descriptor) make-cold-layout)) + +(defvar *general-layout-uniqueid-counter* ; incremented before use + (ecase sb-kernel::layout-id-type + (signed-byte 127) ; predefined IDs range from -128 to 127 + (unsigned-byte 255))) ; all IDs are unsigned integers +;;; Conditions are numbered from -128 downward, +;;; but only if layout IDs can be negative. +(defvar *condition-layout-uniqueid-counter* -128) ; decremented before use + +(defun choose-layout-id (name conditionp) + (case name + ((t) 1) + (structure-object 2) + (layout 3) + (sb-lockless::list-node 4) + (t (or (cdr (assq name sb-kernel::*popular-structure-types*)) + (ecase sb-kernel::layout-id-type + (unsigned-byte + (incf *general-layout-uniqueid-counter*)) + (signed-byte + (if conditionp + ;; It doesn't really matter what ID is assigned to a CONDITION subtype + ;; because we don't use the IDs for type testing. Nor for standard-object. + ;; But I'd like to a have a quick visual scan of the IDs assigned during + ;; genesis by giving them negative values which can't otherwise occur. + (decf *condition-layout-uniqueid-counter*) + (incf *general-layout-uniqueid-counter*)))))))) (defun make-cold-layout (name depthoid flags length bitmap inherits) - ;; Can't call STRUCT-SIZE in first genesis - no metadata yet - (let ((result (allocate-struct (dd-length (find-defstruct-description 'layout)) - *layout-layout* - (symbol-value *cold-layout-gspace*) t))) + ;; 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)) + (bitmap-words (ceiling (1+ (integer-length bitmap)) sb-vm:n-word-bits)) + (result (allocate-struct (+ fixed-words bitmap-words) + *layout-layout* + (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)) @@ -1144,16 +1194,16 @@ :clos-hash (make-fixnum-descriptor (sb-impl::hash-layout-name name)) :invalid *nil-descriptor* :inherits inherits - :info *nil-descriptor* - :bitmap bitmap - :slot-list *nil-descriptor*) + :%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)) - ;; Assign an empty slot-table. Why this is done only for three + (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. @@ -1163,31 +1213,40 @@ (setq *vacuous-slot-table* (host-constant-to-core '#(1 nil)))))) - (when (and (logtest flags +structure-layout-flag+) (> depthoid 2)) - (loop with dsd-index = (get-dsd-index sb-kernel:layout sb-kernel::ancestor_2) - for i from 2 to (min (1- depthoid) sb-c::layout-inherits-max-optimized-depth) - do (write-wordindexed result - (+ sb-vm:instance-slots-offset dsd-index) - (cold-svref inherits i)) - (incf dsd-index))) - - (setf (gethash (descriptor-bits result) *cold-layout-names*) name - (gethash name *cold-layouts*) (%make-cold-layout :depthoid depthoid - :length length - :bitmap bitmap - :flags flags - :inherits inherits - :descriptor result)) + (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) + + (let ((proxy (%make-cold-layout :id this-id + :name name + :depthoid depthoid + :length length + :bitmap bitmap + :flags flags + :inherits inherits + :descriptor result))) + ;; Make two different ways to look up the proxy object - + ;; by name or by descriptor-bits. + (setf (gethash (descriptor-bits result) *cold-layout-by-addr*) proxy + (gethash name *cold-layouts*) proxy)) result)) (defun predicate-for-specializer (type-name) (let ((classoid (find-classoid type-name nil))) (typecase classoid (structure-classoid - (cond ((dd-predicate-name (layout-info (classoid-layout classoid)))) - ;; All early INSTANCEs should be STRUCTURE-OBJECTs. - ;; Except: see hack for CONDITIONs in CLASS-DEPTHOID. - ((eq type-name 'structure-object) '%instancep))) + (dd-predicate-name (layout-info (classoid-layout classoid)))) (built-in-classoid (let ((translation (specifier-type type-name))) (aver (not (contains-unknown-type-p translation))) @@ -1195,13 +1254,9 @@ :test #'type= :key #'car))) (cond (predicate (cdr predicate)) ((eq type-name 'stream) 'streamp) + ((eq type-name 'pathname) 'pathnamep) ((eq type-name 't) 'constantly-t) - (t (error "No predicate for builtin: ~S" type-name)))))) - (null - #+nil (format t "~&; PREDICATE-FOR-SPECIALIZER: no classoid for ~S~%" - type-name) - (case type-name - (condition 'sb-kernel::!condition-p)))))) + (t (error "No predicate for builtin: ~S" type-name))))))))) ;;; Convert SPECIFIER (equivalently OBJ) to its representation as a ctype ;;; in the cold core. @@ -1213,6 +1268,7 @@ (let* ((cell (cold-find-classoid-cell (classoid-name obj) :create t)) (cold-classoid (read-slot cell (find-layout 'sb-kernel::classoid-cell) :classoid))) + (aver (not (sb-kernel::undefined-classoid-p obj))) (unless (cold-null cold-classoid) (return-from ctype-to-core cold-classoid))) ;; CTYPEs can't be TYPE=-hashed, but specifiers can be EQUAL-hashed. @@ -1286,6 +1342,8 @@ (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. @@ -1296,7 +1354,7 @@ (layout-depthoid warm-layout) (layout-flags warm-layout) (layout-length warm-layout) - (number-to-core (layout-bitmap warm-layout)) + (layout-bitmap warm-layout) (vector-in-core inherits))))) (let* ((t-layout (chill-layout 't)) (s-o-layout (chill-layout 'structure-object t-layout))) @@ -1309,7 +1367,8 @@ (let* ((sequence (chill-layout 'sequence t-layout)) (list (chill-layout 'list t-layout sequence)) (symbol (chill-layout 'symbol t-layout))) - (chill-layout 'null t-layout sequence list symbol))))) + (chill-layout 'null t-layout sequence list symbol)) + (chill-layout 'stream t-layout)))) ;;;; interning symbols in the cold image @@ -1546,7 +1605,7 @@ (allocate-vector #-64-bit sb-vm:simple-array-signed-byte-32-widetag #+64-bit sb-vm:simple-array-signed-byte-64-widetag 6 6 *static*) - #+x86-64 (setf (gspace-free-word-index *static*) (/ 256 sb-vm:n-word-bytes)) + #+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)) (nil-val (make-descriptor (+ (descriptor-bits des) (* 2 sb-vm:n-word-bytes) @@ -1623,7 +1682,7 @@ ;; Assign TLS indices of C interface symbols #+sb-thread (progn - (dolist (binding sb-vm::!per-thread-c-interface-symbols) + (dolist (binding sb-vm::per-thread-c-interface-symbols) (ensure-symbol-tls-index (car (ensure-list binding)))) ;; Assign other known TLS indices (dolist (pair tls-init) @@ -1707,7 +1766,11 @@ (cold-cons (cold-intern (car pair)) (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 + ;; we always pre-increment *general-layout-uniqueid-counter* when reading it. + (cold-set 'sb-kernel::*layout-id-generator* + (cold-list (make-fixnum-descriptor (1+ *general-layout-uniqueid-counter*)))) (cold-set 'sb-c::*!initial-parsed-types* (vector-in-core (mapcar (lambda (x) @@ -1938,18 +2001,33 @@ (push stuff (cdr gf)))) (defun attach-classoid-cells-to-symbols (hashtable) - (let ((num (sb-c::meta-info-number (sb-c::meta-info :type :classoid-cell))) - (layout (cold-layout-descriptor - (gethash 'sb-kernel::classoid-cell *cold-layouts*)))) - (when (plusp (hash-table-count *classoid-cells*)) - (aver layout)) - ;; Iteration order is immaterial. The symbols will get sorted later. - (maphash (lambda (symbol cold-classoid-cell) - (setf (gethash symbol hashtable) - (packed-info-insert - (gethash symbol hashtable +nil-packed-infos+) - sb-impl::+no-auxiliary-key+ num cold-classoid-cell))) - *classoid-cells*)) + (when (plusp (hash-table-count *classoid-cells*)) + (aver (cold-layout-descriptor + (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 + (sb-c::meta-info-number (sb-c::meta-info :type :kind)))) + ;; Iteration order is immaterial. The symbols will get sorted later. + (maphash (lambda (symbol cold-classoid-cell) + (let ((packed-info + (packed-info-insert + (gethash symbol hashtable +nil-packed-infos+) + sb-impl::+no-auxiliary-key+ + type-classoid-cell-info cold-classoid-cell))) + ;; an instance classoid won't be returned from %PARSE-TYPE + ;; 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)))) + (setf packed-info + (packed-info-insert + packed-info sb-impl::+no-auxiliary-key+ + type-kind-info (cold-intern :instance)))) + (setf (gethash symbol hashtable) packed-info))) + *classoid-cells*))) hashtable) ;; Create pointer from SYMBOL and/or (SETF SYMBOL) to respective fdefinition @@ -1993,68 +2071,6 @@ (defvar *cold-foreign-symbol-table*) (declaim (type hash-table *cold-foreign-symbol-table*)) -;; Read the sbcl.nm file to find the addresses for foreign-symbols in -;; the C runtime. -#-linkage-table -(defun load-cold-foreign-symbol-table (filename) - (with-open-file (file filename) - (loop for line = (read-line file nil nil) - while line do - ;; UNIX symbol tables might have tabs in them, and tabs are - ;; not in Common Lisp STANDARD-CHAR, so there seems to be no - ;; nice portable way to deal with them within Lisp, alas. - ;; Fortunately, it's easy to use UNIX command line tools like - ;; sed to remove the problem, so it's not too painful for us - ;; to push responsibility for converting tabs to spaces out to - ;; the caller. - ;; - ;; Other non-STANDARD-CHARs are problematic for the same reason. - ;; Make sure that there aren't any.. - (let ((ch (find-if (lambda (char) - (not (typep char 'standard-char))) - line))) - (when ch - (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S" - ch - line))) - (setf line (string-trim '(#\space) line)) - (let ((p1 (position #\space line :from-end nil)) - (p2 (position #\space line :from-end t))) - (if (not (and p1 p2 (< p1 p2))) - ;; KLUDGE: It's too messy to try to understand all - ;; possible output from nm, so we just punt the lines we - ;; don't recognize. We realize that there's some chance - ;; that might get us in trouble someday, so we warn - ;; about it. - (warn "ignoring unrecognized line ~S in ~A" line filename) - (multiple-value-bind (value name) - (if (string= "0x" line :end2 2) - (values (parse-integer line :start 2 :end p1 :radix 16) - (subseq line (1+ p2))) - (values (parse-integer line :end p1 :radix 16) - (subseq line (1+ p2)))) - (multiple-value-bind (old-value found) - (gethash name *cold-foreign-symbol-table*) - (when (and found - (not (= old-value value))) - (warn "redefining ~S from #X~X to #X~X" - name old-value value))) - (setf (gethash name *cold-foreign-symbol-table*) value)))))) - (values)) ;; PROGN - -#-linkage-table -(defun cold-foreign-symbol-address (name) - (declare (ignorable name)) - #+crossbuild-test #xf00fa8 ; any random 4-octet-aligned value should do - #-crossbuild-test - (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*) - (progn - (format *error-output* "~&The foreign symbol table is:~%") - (maphash (lambda (k v) - (format *error-output* "~&~S = #X~8X~%" k v)) - *cold-foreign-symbol-table*) - (error "The foreign symbol ~S is undefined." name)))) - (defvar *cold-assembler-routines*) (defvar *cold-static-call-fixups*) @@ -2069,6 +2085,14 @@ (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))) + ;;; These are fairly straightforward translations of the similarly named accessor ;;; from src/code/simple-fun.lisp (defun code-trailer-ref (code offset) @@ -2126,79 +2150,15 @@ (defun code-jump-table-words (code) (ldb (byte 14 0) (read-bits-wordindexed code (code-header-words code)))) -(declaim (ftype (sfunction (descriptor sb-vm:word sb-vm:word keyword keyword) +(declaim (ftype (sfunction (descriptor sb-vm:word (or sb-vm:word + sb-vm:signed-word) + keyword keyword) descriptor) cold-fixup)) (defun cold-fixup (code-object after-header value kind flavor) - (declare (ignorable flavor)) - (let* ((offset-within-code-object - (+ (code-header-bytes code-object) after-header)) - (gspace-byte-offset (+ (descriptor-byte-offset code-object) - offset-within-code-object))) - #-(or x86 x86-64) - (sb-vm:fixup-code-object code-object gspace-byte-offset value kind flavor) - - #+(or x86 x86-64) - (let* ((gspace-data (descriptor-mem code-object)) - (obj-start-addr (logandc2 (descriptor-bits code-object) sb-vm:lowtag-mask)) - (code-end-addr (+ obj-start-addr (code-object-size code-object))) - (gspace-base (gspace-byte-address (descriptor-gspace code-object))) - (in-dynamic-space - (= (gspace-identifier (descriptor-intuit-gspace code-object)) - dynamic-core-space-id)) - (addr (+ value - (sb-vm::sign-extend (bvref-32 gspace-data gspace-byte-offset) - 32)))) - - (declare (ignorable code-end-addr in-dynamic-space)) - (assert (= obj-start-addr - (+ gspace-base (descriptor-byte-offset code-object)))) - - ;; FIXME: every other backend has the code factored out nicely into - ;; {target}-vm.lisp, but x86 doesn't. Is it really so impossible? - ;; See FIXUP-CODE-OBJECT in x86-vm.lisp and x86-64-vm.lisp. - ;; Except for the use of saps, this is nearly identical. - (when (ecase kind - (:absolute - (setf (bvref-32 gspace-data gspace-byte-offset) - (the (unsigned-byte 32) addr)) - #+x86 - (let ((n-jump-table-words (code-jump-table-words code-object))) - ;; Absolute fixups are recorded if within the object for x86. - (and in-dynamic-space - (< obj-start-addr addr code-end-addr) - ;; Except for an initial sequence of unboxed words - (>= after-header (ash n-jump-table-words sb-vm:word-shift)))) - ;; Absolute fixups on x86-64 do not refer to this code component, - ;; because we have RIP-relative addressing, but references to - ;; other immobile-space objects must be recorded. - ;; FIXME: unfortunately OAOO-violating with x86-64-vm.lisp - #+x86-64 - (member flavor '(:named-call :static-call :layout :immobile-symbol - :symbol-value :assembly-routine :assembly-routine*))) - #+x86-64 - (:absolute64 - (setf (bvref-64 gspace-data gspace-byte-offset) - (the (unsigned-byte 64) addr)) - ;; Never record it. These fixups are used only for jump table entries, - ;; which are automatically adjusted if core relocation happens. - nil) - (:relative ; (used for arguments to X86 relative CALL instruction) - (let ((diff (- addr (+ gspace-base gspace-byte-offset 4)))) ; 4 = size of rel32off - (setf (bvref-32 gspace-data gspace-byte-offset) - ;; 32-bit: use modular arithmetic since the address space is 32 bits - #+x86 (ldb (byte 32 0) diff) - ;; 64-bit: ensure that the fixup actually fits in the size - ;; encodable in the instruction, or we're screwed - #+x86-64 (the (signed-byte 32) diff))) - ;; Relative fixups are recorded if outside of the object. - ;; Except that read-only space contains calls to asm routines, - ;; and we don't record those fixups. - #+x86 (and in-dynamic-space - (not (< obj-start-addr addr code-end-addr))) - #+x86-64 (eq flavor :foreign))) - (push (cons kind after-header) - (gethash (descriptor-bits code-object) *code-fixup-notes*))))) + (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*))) code-object) (defun resolve-static-call-fixups () @@ -2219,7 +2179,6 @@ (:absolute (absolute (cdr item))))) (number-to-core (sb-c:pack-code-fixup-locs (absolute) (relative))))) -#+linkage-table (defun linkage-table-note-symbol (symbol-name datap) "Register a symbol and return its address in proto-linkage-table." (sb-vm::linkage-table-entry-address @@ -2227,21 +2186,9 @@ *cold-foreign-symbol-table* (hash-table-count *cold-foreign-symbol-table*)))) -;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in -;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to -;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in -;;; target-load.lisp refers to. (defun foreign-symbols-to-core () (flet ((to-core (list transducer target-symbol) (cold-set target-symbol (vector-in-core (mapcar transducer list))))) - #-linkage-table - ;; Sort by name - (to-core (sort (%hash-table-alist *cold-foreign-symbol-table*) #'string< :key #'car) - (lambda (symbol) - (cold-cons (set-readonly (base-string-to-core (car symbol))) - (number-to-core (cdr symbol)))) - '*!initial-foreign-symbols*) - #+linkage-table ;; Sort by index into linkage table (to-core (sort (%hash-table-alist *cold-foreign-symbol-table*) #'< :key #'cdr) (lambda (pair &aux (key (car pair)) @@ -2313,30 +2260,35 @@ (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*)) (result (allocate-struct size layout)) - (bitmap (descriptor-fixnum - (read-slot layout *host-layout-of-layout* :bitmap)))) - ;; Raw slots can not possibly work because dump-struct uses - ;; %RAW-INSTANCE-REF/WORD which does not exist in the cross-compiler. - ;; Remove this assertion if that problem is somehow circumvented. - (unless (eql bitmap sb-kernel:+layout-all-tagged+) - (error "Raw slots not working in genesis.")) + (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 (write-wordindexed result - (+ index sb-vm:instance-slots-offset) - (if (logbitp index bitmap) - val - (descriptor-word-sized-integer val)))) + 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)) +(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))))) + (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)) - (bitmap (pop-stack)) + (bitmap-descriptor (pop-stack)) + (bitmap-value (descriptor-integer bitmap-descriptor)) (name (pop-stack)) (existing-layout (gethash name *cold-layouts*))) - (declare (type descriptor bitmap inherits)) + (declare (type descriptor bitmap-descriptor inherits)) (declare (type symbol name)) (setq flags ;; Nothing tests layout-flags at cross-compile time, @@ -2349,6 +2301,12 @@ ;; 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 (when existing-layout (let ((old-flags (cold-layout-flags existing-layout)) @@ -2359,7 +2317,7 @@ (unless (and (= flags old-flags) (= depthoid old-depthoid) (= length old-length) - (= (descriptor-fixnum bitmap) (descriptor-fixnum old-bitmap)) + (= bitmap-value old-bitmap) (eql (cold-vector-len inherits) (cold-vector-len old-inherits)) (dotimes (i (cold-vector-len inherits) t) (unless (descriptor= (cold-svref inherits i) @@ -2369,11 +2327,11 @@ (format t "old=(flags=~d depthoid=~d length=~d bitmap=~d inherits=~s)~%" old-flags old-depthoid old-length old-bitmap old-inherits) (format t "new=(flags=~d depthoid=~d length=~d bitmap=~d inherits=~s)~%" - flags depthoid length (descriptor-fixnum bitmap) inherits) + flags depthoid length bitmap-value 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 inherits)))) + (make-cold-layout name depthoid flags length bitmap-value inherits)))) ;;;; cold fops for loading symbols @@ -2619,16 +2577,18 @@ (define-cold-fop (fop-load-code (header code-size n-fixups)) (let* ((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. (n-boxed-words (ash header -1)) (aligned-n-boxed-words (align-up n-boxed-words sb-c::code-boxed-words-align)) (debug-info (pop-stack)) (des (allocate-cold-descriptor - (or #+immobile-code (and (oddp header) *immobile-varyobj*) + (or #+immobile-code (and immobile *immobile-varyobj*) *dynamic*) (+ (ash aligned-n-boxed-words sb-vm:word-shift) code-size) sb-vm:other-pointer-lowtag :code))) + (declare (ignorable immobile)) (write-code-header-words des aligned-n-boxed-words code-size n-named-calls) (write-wordindexed des sb-vm:code-debug-info-slot debug-info) @@ -2640,8 +2600,10 @@ (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*) 14) jumptable-word))) + (write-wordindexed/raw + des aligned-n-boxed-words + (logior (ash (incf *code-serialno*) (byte-position sb-vm::code-serialno-byte)) + jumptable-word))) (when *show-pre-fixup-code-p* (format *trace-output* "~&LOAD-CODE: ~d header words, ~d code bytes.~%" @@ -2675,10 +2637,7 @@ (write-wordindexed (car place) (cdr place) fun)))) (defun compute-fun (code-object fun-index) - (let* ((code-instructions - (+ (descriptor-bits code-object) - (- sb-vm:other-pointer-lowtag) - (code-header-bytes code-object))) + (let* ((code-instructions (calc-code-insts-address code-object)) (fun (+ code-instructions (%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)) @@ -2763,21 +2722,15 @@ (:asm-routine-nil-offset (- (lookup-assembler-reference sym) sb-vm:nil-value)) (:foreign - (let ((sym (base-string-from-core sym))) - #+linkage-table (linkage-table-note-symbol sym nil) - #-linkage-table (cold-foreign-symbol-address sym))) + (linkage-table-note-symbol (base-string-from-core sym) nil)) (:foreign-dataref - (let ((sym (base-string-from-core sym))) - #+linkage-table (linkage-table-note-symbol sym t) - #-linkage-table - (progn (maphash (lambda (k v) - (format *error-output* "~&~S = #X~8X~%" k v)) - *cold-foreign-symbol-table*) - (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))) + (linkage-table-note-symbol (base-string-from-core sym) t)) (:code-object (descriptor-bits code-obj)) #+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*))) (:immobile-symbol ;; an interned symbol is represented by its host symbol, ;; but an uninterned symbol is a descriptor. @@ -2823,7 +2776,6 @@ (* 32 sb-vm:immobile-card-bytes)))) #-gencgc (check sb-vm:dynamic-0-space-start sb-vm:dynamic-0-space-end :dynamic-0) - #+linkage-table (check sb-vm:linkage-table-space-start sb-vm:linkage-table-space-end :linkage-table)))) ;;;; emitting C header file @@ -2896,7 +2848,7 @@ ;; in the target Lisp but are propagated to C. "SB-COREFILE")) (do-external-symbols (symbol (find-package package-name)) - (when (constantp symbol) + (when (cl:constantp symbol) (let ((name (symbol-name symbol))) (labels ( ;; shared machinery (record (string priority suffix) @@ -2957,6 +2909,7 @@ 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:dsd-raw-type-mask sb-vm:short-header-max-words)) (push (list (c-symbol-name c) -1 ; invent a new priority @@ -3049,7 +3002,12 @@ (sb-xc:byte-position (symbol-value symbol))) (format t "#define ~A_MASK 0x~X /* ~:*~A */~%" (c-symbol-name symbol) - (sb-xc:mask-field (symbol-value symbol) -1)))) + (sb-xc:mask-field (symbol-value symbol) -1))) + ;; find a 1 bit in funcallable-instance-widetag not in instance-widetag + (format t "#define LAYOUT_SELECTOR_BIT ~d~%" + (let ((mask (logandc2 sb-vm:funcallable-instance-widetag sb-vm:instance-widetag))) + (aver (plusp mask)) + (1- (integer-length mask))))) (defun write-regnames-h (stream) (declare (ignorable stream)) @@ -3097,7 +3055,7 @@ (subseq name 0 (- (length name) (length strip)))))) (list-sorted-tags (tail) (loop for symbol being the external-symbols of "SB-VM" - when (and (constantp symbol) + when (and (cl:constantp symbol) (tailwise-equal (string symbol) tail)) collect symbol into tags finally (return (sort tags #'< :key #'symbol-value)))) @@ -3113,6 +3071,7 @@ (write-string "," out)) (terpri out))) (write-line "};" out))) + (format out "#include ~%") ; for NULL (write-tags "static " "-LOWTAG" sb-vm:lowtag-limit 0) ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG ;; ending with the same 2 bits. (#b10) @@ -3153,41 +3112,47 @@ (slots (sb-vm:primitive-object-slots obj)) (lowtag (or (symbol-value (sb-vm:primitive-object-lowtag obj)) 0))) ;; writing primitive object layouts - (format t "#ifndef __ASSEMBLER__~2%") - (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 "struct ~A {~%" c-name) - (when (sb-vm:primitive-object-widetag obj) - (format t " lispobj header;~%")) - (dolist (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))) - (format t "};~%") - (when (member name '(cons vector symbol fdefn)) - (write-cast-operator name c-name lowtag)) - (format t "~%#else /* __ASSEMBLER__ */~2%") - (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%") - (format t " * so they work directly on tagged addresses. */~2%") - (dolist (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))) - (format t "~%#endif /* __ASSEMBLER__ */~2%")) + (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)) + (format t "struct ~A {~%" c-name) + (when (sb-vm:primitive-object-widetag obj) + (format t " lispobj header;~%")) + (dolist (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))) + (format t "};~%") + (when (member name '(cons vector symbol fdefn)) + (write-cast-operator name c-name lowtag))) + (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) + (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)))) + (format t "#ifdef __ASSEMBLER__~2%") + (output-asm) + (format t "~%#else /* __ASSEMBLER__ */~2%") + (format t "#include \"lispobj.h\"~%") + (output-c) + (format t "~%#endif /* __ASSEMBLER__ */~%")))) -(defun write-structure-object (dd *standard-output*) +(defun write-structure-object (dd *standard-output* &optional structname) (flet ((cstring (designator) (c-name (string-downcase designator)))) (format t "#ifndef __ASSEMBLER__~2%") - (format t "struct ~A {~%" (cstring (dd-name dd))) + (format t "#include \"lispobj.h\"~%") + (format t "struct ~A {~%" (or structname (cstring (dd-name dd)))) (format t " lispobj header; // = word_0_~%") ;; "self layout" slots are named '_layout' instead of 'layout' so that ;; classoid's expressly declared layout isn't renamed as a special-case. @@ -3206,7 +3171,10 @@ (rplaca cell name) (rplacd cell name)))) (loop for slot across names - do (format t " lispobj ~A;~@[ // ~A~]~%" (car slot) (cdr slot)))) + do (format t " lispobj ~A;~@[ // ~A~]~%" + ;; reserved word + (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)) @@ -3214,7 +3182,7 @@ (format t "~%#endif /* __ASSEMBLER__ */~2%"))) (defun write-thread-init (stream) - (dolist (binding sb-vm::!per-thread-c-interface-symbols) + (dolist (binding sb-vm::per-thread-c-interface-symbols) (format stream "INITIALIZE_TLS(~A, ~A);~%" (c-symbol-name (if (listp binding) (car binding) binding) "*") (if (listp binding) (second binding))))) @@ -3233,7 +3201,7 @@ (+ sb-vm:nil-value (if symbol (sb-vm:static-symbol-offset symbol) 0))))) #+sb-thread - (dolist (binding sb-vm::!per-thread-c-interface-symbols) + (dolist (binding sb-vm::per-thread-c-interface-symbols) (let* ((symbol (car (ensure-list binding))) (c-symbol (c-symbol-name symbol "*"))) (unless (member symbol sb-vm::+common-static-symbols+) @@ -3312,7 +3280,7 @@ "layouts" "type specifiers" "symbols" - #+linkage-table "linkage table"))) + "linkage table"))) (dotimes (i (length sections)) (format t "~4<~@R~>. ~A~%" (1+ i) (nth i sections)))) (format t "=================~2%") @@ -3378,13 +3346,21 @@ name))) (format t "~%~|~%V. layout names:~2%") + (format t " Bitmap Depth ID Name [Length]~%") (dolist (pair (sort-cold-layouts)) - (let* ((descriptor (cold-layout-descriptor (cdr pair))) + (let* ((proxy (cdr pair)) + (descriptor (cold-layout-descriptor proxy)) (addr (descriptor-bits descriptor))) - (format t "~8,'0X: ~S[~D]~%" - addr (car pair) (cold-layout-length (cdr pair))))) + (format t "~10,'0X: ~8d ~2D ~5D ~S [~D]~%" + addr + (cold-layout-bitmap proxy) + (cold-layout-depthoid proxy) + (cold-layout-id proxy) + (car pair) + (cold-layout-length proxy)))) (format t "~%~|~%VI. parsed type specifiers:~2%") + (format t " [Hash]~%") (mapc (lambda (cell) (format t "~X: [~vx] ~S~%" (descriptor-bits (cdr cell)) @@ -3398,7 +3374,6 @@ (mapc (lambda (cell) (format t "~X: ~S~%" (car cell) (cdr cell))) (sort (%hash-table-alist *cold-symbols*) #'< :key #'car)) - #+linkage-table (progn (format t "~%~|~%VIII. linkage table:~2%") (dolist (entry (sort (sb-int:%hash-table-alist *cold-foreign-symbol-table*) @@ -3666,7 +3641,7 @@ (*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-names* (make-hash-table :test 'eql)) ; addr -> symbol + (*cold-layout-by-addr* (make-hash-table :test 'eql)) ; addr -> cold-layout (*!cold-defsymbols* nil) (*!cold-defuns* nil) ;; '*COLD-METHODS* is never seen in the target, so does not need @@ -3742,7 +3717,7 @@ (layout (gethash name *cold-layouts*))) (aver layout) (write-slots (cold-layout-descriptor layout) *host-layout-of-layout* - :info dd)))) + :%info dd)))) (when verbose (format t "~&; SB-Loader: (~D~@{+~D~}) structs/vars/funs/methods/other~%" (length *known-structure-classoids*) @@ -3829,19 +3804,40 @@ (ensure-directories-exist filename) (with-open-file (stream filename :direction :output :if-exists :supersede) (write-makefile-features stream))) + (write-c-headers c-header-dir-name)))) - (macrolet ((out-to (name &body body) ; write boilerplate and inclusion guard - (let ((headerp (if (and (stringp name) (position #\. name)) nil ".h"))) - `(with-open-file (stream (format nil "~A/~A~@[~A~]" - c-header-dir-name ,name ,headerp) - :direction :output :if-exists :supersede) - (write-boilerplate stream) - ,(when headerp - `(format stream - "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~:*~A~%" - (c-name (string-upcase ,name)))) - ,@body - ,(when headerp `(format stream "#endif~%")))))) +(defun write-c-headers (c-header-dir-name) + (macrolet ((out-to (name &body body) ; write boilerplate and inclusion guard + `(actually-out-to ,name (lambda (stream) ,@body)))) + (flet ((actually-out-to (name lambda) + ;; A file gets a '.inc' extension, not '.h' for either or both + ;; of two reasons: + ;; - if it isn't self-contained, meaning that in order to #include it, + ;; the consumer of it has to know something about which other headers + ;; need to be #included first. + ;; - it is not intended to be directly consumed because any use would + ;; typically need to wrap each slot in some small calculation + ;; such as native_pointer(), but we don't want to embed the wrapper + ;; accessors into the autogenerated header. So there would instead be + ;; a "src/runtime/foo.h" which includes "src/runtime/genesis/foo.inc" + ;; 'thread.h' and 'gc-tables.h' violate the naming convention + ;; by being non-self-contained. + (let* ((extension + (cond ((and (stringp name) (position #\. name)) nil) + (t ".h"))) + (inclusion-guardp + (string= extension ".h"))) + (with-open-file (stream (format nil "~A/~A~@[~A~]" + c-header-dir-name name extension) + :direction :output :if-exists :supersede) + (write-boilerplate stream) + (when inclusion-guardp + (format stream + "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~:*~A~%" + (c-name (string-upcase name)))) + (funcall lambda stream) + (when inclusion-guardp + (format stream "#endif~%")))))) (out-to "config" (write-config-h stream)) (out-to "constants" (write-constants-h stream)) (out-to "regnames" (write-regnames-h stream)) @@ -3858,17 +3854,21 @@ (dolist (obj structs) (format stream "~&#include \"~A.h\"~%" (string-downcase (sb-vm:primitive-object-name obj)))))) - (dolist (class '(classoid defstruct-description hash-table layout package - sb-thread::avlnode + (dolist (class '(defstruct-description defstruct-slot-description + classoid layout 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))) + (out-to "thread-instance" + (write-structure-object (layout-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) (write-boilerplate stream) ; no inclusion guard, it's not a ".h" file (write-thread-init stream)) (out-to "static-symbols" (write-static-symbols stream)) - (out-to "sc-offset" (write-sc+offset-coding stream)))))) + (out-to "sc-offset" (write-sc+offset-coding stream))))) ;;; Invert the action of HOST-CONSTANT-TO-CORE. If STRICTP is given as NIL, ;;; then we can produce a host object even if it is not a faithful rendition. diff -Nru sbcl-2.0.6/src/compiler/generic/interr.lisp sbcl-2.1.1/src/compiler/generic/interr.lisp --- sbcl-2.0.6/src/compiler/generic/interr.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/interr.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -57,7 +57,7 @@ `(simple-array ,(sb-vm:saetp-specifier saetp) (*))))) (remove t sb-vm:*specialized-array-element-type-properties* :key 'sb-vm:saetp-specifier)))) - `(((integer 0 ,sb-xc:array-dimension-limit) + `(((integer 0 ,array-dimension-limit) object-not-array-dimension) ;; Union of all unboxed array specializations, ;; for type-checking the argument to VECTOR-SAP diff -Nru sbcl-2.0.6/src/compiler/generic/late-objdef.lisp sbcl-2.1.1/src/compiler/generic/late-objdef.lisp --- sbcl-2.0.6/src/compiler/generic/late-objdef.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/late-objdef.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -63,8 +63,7 @@ ;; The sizer is short_boxed. (closure ,(or #+(or x86 x86-64) "closure" "short_boxed") "lose" "short_boxed") ;; Like closure, but these can also have a layout pointer in the high header bytes. - (funcallable-instance ,(or #+compact-instance-header "funinstance" "short_boxed") - "lose" "short_boxed") + (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") @@ -85,7 +84,7 @@ #+sb-simd-pack-256 (simd-pack-256 "unboxed") (filler "unboxed") - (simple-array "boxed") + (simple-array "array") (simple-array-unsigned-byte-2 "vector_unsigned_byte_2") (simple-array-unsigned-byte-4 "vector_unsigned_byte_4") (simple-array-unsigned-byte-7 "vector_unsigned_byte_8") @@ -117,16 +116,16 @@ (simple-array-nil "vector_nil") (simple-base-string "base_string") #+sb-unicode (simple-character-string "character_string") - #+sb-unicode (complex-character-string "boxed") - (complex-base-string "boxed") - (complex-vector-nil "boxed") - - (complex-bit-vector "boxed") - (complex-vector "boxed") - (complex-array "boxed")))) + #+sb-unicode (complex-character-string "array") + (complex-base-string "array") + + (complex-bit-vector "array") + (complex-vector "array") + (complex-array "array")))) #+sb-xc-host (defun write-gc-tables (stream) + (format stream "#include \"lispobj.h\"~%") ;; Compute a bitmask of all specialized vector types, ;; not including array headers, for maybe_adjust_large_object(). (let ((min #xff) (bits 0)) @@ -135,14 +134,14 @@ (let ((widetag (saetp-typecode saetp))) (setf min (min widetag min) bits (logior bits (ash 1 (ash widetag -2))))))) - (format stream "static inline boolean specialized_vector_widetag_p(unsigned char widetag) { + (format stream "static inline int specialized_vector_widetag_p(unsigned char widetag) { return widetag>=0x~X && (0x~8,'0XU >> ((widetag-0x80)>>2)) & 1;~%}~%" 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") (setf bits (logior bits (ash 1 (ash (car entry) -2)))))) - (format stream "static inline boolean leaf_obj_widetag_p(unsigned char widetag) {~%") + (format stream "static inline int leaf_obj_widetag_p(unsigned char widetag) {~%") #+64-bit (format stream " return (0x~XLU >> (widetag>>2)) & 1;" bits) #-64-bit (format stream " int bit = widetag>>2; return (bit<32 ? 0x~XU >> bit : 0x~XU >> (bit-32)) & 1;" diff -Nru sbcl-2.0.6/src/compiler/generic/late-type-vops.lisp sbcl-2.1.1/src/compiler/generic/late-type-vops.lisp --- sbcl-2.0.6/src/compiler/generic/late-type-vops.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/late-type-vops.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -74,9 +74,10 @@ 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-64 x86) simple-type-predicate) ;; save a register + #+(or x86) simple-type-predicate) ;; save a register (define-type-vop functionp (fun-pointer-lowtag)) @@ -106,13 +107,14 @@ (define-type-vop complex-double-float-p (complex-double-float-widetag)) -(define-type-vop single-float-p (single-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 simple-array-nil-widetag)) + simple-base-string-widetag)) (macrolet ((define-simple-array-type-vops () @@ -133,7 +135,8 @@ *specialized-array-element-type-properties*)))) (def)) ; simple-rank-1-array-*-p -(define-type-vop characterp (character-widetag)) +(define-type-vop characterp (character-widetag) + #+x86-64 simple-type-predicate) (define-type-vop system-area-pointer-p (sap-widetag)) @@ -155,7 +158,7 @@ (simple-array-widetag #+sb-unicode complex-character-string-widetag complex-base-string-widetag complex-bit-vector-widetag - complex-vector-widetag complex-array-widetag complex-vector-nil-widetag)) + complex-vector-widetag complex-array-widetag)) (define-type-vop simple-array-header-p (simple-array-widetag)) @@ -163,8 +166,7 @@ (define-type-vop stringp (#+sb-unicode simple-character-string-widetag #+sb-unicode complex-character-string-widetag - simple-base-string-widetag complex-base-string-widetag - simple-array-nil-widetag complex-vector-nil-widetag)) + simple-base-string-widetag complex-base-string-widetag)) (define-type-vop base-string-p (simple-base-string-widetag complex-base-string-widetag)) @@ -172,9 +174,6 @@ (define-type-vop bit-vector-p (simple-bit-vector-widetag complex-bit-vector-widetag)) -(define-type-vop vector-nil-p - (simple-array-nil-widetag complex-vector-nil-widetag)) - #+sb-unicode (define-type-vop character-string-p (simple-character-string-widetag complex-character-string-widetag)) @@ -255,8 +254,8 @@ #+sb-simd-pack-256 (define-type-vop simd-pack-256-p (simd-pack-256-widetag)) -#.(when (> unbound-marker-widetag lowtag-mask) - '(define-type-vop unbound-marker-p (unbound-marker-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) diff -Nru sbcl-2.0.6/src/compiler/generic/layout-ids.lisp sbcl-2.1.1/src/compiler/generic/layout-ids.lisp --- sbcl-2.0.6/src/compiler/generic/layout-ids.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/layout-ids.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,240 @@ +;;; This is a semi-machine-generated file + +;;;; 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") + +;;; These are the most commonly occurring structure-object subtypes sorted in +;;; in descending dynamic frequency of occurrence of the typep test of the type. +;;; The list was obtained from a regression run containing a modified +;;; 'structure-is-a' vop which counts executions in the manner of :SB-DYNCOUNT. +;;; Presumably this correlates well with the number of "static" insertions of +;;; each type test also. So it can decrease code size and increase instruction +;;; decode throughput since these all get IDs that encode as imm8 for x86. + +;;; [Some manual editing here was necessary due to not having all the packages +;;; in all build configurations.] +(defparameter *popular-structure-types* (mapcar 'list '( +SB-KERNEL:CTYPE +HASH-TABLE +SB-C::NODE +SB-C::GLOBAL-CONFLICTS +SB-C::FUNCTIONAL +SB-C::LEAF +SB-KERNEL:ANSI-STREAM +SB-C::IR2-BLOCK +SB-RBTREE::RBNODE +SB-C::VALUED-NODE +RANDOM-STATE +CAST +SB-KERNEL::TYPE-CONTEXT +SB-KERNEL:VALUES-TYPE +SB-SYS:FD-STREAM +SB-C::BASIC-COMBINATION +SB-INT:SSET-ELEMENT +SB-C:TN-REF +SB-RBTREE::RED-NODE +SB-KERNEL:ARGS-TYPE +SB-C::VOP +SB-C:STORAGE-CLASS +SB-KERNEL:LEXENV +SB-ASSEM::ANNOTATION +SB-KERNEL:INTERSECTION-TYPE +SB-C:PRIMITIVE-TYPE +SB-RBTREE::BLACK-NODE +#+sb-fasteval SB-INTERPRETER:BASIC-ENV +SB-KERNEL:NUMERIC-TYPE +SB-KERNEL:CLASSOID +SB-KERNEL:UNION-TYPE +SB-C::CONSTRAINT +SB-C::TEMPLATE +SB-ASSEM:LABEL +SB-C::IR2-COMPONENT +SB-C::VOP-INFO +SB-C::IR2-LVAR +SB-IMPL::INFO-HASHTABLE +SB-INT:FORM-TRACKING-STREAM +SB-PRETTY:PRETTY-STREAM +SB-C::CONSET +SB-KERNEL:ARRAY-TYPE +SB-KERNEL:COMPOUND-TYPE +SB-KERNEL:NEGATION-TYPE +SB-REGALLOC::VERTEX +SB-THREAD::AVLNODE +SB-C::ABSTRACT-LEXENV +SB-KERNEL:UNKNOWN-TYPE +SB-KERNEL:CONS-TYPE +SB-C::IR2-PHYSENV +SB-C::BASIC-VAR +SB-KERNEL:FUN-DESIGNATOR-TYPE +SB-PRETTY::QUEUED-OP +SB-C::BLOCK-ANNOTATION +SB-KERNEL:MEMBER-TYPE +SB-C::FUN-INFO +SB-C::COMPILED-DEBUG-FUN +SB-C::LOCATION-INFO +SB-C::TRANSFORM +SB-PRETTY::SECTION-START +SB-KERNEL:NAMED-TYPE +SB-C::CORE-OBJECT +SB-C::EQUALITY-CONSTRAINT +SB-C::ENTRY-INFO +SB-DI::COMPILED-CODE-LOCATION +SB-C::RETURN-INFO +SB-C::SOURCE-INFO +SB-KERNEL:HOST +TWO-WAY-STREAM +SB-ALIEN-INTERNALS:ALIEN-TYPE +SB-DI:FRAME +SB-C::COMPILED-DEBUG-INFO +SB-DI::COMPILED-DEBUG-FUN +SB-C::FUN-TYPE-ANNOTATION +SB-C::CLOOP +SB-DI:DEBUG-FUN +SB-C::COMPILED-DEBUG-FUN-OPTIONAL +SB-C::COMPILED-DEBUG-FUN-MORE +SB-C::COMPILED-DEBUG-FUN-EXTERNAL +SB-ALIEN::ALIEN-TYPE-CLASS +SB-PCL::CACHE +SB-KERNEL::CONDITION-SLOT +SB-PCL::CLASS-PRECEDENCE-DESCRIPTION +SB-KERNEL:FUN-TYPE +SB-C::FILE-INFO +SB-KERNEL:CHARACTER-SET-TYPE +SB-IMPL::PATTERN +SB-C::LVAR-ANNOTATION +SB-DI::COMPILED-DEBUG-BLOCK +SB-C::ARG-INFO +SB-C::COMPILED-DEBUG-FUN-TOPLEVEL +SB-C::COMPILED-DEBUG-FUN-CLEANUP +SB-DI::COMPILED-FRAME +SB-DISASSEM:SEGMENT +SB-ALIEN-INTERNALS:ALIEN-POINTER-TYPE +SB-C::DEBUG-SOURCE +SB-C::DEBUG-INFO +SB-ALIEN-INTERNALS:ALIEN-RECORD-TYPE +SB-C::LVAR-PROPER-SEQUENCE-ANNOTATION +SB-DI:CODE-LOCATION +SB-KERNEL:STRUCTURE-CLASSOID +SB-C::LVAR-FUNCTION-DESIGNATOR-ANNOTATION +SB-LOCKLESS::LINKED-LIST +SB-C::LVAR-MODIFIED-ANNOTATION +SB-DI::BOGUS-DEBUG-FUN +#+sb-simd-pack SB-KERNEL:SIMD-PACK-TYPE +#+sb-simd-pack-256 SB-KERNEL:SIMD-PACK-256-TYPE +#+sb-fasteval SB-INTERPRETER::SEXPR +SB-C::MODULAR-CLASS +SB-DI:DEBUG-BLOCK +SB-C::LVAR-HOOK +SB-KERNEL:HAIRY-TYPE +#+sb-fasteval SB-INTERPRETER::FRAME +SB-C::LOCAL-CALL-CONTEXT +SB-C::IR2-NLX-INFO +SB-C::LVAR-FUNCTION-ANNOTATION +SB-C::DEBUG-NAME-MARKER +SB-C::CORE-DEBUG-SOURCE +SB-REGALLOC::INTERFERENCE-GRAPH +SB-C::RESTART-LOCATION +#+sb-fasteval SB-INTERPRETER::LAMBDA-FRAME +SB-C::LVAR-LAMBDA-VAR-ANNOTATION +SB-KERNEL::UNDEFINED-CLASSOID +SB-ALIEN-INTERNALS:ALIEN-INTEGER-TYPE +SB-C::LVAR-TYPE-ANNOTATION +SB-C:DEFINITION-SOURCE-LOCATION +SB-DI:DEBUG-VAR +SB-DI::COMPILED-DEBUG-VAR +SB-ALIEN-INTERNALS:ALIEN-FUN-TYPE +SB-PCL::DFUN-INFO +TIMER +#+sb-fasteval SB-INTERPRETER::DECL-SCOPE +SB-C::UNDEFINED-WARNING +SB-C::MODULAR-FUN-INFO +SB-KERNEL:DEFSTRUCT-DESCRIPTION +SB-PCL::ACCESSOR-DFUN-INFO +SB-C::COMPILER-ERROR-CONTEXT +SB-C::DEFINITION-SOURCE-LOCATION+PLIST +SB-KERNEL:ALIEN-TYPE-TYPE +SB-KERNEL:DEFSTRUCT-SLOT-DESCRIPTION +SB-VM:PRIMITIVE-OBJECT +SB-PCL::ONE-INDEX-DFUN-INFO +SB-C::DEBUG-FUN +SB-ALIEN::ALIEN-C-STRING-TYPE +SB-DISASSEM:INSTRUCTION +SB-C::APPROXIMATE-KEY-INFO +SB-ALIEN-INTERNALS:ALIEN-RECORD-FIELD +SB-KERNEL:CONSTANT-TYPE +SB-ALIEN-INTERNALS:ALIEN-FLOAT-TYPE +SB-C::APPROXIMATE-FUN-TYPE +SB-ALIEN-INTERNALS:LOCAL-ALIEN-INFO +SB-ALIEN-INTERNALS:ALIEN-ARRAY-TYPE +SB-KERNEL::CONDITION-CLASSOID +SB-IMPL::ENCAPSULATION-INFO +SB-C::VOP-PARSE +SB-ALIEN-INTERNALS:ALIEN-VALUES-TYPE +SB-DISASSEM::SOURCE-FORM-CACHE +SB-IMPL::SHARP-EQUAL-WRAPPER +SB-DISASSEM::LOCATION-GROUP +SB-FASL::CIRCULARITY +SB-LOOP::LOOP-COLLECTOR +SB-IMPL::COMMA +SB-ALIEN-INTERNALS:ALIEN-SINGLE-FLOAT-TYPE +SB-DEBUG::TRACE-INFO +SB-ALIEN-INTERNALS:ALIEN-DOUBLE-FLOAT-TYPE +SB-VM::SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES +SB-DI:BREAKPOINT +SB-KERNEL:LOGICAL-HOST +RESTART +SB-ALIEN-INTERNALS:HEAP-ALIEN-INFO +SB-DI::BREAKPOINT-DATA +SB-PRETTY::PPRINT-DISPATCH-ENTRY +SB-IMPL::EXTERNAL-FORMAT +SB-PCL::METHOD-COMBINATION-INFO +SB-KERNEL::LIST-NODE +SB-ALIEN-INTERNALS:ALIEN-ENUM-TYPE +#+sb-fasteval SB-INTERPRETER::SYMBOL-MACRO-SCOPE +SB-INT:DEPRECATION-INFO +SB-DI::FUN-END-COOKIE +SB-ALIEN::SHARED-OBJECT +))) + +;;; The rationale for using (signed-byte 8) for small IDs on the x86 +;;; is that imm8 operands are sign-extended. +;;; The rationale for using (unsigned-byte 8) for small IDs on ARM +;;; is that imm8 operands are NOT sign-extended. +;;; This condition should probably be x86[-64] and everybody else. +;;; I suspect that nobody else benefits from sign-extended immediates. + +(defconstant layout-id-type + #+(or arm mips) 'unsigned-byte + #-(or arm mips) 'signed-byte) + +;;; There are a few wired IDs: +;;; 1 = T +;;; 2 = STRUCTURE-OBJECT +;;; 3 = LAYOUT +;;; 4 = SB-LOCKLESS::LIST-NODE +(ecase layout-id-type + (unsigned-byte + ;; Assign all the above an (UNSIGNED-BYTE 8) layout-id. + (let ((id 4)) ; pre-increment when using + (dolist (item *popular-structure-types*) + ;; Because of (MAPCAR #'LIST ...) it is ok to modify this list. + (rplacd item (incf id))))) + (signed-byte + ;; Assign all the above a (SIGNED-BYTE 8) layout-id. + ;; There is room for more types that are encodable as one byte. + ;; It might be interesting to figure out a way to allow user code + ;; to avail itself of some of that encoding space. + (let ((id -128)) + (dolist (item *popular-structure-types*) + ;; Because of (MAPCAR #'LIST ...) it is ok to modify this list. + (rplacd item id) + (setq id (if (= id -1) 5 ; hop over the wired IDs + (1+ id))))))) diff -Nru sbcl-2.0.6/src/compiler/generic/objdef.lisp sbcl-2.1.1/src/compiler/generic/objdef.lisp --- sbcl-2.0.6/src/compiler/generic/objdef.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/objdef.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -48,7 +48,7 @@ (define-primitive-object (bignum :lowtag other-pointer-lowtag :widetag bignum-widetag :alloc-trans sb-bignum:%allocate-bignum) - (digits :rest-p t :c-type #-alpha "sword_t" #+alpha "u32")) + (digits :rest-p t :c-type "sword_t")) (define-primitive-object (ratio :type ratio :lowtag other-pointer-lowtag @@ -101,11 +101,6 @@ :ref-known (flushable foldable) :set-trans (setf %array-fill-pointer) :set-known ()) - (fill-pointer-p :type (member t nil) - :ref-trans %array-fill-pointer-p - :ref-known (flushable foldable) - :set-trans (setf %array-fill-pointer-p) - :set-known ()) (elements :type index :ref-trans %array-available-elements :ref-known (flushable foldable) @@ -140,7 +135,7 @@ ;; VECTOR -- see SHRINK-VECTOR. (length :ref-trans sb-c::vector-length :type index) - (data :rest-p t :c-type #-alpha "uword_t" #+alpha "u32")) + (data :rest-p t :c-type "uword_t")) #| Code header representation: @@ -235,7 +230,7 @@ ;; pertain to undefined functions, FINs, and closures. ;; - all others store a native pointer to the function entry address ;; or closure tramp - (raw-addr :c-type #-alpha "char *" #+alpha "u32")) + (raw-addr :c-type "char *")) ;;; a simple function (as opposed to hairier things like closures ;;; which are also subtypes of Common Lisp's FUNCTION type) @@ -283,6 +278,8 @@ :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) ;; 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, @@ -316,7 +313,7 @@ :alloc-trans make-weak-pointer) (value :ref-trans %weak-pointer-value :ref-known (flushable) :init :arg) - (next :c-type #-alpha "struct weak_pointer *" #+alpha "u32")) + (next :c-type "struct weak_pointer *")) ;;;; other non-heap data blocks @@ -325,8 +322,8 @@ symbol) ;; on sb-thread, this is actually a tls-index (define-primitive-object (unwind-block) - (uwp :c-type #-alpha "struct unwind_block *" #+alpha "u32") - (cfp :c-type #-alpha "lispobj *" #+alpha "u32") + (uwp :c-type "struct unwind_block *") + (cfp :c-type "lispobj *") #-(or x86 x86-64) code entry-pc #+(and win32 x86) next-seh-frame @@ -337,8 +334,8 @@ #+unbind-in-unwind current-catch) (define-primitive-object (catch-block) - (uwp :c-type #-alpha "struct unwind_block *" #+alpha "u32") - (cfp :c-type #-alpha "lispobj *" #+alpha "u32") + (uwp :c-type "struct unwind_block *") + (cfp :c-type "lispobj *") #-(or x86 x86-64) code entry-pc #+(and win32 x86) next-seh-frame @@ -346,7 +343,7 @@ #+(and unbind-in-unwind (not c-stack-is-control-stack)) nfp #+(and unbind-in-unwind (not c-stack-is-control-stack)) nsp #+unbind-in-unwind bsp - (previous-catch :c-type #-alpha "struct catch_block *" #+alpha "u32") + (previous-catch :c-type "struct catch_block *") tag) ;;;; symbols @@ -474,18 +471,28 @@ ;;; in c-land. However, we need sight of so many parts of it from Lisp that ;;; it makes sense to define it here anyway, so that the GENESIS machinery ;;; can take care of maintaining Lisp and C versions. -(define-primitive-object (thread :size primitive-thread-object-length) +#.`(define-primitive-object (thread :size primitive-thread-object-length) ;; no_tls_value_marker is borrowed very briefly at thread startup to ;; pass the address of the start routine into new_thread_trampoline. ;; tls[0] = NO_TLS_VALUE_MARKER_WIDETAG because a the tls index slot ;; of a symbol is initialized to zero (no-tls-value-marker) + ;; Technically this slot violates our requirement that the size of the thread ;; primitive object be computable by assuming one word per slot. POSIX says ;; "IEEE Std 1003.1-2001/Cor 2-2004, item XBD/TC2/D6/26 is applied, ;; adding pthread_t to the list of types that are not required to be arithmetic ;; types, thus allowing pthread_t to be defined as a structure." - (os-thread :c-type "os_thread_t") + ;; + ;; 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" + #-(or win32 (not sb-thread)) "pthread_t") ;; Keep this first bunch of slots from binding-stack-pointer through alloc-region ;; near the beginning of the structure so that x86[-64] assembly code @@ -522,6 +529,7 @@ ;; Kept here so that when the thread dies we can release the whole ;; memory we reserved. (os-address :c-type "void *" :pointer t) + (os-kernel-tid) ; the kernel's thread identifier, 32 bits on linux ;; These aren't accessed (much) from Lisp, so don't really care ;; if it takes a 4-byte displacement. @@ -529,32 +537,19 @@ (binding-stack-start :c-type "lispobj *" :pointer t :special *binding-stack-start*) - #+(and sb-thread (not sb-safepoint)) - (state-sem :c-type "os_sem_t *" :pointer t) - #+(and sb-thread (not sb-safepoint)) - (state-not-running-sem :c-type "os_sem_t *" :pointer t) - #+(and sb-thread (not sb-safepoint)) - (state-not-running-waitcount :c-type "int" :length 1) - #+(and sb-thread (not sb-safepoint)) - (state-not-stopped-sem :c-type "os_sem_t *" :pointer t) - #+(and sb-thread (not sb-safepoint)) - (state-not-stopped-waitcount :c-type "int" :length 1) (control-stack-start :c-type "lispobj *" :pointer t :special *control-stack-start*) (control-stack-end :c-type "lispobj *" :pointer t :special *control-stack-end*) - (control-stack-guard-page-protected) - #+win32 (private-events :c-type "struct private_events" :length 2) (this :c-type "struct thread *" :pointer t) (prev :c-type "struct thread *" :pointer t) (next :c-type "struct thread *" :pointer t) - ;; starting, running, suspended, dead - (state :c-type "lispobj") + ;; a struct containing {starting, running, suspended, dead} + ;; and some other state fields. + (state-word :c-type "struct thread_state_word") #+x86 (tls-cookie) ; LDT index #+sb-thread (tls-size) - (interrupt-data :c-type "struct interrupt_data *" - :pointer t) ;; For various reasons related to pseudo-atomic and interrupt ;; 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 @@ -571,21 +566,18 @@ (control-stack-pointer :c-type "lispobj *") #+mach-exception-handler (mach-port-name :c-type "mach_port_name_t") - ;; Context base pointer for running on top of system libraries built using - ;; -fomit-frame-pointer. Currently truly required and implemented only - ;; for (and win32 x86-64), but could be generalized to other platforms if - ;; needed: - #+win32 (carried-base-pointer :c-type "os_context_register_t") - #+sb-safepoint (csp-around-foreign-call :c-type "lispobj *") - #+win32 (synchronous-io-handle-and-flag :c-type "HANDLE" :length 1) - #+(and sb-safepoint-strictly (not win32)) - (sprof-alloc-region :c-type "struct alloc_region" :length 4) ;; 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*) + ,@*thread-trailer-slots* + ;; 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*)) (defconstant code-header-size-shift #+64-bit 32 #-64-bit n-widetag-bits) +(defconstant-eqx code-serialno-byte + #+64-bit (byte 32 32) #-64-bit (byte 18 14) + #'equalp) (declaim (inline code-object-size code-header-words %code-code-size)) #-sb-xc-host (progn @@ -625,6 +617,6 @@ (if (eql (code-header-ref code code-boxed-size-slot) 0) 0 (with-pinned-objects (code) - (ldb (byte 18 14) (sap-ref-word (code-instructions code) 0))))) + (ldb code-serialno-byte (sap-ref-word (code-instructions code) 0))))) ) ; end PROGN diff -Nru sbcl-2.0.6/src/compiler/generic/parms.lisp sbcl-2.1.1/src/compiler/generic/parms.lisp --- sbcl-2.0.6/src/compiler/generic/parms.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/parms.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -152,14 +152,14 @@ sb-unix::signal-handler-callback) #'equal) -;;; (potentially) static symbols that C code must be able to assign to, +;;; (potentially) static symbols that C code must be able to set/get ;;; as contrasted with static for other reasons such as: ;;; - garbage collections roots (namely NIL) ;;; - other symbols that Lisp codegen must hardwire (T) ;;; - static for efficiency of access but need not be ;;; On #+sb-thread builds, these are not static, because access to them ;;; is via the TLS, not the symbol. -(defconstant-eqx !per-thread-c-interface-symbols +(defconstant-eqx per-thread-c-interface-symbols `((*free-interrupt-context-index* 0) (sb-sys:*allow-with-interrupts* t) (sb-sys:*interrupts-enabled* t) @@ -173,6 +173,7 @@ #+sb-thread *stop-for-gc-pending* ;; non-x86oid gencgc object pinning #+(and gencgc (not (or x86 x86-64))) *pinned-objects* + #+gencgc (*gc-pin-code-pages* 0) ;; things needed for non-local-exit (*current-catch-block* 0) (*current-unwind-protect-block* 0) @@ -180,11 +181,11 @@ #'equal) (defconstant-eqx +common-static-symbols+ - `(t + '#.`(t ;; These symbols are accessed from C only through TLS, ;; never the symbol-value slot #-sb-thread ,@(mapcar (lambda (x) (car (ensure-list x))) - !per-thread-c-interface-symbols) + per-thread-c-interface-symbols) ;; NLX variables are thread slots on x86-64 and RISC-V. A static sym is needed ;; for arm64, ppc, and x86 because we haven't implemented TLS index fixups, ;; so must lookup the TLS index given the symbol. @@ -192,14 +193,8 @@ ,@'(*current-catch-block* *current-unwind-protect-block*) - ;; sb-safepoint in addition to accessing this symbol via TLS, - ;; uses the symbol itself as a value. Kinda weird. - #+(and sb-safepoint sb-thread) *in-without-gcing* - #+immobile-space *immobile-freelist* ; not per-thread (yet...) - #+hpux *c-lra* - ;; stack pointers #-sb-thread *binding-stack-start* ; a thread slot if #+sb-thread #-sb-thread *control-stack-start* ; ditto @@ -208,10 +203,11 @@ #-sb-thread *stepping* ;; threading support - #+sb-thread *free-tls-index* + #+sb-thread ,@'(sb-thread::*starting-threads* *free-tls-index*) - ;; dynamic runtime linking support - #+linkage-table +required-foreign-symbols+ + ;; runtime linking of lisp->C calls (regardless of whether + ;; the C function is in a dynamic shared object or not) + +required-foreign-symbols+ ;;; The following symbols aren't strictly required to be static ;;; - they are not accessed from C - but we make them static in order @@ -230,12 +226,27 @@ ;;; Refer to the lengthy comment in 'src/runtime/interrupt.h' about ;;; the choice of this number. Rather than have to two copies ;;; of the comment, please see that file before adjusting this. -(defconstant max-interrupts 1024) +;;; I think most of the need for a ridiculously large value stemmed from +;;; receive-pending-interrupt after a pseudo-atomic code section. +;;; If that trapped into GC, and then ran finalizers in POST-GC (while still +;;; in a signal handler), which consed, which caused the need for another GC, +;;; you'd receive a nested interrupt, as the GC trap was still on the stack +;;; not having returned to "user" code yet. [See example in src/code/final] +;;; +;;; But now that #+sb-thread creates a dedicated finalizer thread, nesting +;;; seems unlikely to occur, because "your" code doesn't get a chance to run again +;;; until after the interrupt returns. And the finalizer thread won't invoke +;;; run-pending-finalizers in post-GC, it will just pick up the next finalizer +;;; in due turn. You could potentially force a nested GC by consing a lot in +;;; a post-GC hook, but if you do that, your hook function is badly behaved +;;; and you should fix it. +(defconstant max-interrupts + #+sb-thread 8 ; reasonable value + #-sb-thread 1024) ; crazy value + ;;; Thread slots accessed at negative indices relative to struct thread. -;;; These slots encroach on the interrupt contexts- the maximum that -;;; can actually be stored is decreased by this amount. -;;; sb-safepoint puts the safepoint page immediately preceding the -;;; thread structure, so this trick doesn't work. +;;; 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)) diff -Nru sbcl-2.0.6/src/compiler/generic/pinned-objects.lisp sbcl-2.1.1/src/compiler/generic/pinned-objects.lisp --- sbcl-2.0.6/src/compiler/generic/pinned-objects.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/pinned-objects.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -61,3 +61,33 @@ #+(and gencgc (or x86 x86-64)) `(dx-let ((.cell. (cons nil nil))) (macrolet ((,name (arg) `(rplaca .cell. ,arg))) ,@body))) + +;;; Allow GC within the body, but pin (for some definition of "pin") all code. +;;; There are two different behaviors: +;;; +;;; - If SPACE is :DYNAMIC, then no code object in the dynamic-space may move or die, +;;; but immobile-space code objects may die, in the absence of any (ambiguous or exact) +;;; reference. This mode of pinning prevents object movement, which only implies +;;; preventing death in as much as those are inextricably the same concept. +;;; +;;; - If SPACE is :IMMOBILE, then the GC is not allowed to do anything that affects the +;;; freelists in the mark-and-sweep code space. This prevents death, and of course +;;; the non-movement is implicit. Dynamic-space code is unnaffected. +;;; The use-case it to provide mutual exclusion of the allocator and collector. +;;; ** THIS MODE IS NOT IMPLEMENTED YET *** +;;; +;;; The two may not be specified simultaneously, however, nesting may occur, and +;;; should behave as expected, taking the union of the requests into account. +;;; e.g. one could imagine that during a backtrace - hence with :DYNAMIC space +;;; code pinned - it might be necessary to JIT-compile a method for PRINT-OBJECT +;;; which might pin :IMMOBILE space code. +;;; +(defmacro with-code-pages-pinned ((space) &body body) + #+cheneygc (declare (ignore space)) + #+gencgc `(let ((*gc-pin-code-pages* + (logior *gc-pin-code-pages* + ,(ecase space + (:dynamic 1) + #+immobile-space (:immobile 2))))) + ,@body) + #+cheneygc `(without-gcing ,@body)) diff -Nru sbcl-2.0.6/src/compiler/generic/primtype.lisp sbcl-2.1.1/src/compiler/generic/primtype.lisp --- sbcl-2.0.6/src/compiler/generic/primtype.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/primtype.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -234,7 +234,7 @@ (integer (cond ((and hi lo) (dolist (spec - `((positive-fixnum 0 ,sb-xc:most-positive-fixnum) + `((positive-fixnum 0 ,most-positive-fixnum) ,@(ecase n-machine-word-bits (32 `((unsigned-byte-31 @@ -246,8 +246,8 @@ 0 ,(1- (ash 1 63))) (unsigned-byte-64 0 ,(1- (ash 1 64)))))) - (fixnum ,sb-xc:most-negative-fixnum - ,sb-xc:most-positive-fixnum) + (fixnum ,most-negative-fixnum + ,most-positive-fixnum) ,(ecase n-machine-word-bits (32 `(signed-byte-32 ,(ash -1 31) @@ -255,8 +255,8 @@ (64 `(signed-byte-64 ,(ash -1 63) ,(1- (ash 1 63)))))) - (if (or (< hi sb-xc:most-negative-fixnum) - (> lo sb-xc:most-positive-fixnum)) + (if (or (< hi most-negative-fixnum) + (> lo most-positive-fixnum)) (part-of bignum) (part-of integer))) (let ((type (car spec)) @@ -266,8 +266,8 @@ (return (values (primitive-type-or-lose type) (and (= lo min) (= hi max)))))))) - ((or (and hi (< hi sb-xc:most-negative-fixnum)) - (and lo (> lo sb-xc:most-positive-fixnum))) + ((or (and hi (< hi most-negative-fixnum)) + (and lo (> lo most-positive-fixnum))) (part-of bignum)) (t (part-of integer)))) @@ -406,6 +406,8 @@ (exactly simd-pack-256-single)) ((member 'double-float eltypes) (exactly simd-pack-256-double))))) + (cons-type + (part-of list)) (built-in-classoid (case (classoid-name type) #+sb-simd-pack @@ -417,8 +419,8 @@ (exactly simd-pack-256-int)) ((complex function system-area-pointer weak-pointer) (values (primitive-type-or-lose (classoid-name type)) t)) - (cons-type - (part-of list)) + ((pathname logical-pathname) + (part-of instance)) (t (any)))) (fun-designator-type diff -Nru sbcl-2.0.6/src/compiler/generic/target-core.lisp sbcl-2.1.1/src/compiler/generic/target-core.lisp --- sbcl-2.0.6/src/compiler/generic/target-core.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/target-core.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -88,6 +88,7 @@ #+sb-thread (:symbol-tls-index (ensure-symbol-tls-index sym)) (: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))) #+immobile-code @@ -108,13 +109,6 @@ (finish-fixups (code-obj preserved-lists) (declare (ignorable code-obj preserved-lists)) - ;; clip to 18 significant bits for serialno regardless of machine word size - (let* ((serialno (ldb (byte 18 0) (atomic-incf sb-fasl::*code-serialno*))) - (insts (code-instructions code-obj)) - (jumptable-word (sap-ref-word insts 0))) - (aver (zerop (ash jumptable-word -14))) - ;; insert serialno - (setf (sap-ref-word insts 0) (logior (ash serialno 14) jumptable-word))) #+(or x86 x86-64) (let ((rel-fixups (elt preserved-lists 1)) (abs-fixups (elt preserved-lists 2)) @@ -245,6 +239,16 @@ ;;; are 0, so the jump table count is 0. ;;; Similar considerations pertain to x86[-64] fixups within the machine code. +(defun assign-code-serialno (code-obj) + (let* ((serialno (ldb (byte (byte-size sb-vm::code-serialno-byte) 0) + (atomic-incf sb-fasl::*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 + (logior (ash serialno (byte-position sb-vm::code-serialno-byte)) + jumptable-word)))) + (defun make-core-component (component segment length fixup-notes object) (declare (type component component) (type segment segment) @@ -276,7 +280,10 @@ ;; 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. - (%byte-blt bytes 0 (code-instructions code-obj) 0 (length bytes))) + (%byte-blt bytes 0 (code-instructions code-obj) 0 (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)) ;; Enforce that the final unboxed data word is published to memory ;; before the debug-info is set. (sb-thread:barrier (:write)) diff -Nru sbcl-2.0.6/src/compiler/generic/type-error.lisp sbcl-2.1.1/src/compiler/generic/type-error.lisp --- sbcl-2.0.6/src/compiler/generic/type-error.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/type-error.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -126,7 +126,6 @@ (def "INVALID-ARG-COUNT" sb-c::%arg-count-error nil nargs) (def "LOCAL-INVALID-ARG-COUNT" sb-c::%local-arg-count-error nil nargs fname) (def "OBJECT-NOT-TYPE" sb-c::%type-check-error t object ptype) - (def "LAYOUT-INVALID" sb-c::%layout-invalid-error nil object layout) (def "ODD-KEY-ARGS" sb-c::%odd-key-args-error nil) (def "UNKNOWN-KEY-ARG" sb-c::%unknown-key-arg-error t key) (def "ECASE-FAILURE" ecase-failure nil value keys) diff -Nru sbcl-2.0.6/src/compiler/generic/utils.lisp sbcl-2.1.1/src/compiler/generic/utils.lisp --- sbcl-2.0.6/src/compiler/generic/utils.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/utils.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -50,13 +50,11 @@ 0)) ;;; the address of the linkage table entry for table index I. -#+linkage-table (defun linkage-table-entry-address (i) (ecase linkage-table-growth-direction (:up (+ (* i linkage-table-entry-size) linkage-table-space-start)) (:down (- linkage-table-space-end (* (1+ i) linkage-table-entry-size))))) -#+linkage-table (defun linkage-table-index-from-address (addr) (ecase linkage-table-growth-direction (:up @@ -217,8 +215,25 @@ instance-length-shift n-widetag-bits)) -(defun compute-object-header (size widetag) - (logior (case widetag - (#.fdefn-widetag 0) - (t (ash (1- size) (length-field-shift widetag)))) - widetag)) +(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- +;;; they store 0 for the rank, which is the correct encoding for 1. +;;; The encoding 1 means 2, encoding 2 means 3, and so on. +;;; Decoding is just an addition and bitwise AND. +(defun encode-array-rank (rank) + (declare (type (unsigned-byte 8) rank)) + (logand (1- rank) array-rank-mask)) + +(defun compute-object-header (nwords widetag) + (let ((array-header-p + (or (= widetag simple-array-widetag) + (>= 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)) + (case widetag + (#.fdefn-widetag 0) + (t (ash (1- nwords) (length-field-shift widetag))))) + widetag))) diff -Nru sbcl-2.0.6/src/compiler/generic/vm-array.lisp sbcl-2.1.1/src/compiler/generic/vm-array.lisp --- sbcl-2.0.6/src/compiler/generic/vm-array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/vm-array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -60,8 +60,7 @@ (apply #'!make-saetp args)) `(;; Erm. Yeah. There aren't a lot of things that make sense ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07 - (nil #:mu 0 simple-array-nil - :complex-typecode #.complex-vector-nil-widetag) + (nil #:mu 0 simple-array-nil) #-sb-unicode (character ,(code-char 0) 8 simple-base-string ;; (SIMPLE-BASE-STRINGs are stored with an extra @@ -181,6 +180,17 @@ :key #'sb-vm:saetp-specifier :test #'equal) (error "No saetp for ~S" element-type))) +(defun vector-n-data-octets (vector saetp) + (declare (type (simple-array * (*)) vector)) + (let* ((length (+ (length vector) (saetp-n-pad-elements saetp))) + (n-bits (saetp-n-bits saetp)) + (alignment-pad (floor 7 n-bits))) + ;; This math confuses me. So there's a self-test + ;; against the C code which is known good. + (if (>= n-bits 8) + (* length (ash n-bits -3)) + (ash (* (+ length alignment-pad) n-bits) -3)))) + (in-package "SB-C") (defun find-saetp (element-type) diff -Nru sbcl-2.0.6/src/compiler/generic/vm-fndb.lisp sbcl-2.1.1/src/compiler/generic/vm-fndb.lisp --- sbcl-2.0.6/src/compiler/generic/vm-fndb.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/vm-fndb.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -28,7 +28,7 @@ array-header-p simple-array-header-p sequencep extended-sequence-p - simple-array-p simple-array-nil-p vector-nil-p + simple-array-p simple-array-nil-p simple-array-unsigned-byte-2-p simple-array-unsigned-byte-4-p simple-array-unsigned-byte-7-p simple-array-unsigned-byte-8-p simple-array-unsigned-byte-15-p @@ -74,11 +74,6 @@ non-null-symbol-p) (t) boolean (movable foldable flushable)) -(defknown (fixnump-instance-ref) (instance index) boolean - (flushable always-translatable)) -(defknown (fixnump-car fixnump-cdr) (list) boolean - (flushable always-translatable)) - (defknown #.(loop for (name) in *vector-without-complex-typecode-infos* collect name) (t) boolean (movable foldable flushable)) @@ -171,6 +166,9 @@ (defknown (set-header-bits unset-header-bits) (t (unsigned-byte #.(- sb-vm:n-word-bits sb-vm:n-widetag-bits))) (values) ()) +(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)) @@ -179,7 +177,7 @@ (defknown %array-rank (array) array-rank (flushable)) -#+x86-64 +#+(or x86 x86-64) (defknown (%array-rank= widetag=) (t t) boolean (flushable)) @@ -216,10 +214,9 @@ (defknown %instance-set (instance index t) t (always-translatable) :derive-type #'result-type-last-arg) -(defknown %layout-invalid-error (t layout) nil) -(defknown update-object-layout-or-invalid (t layout) layout) +(defknown update-object-layout (t) layout) -#+(or x86 x86-64 riscv) +#+(or arm64 ppc ppc64 riscv x86 x86-64) (defknown %raw-instance-cas/word (instance index sb-vm:word sb-vm:word) sb-vm:word ()) #+riscv @@ -282,7 +279,7 @@ (flushable movable)) ;;; Allocate an array header with type code TYPE and rank RANK. -(defknown make-array-header ((unsigned-byte 8) (mod #.sb-xc:array-rank-limit)) array +(defknown make-array-header ((unsigned-byte 8) (mod #.array-rank-limit)) array (flushable movable)) (defknown make-array-header* (&rest t) array (flushable movable)) @@ -535,7 +532,7 @@ ;;; 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 alpha hppa ppc64) always-translatable)) + (flushable #-(or sparc ppc64) always-translatable)) (defknown fun-subtype (function) (member . #.sb-vm::+function-widetags+) (flushable)) @@ -616,12 +613,12 @@ (defknown (%asin %atan) (double-float) - (double-float #.(coerce (sb-xc:- (sb-xc:/ sb-xc:pi 2)) 'double-float) - #.(coerce (sb-xc:/ sb-xc:pi 2) 'double-float)) + (double-float #.(coerce (sb-xc:- (sb-xc:/ pi 2)) 'double-float) + #.(coerce (sb-xc:/ pi 2) 'double-float)) (movable foldable flushable)) (defknown (%acos) - (double-float) (double-float $0.0d0 #.(coerce sb-xc:pi 'double-float)) + (double-float) (double-float $0.0d0 #.(coerce pi 'double-float)) (movable foldable flushable)) (defknown (%cosh) @@ -646,8 +643,8 @@ (defknown (%atan2) (double-float double-float) - (double-float #.(coerce (sb-xc:- sb-xc:pi) 'double-float) - #.(coerce sb-xc:pi 'double-float)) + (double-float #.(coerce (sb-xc:- pi) 'double-float) + #.(coerce pi 'double-float)) (movable foldable flushable)) (defknown (%scalb) diff -Nru sbcl-2.0.6/src/compiler/generic/vm-ir2tran.lisp sbcl-2.1.1/src/compiler/generic/vm-ir2tran.lisp --- sbcl-2.0.6/src/compiler/generic/vm-ir2tran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/vm-ir2tran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -73,11 +73,6 @@ res) (move-lvar-result node block locs lvar))) -(eval-when (:compile-toplevel) - ;; Assert correctness of build order. (Need not be exhaustive) - #+(and x86-64 (not (vop-named sb-vm::raw-instance-init/word))) - (error "Expected raw-instance-init vops")) - (defun emit-inits (node block name object lowtag inits args) (let ((unbound-marker-tn nil) (funcallable-instance-tramp-tn nil) @@ -105,7 +100,9 @@ (zero-init-p arg)) (let ((arg-tn (lvar-tn node block arg))) (macrolet - ((make-case (&optional rsd-list) + ((make-case (&aux (rsd-list + (if (vop-existsp :named sb-vm::raw-instance-init/word) + sb-kernel::*raw-slot-data*))) `(ecase raw-type ((t) (vop init-slot node block object arg-tn @@ -115,9 +112,8 @@ `(,(sb-kernel::raw-slot-data-raw-type rsd) (vop ,(sb-kernel::raw-slot-data-init-vop rsd) node block object arg-tn slot))) - (symbol-value rsd-list))))) - (make-case #+(vop-named sb-vm::raw-instance-init/word) - sb-kernel::*raw-slot-data*)))))) + rsd-list)))) + (make-case)))))) (:dd (vop init-slot node block object (emit-constant (sb-kernel::dd-layout-or-lose slot)) @@ -286,6 +282,7 @@ ;;; 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) +;;; WIDETAG may have ORed into it 1 bit for +ARRAY-FILL-POINTER-P+ (defoptimizer (make-array-header* ir2-convert) ((widetag &rest args) node block) (let ((n-args (length args))) ;; Remove the widetag lvar @@ -409,29 +406,26 @@ ;;; 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) - (macrolet ((expand () - `(list* sb-vm:simple-array-widetag - ,@(mapcar (lambda (slot) - (ecase (slot-name slot) - (data 'storage) - (fill-pointer 'n-elements) - (elements 'n-elements) - (fill-pointer-p nil) - (displacement 0) - (displaced-p nil) - (displaced-from nil))) - (butlast (primitive-object-slots - (find 'array *primitive-objects* - :key 'primitive-object-name)))) - dimensions))) - (expand))) + (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)) ;;; 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))) - '(fill-pointer fill-pointer-p elements data + '(fill-pointer elements data displacement displaced-p displaced-from dimensions))) (defun emit-code-page-write-barrier-p (fun-name) diff -Nru sbcl-2.0.6/src/compiler/generic/vm-macs.lisp sbcl-2.1.1/src/compiler/generic/vm-macs.lisp --- sbcl-2.0.6/src/compiler/generic/vm-macs.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/vm-macs.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -88,25 +88,14 @@ pointer &allow-other-keys) (if (atom spec) (list spec) spec) - #-alpha (declare (ignorable pointer)) - #+alpha - (when pointer - ;; Pointer values on ALPHA are 64 bits wide, and - ;; double-word aligned. We may also wish to have such a - ;; mode for other 64-bit hardware outside of any defined - ;; 32-on-64 ABI (which would presumably have 32-bit - ;; pointers in the first place, obviating the alignment - ;; and size requirements). - (unless rest-p - (setf length 2)) - (when (oddp offset) - (incf offset))) (slots `(make-slot ',slot-name ,rest-p ,offset ',special ',(remove-keywords options '(:rest-p :length)))) (let ((offset-sym (symbolicate name "-" slot-name (if rest-p "-OFFSET" "-SLOT")))) - (constants `(defconstant ,offset-sym ,offset)) + (constants + `(progn (defconstant ,offset-sym ,offset) + (setf (info :variable :kind ',offset-sym) :constant))) (when special (specials `(progn (defvar ,special) @@ -194,8 +183,8 @@ (deftype sc-offset () `(integer 0 (,sc-offset-limit))) (defconstant finite-sc-offset-limit - #-(or sparc alpha hppa) 32 - #+(or sparc alpha hppa) 64) + #-(or sparc) 32 + #+(or sparc) 64) (defconstant finite-sc-offset-bits (integer-length (1- finite-sc-offset-limit))) (deftype finite-sc-offset () `(integer 0 (,finite-sc-offset-limit))) diff -Nru sbcl-2.0.6/src/compiler/generic/vm-tran.lisp sbcl-2.1.1/src/compiler/generic/vm-tran.lisp --- sbcl-2.0.6/src/compiler/generic/vm-tran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/vm-tran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -84,6 +84,10 @@ sb-vm:bignum-digits-offset index offset)) +(defun dd-contains-raw-slots-p (dd) + (dolist (dsd (dd-slots dd)) + (unless (eq (dsd-raw-type dsd) t) (return t)))) + (deftransform copy-structure ((instance) * * :result result :node node) (let* ((classoid (lvar-type instance)) (name (and (structure-classoid-p classoid) (classoid-name classoid))) @@ -104,8 +108,8 @@ ;; Also note that VAR-ALLOC can not cope with dynamic-extent except where ;; support has been added (x86oid so far); so requiring an exact type here ;; causes VAR-ALLOC to become FIXED-ALLOC which works on more architectures. - #-c-stack-is-control-stack - (and dd (eql (layout-bitmap layout) sb-kernel:+layout-all-tagged+)) + #-c-stack-is-control-stack (and dd (not (dd-contains-raw-slots-p dd))) + ;; Definitely do this if copying to stack (or (lvar-dynamic-extent result) ;; Or if it's a small fixed number of words @@ -131,19 +135,24 @@ (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)) + (deftransform %instance-length ((instance)) (let ((classoid (lvar-type instance))) (if (and (structure-classoid-p classoid) (sb-kernel::compiler-layout-ready-p (classoid-name classoid)) (eq (classoid-state classoid) :sealed) + (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-info (sb-kernel::compiler-layout-or-lose (classoid-name classoid)))) + (dd-length (layout-dd (sb-kernel::compiler-layout-or-lose (classoid-name classoid)))) (give-up-ir1-transform)))) -;;; The layout is stored in slot 0. -;;; *** These next two transforms should be the only code, aside from -;;; some parts of the C runtime, with knowledge of the layout index. +;;; *** These transforms should be the only code, aside from the C runtime +;;; with knowledge of the layout index. #+compact-instance-header (define-source-transform function-with-layout-p (x) `(functionp ,x)) #-compact-instance-header @@ -153,11 +162,7 @@ (define-source-transform %set-instance-layout (x val) `(%instance-set ,x 0 (the layout ,val))) (define-source-transform function-with-layout-p (x) - `(funcallable-instance-p ,x)) - (define-source-transform %fun-layout (x) - `(truly-the layout (%funcallable-instance-info ,x 0))) - (define-source-transform %set-funcallable-instance-layout (x val) - `(setf (%funcallable-instance-info ,x 0) (the layout ,val)))) + `(funcallable-instance-p ,x))) ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET @@ -384,7 +389,7 @@ ,(if (and (integer-type-p index-type) (numeric-type-low index-type)) `(integer ,(numeric-type-low index-type) - (,sb-xc:array-dimension-limit)) + (,array-dimension-limit)) `index)))))) (deftransform %data-vector-and-index ((%array %index) @@ -688,15 +693,15 @@ (values))) ;;;; transforms for EQL of floating point values -#-(vop-named sb-vm::eql/single-float) +(unless (vop-existsp :named sb-vm::eql/single-float) (deftransform eql ((x y) (single-float single-float)) - '(= (single-float-bits x) (single-float-bits y))) + '(= (single-float-bits x) (single-float-bits y)))) -#-(vop-named sb-vm::eql/double-float) +(unless (vop-existsp :named sb-vm::eql/double-float) (deftransform eql ((x y) (double-float double-float)) #-64-bit '(and (= (double-float-low-bits x) (double-float-low-bits y)) (= (double-float-high-bits x) (double-float-high-bits y))) - #+64-bit '(= (double-float-bits x) (double-float-bits y))) + #+64-bit '(= (double-float-bits x) (double-float-bits y)))) ;;;; modular functions diff -Nru sbcl-2.0.6/src/compiler/generic/vm-type.lisp sbcl-2.1.1/src/compiler/generic/vm-type.lisp --- sbcl-2.0.6/src/compiler/generic/vm-type.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/vm-type.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -56,7 +56,7 @@ (sb-xc:deftype internal-time () `(unsigned-byte ,internal-time-bits)) (defconstant internal-seconds-limit - (floor (ash 1 internal-time-bits) sb-xc:internal-time-units-per-second)) + (floor (ash 1 internal-time-bits) internal-time-units-per-second)) (sb-xc:deftype internal-seconds () `(integer 0 ,internal-seconds-limit)) (sb-xc:deftype bignum-element-type () 'sb-vm:word) @@ -106,7 +106,7 @@ (when (csubtypep eltype stype) (return stype))))) -(defun sb-xc:upgraded-array-element-type (spec &optional environment) +(defun upgraded-array-element-type (spec &optional environment) "Return the element type that will actually be used to implement an array with the specifier :ELEMENT-TYPE Spec." (declare (type lexenv-designator environment) (ignore environment)) @@ -119,7 +119,7 @@ (t (type-specifier (%upgraded-array-element-type type)))))) -(defun sb-xc:upgraded-complex-part-type (spec &optional environment) +(defun upgraded-complex-part-type (spec &optional environment) "Return the element type of the most specialized COMPLEX number type that can hold parts of type SPEC." (declare (type lexenv-designator environment) (ignore environment)) @@ -265,26 +265,48 @@ (push disjunct output))))) (t input))))) ; no change +;;; If TYPE is such that its entirety is represented by 1 widetag +;;; - and that widetag can represent nothing else - then return the widetag. +;;; This is almost but not exactly in correspondence with (SB-C:PRIMITIVE-TYPE X). +;;; But a primitive type can be more specific than the type expressed by a widetag. +;;; e.g. (SB-C:PRIMITIVE-TYPE (SPECIFIER-TYPE '(SIMD-PACK-256 DOUBLE-FLOAT)))) +;;; => # and T +;;; So I guess we don't have a predicate that returns T if and only if a CTYPE +;;; is exactly one and only one of the "most primitive" representations, +;;; hence this. The computation is just a best effort - it's generally OK to +;;; say NIL for anything nontrivial, even if there should be an exact answer. +(defun widetag-for-exactly-type (type) + (cond ((built-in-classoid-p type) + (case (classoid-name type) + (system-area-pointer sb-vm:sap-widetag) + (fdefn sb-vm:fdefn-widetag))) + ((numeric-type-p type) + (cond ((type= type (specifier-type '(complex single-float))) + sb-vm:complex-single-float-widetag) + ((type= type (specifier-type '(complex double-float))) + sb-vm:complex-double-float-widetag) + ((type= type (specifier-type '(complex rational))) + sb-vm:complex-widetag))) + #+sb-simd-pack + ((simd-pack-type-p type) + (cond ((type= type (specifier-type 'simd-pack)) + sb-vm:simd-pack-widetag))) + #+sb-simd-pack-256 + ((simd-pack-256-type-p type) + (cond ((type= type (specifier-type 'simd-pack-256)) + sb-vm:simd-pack-256-widetag))))) + ;; Given TYPES which is a list of types from a union type, decompose into ;; two unions, one being an OR over types representable as widetags ;; with other-pointer-lowtag, and the other being the difference ;; between the input TYPES and the widetags. -;; This is architecture-independent, but unfortunately the needed VOP can't -;; be defined using DEFINE-TYPE-VOPS, so return (VALUES NIL TYPES) for -;; unsupported backends which can't generate an arbitrary call to %TEST-HEADERS. (defun widetags-from-union-type (types) (setq types (simplify-array-unions types t)) - ;; This seems preferable to a reader-conditional in generic code. - ;; There is a unit test that the supported architectures don't generate - ;; excessively large code, so hopefully it'll not get broken. - (let ((info (info :function :info '%other-pointer-subtype-p))) - (unless (and info (sb-c::fun-info-templates info)) - (return-from widetags-from-union-type (values nil types)))) (let (widetags remainder) ;; A little optimization for (OR BIGNUM other). Without this, there would ;; be a two-sided GENERIC-{<,>} test plus whatever test(s) "other" entails. - (let ((neg-bignum (specifier-type `(integer * (,sb-xc:most-negative-fixnum)))) - (pos-bignum (specifier-type `(integer (,sb-xc:most-positive-fixnum) *)))) + (let ((neg-bignum (specifier-type `(integer * (,most-negative-fixnum)))) + (pos-bignum (specifier-type `(integer (,most-positive-fixnum) *)))) (when (and (member neg-bignum types :test #'type=) (member pos-bignum types :test #'type=)) (push sb-vm:bignum-widetag widetags) @@ -293,6 +315,7 @@ (dolist (x types) (let ((adjunct (cond + ((widetag-for-exactly-type x)) ; easiest case ((and (array-type-p x) (equal (array-type-dimensions x) '(*)) (type= (array-type-specialized-element-type x) @@ -314,10 +337,9 @@ (list* (sb-vm:saetp-complex-typecode saetp) (when (eq (array-type-complexp x) :maybe) (list (sb-vm:saetp-typecode saetp))))))))) - ((classoid-p x) + ((built-in-classoid-p x) (case (classoid-name x) - (symbol sb-vm:symbol-widetag) ; plus a hack for nil - (system-area-pointer sb-vm:sap-widetag)))))) + (symbol sb-vm:symbol-widetag)))))) ; plus a hack for nil (cond ((not adjunct) (push x remainder)) ((listp adjunct) (setq widetags (nconc adjunct widetags))) (t (push adjunct widetags))))) diff -Nru sbcl-2.0.6/src/compiler/generic/vm-typetran.lisp sbcl-2.1.1/src/compiler/generic/vm-typetran.lisp --- sbcl-2.0.6/src/compiler/generic/vm-typetran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/generic/vm-typetran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -109,7 +109,6 @@ (define-type-predicate simd-pack-p simd-pack) #+sb-simd-pack-256 (define-type-predicate simd-pack-256-p simd-pack-256) -(define-type-predicate vector-nil-p (vector nil)) (define-type-predicate weak-pointer-p weak-pointer) (define-type-predicate code-component-p code-component) #-(or x86 x86-64) (define-type-predicate lra-p lra) diff -Nru sbcl-2.0.6/src/compiler/globaldb.lisp sbcl-2.1.1/src/compiler/globaldb.lisp --- sbcl-2.0.6/src/compiler/globaldb.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/globaldb.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -198,7 +198,10 @@ ;; 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 (setq *info-environment* (make-info-hashtable))) + #-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 @@ -367,6 +370,10 @@ ;;; For PCL code walker (define-info-type (:function :walker-template) :type-spec (or list symbol)) +;;; The exact type for which this function is the predicate. +;;; Applicable only for symbols in the CL package. +(define-info-type (:function :predicate-for) :type-spec t) + ;;; This is a type specifier such that if an argument X to the function ;;; does not satisfy (TYPEP x ) then the function definitely returns NIL. ;;; When the named function is a predicate that appears in (SATISFIES p) diff -Nru sbcl-2.0.6/src/compiler/hppa/alloc.lisp sbcl-2.1.1/src/compiler/hppa/alloc.lisp --- sbcl-2.0.6/src/compiler/hppa/alloc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/alloc.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,222 +0,0 @@ -;;;; allocation VOPs for the HPPA - -;;;; 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") - -;;;; LIST and LIST* -(define-vop (list-or-list*) - (:args (things :more t)) - (:temporary (:scs (descriptor-reg)) ptr) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) - res) - (:info num) - (:results (result :scs (descriptor-reg))) - (:variant-vars star) - (:policy :safe) - (:node-var node) - (:generator 0 - (cond ((zerop num) - (move null-tn result)) - ((and star (= num 1)) - (move (tn-ref-tn things) result)) - (t - (macrolet - ((store-car (tn list &optional (slot cons-car-slot)) - `(let ((reg (sc-case ,tn - ((any-reg descriptor-reg zero null) ,tn) - (control-stack - (load-stack-tn temp ,tn) - temp)))) - (storew reg ,list ,slot list-pointer-lowtag)))) - (let* ((dx-p (node-stack-allocate-p node)) - (cons-cells (if star (1- num) num)) - (alloc (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (:extra (if dx-p 0 alloc)) - (when dx-p - (align-csp res)) - (set-lowtag list-pointer-lowtag (if dx-p csp-tn alloc-tn) res) - (when dx-p - (if (typep alloc '(signed-byte 14)) - (inst ldo alloc csp-tn csp-tn) - ;; FIXME: We have TEMP available, so can do an - ;; LIDL / LDO / ADD sequence here instead of - ;; punting. - (error "VOP LIST-OR-LIST* can't stack-allocate more than 511 CONSes at once"))) - (move res ptr) - (dotimes (i (1- cons-cells)) - (store-car (tn-ref-tn things) ptr) - (setf things (tn-ref-across things)) - (inst addi (pad-data-block cons-size) ptr ptr) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-lowtag)) - (store-car (tn-ref-tn things) ptr) - (cond (star - (setf things (tn-ref-across things)) - (store-car (tn-ref-tn things) ptr cons-cdr-slot)) - (t - (storew null-tn ptr - cons-cdr-slot list-pointer-lowtag))) - (aver (null (tn-ref-across things))) - (move res result)))))))) - -(define-vop (list list-or-list*) - (:variant nil)) - -(define-vop (list* list-or-list*) - (:variant t)) - - -;;;; Special purpose inline allocators. -;;; ALLOCATE-VECTOR -(define-vop (allocate-vector-on-heap) - (:args (type :scs (unsigned-reg)) - (length :scs (any-reg)) - (words :scs (any-reg))) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum) - (:temporary (:sc non-descriptor-reg) bytes) - (:results (result :scs (descriptor-reg) :from :load)) - (:policy :fast-safe) - (:generator 100 - (inst addi (+ lowtag-mask - (* vector-data-offset n-word-bytes)) words bytes) - (inst dep 0 31 n-lowtag-bits bytes) - (pseudo-atomic () - (set-lowtag other-pointer-lowtag alloc-tn result) - (inst add bytes alloc-tn alloc-tn) - (storew type result 0 other-pointer-lowtag) - (storew length result vector-length-slot other-pointer-lowtag)))) - -(define-vop (allocate-vector-on-stack) - (:args (type :scs (unsigned-reg)) - (length :scs (any-reg)) - (words :scs (any-reg))) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum) - (:temporary (:sc non-descriptor-reg) bytes temp) - (:results (result :scs (descriptor-reg) :from :load)) - (:policy :fast-safe) - (:generator 100 - (inst addi (+ lowtag-mask - (* vector-data-offset n-word-bytes)) words bytes) - (inst dep 0 31 n-lowtag-bits bytes) - ;; FIXME: It would be good to check for stack overflow here. - (pseudo-atomic () - (align-csp temp) - (set-lowtag other-pointer-lowtag csp-tn result) - (inst addi (* vector-data-offset n-word-bytes) csp-tn temp) - (inst add bytes csp-tn csp-tn) - (storew type result 0 other-pointer-lowtag) - (storew length result vector-length-slot other-pointer-lowtag) - (let ((loop (gen-label))) - (emit-label loop) - (inst comb :<> temp csp-tn loop :nullify t) - (inst stwm zero-tn n-word-bytes temp))))) - -(define-vop (make-fdefn) - (:translate make-fdefn) - (:policy :fast-safe) - (:args (name :scs (descriptor-reg) :to :eval)) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg) :from :argument)) - (:generator 37 - (with-fixed-allocation (result nil temp fdefn-widetag fdefn-size nil) - (inst li (make-fixup 'undefined-tramp :assembly-routine) temp) - (storew name result fdefn-name-slot other-pointer-lowtag) - (storew null-tn result fdefn-fun-slot other-pointer-lowtag) - (storew temp result fdefn-raw-addr-slot other-pointer-lowtag)))) - -(define-vop (make-closure) - (:args (function :to :save :scs (descriptor-reg))) - (:info label length stack-allocate-p) - (:ignore label) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 10 - (with-fixed-allocation - (result nil temp closure-widetag - (+ length closure-info-offset) - stack-allocate-p :lowtag fun-pointer-lowtag) - (storew function result closure-fun-slot fun-pointer-lowtag)))) - -;;; The compiler likes to be able to directly make value cells. -(define-vop (make-value-cell) - (:args (value :to :save :scs (descriptor-reg any-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:info stack-allocate-p) - (:generator 10 - (with-fixed-allocation - (result nil temp value-cell-widetag value-cell-size stack-allocate-p) - (storew value result value-cell-value-slot other-pointer-lowtag)))) - -;;;; Automatic allocators for primitive objects. - -(define-vop (make-unbound-marker) - (:args) - (:results (result :scs (descriptor-reg any-reg))) - (:generator 1 - (inst li unbound-marker-widetag result))) - -(define-vop (make-funcallable-instance-tramp) - (:args) - (:results (result :scs (any-reg))) - (:generator 1 - (inst li (make-fixup 'funcallable-instance-tramp :assembly-routine) - result))) - -(define-vop (fixed-alloc) - (:args) - (:info name words type lowtag stack-allocate-p) - (:ignore name) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 4 - (with-fixed-allocation - (result nil temp type words stack-allocate-p - :lowtag lowtag :maybe-write t)))) - -(define-vop (var-alloc) - (:args (extra :scs (any-reg))) - (:arg-types positive-fixnum) - (:info name words type lowtag stack-allocate-p) - (:ignore name stack-allocate-p) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (any-reg)) bytes) - (:temporary (:scs (non-descriptor-reg)) header) - (:generator 6 - (inst addi (* (1+ words) n-word-bytes) extra bytes) - (inst sll bytes (- n-widetag-bits 2) header) - ;; The specified EXTRA value is the exact value placed in the header - ;; as the word count when allocating code. - (cond ((= type code-header-widetag) - (inst addi type header header)) - (t - (cond ((> (length-field-shift type) n-widetag-bits) - ;; can't encode (+ (ash -2 n-widetag-bits) instance-widetag) - ;; as an immediate operand, so do what worked before. - (inst addi (+ (ash -2 n-widetag-bits) 0) header header) - ;; now shift left a few bits more - (inst sll header (- (length-field-shift type) n-widetag-bits) header) - ;; and add the widetag in - (inst addi type header header)) - (t - (inst addi (+ (ash -2 n-widetag-bits) type) header header))) - (inst dep 0 31 n-lowtag-bits bytes))) - (pseudo-atomic () - (set-lowtag lowtag alloc-tn result) - (storew header result 0 lowtag) - (inst add alloc-tn bytes alloc-tn)))) - diff -Nru sbcl-2.0.6/src/compiler/hppa/arith.lisp sbcl-2.1.1/src/compiler/hppa/arith.lisp --- sbcl-2.0.6/src/compiler/hppa/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/arith.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,932 +0,0 @@ -;;;; the VM definition arithmetic VOPs for HPPA - -;;;; 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") - -;;;; Unary operations. - -(define-vop (fast-safe-arith-op) - (:policy :fast-safe)) - -(define-vop (fixnum-unop fast-safe-arith-op) - (:args (x :scs (any-reg))) - (:results (res :scs (any-reg))) - (:note "inline fixnum arithmetic") - (:arg-types tagged-num) - (:result-types tagged-num)) - -(define-vop (signed-unop fast-safe-arith-op) - (:args (x :scs (signed-reg))) - (:results (res :scs (signed-reg))) - (:note "inline (signed-byte 32) arithmetic") - (:arg-types signed-num) - (:result-types signed-num)) - -(define-vop (fast-negate/fixnum fixnum-unop) - (:translate %negate) - (:generator 1 - (inst sub zero-tn x res))) - -(define-vop (fast-negate/signed signed-unop) - (:translate %negate) - (:generator 2 - (inst sub zero-tn x res))) - -(define-vop (fast-lognot/fixnum fixnum-unop) - (:translate lognot) - (:temporary (:scs (any-reg) :to (:result 0)) - temp) - (:generator 1 - (inst li (fixnumize -1) temp) - (inst xor x temp res))) - -(define-vop (fast-lognot/signed signed-unop) - (:translate lognot) - (:generator 2 - (inst uaddcm zero-tn x res))) - -;;;; Binary fixnum operations. - -;;; 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 zero)) - (y :target r :scs (any-reg zero))) - (: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 zero)) - (y :target r :scs (unsigned-reg zero))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:note "inline (unsigned-byte 32) arithmetic")) - -(define-vop (fast-signed-binop fast-safe-arith-op) - (:args (x :target r :scs (signed-reg zero)) - (y :target r :scs (signed-reg zero))) - (:arg-types signed-num signed-num) - (:results (r :scs (signed-reg))) - (:result-types signed-num) - (:note "inline (signed-byte 32) arithmetic")) - -(define-vop (fast-fixnum-c-binop fast-fixnum-binop) - (:args (x :target r :scs (any-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(define-vop (fast-signed-c-binop fast-signed-binop) - (:args (x :target r :scs (signed-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(define-vop (fast-unsigned-c-binop fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(macrolet - ((define-binop (translate cost untagged-cost op arg-swap) - `(progn - (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") - fast-fixnum-binop) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) - (:translate ,translate) - (:generator ,(1+ cost) - ,(if arg-swap - `(inst ,op y x r) - `(inst ,op x y r)))) - (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") - fast-signed-binop) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:translate ,translate) - (:generator ,(1+ untagged-cost) - ,(if arg-swap - `(inst ,op y x r) - `(inst ,op x y r)))) - (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") - fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) - (:translate ,translate) - (:generator ,(1+ untagged-cost) - ,(if arg-swap - `(inst ,op y x r) - `(inst ,op x y r))))))) - (define-binop + 1 5 add nil) - (define-binop - 1 5 sub nil) - (define-binop logior 1 2 or nil) - (define-binop logand 1 2 and nil) - (define-binop logandc1 1 2 andcm t) - (define-binop logandc2 1 2 andcm nil) - (define-binop logxor 1 2 xor nil)) - -(macrolet - ((define-c-binop (translate cost untagged-cost tagged-type untagged-type inst) - `(progn - (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") - fast-fixnum-c-binop) - (:arg-types tagged-num (:constant ,tagged-type)) - (:translate ,translate) - (:generator ,cost - (let ((y (fixnumize y))) - ,inst))) - (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") - fast-signed-c-binop) - (:arg-types signed-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - ,inst)) - (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED") - fast-unsigned-c-binop) - (:arg-types unsigned-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - ,inst))))) - - (define-c-binop + 1 3 (signed-byte 9) (signed-byte 11) - (inst addi y x r)) - (define-c-binop - 1 3 - (integer #.(- 1 (ash 1 8)) #.(ash 1 8)) - (integer #.(- 1 (ash 1 10)) #.(ash 1 10)) - (inst addi (- y) x r))) - -(define-vop (fast-lognor/fixnum=>fixnum fast-fixnum-binop) - (:translate lognor) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) - (:temporary (:sc non-descriptor-reg) temp) - (:generator 4 - (inst or x y temp) - (inst uaddcm zero-tn temp temp) - (inst addi (- fixnum-tag-mask) temp r))) - -(define-vop (fast-lognor/signed=>signed fast-signed-binop) - (:translate lognor) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:generator 4 - (inst or x y r) - (inst uaddcm zero-tn r r))) - -(define-vop (fast-lognor/unsigned=>unsigned fast-unsigned-binop) - (:translate lognor) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) - (:generator 4 - (inst or x y r) - (inst uaddcm zero-tn r r))) - -;;; Shifting -(macrolet - ((fast-ash (name reg num tag save) - `(define-vop (,name) - (:translate ash) - (:note "inline ASH") - (:policy :fast-safe) - (:args (number :scs (,reg) :to :save) - (count :scs (signed-reg))) - (:arg-types ,num ,tag) - (:results (result :scs (,reg))) - (:result-types ,num) - (:temporary (:scs (unsigned-reg) - ,@(unless save - '(:to (:result 0)))) temp) - (:generator 8 - (inst comb :>= count zero-tn positive :nullify t) - (inst sub zero-tn count temp) - ,@(if save - '(;; Unsigned case - (inst comiclr 31 temp result :>=) - (inst b done :nullify t) - (inst mtctl temp :sar) - (inst b done) - (inst shd zero-tn number :variable result)) - '(;; Signed case - (inst comiclr 31 temp zero-tn :>=) - (inst li 31 temp) - (inst mtctl temp :sar) - (inst extrs number 0 1 temp) - (inst b done) - (inst shd temp number :variable result))) - POSITIVE - (inst subi 31 count temp) - (inst mtctl temp :sar) - (inst zdep number :variable 32 result) - DONE)))) - (fast-ash fast-ash/unsigned=>unsigned unsigned-reg unsigned-num - tagged-num t) - (fast-ash fast-ash/signed=>signed signed-reg signed-num signed-num nil)) - -(define-vop (fast-ash-c/unsigned=>unsigned) - (:translate ash) - (:note "inline ASH") - (:policy :fast-safe) - (:args (number :scs (unsigned-reg))) - (:info count) - (:arg-types unsigned-num (:constant integer)) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (cond - ((< count -31) (move zero-tn result)) - ((< count 0) (inst srl number (min (- count) 31) result)) - ((> count 0) (inst sll number (min count 31) result)) - (t (bug "identity ASH not transformed away"))))) - -(define-vop (fast-ash-c/signed=>signed) - (:translate ash) - (:note "inline ASH") - (:policy :fast-safe) - (:args (number :scs (signed-reg))) - (:info count) - (:arg-types signed-num (:constant integer)) - (:results (result :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (cond - ((< count 0) (inst sra number (min (- count) 31) result)) - ((> count 0) (inst sll number (min count 31) result)) - (t (bug "identity ASH not transformed away"))))) - -(macrolet ((def (name sc-type type result-type cost) - `(define-vop (,name) - (:translate ash) - (:note "inline ASH") - (:policy :fast-safe) - (:args (number :scs (,sc-type)) - (amount :scs (signed-reg unsigned-reg immediate))) - (:arg-types ,type positive-fixnum) - (:results (result :scs (,result-type))) - (:result-types ,type) - (:temporary (:scs (,sc-type) :to (:result 0)) temp) - (:generator ,cost - (sc-case amount - ((signed-reg unsigned-reg) - (inst subi 31 amount temp) - (inst mtctl temp :sar) - (inst zdep number :variable 32 result)) - (immediate - (let ((amount (tn-value amount))) - (aver (> amount 0)) - (inst sll number amount result)))))))) - (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)) - -(define-vop (signed-byte-32-len) - (:translate integer-length) - (:note "inline (signed-byte 32) integer-length") - (:policy :fast-safe) - (:args (arg :scs (signed-reg) :target shift)) - (:arg-types signed-num) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) - (:generator 30 - (inst move arg shift :>=) - (inst uaddcm zero-tn shift shift) - (inst comb := shift zero-tn done) - (inst li 0 res) - LOOP - (inst srl shift 1 shift) - (inst comb :<> shift zero-tn loop) - (inst addi (fixnumize 1) res res) - DONE)) - -(define-vop (unsigned-byte-32-count) - (:translate logcount) - (:note "inline (unsigned-byte 32) logcount") - (:policy :fast-safe) - (:args (arg :scs (unsigned-reg) :target num)) - (:arg-types unsigned-num) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) - :target res) num) - (:temporary (:scs (non-descriptor-reg)) mask temp) - (:generator 30 - (inst li #x55555555 mask) - (inst srl arg 1 temp) - (inst and arg mask num) - (inst and temp mask temp) - (inst add num temp num) - (inst li #x33333333 mask) - (inst srl num 2 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst add num temp num) - (inst li #x0f0f0f0f mask) - (inst srl num 4 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst add num temp num) - (inst li #x00ff00ff mask) - (inst srl num 8 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst add num temp num) - (inst li #x0000ffff mask) - (inst srl num 16 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst add num temp res))) - -;;; Multiply and Divide. - -(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) - (:translate *) - (:args (x :scs (any-reg zero) :target x-pass) - (y :scs (any-reg zero) :target y-pass)) - (:temporary (:sc signed-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc signed-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc signed-reg :offset nl2-offset :target r - :from (:argument 1) :to (:result 0)) res-pass) - (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp) - (:temporary (:sc signed-reg :offset nl4-offset - :from (:argument 1) :to (:result 0)) sign) - (:temporary (:sc interior-reg :offset lip-offset) lip) - (:ignore lip sign) ; fix-lav: why dont we ignore tmp ? - (:generator 30 - ;; looking at the register setup above, not sure if both can clash - ;; maybe it is ok that x and x-pass share register ? like it was - (unless (location= y y-pass) - (inst sra x 2 x-pass)) - (let ((fixup (make-fixup 'multiply :assembly-routine))) - (inst ldil fixup tmp) - (inst ble fixup lisp-heap-space tmp)) - (if (location= y y-pass) - (inst sra x 2 x-pass) - (inst move y y-pass)) - (move res-pass r))) - -(define-vop (fast-*/signed=>signed fast-signed-binop) - (:translate *) - (:args (x :scs (signed-reg) :target x-pass) - (y :scs (signed-reg) :target y-pass)) - (:temporary (:sc signed-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc signed-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc signed-reg :offset nl2-offset :target r - :from (:argument 1) :to (:result 0)) res-pass) - (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp) - (:temporary (:sc signed-reg :offset nl4-offset - :from (:argument 1) :to (:result 0)) sign) - (:temporary (:sc interior-reg :offset lip-offset) lip) - (:ignore lip sign) - (:generator 31 - (let ((fixup (make-fixup 'multiply :assembly-routine))) - (move x x-pass) - (move y y-pass) - (inst ldil fixup tmp) - (inst ble fixup lisp-heap-space tmp) - (inst nop) - (move res-pass r)))) - -(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop) - (:translate *) - (:args (x :scs (unsigned-reg) :target x-pass) - (y :scs (unsigned-reg) :target y-pass)) - (:temporary (:sc unsigned-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc unsigned-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc unsigned-reg :offset nl2-offset :target r - :from (:argument 1) :to (:result 0)) res-pass) - (:temporary (:sc unsigned-reg :offset nl3-offset :to (:result 0)) tmp) - (:temporary (:sc unsigned-reg :offset nl4-offset - :from (:argument 1) :to (:result 0)) sign) - (:temporary (:sc interior-reg :offset lip-offset) lip) - (:ignore lip sign) - (:generator 31 - (let ((fixup (make-fixup 'multiply :assembly-routine))) - (move x x-pass) - (move y y-pass) - (inst ldil fixup tmp) - (inst ble fixup lisp-heap-space tmp) - (inst nop) - (move res-pass r)))) - -(define-vop (fast-truncate/fixnum fast-fixnum-binop) - (:translate truncate) - (:args (x :scs (any-reg) :target x-pass) - (y :scs (any-reg) :target y-pass)) - (:temporary (:sc signed-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc signed-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc signed-reg :offset nl2-offset :target q - :from (:argument 1) :to (:result 0)) q-pass) - (:temporary (:sc signed-reg :offset nl3-offset :target r - :from (:argument 1) :to (:result 1)) r-pass) - (:results (q :scs (any-reg)) - (r :scs (any-reg))) - (:result-types tagged-num tagged-num) - (:vop-var vop) - (:save-p :compute-only) - (:generator 30 - (let ((zero (generate-error-code vop 'division-by-zero-error x y))) - (inst bc := nil y zero-tn zero)) - (move x x-pass) - (move y y-pass) - (let ((fixup (make-fixup 'truncate :assembly-routine))) - (inst ldil fixup q-pass) - (inst ble fixup lisp-heap-space q-pass :nullify t)) - (inst nop) - (inst sll q-pass n-fixnum-tag-bits q) - ;(move q-pass q) - (move r-pass r))) - -#+(or) ;; This contains two largely-inexplicable hacks, and there's no - ;; equivalent VOP for either Alpha or ARM. Why is this even - ;; here? -- AB, 2015-11-19 -(define-vop (fast-truncate/unsigned fast-unsigned-binop) - (:translate truncate) - (:args (x :scs (unsigned-reg) :target x-pass) - (y :scs (unsigned-reg) :target y-pass)) - (:temporary (:sc unsigned-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc unsigned-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc unsigned-reg :offset nl2-offset :target q - :from (:argument 1) :to (:result 0)) q-pass) - (:temporary (:sc unsigned-reg :offset nl3-offset :target r - :from (:argument 1) :to (:result 1)) r-pass) - (:results (q :scs (unsigned-reg)) - (r :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:vop-var vop) - (:save-p :compute-only) - (:generator 35 - (let ((zero (generate-error-code vop 'division-by-zero-error x y))) - (inst bc := nil y zero-tn zero)) - (move x x-pass) - (move y y-pass) - ;; really dirty trick to avoid the bug truncate/unsigned vop - ;; followed by move-from/word->fixnum where the result from - ;; the truncate is 0xe39516a7 and move-from-word will treat - ;; the unsigned high number as an negative number. - ;; instead we clear the high bit in the input to truncate. - (inst li #x1fffffff q) - (inst comb :<> q y skip :nullify t) - (inst addi -1 zero-tn q) - (inst srl q 1 q) ; this should result in #7fffffff - (inst and x-pass q x-pass) - (inst and y-pass q y-pass) - SKIP - ;; fix bug#2 (truncate #xe39516a7 #x3) => #0xf687078d,#x0 - (inst li #x7fffffff q) - (inst and x-pass q x-pass) - (let ((fixup (make-fixup 'truncate :assembly-routine))) - (inst ldil fixup q-pass) - (inst ble fixup lisp-heap-space q-pass :nullify t)) - (inst nop) - (move q-pass q) - (move r-pass r))) - -(define-vop (fast-truncate/signed fast-signed-binop) - (:translate truncate) - (:args (x :scs (signed-reg) :target x-pass) - (y :scs (signed-reg) :target y-pass)) - (:temporary (:sc signed-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc signed-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc signed-reg :offset nl2-offset :target q - :from (:argument 1) :to (:result 0)) q-pass) - (:temporary (:sc signed-reg :offset nl3-offset :target r - :from (:argument 1) :to (:result 1)) r-pass) - (:results (q :scs (signed-reg)) - (r :scs (signed-reg))) - (:result-types signed-num signed-num) - (:vop-var vop) - (:save-p :compute-only) - (:generator 35 - (let ((zero (generate-error-code vop 'division-by-zero-error x y))) - (inst bc := nil y zero-tn zero)) - (move x x-pass) - (move y y-pass) - (let ((fixup (make-fixup 'truncate :assembly-routine))) - (inst ldil fixup q-pass) - (inst ble fixup lisp-heap-space q-pass :nullify t)) - (inst nop) - (move q-pass q) - (move r-pass r))) - - -;;;; Binary conditional VOPs: - -(define-vop (fast-conditional) - (:conditional) - (:info target not-p) - (:policy :fast-safe)) - -(define-vop (fast-conditional/fixnum fast-conditional) - (:args (x :scs (any-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison")) - -(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg))) - (:arg-types tagged-num (:constant (signed-byte 9))) - (:info target not-p y)) - -(define-vop (fast-conditional/signed fast-conditional) - (:args (x :scs (signed-reg)) - (y :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:note "inline (signed-byte 32) comparison")) - -(define-vop (fast-conditional-c/signed fast-conditional/signed) - (:args (x :scs (signed-reg))) - (:arg-types signed-num (:constant (signed-byte 11))) - (:info target not-p y)) - -(define-vop (fast-conditional/unsigned fast-conditional) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:note "inline (unsigned-byte 32) comparison")) - -(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num (:constant (signed-byte 11))) - (:info target not-p y)) - - -(defmacro define-conditional-vop (translate signed-cond unsigned-cond) - `(progn - ,@(mapcar #'(lambda (suffix cost signed imm) - (unless (and (member suffix '(/fixnum -c/fixnum)) - (eq translate 'eql)) - `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" - translate suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,translate) - (:generator ,cost - (inst ,(if imm 'bci 'bc) - ,(if signed signed-cond unsigned-cond) - not-p - ,(if (eq suffix '-c/fixnum) - '(fixnumize y) - 'y) - x - target))))) - '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - '(3 2 5 4 5 4) - '(t t t t nil nil) - '(nil t nil t nil t)))) - -;; We switch < and > because the immediate has to come first. - -(define-conditional-vop < :> :>>) -(define-conditional-vop > :< :<<) - -;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a -;;; known fixnum. -;;; -(define-conditional-vop eql := :=) - -;;; These versions specify a fixnum restriction on their first arg. We have -;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on -;;; the first arg and a higher cost. The reason for doing this is to prevent -;;; fixnum specific operations from being used on word integers, spuriously -;;; consing the argument. -;;; -(define-vop (fast-eql/fixnum fast-conditional) - (:args (x :scs (any-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison") - (:translate eql) - (:generator 3 - (inst bc := not-p x y target))) -;;; -(define-vop (generic-eql/fixnum fast-eql/fixnum) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg))) - (:arg-types * tagged-num) - (:variant-cost 7)) - -(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg))) - (:arg-types tagged-num (:constant (signed-byte 9))) - (:info target not-p y) - (:translate eql) - (:generator 2 - (inst bci := not-p (fixnumize y) x target))) -;;; -(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:arg-types * (:constant (signed-byte 9))) - (:variant-cost 6)) - - -;;;; modular functions -(define-modular-fun +-mod32 (x y) + :untagged nil 32) -(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned) - (:translate +-mod32)) -(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned) - (:translate +-mod32)) -(define-modular-fun --mod32 (x y) - :untagged nil 32) -(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned) - (:translate --mod32)) -(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned) - (:translate --mod32)) - -(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned - fast-ash-c/unsigned=>unsigned) - (:translate ash-left-mod32)) - -(define-vop (fast-ash-left-mod32/unsigned=>unsigned - fast-ash-left/unsigned=>unsigned)) -(deftransform ash-left-mod32 ((integer count) - ((unsigned-byte 32) (unsigned-byte 5))) - (when (sb-c::constant-lvar-p count) - (sb-c::give-up-ir1-transform)) - '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count)) - -;;; logical operations -(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32) -(define-vop (lognot-mod32/unsigned=>unsigned) - (:translate lognot-mod32) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (res :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe) - (:generator 1 - (inst uaddcm zero-tn x res))) - -(define-modular-fun lognor-mod32 (x y) lognor :untagged nil 32) -(define-vop (fast-lognor-mod32/unsigned=>unsigned - fast-lognor/unsigned=>unsigned) - (:translate lognor-mod32)) - -(define-source-transform logeqv (&rest args) - (if (oddp (length args)) - `(logxor ,@args) - `(lognot (logxor ,@args)))) -(define-source-transform logorc1 (x y) - `(logior (lognot ,x) ,y)) -(define-source-transform logorc2 (x y) - `(logior ,x (lognot ,y))) -(define-source-transform lognand (x y) - `(lognot (logand ,x ,y))) -(define-source-transform lognor (x y) - `(lognot (logior ,x ,y))) - -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (inst subi 31 amount temp) - (inst mtctl temp :sar) - (inst zdep num :variable 32 r))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (inst mtctl amount :sar) - (inst shd zero-tn num :variable r))) - - - -;;;; Bignum stuff. - -(define-vop (bignum-length get-header-data) - (:translate sb-bignum:%bignum-length) - (:policy :fast-safe)) - -(define-vop (bignum-set-length set-header-data) - (:translate sb-bignum:%bignum-set-length) - (:policy :fast-safe)) - -(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag - (unsigned-reg) unsigned-num sb-bignum:%bignum-ref) - -(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag - (unsigned-reg) unsigned-num sb-bignum:%bignum-set) - -(define-vop (digit-0-or-plus) - (:translate sb-bignum:%digit-0-or-plusp) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:conditional) - (:info target not-p) - (:generator 2 - (inst bc :>= not-p digit zero-tn target))) - -(define-vop (add-w/carry) - (:translate sb-bignum:%add-with-carry) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (any-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg)) - (carry :scs (unsigned-reg))) - (:result-types unsigned-num positive-fixnum) - (:generator 3 - (inst addi -1 c zero-tn) - (inst addc a b result) - (inst addc zero-tn zero-tn carry))) - -(define-vop (sub-w/borrow) - (:translate sb-bignum:%subtract-with-borrow) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg)) - (borrow :scs (unsigned-reg))) - (:result-types unsigned-num positive-fixnum) - (:generator 4 - (inst addi -1 c zero-tn) - (inst subb a b result) - (inst addc zero-tn zero-tn borrow))) - -(define-vop (bignum-mult) - (:translate sb-bignum:%multiply) - (:policy :fast-safe) - (:args (x-arg :scs (unsigned-reg) :target x) - (y-arg :scs (unsigned-reg) :target y)) - (:arg-types unsigned-num unsigned-num) - (:temporary (:scs (signed-reg) :from (:argument 0)) x) - (:temporary (:scs (signed-reg) :from (:argument 1)) y) - (:temporary (:scs (signed-reg)) tmp) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 3 - ;; Make sure X is less then Y. - (inst comclr x-arg y-arg tmp :<<) - (inst xor x-arg y-arg tmp) - (inst xor x-arg tmp x) - (inst xor y-arg tmp y) - - ;; Blow out of here if the result is zero. - (inst li 0 hi) - (inst comb := x zero-tn done) - (inst li 0 lo) - (inst li 0 tmp) - - LOOP - (inst comb :ev x zero-tn next-bit) - (inst srl x 1 x) - (inst add lo y lo) - (inst addc hi tmp hi) - NEXT-BIT - (inst add y y y) - (inst comb :<> x zero-tn loop) - (inst addc tmp tmp tmp) - - DONE)) - -(define-source-transform sb-bignum:%multiply-and-add (x y carry &optional (extra 0)) - #+nil ;; This would be greate if it worked, but it doesn't. - (if (eql extra 0) - `(multiple-value-call #'sb-bignum:%dual-word-add - (sb-bignum:%multiply ,x ,y) - (values ,carry)) - `(multiple-value-call #'sb-bignum:%dual-word-add - (multiple-value-call #'sb-bignum:%dual-word-add - (sb-bignum:%multiply ,x ,y) - (values ,carry)) - (values ,extra))) - (with-unique-names (hi lo) - (if (eql extra 0) - `(multiple-value-bind (,hi ,lo) (sb-bignum:%multiply ,x ,y) - (sb-bignum::%dual-word-add ,hi ,lo ,carry)) - `(multiple-value-bind (,hi ,lo) (sb-bignum:%multiply ,x ,y) - (multiple-value-bind - (,hi ,lo) - (sb-bignum::%dual-word-add ,hi ,lo ,carry) - (sb-bignum::%dual-word-add ,hi ,lo ,extra)))))) - -(defknown sb-bignum::%dual-word-add - (sb-bignum:bignum-element-type sb-bignum:bignum-element-type sb-bignum:bignum-element-type) - (values sb-bignum:bignum-element-type sb-bignum:bignum-element-type) - (flushable movable)) - -(define-vop (dual-word-add) - (:policy :fast-safe) - (:translate sb-bignum::%dual-word-add) - (:args (hi :scs (unsigned-reg) :to (:result 1)) - (lo :scs (unsigned-reg)) - (extra :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:results (hi-res :scs (unsigned-reg) :from (:result 1)) - (lo-res :scs (unsigned-reg) :from (:result 0))) - (:result-types unsigned-num unsigned-num) - (:generator 3 - (inst add lo extra lo-res) - (inst addc hi zero-tn hi-res))) - -(define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned) - (:translate sb-bignum:%lognot)) - -(define-vop (fixnum-to-digit) - (:translate sb-bignum:%fixnum-to-digit) - (:policy :fast-safe) - (:args (fixnum :scs (any-reg))) - (:arg-types tagged-num) - (:results (digit :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst sra fixnum n-fixnum-tag-bits digit))) - -(define-vop (bignum-floor) - (:translate sb-bignum:%bigfloor) - (:policy :fast-safe) - (:args (hi :scs (unsigned-reg) :to (:argument 1)) - (lo :scs (unsigned-reg) :to (:argument 0)) - (divisor :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp) - (:results (quo :scs (unsigned-reg) :from (:argument 0)) - (rem :scs (unsigned-reg) :from (:argument 1))) - (:result-types unsigned-num unsigned-num) - (:generator 65 - (inst sub zero-tn divisor temp) - (inst ds zero-tn temp zero-tn) - (inst add lo lo quo) - (inst ds hi divisor rem) - (inst addc quo quo quo) - (dotimes (i 31) - (inst ds rem divisor rem) - (inst addc quo quo quo)) - (inst comclr rem zero-tn zero-tn :>=) - (inst add divisor rem rem))) - -(define-vop (signify-digit) - (:translate sb-bignum:%fixnum-digit-with-correct-sign) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target res)) - (:arg-types unsigned-num) - (:results (res :scs (any-reg signed-reg))) - (:result-types signed-num) - (:generator 1 - (sc-case res - (any-reg - (inst sll digit n-fixnum-tag-bits res)) - (signed-reg - (move digit res))))) - -(define-vop (digit-lshr) - (:translate sb-bignum:%digit-logical-shift-right) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg)) - (count :scs (unsigned-reg))) - (:arg-types unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 2 - (inst mtctl count :sar) - (inst shd zero-tn digit :variable result))) - -(define-vop (digit-ashr digit-lshr) - (:translate sb-bignum:%ashr) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 1 - (inst extrs digit 0 1 temp) - (inst mtctl count :sar) - (inst shd temp digit :variable result))) - -(define-vop (digit-ashl digit-ashr) - (:translate sb-bignum:%ashl) - (:generator 1 - (inst subi 31 count temp) - (inst mtctl temp :sar) - (inst zdep digit :variable 32 result))) diff -Nru sbcl-2.0.6/src/compiler/hppa/array.lisp sbcl-2.1.1/src/compiler/hppa/array.lisp --- sbcl-2.0.6/src/compiler/hppa/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/array.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,382 +0,0 @@ -;;;; the HPPA definitions for array operations - -;;;; 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") - -;;;; Allocator for the array header. -(define-vop (make-array-header) - (:translate make-array-header) - (:policy :fast-safe) - (:args (type :scs (any-reg)) - (rank :scs (any-reg))) - (:arg-types positive-fixnum positive-fixnum) - (:temporary (:scs (any-reg)) bytes) - (:temporary (:scs (non-descriptor-reg)) header) - (:results (result :scs (descriptor-reg))) - (:generator 13 - ;; Note: Cant use addi, the immediate is too large - (inst li (+ (* (1+ array-dimensions-offset) n-word-bytes) - lowtag-mask) header) - (inst add header rank bytes) - (inst li (lognot lowtag-mask) header) - (inst and bytes header bytes) - (inst addi (fixnumize (1- array-dimensions-offset)) rank header) - (inst sll header n-widetag-bits header) - (inst or header type header) - (inst srl header n-fixnum-tag-bits header) - (pseudo-atomic () - (set-lowtag other-pointer-lowtag alloc-tn result) - (storew header result 0 other-pointer-lowtag) - (inst add bytes alloc-tn alloc-tn)))) - - -;;;; Additional accessors and setters for the array header. -(define-full-reffer %array-dimension * - array-dimensions-offset other-pointer-lowtag - (any-reg) positive-fixnum %array-dimension) - -(define-full-setter %set-array-dimension * - array-dimensions-offset other-pointer-lowtag - (any-reg) positive-fixnum %set-array-dimension) - -(define-vop (array-rank-vop) - (:translate %array-rank) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw res x 0 other-pointer-lowtag) - (inst sra res n-widetag-bits res) - (inst addi (- (1- array-dimensions-offset)) res res) - (inst sll res n-fixnum-tag-bits res))) - -;;;; Bounds checking routine. -(define-vop (check-bound) - (:translate %check-bound) - (:policy :fast-safe) - (:args (array :scs (descriptor-reg)) - (bound :scs (any-reg descriptor-reg)) - (index :scs (any-reg descriptor-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (let ((error (generate-error-code vop 'invalid-array-index-error - array bound index))) - (%test-fixnum index nil error t) - (inst bc :>>= nil index bound error)))) - - -;;;; Accessors/Setters - -;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos -;;; elements are represented in integer registers and are built out of -;;; 8, 16, or 32 bit elements. -(macrolet ((def-full-data-vector-frobs (type element-type &rest scs) - `(progn - (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type - vector-data-offset other-pointer-lowtag - ,(remove-if (lambda (x) (member x '(null zero))) scs) - ,element-type - data-vector-ref) - (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type - vector-data-offset other-pointer-lowtag ,scs ,element-type - data-vector-set))) - - (def-partial-data-vector-frobs - (type element-type size signed &rest scs) - `(progn - (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type - ,size ,signed vector-data-offset other-pointer-lowtag ,scs - ,element-type data-vector-ref) - (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type - ,size vector-data-offset other-pointer-lowtag ,scs - ,element-type data-vector-set)))) - - (def-full-data-vector-frobs simple-vector * - descriptor-reg any-reg null zero) - - (def-partial-data-vector-frobs simple-base-string character - :byte nil character-reg) - #+sb-unicode - (def-full-data-vector-frobs simple-character-string character character-reg) - - (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum - :byte nil unsigned-reg signed-reg) - (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum - :byte nil unsigned-reg signed-reg) - - (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum - :short nil unsigned-reg signed-reg) - (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum - :short nil unsigned-reg signed-reg) - - (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num - unsigned-reg) - (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num - unsigned-reg) - - (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num - :byte t signed-reg) - - (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num - :short t signed-reg) - - (def-full-data-vector-frobs simple-array-unsigned-fixnum positive-fixnum - any-reg) - (def-full-data-vector-frobs simple-array-fixnum tagged-num - any-reg) - - (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num - signed-reg)) - -;;; Integer vectors whose elements are smaller than a byte. I.e. bit, 2-bit, -;;; and 4-bit vectors. -(macrolet ((def-small-data-vector-frobs (type bits) - (let* ((elements-per-word (floor n-word-bits bits)) - (bit-shift (1- (integer-length elements-per-word)))) - `(progn - (define-vop (,(symbolicate 'data-vector-ref/ type)) - (:translate data-vector-ref) - (:note "inline array access") - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (result :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp) - (:generator 20 - (inst srl index ,bit-shift temp) - (inst sh2add temp object lip) - (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) - ,@(unless (= bits 1) - `((inst addi ,(1- bits) temp temp))) - (inst mtctl temp :sar) - (loadw result lip vector-data-offset other-pointer-lowtag) - (inst extru result :variable ,bits result) - (inst sll result n-fixnum-tag-bits result))) - (define-vop (,(symbolicate 'data-vector-ref-c/ type)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:arg-types ,type (:constant index)) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp) - (:generator 15 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (let ((offset (- (* (+ word vector-data-offset) n-word-bytes) - other-pointer-lowtag))) - (cond ((typep offset '(signed-byte 14)) - (inst ldw offset object result)) - (t - (inst li offset temp) - (inst ldwx object temp result)))) - (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result)))) - (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)) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type positive-fixnum positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp) - (:temporary (:scs (non-descriptor-reg)) old) - (:temporary (:scs (interior-reg)) lip) - (:generator 25 - (inst srl index ,bit-shift temp) - (inst sh2add temp object lip) - (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) - ,@(unless (= bits 1) - `((inst addi ,(1- bits) temp temp))) - (inst mtctl temp :sar) - (loadw old lip vector-data-offset other-pointer-lowtag) - (inst dep (sc-case value (immediate (tn-value value)) (t value)) - :variable ,bits old) - (storew old lip vector-data-offset other-pointer-lowtag) - (sc-case value - (immediate - (inst li (tn-value value) result)) - (t - (move value result))))) - (define-vop (,(symbolicate 'data-vector-set-c/ type)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type - (:constant index) - positive-fixnum) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) old) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (let ((offset (- (* (+ word vector-data-offset) n-word-bytes) - other-pointer-lowtag))) - (cond ((typep offset '(signed-byte 14)) - (inst ldw offset object old)) - (t - (inst li offset lip) - (inst add object lip lip) - (inst ldw 0 lip old))) - (inst dep (sc-case value - (immediate (tn-value value)) - (t value)) - (+ (* extra ,bits) ,(1- bits)) - ,bits - old) - (if (typep offset '(signed-byte 14)) - (inst stw old offset object) - (inst stw old (ldb (byte 11 0) offset) lip))) - (sc-case value - (immediate - (inst li (tn-value value) result)) - (t - (move value result)))))))))) - (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)) - -;;; And the float variants. -(macrolet - ((data-vector ((type set cost) &body body) - (let* ((typen (case type (single 'single-float) - (double 'double-float) - (t type))) - (name (symbolicate "DATA-VECTOR-" (if set "SET" "REF") - "/SIMPLE-ARRAY-" typen)) - (reg-type (symbolicate type "-REG"))) - `(define-vop (,name) - (:translate ,(symbolicate "DATA-VECTOR-" (if set "SET" "REF"))) - (:note ,(concatenate 'string "inline array " - (if set "store" "access"))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset) - ,@(if set `((value :scs (,reg-type) :target result)))) - (:arg-types ,(symbolicate "SIMPLE-ARRAY-" typen) positive-fixnum - ,@(if set `(,typen))) - (:results (,(if set 'result 'value) :scs (,reg-type))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) - (:result-types ,typen) - (:generator ,cost - ,@body))))) - (data-vector (single nil 5) - (inst addi (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - index offset) - (inst fldx offset object value)) - (data-vector (single t 5) - (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - index offset) - (inst fstx value offset object) - (unless (location= result value) - (inst funop :copy value result))) - (data-vector (double nil 7) - (inst sll index 1 offset) - (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) - (inst fldx offset object value)) - (data-vector (double t 7) - (inst sll index 1 offset) - (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) - (inst fstx value offset object) - (unless (location= result value) - (inst funop :copy value result)))) - -(macrolet - ((data-vector ((type set cost) &body body) - (let* ((typen (case type (complex-single 'complex-single-float) - (complex-double 'complex-double-float) - (t type))) - (name (symbolicate "DATA-VECTOR-" (if set "SET" "REF") - "/SIMPLE-ARRAY-" typen)) - (reg-type (symbolicate type "-REG"))) - `(define-vop (,name) - (:translate ,(symbolicate "DATA-VECTOR-" (if set "SET" "REF"))) - (:note ,(concatenate 'string "inline array " - (if set "store" "access"))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to :result) - (index :scs (any-reg)) - ,@(if set `((value :scs (,reg-type) :target result)))) - (:arg-types ,(symbolicate "SIMPLE-ARRAY-" typen) positive-fixnum - ,@(if set `(,typen))) - (:results (,(if set 'result 'value) :scs (,reg-type))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) - (:result-types ,typen) - (:generator ,cost - ,@body))))) - (data-vector (complex-single nil 5) - (inst sll index 1 offset) - (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) - (let ((real-tn (complex-single-reg-real-tn value))) - (inst fldx offset object real-tn)) - (let ((imag-tn (complex-single-reg-imag-tn value))) - (inst addi n-word-bytes offset offset) - (inst fldx offset object imag-tn))) - (data-vector (complex-single t 5) - (inst sll index 1 offset) - (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) - (let ((value-real (complex-single-reg-real-tn value)) - (result-real (complex-single-reg-real-tn result))) - (inst fstx value-real offset object) - (unless (location= result-real value-real) - (inst funop :copy value-real result-real))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) - (inst addi n-word-bytes offset offset) - (inst fstx value-imag offset object) - (unless (location= result-imag value-imag) - (inst funop :copy value-imag result-imag)))) - (data-vector (complex-double nil 7) - (inst sll index 2 offset) - (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) - (let ((real-tn (complex-double-reg-real-tn value))) - (inst fldx offset object real-tn)) - (let ((imag-tn (complex-double-reg-imag-tn value))) - (inst addi (* 2 n-word-bytes) offset offset) - (inst fldx offset object imag-tn))) - (data-vector (complex-double t 20) - (inst sll index 2 offset) - (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) - (let ((value-real (complex-double-reg-real-tn value)) - (result-real (complex-double-reg-real-tn result))) - (inst fstx value-real offset object) - (unless (location= result-real value-real) - (inst funop :copy value-real result-real))) - (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) - (inst addi (* 2 n-word-bytes) offset offset) - (inst fstx value-imag offset object) - (unless (location= result-imag value-imag) - (inst funop :copy value-imag result-imag))))) - - -;;; These vops are useful for accessing the bits of a vector irrespective of -;;; what type of vector it is. -(define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag - (unsigned-reg) unsigned-num %vector-raw-bits) -(define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag - (unsigned-reg) unsigned-num %set-vector-raw-bits) diff -Nru sbcl-2.0.6/src/compiler/hppa/call.lisp sbcl-2.1.1/src/compiler/hppa/call.lisp --- sbcl-2.0.6/src/compiler/hppa/call.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/call.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1226 +0,0 @@ -;;;; the VM definition of function call for HPPA - -;;;; 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 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) - (if standard - (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number lra-offset) - (make-restricted-tn *backend-t-primitive-type* descriptor-reg-sc-number))) - -;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a -;;; location to pass OLD-FP in. This is (obviously) wired in the -;;; standard convention, but is totally unrestricted in non-standard -;;; conventions, since we can always fetch it off of the stack using -;;; the arg pointer. -(defun make-old-fp-passing-location () - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)) - -(defconstant old-fp-passing-offset - (make-sc+offset descriptor-reg-sc-number ocfp-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) - (specify-save-tn - (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) - (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset))) - -(defun make-return-pc-save-location (env) - (let ((ptype *backend-t-primitive-type*)) - (specify-save-tn - (physenv-debug-live-tn (make-normal-tn ptype) env) - (make-wired-tn ptype control-stack-arg-scn lra-save-offset)))) - -;;; Make a TN for the standard argument count passing location. We only -;;; need to make the standard location, since a count is never passed when we -;;; are using non-standard conventions. -(defun make-arg-count-location () - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) - -;;; bytes-needed-for-non-descriptor-stack-frame is the amount -;;; we grow or shrink the NSP/NFP stack. This stack is used -;;; by C-code so the convention (grow direction, grow size) -;;; is governed by the hpux+hppa ABI or linux+hppa ABI. -;;; Return the number of bytes needed for the current non-descriptor stack. -;;; We have to allocate multiples of 64 bytes -(defun bytes-needed-for-non-descriptor-stack-frame () - (logandc2 (+ (* (sb-allocated-size 'non-descriptor-stack) n-word-bytes) 63) - 63)) - -;;; Used for setting up the Old-FP in local call. -;;; -(define-vop (current-fp) - (:results (val :scs (any-reg))) - (:generator 1 - (move cfp-tn val))) - -;;; Used for computing the caller's NFP for use in known-values return. Only -;;; works assuming there is no variable size stuff on the nstack. -;;; -(define-vop (compute-old-nfp) - (:results (val :scs (any-reg))) - (:vop-var vop) - (:generator 1 - (let ((nfp (current-nfp-tn vop))) - (when nfp - (inst ldo (- (bytes-needed-for-non-descriptor-stack-frame)) - nfp val))))) - -;;; Accessing a slot from an earlier stack frame is definite hackery. -(define-vop (ancestor-frame-ref) - (:args (frame-pointer :scs (descriptor-reg)) - (variable-home-tn :load-if nil)) - (:results (value :scs (descriptor-reg any-reg))) - (:policy :fast-safe) - (:generator 4 - (aver (sc-is variable-home-tn control-stack)) - (loadw value frame-pointer (tn-offset variable-home-tn)))) -(define-vop (ancestor-frame-set) - (:args (frame-pointer :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:results (variable-home-tn :load-if nil)) - (:policy :fast-safe) - (:generator 4 - (aver (sc-is variable-home-tn control-stack)) - (storew value frame-pointer (tn-offset variable-home-tn)))) - -(define-vop (xep-allocate-frame) - (:info start-lab) - ;; KLUDGE: Specify an explicit offset for TEMP because NARGS is a - ;; non-descriptor-reg, but is also live, yet the register allocator - ;; does not know that it is, and if TEMP collides NARGS and - ;; COMPUTE-CODE-FROM-LIP needs TEMP then we run into trouble very - ;; quickly. - (:temporary (:sc non-descriptor-reg :offset nl5-offset) temp) - (:generator 1 - ;; Make sure the function is aligned, and drop a label pointing to this - ;; function header. - (emit-alignment n-lowtag-bits) - (emit-label start-lab) - ;; Allocate function header. - (inst simple-fun-header-word) - (inst .skip (* (1- simple-fun-insts-offset) n-word-bytes)) - ;; The start of the actual code. - ;; Fix CODE, cause the function object was passed in. - (let ((entry-point (gen-label))) - (emit-label entry-point) - (inst compute-code-from-lip lip-tn entry-point temp code-tn) - ;; ### We should also save it on the stack so that the garbage - ;; collector won't forget about us if we call anyone else. - ))) - -(define-vop (xep-setup-sp) - (:vop-var vop) - (:generator 1 - (inst ldo (* n-word-bytes (sb-allocated-size 'control-stack)) - cfp-tn csp-tn) - (let ((nfp (current-nfp-tn vop))) - (when nfp - (move nsp-tn nfp) - (inst ldo (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn nsp-tn))))) - -(define-vop (allocate-frame) - (:results (res :scs (any-reg)) - (nfp :scs (any-reg))) - (:info callee) - (:generator 2 - (move csp-tn res) - (inst ldo (* n-word-bytes (sb-allocated-size 'control-stack)) - csp-tn csp-tn) - (when (ir2-physenv-number-stack-p callee) - (move nsp-tn nfp) - (inst ldo (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn nsp-tn)))) - -;;; 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. -;;; -(define-vop (allocate-full-call-frame) - (:info nargs) - (:results (res :scs (any-reg))) - (:generator 2 - (when (> nargs register-arg-count) - (move csp-tn res) - (inst ldo (* nargs n-word-bytes) csp-tn csp-tn)))) - - -;;; Fix: boil down below notes into something nicer -;;; 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 list for the -;;; locations that the values are to be received into. NVALS is the number of -;;; values that are to be received (should equal the length of VALUES). -;;; -;;; MOVE-TEMP is a DESCRIPTOR-REG TN used as a temporary. -;;; -;;; This code exploits the fact that in the unknown-values convention, a -;;; single value return returns at the return PC + 8, whereas a return of other -;;; than one value returns directly at the return PC. -;;; -;;; If 0 or 1 values are expected, then we just emit an instruction to reset -;;; the SP (which will only be executed when other than 1 value is returned.) -;;; -;;; In the general case, we have to do three things: -;;; -- Default unsupplied register values. This need only be done when a -;;; single value is returned, since register values are defaulted by the -;;; called in the non-single case. -;;; -- Default unsupplied stack values. This needs to be done whenever there -;;; are stack values. -;;; -- Reset SP. This must be done whenever other than 1 value is returned, -;;; regardless of the number of values desired. -;;; -;;; The general-case code looks like this: -#| - b regs-defaulted ; Skip if MVs - nop - - move a1 null-tn ; Default register values - ... - loadi nargs 1 ; Force defaulting of stack values - move old-fp csp ; Set up args for SP resetting - -regs-defaulted - subu temp nargs register-arg-count - - bltz temp default-value-7 ; jump to default code - addu temp temp -1 - loadw move-temp old-fp-tn 6 ; Move value to correct location. - store-stack-tn val4-tn move-temp - - bltz temp default-value-8 - addu temp temp -1 - loadw move-temp old-fp-tn 7 - store-stack-tn val5-tn move-temp - - ... - -defaulting-done - move sp old-fp ; Reset SP. - - - -default-value-7 - store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) - -default-value-8 - store-stack-tn val5-tn null-tn ; Nil out 8'th value. - - ... - - br defaulting-done - nop -|# - -(defun default-unknown-values (vop values nvals move-temp temp lra-label) - (declare (type (or tn-ref null) values) - (type unsigned-byte nvals) - (type tn move-temp temp)) - (cond - ((<= nvals 1) - ;; Note that this is a single-value return point. This is actually - ;; the multiple-value entry point for a single desired value, but - ;; the code location has to be here, or the debugger backtrace - ;; gets confused. - (without-scheduling () - (note-this-location vop :single-value-return) - (move ocfp-tn csp-tn t) - (inst nop)) - (when lra-label - (inst compute-code-from-lra code-tn lra-label temp code-tn))) - (t - (let ((regs-defaulted (gen-label)) - (defaulting-done (gen-label)) - (default-stack-vals (gen-label))) - (without-scheduling () - ;; Note that this is an unknown-values return point. - (note-this-location vop :unknown-return) - ;; Branch off to the MV case. - (inst b regs-defaulted) ; dont nullify - ;; If there are no stack results, clear the stack before branch. - (if (> nvals register-arg-count) ; what inst to late-branch-exec - (inst addi (fixnumize (- register-arg-count)) nargs-tn temp) - (move ocfp-tn csp-tn t))) - ;; Do the single value case. - (do ((i 1 (1+ i)) - (val (tn-ref-across values) (tn-ref-across val))) - ((= i (min nvals register-arg-count))) - (move null-tn (tn-ref-tn val))) - (when (> nvals register-arg-count) - (inst b default-stack-vals) - (move csp-tn ocfp-tn t)) - - (emit-label regs-defaulted) - - (when (> nvals register-arg-count) - ;; If there are stack results, we have to default them - ;; and clear the stack. - (collect ((defaults)) - (do ((i register-arg-count (1+ i)) - (val (do ((i 0 (1+ i)) - (val values (tn-ref-across val))) - ((= i register-arg-count) val)) - (tn-ref-across val))) - ((null val)) - - (let ((default-lab (gen-label)) - (tn (tn-ref-tn val))) - (defaults (cons default-lab tn)) - - (inst ldw (* i n-word-bytes) ocfp-tn move-temp) - (inst bc :<= nil temp zero-tn default-lab) - (inst addi (fixnumize -1) temp temp) - (store-stack-tn tn move-temp))) - - (emit-label defaulting-done) - (move ocfp-tn csp-tn) - - (let ((defaults (defaults))) - (aver defaults) - (assemble (:elsewhere) - (emit-label default-stack-vals) - (do ((remaining defaults (cdr remaining))) - ((null remaining)) - (let ((def (car remaining))) - (emit-label (car def)) - (when (null (cdr remaining)) - (inst b defaulting-done)) - (store-stack-tn (cdr def) null-tn))))))) - (when lra-label - (inst compute-code-from-lra code-tn lra-label temp code-tn))))) - (values)) - - -;;;; Unknown values receiving: - -;;; Emit code needed at the return point for an unknown-values call for an -;;; arbitrary number of values. -;;; -;;; We do the single and non-single cases with no shared code: there doesn't -;;; seem to be any potential overlap, and receiving a single value is more -;;; important efficiency-wise. -;;; -;;; When there is a single value, we just push it on the stack, returning -;;; the old SP and 1. -;;; -;;; When there is a variable number of values, we move all of the argument -;;; registers onto the stack, and return Args and Nargs. -;;; -;;; 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 temp) - (declare (type tn args nargs start count temp)) - (let ((variable-values (gen-label)) - (done (gen-label))) - (without-scheduling () - (inst b variable-values :nullify t) - (inst nop)) ; nop because of emit-return-pc alignment - - (when lra-label - (inst compute-code-from-lra code-tn lra-label temp code-tn)) - (inst addi n-word-bytes csp-tn csp-tn) - (storew (first *register-arg-tns*) csp-tn -1) - (inst addi (- n-word-bytes) csp-tn start) - (inst li (fixnumize 1) count) - - (emit-label done) - - (assemble (:elsewhere) - (emit-label variable-values) - (when lra-label - (inst compute-code-from-lra code-tn lra-label temp code-tn)) - (do ((arg *register-arg-tns* (rest arg)) - (i 0 (1+ i))) - ((null arg)) - (storew (first arg) args i)) - (move args start) - (inst b done) - (move nargs count t))) - (values)) - -;;; VOP that can be inherited by unknown values receivers. The main thing this -;;; handles is allocation of the result temporaries. -;;; -(define-vop (unknown-values-receiver) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:sc descriptor-reg :offset ocfp-offset - :from :eval :to (:result 0)) - values-start) - (:temporary (:sc any-reg :offset nargs-offset - :from :eval :to (:result 1)) - nvals) - (:temporary (:scs (non-descriptor-reg)) temp)) - - -;;; 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 -;;; does nothing. -(defun emit-block-header (start-label trampoline-label fall-thru-p alignp) - (declare (ignore fall-thru-p alignp)) - (when trampoline-label - (emit-label trampoline-label)) - (emit-label start-label)) - - -;;;; Local call with unknown values convention return: - -;;; Non-TR local call for a fixed number of values passed according to the -;;; unknown values convention. -;;; -;;; Args are the argument passing locations, which are specified only to -;;; terminate their lifetimes in the caller. -;;; -;;; Values are the return value locations (wired to the standard passing -;;; locations). -;;; -;;; Save is the save info, which we can ignore since saving has been done. -;;; Return-PC is the TN that the return PC should be passed in. -;;; Target is a continuation pointing to the start of the called function. -;;; Nvals is the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (call-local) - (:args (cfp) - (nfp) - (args :more t)) - (:results (values :more t)) - (:save-p t) - (:move-args :local-call) - (:info arg-locs callee target nvals) - (:vop-var vop) - (:temporary (:scs (descriptor-reg) :from :eval) move-temp) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp) - (:ignore arg-locs args ocfp) - (:generator 5 - (let ((label (gen-label)) - (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 cfp) - (inst compute-lra-from-code code-tn label temp - (callee-return-pc-tn callee)) - (note-this-location vop :call-site) - (inst b target :nullify t) - (emit-return-pc label) - (default-unknown-values vop values nvals move-temp temp label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - -;;; Non-TR local call for a variable number of return values passed according -;;; to the unknown values convention. The results are the start of the values -;;; glob and the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (multiple-call-local unknown-values-receiver) - (:args (cfp) - (nfp) - (args :more t)) - (:save-p t) - (:move-args :local-call) - (:info save callee target) - (:ignore args save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 20 - (let ((label (gen-label)) - (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 cfp) - (inst compute-lra-from-code code-tn label temp - (callee-return-pc-tn callee)) - (note-this-location vop :call-site) - (inst b target :nullify t) - (emit-return-pc label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count label temp) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - - -;;;; Local call with known values return: - -;;; Non-TR local call with known return locations. Known-value return works -;;; just like argument passing in local call. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (known-call-local) - (:args (cfp) - (nfp) - (args :more t)) - (:results (res :more t)) - (:move-args :local-call) - (:save-p t) - (:info save callee target) - (:ignore args res save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (let ((label (gen-label)) - (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 cfp) - (inst compute-lra-from-code code-tn label temp - (callee-return-pc-tn callee)) - (note-this-location vop :call-site) - (inst b target :nullify t) - (emit-return-pc label) - (note-this-location vop :known-return) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - -;;; Return from known values call. We receive the return locations as -;;; arguments to terminate their lifetimes in the returning function. We -;;; restore FP and CSP and jump to the Return-PC. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (known-return) - (:args (ocfp :target ocfp-temp) - (return-pc :target return-pc-temp) - (vals :more t)) - (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp) - (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) - (:temporary (:scs (interior-reg)) lip) - (:move-args :known-return) - (:info val-locs) - (:ignore val-locs vals) - (:vop-var vop) - (:generator 6 - (maybe-load-stack-tn ocfp-temp ocfp) - (maybe-load-stack-tn return-pc-temp return-pc) - (move cfp-tn csp-tn) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nsp-tn))) - (inst addi (- n-word-bytes other-pointer-lowtag) return-pc-temp lip) - (inst bv lip) - (move ocfp-temp cfp-tn t))) - - -;;;; Full call: -;;; -;;; There is something of a cross-product effect with full calls. Different -;;; versions are used depending on whether we know the number of arguments or -;;; the name of the called function, and whether we want fixed values, unknown -;;; values, or a tail call. -;;; -;;; In full call, the arguments are passed creating a partial frame on the -;;; stack top and storing stack arguments into that frame. On entry to the -;;; callee, this partial frame is pointed to by FP. If there are no stack -;;; arguments, we don't bother allocating a partial frame, and instead set FP -;;; to SP just before the call. - -;;; This macro helps in the definition of full call VOPs by avoiding code -;;; replication in defining the cross-product VOPs. -;;; -;;; Name is the name of the VOP to define. -;;; -;;; Named is true if the first argument is a symbol whose global function -;;; definition is to be called. -;;; -;;; Return is either :Fixed, :Unknown or :Tail: -;;; -- If :Fixed, then the call is for a fixed number of values, returned in -;;; the standard passing locations (passed as result operands). -;;; -- If :Unknown, then the result values are pushed on the stack, and the -;;; result values are specified by the Start and Count as in the -;;; unknown-values continuation representation. -;;; -- If :Tail, then do a tail-recursive call. No values are returned. -;;; The Old-Fp and Return-PC are passed as the second and third arguments. -;;; -;;; In non-tail calls, the pointer to the stack arguments is passed as the last -;;; fixed argument. If Variable is false, then the passing locations are -;;; passed as a more arg. Variable is true if there are a variable number of -;;; arguments passed on the stack. Variable cannot be specified with :Tail -;;; return. TR variable argument call is implemented separately. -;;; -;;; 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. -;;; -(macrolet ((define-full-call (name named return variable) - (aver (not (and variable (eq return :tail)))) - `(define-vop (,name - ,@(when (eq return :unknown) - '(unknown-values-receiver))) - (:args - ,@(unless (eq return :tail) - '((new-fp :scs (any-reg) :to :eval))) - ,@(case named - ((nil) - '((arg-fun :target lexenv))) - (:direct) - (t - '((name :target name-pass)))) - - ,@(when (eq return :tail) - '((ocfp :target ocfp-pass) - (return-pc :target return-pc-pass))) - - ,@(unless variable '((args :more t :scs (descriptor-reg))))) - - ,@(when (eq return :fixed) - '((:results (values :more t)))) - - (:save-p ,(if (eq return :tail) :compute-only t)) - - ,@(unless (or (eq return :tail) variable) - '((:move-args :full-call))) - - (:vop-var vop) - (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(nargs)) - ,@(when (eq named :direct) '(fun)) - ,@(when (eq return :fixed) '(nvals)) - step-instrumenting) - - (:ignore - ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(args))) - - (:temporary (:sc descriptor-reg - :offset ocfp-offset - :from (:argument 1) - ,@(unless (eq return :fixed) - '(:to :eval))) - ocfp-pass) - - (:temporary (:sc descriptor-reg - :offset lra-offset - :from (:argument ,(if (eq return :tail) 2 1)) - :to :eval) - return-pc-pass) - - ,@(case named - ((t) - `((:temporary (:sc descriptor-reg :offset fdefn-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - name-pass))) - ((nil) - `((:temporary (:sc descriptor-reg :offset lexenv-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - lexenv) - (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) - function)))) - - (:temporary (:sc any-reg :offset nargs-offset :to :eval) - nargs-pass) - - ,@(when variable - (mapcar (lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :to :eval) - ,name)) - register-arg-names *register-arg-offsets*)) - ,@(when (eq return :fixed) - '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) - - (:temporary (:scs (descriptor-reg) :to :eval) stepping) - - ,@(unless (eq return :tail) - '((:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) - - (:temporary (:sc interior-reg :offset lip-offset) entry-point) - - (:generator ,(+ (if named 5 0) - (if variable 19 1) - (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)))) - (step-done-label (gen-label)) - (filler - (remove nil - (list :load-nargs - ,@(if (eq return :tail) - '((unless (location= ocfp ocfp-pass) - :load-ocfp) - (unless (location= return-pc - return-pc-pass) - :load-return-pc) - (when cur-nfp - :frob-nfp)) - '(:comp-lra - (when cur-nfp - :frob-nfp) - :save-fp - :load-fp)))))) - (flet ((do-next-filler () - (let* ((next (pop filler)) - (what (if (consp next) (car next) next))) - (ecase what - (:load-nargs - ,@(if variable - `((inst sub csp-tn new-fp nargs-pass) - ,@(let ((index -1)) - (mapcar (lambda (name) - `(inst ldw ,(ash (incf index) - word-shift) - new-fp - ,name)) - register-arg-names))) - '((inst li (fixnumize nargs) nargs-pass)))) - ,@(if (eq return :tail) - '((:load-ocfp - (sc-case ocfp - (any-reg - (move ocfp ocfp-pass t)) - (control-stack - (inst ldw (ash (tn-offset ocfp) - word-shift) - cfp-tn ocfp-pass)))) - (:load-return-pc - (sc-case return-pc - (descriptor-reg - (move return-pc return-pc-pass t)) - (control-stack - (inst ldw (ash (tn-offset return-pc) - word-shift) - cfp-tn return-pc-pass)))) - (:frob-nfp - (inst ldo (- (bytes-needed-for-non-descriptor-stack-frame)) - nsp-tn nsp-tn))) - `((:comp-lra - (inst compute-lra-from-code code-tn lra-label - temp return-pc-pass)) - (:frob-nfp - (store-stack-tn nfp-save cur-nfp)) - (:save-fp - (move cfp-tn ocfp-pass t)) - (:load-fp - ,(if variable - '(move new-fp cfp-tn) - '(if (> nargs register-arg-count) - (move new-fp cfp-tn) - (move csp-tn cfp-tn)))))) - ((nil) - (inst nop))))) - (insert-step-instrumenting (callable-tn) - ;; Conditionally insert a conditional trap: - (when step-instrumenting - (load-symbol-value stepping sb-impl::*stepping*) - ;; If it's not zero, trap. - (inst comb := stepping zero-tn step-done-label :nullify t) - ;; CONTEXT-PC will be pointing here when the - ;; interrupt is handled, not after the BREAK. - (note-this-location vop :internal-error) - ;; Construct a trap code with the low bits from - ;; SINGLE-STEP-AROUND-TRAP and the high bits from - ;; the register number of CALLABLE-TN. - (inst break 0 (logior single-step-around-trap - (ash (reg-tn-encoding callable-tn) - 5))) - (emit-label step-done-label)))) - (declare (ignorable #'insert-step-instrumenting)) - ,@(case named - ((t) - `((sc-case name - (descriptor-reg (move name name-pass)) - (control-stack - (inst ldw (tn-byte-offset name) - cfp-tn name-pass) - (do-next-filler)) - (constant - (inst ldw (- (tn-byte-offset name) - other-pointer-lowtag) - code-tn name-pass) - (do-next-filler))) - ;; The step instrumenting must be done after - ;; FUNCTION is loaded, but before ENTRY-POINT is - ;; calculated. - (insert-step-instrumenting name-pass) - (inst ldw (- (ash fdefn-raw-addr-slot word-shift) - other-pointer-lowtag) - name-pass entry-point) - (do-next-filler))) - ((nil) - `((sc-case arg-fun - (descriptor-reg - (move arg-fun lexenv)) - (control-stack - (inst ldw (tn-byte-offset arg-fun) - cfp-tn lexenv) - (do-next-filler)) - (constant - (inst ldw - (- (tn-byte-offset arg-fun) - other-pointer-lowtag) code-tn lexenv) - (do-next-filler))) - (inst ldw (- (ash closure-fun-slot word-shift) - fun-pointer-lowtag) - lexenv function) - (do-next-filler) - ;; The step instrumenting must be done before - ;; after FUNCTION is loaded, but before ENTRY-POINT - ;; is calculated. - (insert-step-instrumenting function) - (inst addi (- (ash simple-fun-insts-offset word-shift) - fun-pointer-lowtag) - function entry-point))) - (:direct - `((inst ldw (static-fun-offset fun) null-tn entry-point)))) - (loop - (if (cdr filler) - (do-next-filler) - (return))) - - (do-next-filler) - (note-this-location vop :call-site) - (inst bv entry-point :nullify t)) - - ,@(ecase return - (:fixed - '((emit-return-pc lra-label) - (default-unknown-values vop values nvals - move-temp temp 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 temp) - (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) - (define-full-call static-call-named :direct :fixed nil) - (define-full-call multiple-call nil :unknown nil) - (define-full-call multiple-call-named t :unknown nil) - (define-full-call static-multiple-call-named :direct :unknown nil) - (define-full-call tail-call nil :tail nil) - (define-full-call tail-call-named t :tail nil) - (define-full-call static-tail-call-named :direct :tail nil) - - (define-full-call call-variable nil :fixed t) - (define-full-call multiple-call-variable nil :unknown t)) - - -;;; Defined separately, since needs special code that blits the arguments -;;; down. -;;; -(define-vop (tail-call-variable) - (:args (args-arg :scs (any-reg) :target args) - (function-arg :scs (descriptor-reg) :target lexenv) - (ocfp-arg :scs (any-reg) :target ocfp) - (lra-arg :scs (descriptor-reg) :target lra)) - - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) - (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) - (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp) - (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) - (:temporary (:scs (any-reg) :from (:argument 3)) tmp) - (:vop-var vop) - (:generator 75 - ;; Move these into the passing locations if they are not already there. - (move args-arg args) - (move function-arg lexenv) - (move ocfp-arg ocfp) - (move lra-arg lra) - ;; And jump to the assembly-routine that does the bliting. - (let ((fixup (make-fixup 'tail-call-variable :assembly-routine))) - (inst ldil fixup tmp) - (inst be fixup lisp-heap-space tmp)) - ;; Pull the number stack if anything is there. - (let ((cur-nfp (current-nfp-tn vop))) - (if cur-nfp - ;;; NSP is restored by setting it to NSP, - ;;; because stack grows towards higher addresses. - (move cur-nfp nsp-tn) - (inst nop))))) - - -;;;; Unknown values return: - -;;; Return a single value using the unknown-values convention. -;;; -;;; NSP is restored by setting it to NSP, because stack grows -;;; towards higher addresses. -(define-vop (return-single) - (:args (ocfp :scs (any-reg)) - (return-pc :scs (descriptor-reg)) - (value)) - (:ignore value) - (:vop-var vop) - (:generator 6 - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nsp-tn))) - ;; Clear the control stack, and restore the frame pointer. - (move cfp-tn csp-tn) - (move ocfp cfp-tn) - ;; Out of here. - (lisp-return return-pc :offset 2))) - -;;; 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 -;;; number of values returned. -;;; -;;; If returning a single value, then deallocate the current frame, restore -;;; FP and jump to the single-value entry at Return-PC + 8. -;;; -;;; If returning other than one value, then load the number of values returned, -;;; NIL out unsupplied values registers, restore FP and return at Return-PC. -;;; When there are stack values, we must initialize the argument pointer to -;;; point to the beginning of the values block (which is the beginning of the -;;; current frame.) -;;; -(define-vop (return) - (:args (ocfp :scs (any-reg)) - (return-pc :scs (descriptor-reg) :to (:eval 1)) - (values :more t)) - (:ignore values) - (:info nvals) - (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) - (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1) - (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2) - (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) - (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4) - (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) - - (:vop-var vop) - (:generator 6 - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nsp-tn))) - (cond - ((= nvals 1) ;; Clear the control stack, and restore the frame pointer - (move cfp-tn csp-tn) - (move ocfp cfp-tn) - ;; Out of here. - (lisp-return return-pc :offset 2)) - (t - ;; Establish the values pointer and values count. - (move cfp-tn val-ptr) - (inst li (fixnumize nvals) nargs) - ;; restore the frame pointer and clear as much of the control - ;; stack as possible. - (move ocfp cfp-tn) - (inst ldo (* nvals n-word-bytes) val-ptr csp-tn) - (aver (= (* nvals n-word-bytes) (fixnumize nvals))) - ;; pre-default any argument register that need it. - (when (< nvals register-arg-count) - (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) - (move null-tn reg))) - ;; And away we go. - (lisp-return return-pc))))) - -;;; Do unknown-values return of an arbitrary number of values (passed on the -;;; stack.) We check for the common case of a single return value, and do that -;;; inline using the normal single value return convention. Otherwise, we -;;; branch off to code that calls an assembly-routine. -;;; -(define-vop (return-multiple) - (:args (ocfp-arg :scs (any-reg) :target ocfp) - (lra-arg :scs (descriptor-reg) :target lra) - (vals-arg :scs (any-reg) :target vals) - (nvals-arg :scs (any-reg) :target nvals)) - - (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp) - (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) - (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) - (:temporary (:sc descriptor-reg :offset a0-offset) a0) - (:temporary (:scs (any-reg) :from (:eval 0)) tmp) - (:vop-var vop) - (:generator 13 - (let ((not-single (gen-label))) - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nsp-tn))) - ;; Check for the single case. - (inst comib :<> (fixnumize 1) nvals-arg not-single) - (loadw a0 vals-arg) - ;; Return with one value. - (move cfp-tn csp-tn) - (move ocfp-arg cfp-tn) - (lisp-return lra-arg :offset 2) - ;; Nope, not the single case. - (emit-label not-single) - ;; most of these moves will not be emitted and therefor - ;; isn't suitable to put in the delay slot below. But if - ;; you do, dont forget to force-emit as in (move src dst t) - (move ocfp-arg ocfp) - (move lra-arg lra) - (move vals-arg vals) - (move nvals-arg nvals) - (let ((fixup (make-fixup 'return-multiple :assembly-routine))) - (inst ldil fixup tmp) - (inst be fixup lisp-heap-space tmp :nullify t))))) - - -;;;; XEP hackery: - -;;; Get the lexical environment from its passing location. -;;; -(define-vop (setup-closure-environment) - (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure - :to (:result 0)) - lexenv) - (:results (closure :scs (descriptor-reg))) - (:info label) - (:ignore label) - (:generator 6 - ;; Get result. - (move lexenv closure))) - -;;; Copy a more arg from the argument area to the end of the current frame. -;;; Fixed is the number of non-more arguments. -;;; FIXME-lav: old hppa code look smarter. -(define-vop (copy-more-arg) - (:temporary (:sc any-reg :offset nl0-offset) result) - (:temporary (:sc any-reg :offset nl1-offset) count) - (:temporary (:sc any-reg :offset nl2-offset) src) - (:temporary (:sc any-reg :offset nl3-offset) dst) - (:temporary (:sc descriptor-reg :offset l0-offset) temp) - (:info fixed) - (:generator 20 - (let ((loop (gen-label)) - (do-regs (gen-label)) - (done (gen-label))) - (when (< fixed register-arg-count) - ;; Save a pointer to the results so we can fill in register args. - ;; We don't need this if there are more fixed args than reg args. - (move csp-tn result)) - ;; Allocate the space on the stack. - (cond ((zerop fixed) - (inst comb := nargs-tn zero-tn done) - (inst add nargs-tn csp-tn csp-tn)) - (t - (inst addi (fixnumize (- fixed)) nargs-tn count) - (inst comb :<= count zero-tn done :nullify t) - (inst add count csp-tn csp-tn))) - (when (< fixed register-arg-count) - ;; We must stop when we run out of stack args, not when we run out of - ;; more args. - (inst addi (fixnumize (- register-arg-count)) nargs-tn count)) - ;; Everything of interest in registers. - (inst comb :<= count zero-tn do-regs) - ;; Initialize dst to be end of stack. - (move csp-tn dst t) - ;; Initialize src to be end of args. - (inst add nargs-tn cfp-tn src) - - (emit-label loop) - ;; decrease src, then load src into temp - (inst ldwm (- n-word-bytes) src temp) - ;; increase, compare if count >= to zero, if true, jump - (inst addib :>= (fixnumize -1) count loop) - ;; decrease dst, then store temp at dst - (inst stwm temp (- n-word-bytes) dst) - - (emit-label do-regs) - (when (< fixed register-arg-count) - ;; Now we have to deposit any more args that showed up in registers. - ;; We know there is at least one more arg, otherwise we would have - ;; branched to done up at the top. - (inst addi (- (fixnumize (1+ fixed))) nargs-tn count) - (do ((i fixed (1+ i))) - ((>= i register-arg-count)) - ;; Is this the last one? - (inst comb := count zero-tn done) - ;; Store it relative to the pointer saved at the start. - (storew (nth i *register-arg-tns*) result (- i fixed)) - ;; Decrement count. - (inst addi (- (fixnumize 1)) count count))) - (emit-label done)))) - -;;; More args are stored consequtively on the stack, starting immediately at -;;; the context pointer. The context pointer is not typed, so the lowtag is 0. -;;; -(define-vop (more-arg) - (:translate %more-arg) - (:policy :fast-safe) - (:args (context :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types * tagged-num) - (:temporary (:scs (any-reg)) temp) - (:results (value :scs (descriptor-reg any-reg))) - (:result-types *) - (:generator 5 - (inst add context index temp) - (loadw value temp))) -(define-vop (more-arg-c) - (:translate %more-arg) - (:policy :fast-safe) - (:args (context :scs (descriptor-reg))) - (:info index) - (:arg-types * (:constant (load/store-index 8 0 0))) - (:results (value :scs (descriptor-reg any-reg))) - (:result-types *) - (:generator 4 - (loadw value context index))) - -;;; Turn more arg (context, count) into a list. -(define-vop () - (:translate %listify-rest-args) - (:args (context-arg :target context :scs (descriptor-reg)) - (count-arg :target count :scs (any-reg))) - (:arg-types * tagged-num) - (:temporary (:scs (any-reg) :from (:argument 0)) context) - (:temporary (:scs (any-reg) :from (:argument 1)) count) - (:temporary (:scs (descriptor-reg) :from :eval) temp dst) - (:results (result :scs (descriptor-reg))) - (:policy :safe) - (:node-var node) - (:generator 20 - (let* ((enter (gen-label)) - (loop (gen-label)) - (done (gen-label)) - (dx-p (node-stack-allocate-p node)) - (alloc-area-tn (if dx-p csp-tn alloc-tn))) - (move context-arg context) - (move count-arg count) - ;; Check to see if there are any arguments. - (inst comb := count zero-tn done) - (move null-tn result t) - - ;; We need to do this atomically. - (pseudo-atomic () - (when dx-p - (align-csp temp)) - ;; Allocate a cons (2 words) for each item. - (set-lowtag list-pointer-lowtag alloc-area-tn result) - (move result dst) - (inst sll count 1 temp) - (inst b enter) - (inst add temp alloc-area-tn alloc-area-tn) - - ;; Store the current cons in the cdr of the previous cons. - (emit-label loop) - (inst addi (* 2 n-word-bytes) dst dst) - (storew dst dst -1 list-pointer-lowtag) - - (emit-label enter) - ;; Grab one value. - (inst ldwm n-word-bytes context temp) - ;; Dec count, and if != zero, go back for more. - (inst addib :<> (fixnumize -1) count loop) - ;; Store the value in the car (in delay slot) - (storew temp dst 0 list-pointer-lowtag) - - ;; NIL out the last cons. - (storew null-tn dst 1 list-pointer-lowtag)) - (emit-label done)))) - -;;; Return the location and size of the more arg glob created by Copy-More-Arg. -;;; Supplied is the total number of arguments supplied (originally passed in -;;; NARGS.) Fixed is the number of non-rest arguments. -;;; -;;; We must duplicate some of the work done by Copy-More-Arg, since at that -;;; time the environment is in a pretty brain-damaged state, preventing this -;;; info from being returned as values. What we do is compute -;;; supplied - fixed, and return a pointer that many words below the current -;;; stack top. -;;; -(define-vop () - (:policy :fast-safe) - (:translate sb-c::%more-arg-context) - (:args (supplied :scs (any-reg))) - (:arg-types tagged-num (:constant fixnum)) - (:info fixed) - (:results (context :scs (descriptor-reg)) - (count :scs (any-reg))) - (:result-types t tagged-num) - (:note "more-arg-context") - (:generator 5 - (inst addi (fixnumize (- fixed)) supplied count) - (inst sub csp-tn count context))) - -(define-vop (verify-arg-count) - (:policy :fast-safe) - (:args (nargs :scs (any-reg))) - (:arg-types positive-fixnum (:constant t) (:constant t)) - (:info min max) - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (let ((err-lab - (generate-error-code vop 'invalid-arg-count-error nargs))) - (cond ((not min) - (if (zerop max) - (inst bc :<> nil nargs zero-tn err-lab) - (inst bci :<> nil (fixnumize max) nargs err-lab))) - (max - (when (plusp min) - (inst bci :> nil (fixnumize min) nargs err-lab)) - (inst bci :< nil (fixnumize max) nargs err-lab)) - ((plusp min) - (inst bci :> nil (fixnumize min) nargs err-lab)))))) - -;;; Single-stepping - -(define-vop (step-instrument-before-vop) - (:temporary (:scs (descriptor-reg)) stepping) - (:policy :fast-safe) - (:vop-var vop) - (:generator 3 - (load-symbol-value stepping sb-impl::*stepping*) - ;; If it's not zero, trap. - (inst comb := stepping zero-tn DONE :nullify t) - ;; CONTEXT-PC will be pointing here when the interrupt is handled, - ;; not after the BREAK. - (note-this-location vop :internal-error) - ;; CALLEE-REGISTER-OFFSET isn't needed for before-traps, so we - ;; can just use a bare SINGLE-STEP-BEFORE-TRAP as the code. - (inst break 0 single-step-before-trap) - DONE)) diff -Nru sbcl-2.0.6/src/compiler/hppa/c-call.lisp sbcl-2.1.1/src/compiler/hppa/c-call.lisp --- sbcl-2.0.6/src/compiler/hppa/c-call.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/c-call.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,324 +0,0 @@ -;;;; VOPs and other machine-specific support routines for call-out to C - -;;;; 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") - -(defstruct arg-state - (stack-frame-size 0) - (float-args 0) - nargs) - -;;; beware that we deal alot here with register-offsets directly -;;; instead of their symbol-name in vm.lisp -;;; offset works differently depending on sc-type -(defun my-make-wired-tn (prim-type-name sc-name offset state) - (make-wired-tn (primitive-type-or-lose prim-type-name) - (sc-number-or-lose sc-name) - ;; try to utilize vm.lisp definitions of registers: - (ecase sc-name - ((any-reg sap-reg signed-reg unsigned-reg) - (ecase offset ; FIX: port to other arch ??? - ;(:nfp-offset offset) - (0 nl0-offset) ; On other arch we can - (1 nl1-offset) ; just add an offset to - (2 nl2-offset) ; beginning of args, but on - (3 nl3-offset) ; hppa c-args are spread. - (4 nl4-offset) ; These two are for - (5 nl5-offset))) ; c-return values - ((single-int-carg-reg double-int-carg-reg) - (ecase offset ; FIX: port to other arch ??? - (0 nl0-offset) - (1 nl1-offset) - (2 nl2-offset) - (3 nl3-offset))) - ((single-reg double-reg) ; only for return - (+ 4 offset)) - ;; A tn of stack type tells us that we have data on - ;; stack. This offset is current argument number so - ;; -1 points to the correct place to write that data - ((sap-stack signed-stack unsigned-stack) - (- (arg-state-nargs state) offset 8 1))))) - -(define-alien-type-method (integer :arg-tn) (type state) - (let ((stack-frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (multiple-value-bind - (ptype reg-sc stack-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-32 'signed-reg 'signed-stack) - (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)) - (if (< stack-frame-size 4) - (my-make-wired-tn ptype reg-sc stack-frame-size state) - (my-make-wired-tn ptype stack-sc stack-frame-size state))))) - -(define-alien-type-method (system-area-pointer :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (if (< stack-frame-size 4) - (my-make-wired-tn 'system-area-pointer - 'sap-reg - stack-frame-size state) - (my-make-wired-tn 'system-area-pointer - 'sap-stack - stack-frame-size state)))) - -(define-alien-type-method (double-float :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1)) - (float-args (arg-state-float-args state))) - (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2)) - (setf (arg-state-float-args state) (+ 2 float-args)) - (cond ((>= stack-frame-size 4) - (my-make-wired-tn 'double-float - 'double-stack - stack-frame-size state)) - (t - (my-make-wired-tn 'double-float - 'double-reg - (1+ float-args) state))))) - -(define-alien-type-method (single-float :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (arg-state-stack-frame-size state)) - (float-args (arg-state-float-args state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (setf (arg-state-float-args state) (1+ float-args)) - (cond ((>= stack-frame-size 4) - (my-make-wired-tn 'single-float - 'single-stack - stack-frame-size state)) - (t - (my-make-wired-tn 'single-float - 'single-reg - float-args state))))) - -(defstruct result-state - (num-results 0)) - -(define-alien-type-method (integer :result-tn) (type state) - (let ((num-results (result-state-num-results state))) - (setf (result-state-num-results state) (1+ num-results)) - (multiple-value-bind (ptype reg-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-32 'signed-reg) - (values 'unsigned-byte-32 'unsigned-reg)) - (if (> num-results 1) (error "Too many result values from c-call.")) - (my-make-wired-tn ptype reg-sc (+ num-results 4) state)))) - -(define-alien-type-method (system-area-pointer :result-tn) (type state) - (declare (ignore type)) - (let ((num-results (result-state-num-results state))) - (setf (result-state-num-results state) (1+ num-results)) - (if (> num-results 1) (error "Too many result values from c-call.")) - (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 4) state))) - -(define-alien-type-method (double-float :result-tn) (type state) - (declare (ignore type)) - (let ((num-results (result-state-num-results state))) - (setf (result-state-num-results state) (1+ num-results)) - (my-make-wired-tn 'double-float 'double-reg (* num-results 2) state))) - -(define-alien-type-method (single-float :result-tn) (type state) - (declare (ignore type)) - (let ((num-results (result-state-num-results state))) - (setf (result-state-num-results state) (1+ num-results)) - (my-make-wired-tn 'single-float 'single-reg (* num-results 2) state))) - -(define-alien-type-method (values :result-tn) (type state) - (let ((values (alien-values-type-values type))) - (when (> (length values) 2) - (error "Too many result values from c-call.")) - (mapcar (lambda (type) - (invoke-alien-type-method :result-tn type state)) - values))) - -(defun make-call-out-tns (type) - (let ((arg-state (make-arg-state)) - (nargs 0)) - (dolist (arg-type (alien-fun-type-arg-types type)) - (cond - ((alien-double-float-type-p arg-type) - (incf nargs (logior (1+ nargs) 1))) - (t (incf nargs)))) - (setf (arg-state-nargs arg-state) (logandc2 (+ nargs 8 15) 15)) - (collect ((arg-tns)) - (dolist (arg-type (alien-fun-type-arg-types type)) - (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) - (values (make-normal-tn *fixnum-primitive-type*) - (* n-word-bytes (logandc2 (+ nargs 8 15) 15)) - (arg-tns) - (invoke-alien-type-method :result-tn - (alien-fun-type-result-type type) - (make-result-state)))))) - -(deftransform %alien-funcall ((function type &rest args)) - (aver (sb-c::constant-lvar-p type)) - (let* ((type (sb-c::lvar-value type)) - (env (make-null-lexenv)) - (arg-types (alien-fun-type-arg-types type)) - (result-type (alien-fun-type-result-type type))) - (aver (= (length arg-types) (length args))) - ;; We need to do something special for 64-bit integer arguments - ;; and results. - (if (or (some (lambda (type) - (and (alien-integer-type-p type) - (> (sb-alien::alien-integer-type-bits type) 32))) - arg-types) - (and (alien-integer-type-p result-type) - (> (sb-alien::alien-integer-type-bits result-type) 32))) - (collect ((new-args) (lambda-vars) (new-arg-types)) - (dolist (type arg-types) - (let ((arg (gensym))) - (lambda-vars arg) - (cond ((and (alien-integer-type-p type) - (> (sb-alien::alien-integer-type-bits type) 32)) - ;; 64-bit long long types are stored in - ;; consecutive locations, endian word order, - ;; aligned to 8 bytes. - (when (oddp (length (new-args))) - (new-args nil)) - (progn (new-args `(ash ,arg -32)) - (new-args `(logand ,arg #xffffffff)) - (if (oddp (length (new-arg-types))) - (new-arg-types (parse-alien-type '(unsigned 32) env))) - (if (alien-integer-type-signed type) - (new-arg-types (parse-alien-type '(signed 32) env)) - (new-arg-types (parse-alien-type '(unsigned 32) env))) - (new-arg-types (parse-alien-type '(unsigned 32) env)))) - (t - (new-args arg) - (new-arg-types type))))) - (cond ((and (alien-integer-type-p result-type) - (> (sb-alien::alien-integer-type-bits result-type) 32)) - (let ((new-result-type - (let ((sb-alien::*values-type-okay* t)) - (parse-alien-type - (if (alien-integer-type-signed result-type) - '(values (signed 32) (unsigned 32)) - '(values (unsigned 32) (unsigned 32))) - env)))) - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (multiple-value-bind - (high low) - (%alien-funcall function - ',(make-alien-fun-type - :arg-types (new-arg-types) - :result-type new-result-type) - ,@(new-args)) - (logior low (ash high 32)))))) - (t - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (%alien-funcall function - ',(make-alien-fun-type - :arg-types (new-arg-types) - :result-type result-type) - ,@(new-args)))))) - (sb-c::give-up-ir1-transform)))) - -(define-vop (foreign-symbol-sap) - (:translate foreign-symbol-sap) - (:policy :fast-safe) - (:args) - (:arg-types (:constant simple-string)) - (:info foreign-symbol) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst li (make-fixup foreign-symbol :foreign) res))) - -#+linkage-table -(define-vop (foreign-symbol-dataref-sap) - (:translate foreign-symbol-dataref-sap) - (:policy :fast-safe) - (:args) - (:arg-types (:constant simple-string)) - (:info foreign-symbol) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:temporary (:scs (non-descriptor-reg)) addr) - (:generator 2 - (inst li (make-fixup foreign-symbol :foreign-dataref) addr) - (loadw res addr))) - -(define-vop (call-out) - (:args (function :scs (sap-reg) :target cfunc) - (args :more t)) - (:results (results :more t)) - (:ignore args results) - (:save-p t) - (:temporary (:sc any-reg :offset cfunc-offset - :from (:argument 0) :to (:result 0)) cfunc) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - ;; Not sure if using nargs is safe ( have we saved it ). - ;; but we cant use any non-descriptor-reg because c-args nl-4 is of that type - (:temporary (:sc non-descriptor-reg :offset nargs-offset) temp) - (:vop-var vop) - (:generator 0 - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((fixup (make-fixup "call_into_c" :foreign))) - (inst ldil fixup temp) - (inst ble fixup c-text-space temp) - (move function cfunc t)) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - -(define-vop (alloc-number-stack-space) - (:info amount) - (:result-types system-area-pointer) - (:results (result :scs (sap-reg any-reg))) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - ;; Because stack grows to higher addresses, we have the result - ;; pointing to an lowerer address than nsp - (move nsp-tn result) - (unless (zerop amount) - ;; hp-ux stack grows towards larger addresses and stack must be - ;; allocated in blocks of 64 bytes - (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16 - (cond ((< delta (ash 1 10)) - (inst addi delta nsp-tn nsp-tn)) - (t - (inst li delta temp) - (inst add nsp-tn temp nsp-tn))))))) - -(define-vop (dealloc-number-stack-space) - (:info amount) - (:policy :fast-safe) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (unless (zerop amount) - (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16 - (cond ((< delta (ash 1 10)) - (inst addi (- delta) nsp-tn nsp-tn)) - (t - (inst li (- delta) temp) - (inst sub nsp-tn temp nsp-tn))))))) - -#-sb-xc-host -(defun alien-callback-accessor-form (type sap offset) - (let ((parsed-type type)) - (if (alien-integer-type-p parsed-type) - (let ((bits (sb-alien::alien-integer-type-bits parsed-type))) - (let ((byte-offset - (cond ((< bits n-word-bits) - (- n-word-bytes - (ceiling bits n-byte-bits))) - (t 0)))) - `(deref (sap-alien (sap+ ,sap - ,(+ byte-offset offset)) - (* ,type))))) - `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))))) - diff -Nru sbcl-2.0.6/src/compiler/hppa/cell.lisp sbcl-2.1.1/src/compiler/hppa/cell.lisp --- sbcl-2.0.6/src/compiler/hppa/cell.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/cell.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,450 +0,0 @@ -;;;; the VM definition of various primitive memory access VOPs for -;;;; HPPA - -;;;; 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") - -;;;; Data object ref/set stuff. - -(define-vop (slot) - (:args (object :scs (descriptor-reg))) - (:info name offset lowtag) - (:ignore name) - (:results (result :scs (descriptor-reg any-reg))) - (:generator 1 - (loadw result object offset lowtag))) - -(define-vop (set-slot) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg null 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)) - -;;;; Symbol hacking VOPs: - -;;; The compiler likes to be able to directly SET symbols. -(define-vop (set cell-set) - (:variant symbol-value-slot other-pointer-lowtag)) - -;;; Do a cell ref with an error check for being unbound. -(define-vop (checked-cell-ref) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) - -;;; With Symbol-Value, we check that the value isn't the trap object. So -;;; Symbol-Value of NIL is NIL. -(define-vop (symbol-value checked-cell-ref) - (:translate symeval) - (:generator 9 - (move object obj-temp) - (loadw value obj-temp symbol-value-slot other-pointer-lowtag) - (let ((err-lab (generate-error-code vop 'unbound-symbol-error obj-temp))) - (inst li unbound-marker-widetag temp) - (inst bc := nil value temp err-lab)))) - -;;; 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) - (:temporary (:scs (non-descriptor-reg)) temp)) - -(define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst li unbound-marker-widetag temp) - (inst bc :<> not-p value temp target))) - -(define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-lowtag) - (:policy :fast) - (:translate symeval)) - -(define-vop (symbol-hash) - (:policy :fast-safe) - (:translate symbol-hash) - (:args (symbol :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:generator 2 - (loadw temp symbol symbol-hash-slot other-pointer-lowtag) - (inst dep 0 31 n-fixnum-tag-bits temp) - ;; we must go through an temporary to avoid gc - (move temp res))) - -;;; On unithreaded builds these are just copies of the non-global versions. -(define-vop (%set-symbol-global-value set)) -(define-vop (symbol-global-value symbol-value) - (:translate sym-global-val)) -(define-vop (fast-symbol-global-value fast-symbol-value) - (:translate sym-global-val)) - -;;;; Fdefinition (fdefn) objects. - -(define-vop (fdefn-fun cell-ref) - (:variant fdefn-fun-slot other-pointer-lowtag)) - -(define-vop (safe-fdefn-fun) - (:translate safe-fdefn-fun) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) - (:generator 10 - (move obj-temp object) - (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag) - (let ((err-lab (generate-error-code vop 'undefined-fun-error obj-temp))) - (inst bc := nil value null-tn err-lab)))) - -(define-vop (set-fdefn-fun) - (:policy :fast-safe) - (:translate (setf fdefn-fun)) - (:args (function :scs (descriptor-reg) :target result) - (fdefn :scs (descriptor-reg))) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg)) type) - (:results (result :scs (descriptor-reg))) - (:generator 38 - (let ((normal-fn (gen-label))) - (load-type type function (- fun-pointer-lowtag)) - (inst addi (- simple-fun-widetag) type type) - (inst comb := type zero-tn normal-fn) - (inst addi (- (ash simple-fun-insts-offset word-shift) fun-pointer-lowtag) - function lip) - (inst li (make-fixup 'closure-tramp :assembly-routine) lip) - (emit-label normal-fn) - (storew function fdefn fdefn-fun-slot other-pointer-lowtag) - (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) - (move function result)))) - -(define-vop (fdefn-makunbound) - (:policy :fast-safe) - (:translate fdefn-makunbound) - (:args (fdefn :scs (descriptor-reg) :target result)) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 38 - (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag) - (inst li (make-fixup 'undefined-tramp :assembly-routine) temp) - (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag) - (move fdefn result))) - - -;;;; Binding and Unbinding. - -;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and -;;; the symbol on the binding stack and stuff the new value into the -;;; symbol. -;;; -;;; See the "Chapter 9: Specials" of the SBCL Internals Manual. - -(define-vop (dynbind) - (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:generator 5 - (loadw temp symbol symbol-value-slot other-pointer-lowtag) - (inst addi (* 2 n-word-bytes) bsp-tn bsp-tn) - (storew temp bsp-tn (- binding-value-slot binding-size)) - (storew symbol bsp-tn (- binding-symbol-slot binding-size)) - (storew val symbol symbol-value-slot other-pointer-lowtag))) - -(define-vop (unbind) - (:temporary (:scs (descriptor-reg)) symbol value) - (:generator 0 - (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) - (loadw value bsp-tn (- binding-value-slot binding-size)) - (storew value symbol symbol-value-slot other-pointer-lowtag) - (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) - (storew zero-tn bsp-tn (- binding-value-slot binding-size)) - (inst addi (- (* 2 n-word-bytes)) bsp-tn bsp-tn))) - -(define-vop (unbind-to-here) - (:args (arg :scs (descriptor-reg any-reg) :target where)) - (:temporary (:scs (any-reg) :from (:argument 0)) where) - (:temporary (:scs (descriptor-reg)) symbol value) - (:generator 0 - (let ((loop (gen-label)) - (skip (gen-label)) - (done (gen-label))) - (move arg where) - (inst comb := where bsp-tn done :nullify t) - - (emit-label loop) - (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) - (inst comb := symbol zero-tn skip) - (loadw value bsp-tn (- binding-value-slot binding-size)) - (storew value symbol symbol-value-slot other-pointer-lowtag) - (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) - - (emit-label skip) - (storew zero-tn bsp-tn (- binding-value-slot binding-size)) - (inst addi (* -2 n-word-bytes) bsp-tn bsp-tn) - (inst comb :<> where bsp-tn loop) - (inst nop) - (emit-label done)))) - - -;;;; Closure indexing. - -(define-full-reffer closure-index-ref * - 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 zero) * %set-funcallable-instance-info) - -(define-full-reffer funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (descriptor-reg any-reg) * %funcallable-instance-info) - -(define-vop (closure-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:info offset) - (:generator 4 - (loadw value object (+ closure-info-offset offset) fun-pointer-lowtag))) - -(define-vop (closure-init) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:info offset) - (:generator 4 - (storew value object (+ closure-info-offset offset) fun-pointer-lowtag))) - -(define-vop (closure-init-from-fp) - (:args (object :scs (descriptor-reg))) - (:info offset) - (:generator 4 - (storew cfp-tn object (+ closure-info-offset offset) fun-pointer-lowtag))) - -;;;; Value Cell hackery. - -(define-vop (value-cell-ref cell-ref) - (:variant value-cell-value-slot other-pointer-lowtag)) - -(define-vop (value-cell-set cell-set) - (:variant value-cell-value-slot other-pointer-lowtag)) - - - -;;;; Instance hackery: - -(define-vop () - (:policy :fast-safe) - (:translate %instance-length) - (:args (struct :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 4 - (loadw res struct 0 instance-pointer-lowtag) - (inst srl res instance-length-shift res))) - -(define-full-reffer instance-index-ref * instance-slots-offset - instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref) - -(define-full-setter instance-index-set * instance-slots-offset - instance-pointer-lowtag (descriptor-reg any-reg null zero) * %instance-set) - - - -;;;; Code object frobbing. - -(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 zero) * code-header-set) - - -;;;; raw instance slot accessors -(macrolet ((lfloat (imm base dst &key side) - `(cond - ((< ,imm (ash 1 4)) - (inst flds ,imm ,base ,dst :side ,side)) - ((and (< ,imm (ash 1 13)) - (> ,imm 0)) - (progn - (inst li ,imm offset) - (inst fldx offset ,base ,dst :side ,side))) - (t - (error "inst fldx cant handle offset-register loaded with immediate ~s" ,imm)))) - (sfloat (src imm base &key side) - `(cond - ((< ,imm (ash 1 4)) - (inst fsts ,src ,imm ,base :side ,side)) - ((and (< ,imm (ash 1 13)) - (> ,imm 0)) - (progn - (inst ldo ,imm zero-tn offset) - (inst fstx ,src offset ,base :side ,side))) - (t - (error "inst fstx cant handle offset-register loaded with immediate ~s" ,imm)))) - (raw-instance ((type inc-offset-by set &optional complex) - &body body) - (declare (ignore inc-offset-by)) ; FIXME: remove - (let ((name (symbolicate "RAW-INSTANCE-" - (if set "SET/" "REF/") - (case type - (unsigned "WORD") - (signed "SIGNED-WORD") - (t (or complex type))))) - (type-num (cond - ((eq type 'single) - (if complex 'complex-single-float - 'single-float)) - ((eq type 'double) - (if complex 'complex-double-float - 'double-float)) - (t (symbolicate type "-NUM")))) - (type-reg (symbolicate (or complex type) "-REG"))) - `(define-vop (,name) - (:translate ,(symbolicate "%" name)) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - ,@(if set - `((value :scs (,type-reg) :target result)))) - (:arg-types * positive-fixnum ,@(if set `(,type-num))) - (:results (,(if set 'result 'value) :scs (,type-reg))) - ;; Floating-point load/store might need an extra register - ;; since an immediate displacement is only 5 signed bits. - ,@(if (member type '(single double)) - '((:temporary (:scs (non-descriptor-reg)) offset))) - (:temporary (:scs (interior-reg)) lip) - (:result-types ,type-num) - (:generator 5 - (inst add index object lip) - ,@body))))) - (raw-instance (unsigned -1 nil) - (inst ldw (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) lip value)) - - (raw-instance (unsigned -1 t) - (inst stw value (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) lip) - (move value result)) - - (raw-instance (signed -1 nil) - (inst ldw (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) lip value)) - - (raw-instance (signed -1 t) - (inst stw value (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) lip) - (move value result)) - - (raw-instance (single -1 nil) - (let ((io (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag))) - (lfloat io lip value))) - - (raw-instance (single -1 t) - (let ((io (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag))) - (sfloat value io lip)) - (unless (location= result value) - (inst funop :copy value result))) - - (raw-instance (double -2 nil) - (let ((io (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag))) - (lfloat io lip value))) - - (raw-instance (double -2 t) - (let ((io (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag))) - (sfloat value io lip :side 0)) - (let ((io (- (* (1+ instance-slots-offset) n-word-bytes) - instance-pointer-lowtag))) - (sfloat value io lip :side 1)) - (unless (location= result value) - (inst funop :copy value result))) - - (raw-instance (single -2 nil complex-single) - (let ((io (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag))) - (lfloat io lip (complex-single-reg-real-tn value))) - (let ((io (- (* (1+ instance-slots-offset) n-word-bytes) - instance-pointer-lowtag))) - (lfloat io lip (complex-single-reg-imag-tn value)))) - - (raw-instance (single -2 t complex-single) - (let ((value-real (complex-single-reg-real-tn value)) - (result-real (complex-single-reg-real-tn result)) - (io (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag))) - - (sfloat value-real io lip) - (unless (location= result-real value-real) - (inst funop :copy value-real result-real))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result)) - (io (- (* (1+ instance-slots-offset) n-word-bytes) - instance-pointer-lowtag))) - (sfloat value-imag io lip) - (unless (location= result-imag value-imag) - (inst funop :copy value-imag result-imag)))) - - (raw-instance (double -4 nil complex-double) - (let ((r0 (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag)) - (r1 (- (* (+ instance-slots-offset 1) n-word-bytes) - instance-pointer-lowtag)) - (i0 (- (* (+ instance-slots-offset 2) n-word-bytes) - instance-pointer-lowtag)) - (i1 (- (* (+ instance-slots-offset 3) n-word-bytes) - instance-pointer-lowtag))) - (lfloat r0 lip (complex-double-reg-real-tn value) :side 0) - (lfloat r1 lip (complex-double-reg-real-tn value) :side 1) - (lfloat i0 lip (complex-double-reg-imag-tn value) :side 0) - (lfloat i1 lip (complex-double-reg-imag-tn value) :side 1))) - - (raw-instance (double -4 t complex-double) - (let ((value-real (complex-double-reg-real-tn value)) - (result-real (complex-double-reg-real-tn result)) - (value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result)) - (r0 (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag)) - (r1 (- (* (+ instance-slots-offset 1) n-word-bytes) - instance-pointer-lowtag)) - (i0 (- (* (+ instance-slots-offset 2) n-word-bytes) - instance-pointer-lowtag)) - (i1 (- (* (+ instance-slots-offset 3) n-word-bytes) - instance-pointer-lowtag))) - (sfloat value-real r0 lip :side 0) - (sfloat value-real r1 lip :side 1) - (sfloat value-imag i0 lip :side 0) - (sfloat value-imag i1 lip :side 1) - (unless (location= result-real value-real) - (inst funop :copy value-real result-real)) - (unless (location= result-imag value-imag) - (inst funop :copy value-imag result-imag))))) diff -Nru sbcl-2.0.6/src/compiler/hppa/char.lisp sbcl-2.1.1/src/compiler/hppa/char.lisp --- sbcl-2.0.6/src/compiler/hppa/char.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/char.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -;;;; the HPPA VM definition of character operations - -;;;; 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") - -;;;; Moves and coercions: - -;;; Move a tagged char to an untagged representation. -(define-vop (move-to-character) - (:note "character untagging") - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (character-reg))) - (:generator 1 - (inst srl x n-widetag-bits y))) -(define-move-vop move-to-character :move - (any-reg descriptor-reg) (character-reg)) - -;;; Move an untagged char to a tagged representation. -(define-vop (move-from-character) - (:note "character tagging") - (:args (x :scs (character-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:generator 1 - (inst sll x n-widetag-bits y) - (inst addi character-widetag y y))) -(define-move-vop move-from-character :move - (character-reg) (any-reg descriptor-reg)) - -;;; Move untagged character values. -(define-vop (character-move) - (:note "character move") - (:args (x :target y - :scs (character-reg) - :load-if (not (location= x y)))) - (:results (y :scs (character-reg) - :load-if (not (location= x y)))) - (:generator 0 - (move x y))) -(define-move-vop character-move :move - (character-reg) (character-reg)) - -;;; Move untagged character args/return-values. -(define-vop (move-character-arg) - (:note "character arg move") - (:args (x :target y - :scs (character-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y character-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (character-reg - (move x y)) - (character-stack - (storew x fp (tn-offset y)))))) -(define-move-vop move-character-arg :move-arg - (any-reg character-reg) (character-reg)) - -;;; Use standard MOVE-ARG + coercion to move an untagged character to -;;; a descriptor passing location. -(define-move-vop move-arg :move-arg - (character-reg) (any-reg descriptor-reg)) - -;;;; Other operations: -(define-vop (char-code) - (:translate char-code) - (:policy :fast-safe) - (:args (ch :scs (character-reg) :target res)) - (:arg-types character) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:generator 1 - (inst sll ch 2 res))) - -(define-vop (code-char) - (:translate code-char) - (:policy :fast-safe) - (:args (code :scs (any-reg) :target res)) - (:arg-types positive-fixnum) - (:results (res :scs (character-reg))) - (:result-types character) - (:generator 1 - (inst srl code 2 res))) - -;;; Comparison of characters. -(define-vop (character-compare) - (:args (x :scs (character-reg)) - (y :scs (character-reg))) - (:arg-types character character) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:note "inline comparison") - (:variant-vars cond) - (:generator 3 - (inst bc cond not-p x y target))) - -(define-vop (fast-char=/character character-compare) - (:translate char=) - (:variant :=)) - -(define-vop (fast-char/character character-compare) - (:translate char>) - (:variant :>>)) - diff -Nru sbcl-2.0.6/src/compiler/hppa/debug.lisp sbcl-2.1.1/src/compiler/hppa/debug.lisp --- sbcl-2.0.6/src/compiler/hppa/debug.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/debug.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -(in-package "SB-VM") - -(define-vop () - (:translate current-sp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move csp-tn res))) - -(define-vop () - (:translate current-fp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move cfp-tn res))) - -(define-vop () - (:translate stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg)) - (offset :scs (any-reg))) - (:arg-types system-area-pointer positive-fixnum) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 5 - (inst ldwx offset object result))) - -(define-vop () - (:translate %set-stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg)) - (value :scs (descriptor-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:temporary (:scs (sap-reg) :from (:argument 1)) sap) - (:generator 2 - (inst add object offset sap) - (inst stw value 0 sap) - (move value result))) - -(define-vop (code-from-mumble) - (:policy :fast-safe) - (:args (thing :scs (descriptor-reg))) - (:results (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:variant-vars lowtag) - (:generator 5 - (let ((bogus (gen-label)) - (done (gen-label))) - (loadw temp thing 0 lowtag) - (inst srl temp n-widetag-bits temp) - (inst comb := zero-tn temp bogus) - (inst sll temp word-shift temp) - (unless (= lowtag other-pointer-lowtag) - (inst addi (- lowtag other-pointer-lowtag) temp temp)) - (inst sub thing temp code) - (emit-label done) - (assemble (:elsewhere) - (emit-label bogus) - (inst b done) - (move null-tn code t))))) - -(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)) - -(define-vop (%make-lisp-obj) - (:policy :fast-safe) - (:translate %make-lisp-obj) - (:args (value :scs (unsigned-reg) :target result)) - (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 1 - (move value result))) - -(define-vop (get-lisp-obj-address) - (:policy :fast-safe) - (:translate sb-di::get-lisp-obj-address) - (:args (thing :scs (descriptor-reg any-reg) :target result)) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (move thing result))) diff -Nru sbcl-2.0.6/src/compiler/hppa/float.lisp sbcl-2.1.1/src/compiler/hppa/float.lisp --- sbcl-2.0.6/src/compiler/hppa/float.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/float.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,996 +0,0 @@ -;;;; the HPPA VM definition of floating point operations - -;;;; 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") - -;;;; Move functions. -(define-move-fun (load-fp-zero 1) (vop x y) - ((fp-single-zero) (single-reg) - (fp-double-zero) (double-reg)) - (inst funop :copy x y)) - -(defun ld-float (offset base r) - (cond ((< offset (ash 1 4)) - (inst flds offset base r)) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn lip-tn) - (inst fldx lip-tn base r)) - (t - (error "ld-float: bad offset: ~s~%" offset)))) - -(define-move-fun (load-float 1) (vop x y) - ((single-stack) (single-reg) - (double-stack) (double-reg)) - (let ((offset (tn-byte-offset x))) - (ld-float offset (current-nfp-tn vop) y))) - -(defun str-float (x offset base) - (cond ((< offset (ash 1 4)) - ;(note-next-instruction vop :internal-error) - (inst fsts x offset base)) - ((and (< offset (ash 1 13)) - (> offset 0)) - ;; FIXME-lav, ok with GC to use lip-tn for arbitrary offsets ? - (inst ldo offset zero-tn lip-tn) - ;(note-next-instruction vop :internal-error) - (inst fstx x lip-tn base)) - (t - (error "str-float: bad offset: ~s~%" offset)))) - -(define-move-fun (store-float 1) (vop x y) - ((single-reg) (single-stack) - (double-reg) (double-stack)) - (let ((offset (tn-byte-offset y))) - (str-float x offset (current-nfp-tn vop)))) - -;;;; Move VOPs -(define-vop (move-float) - (:args (x :scs (single-reg double-reg) - :target y - :load-if (not (location= x y)))) - (:results (y :scs (single-reg double-reg) - :load-if (not (location= x y)))) - (:note "float move") - (:generator 0 - (unless (location= y x) - (inst funop :copy x y)))) -(define-move-vop move-float :move (single-reg) (single-reg)) -(define-move-vop move-float :move (double-reg) (double-reg)) - -(define-vop (move-from-float) - (:args (x :to :save)) - (:results (y :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:variant-vars size type data) - (:note "float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y nil ndescr type size nil) - nil) - (inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y))) - -(macrolet ((frob (name sc &rest args) - `(progn - (define-vop (,name move-from-float) - (:args (x :scs (,sc) :to :save)) - (:variant ,@args)) - (define-move-vop ,name :move (,sc) (descriptor-reg))))) - (frob move-from-single single-reg - single-float-size single-float-widetag single-float-value-slot) - (frob move-from-double double-reg - double-float-size double-float-widetag double-float-value-slot)) - -(define-vop (move-to-float) - (:args (x :scs (descriptor-reg))) - (:results (y)) - (:variant-vars offset) - (:note "pointer to float coercion") - (:generator 2 - (inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y))) - -(macrolet ((frob (name sc offset) - `(progn - (define-vop (,name move-to-float) - (:results (y :scs (,sc))) - (:variant ,offset)) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-single single-reg single-float-value-slot) - (frob move-to-double double-reg double-float-value-slot)) - -(define-vop (move-float-arg) - (:args (x :scs (single-reg double-reg) :target y) - (nfp :scs (any-reg) - :load-if (not (sc-is y single-reg double-reg)))) - (:results (y)) - (:note "float argument move") - (:generator 1 - (sc-case y - ((single-reg double-reg) - (unless (location= x y) - (inst funop :copy x y))) - ((single-stack double-stack) - (let ((offset (tn-byte-offset y))) - (str-float x offset nfp)))))) -(define-move-vop move-float-arg :move-arg - (single-reg descriptor-reg) (single-reg)) -(define-move-vop move-float-arg :move-arg - (double-reg descriptor-reg) (double-reg)) - -;;;; Complex float move functions -(defun complex-single-reg-real-tn (x) - (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) - :offset (tn-offset x))) -(defun complex-single-reg-imag-tn (x) - (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) - :offset (1+ (tn-offset x)))) - -(defun complex-double-reg-real-tn (x) - (make-random-tn :kind :normal :sc (sc-or-lose 'complex-double-reg) - :offset (tn-offset x))) -(defun complex-double-reg-imag-tn (x) - (make-random-tn :kind :normal :sc (sc-or-lose 'complex-double-reg) - :offset (1+ (tn-offset x)))) - -(macrolet - ((def-move-fun (dir type size from to) - `(define-move-fun (,(symbolicate dir "-" type) ,size) (vop x y) - ((,(symbolicate type "-" from)) (,(symbolicate type "-" to))) - (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset ,(if (eq dir 'load) 'x 'y)) n-word-bytes))) - ,@(if (eq dir 'load) - `((let ((real-tn (,(symbolicate type "-REG-REAL-TN") y))) - (ld-float offset nfp real-tn)) - (let ((imag-tn (,(symbolicate type "-REG-IMAG-TN") y))) - (ld-float (+ offset (* ,(/ size 2) n-word-bytes)) nfp imag-tn))) - `((let ((real-tn (,(symbolicate type "-REG-REAL-TN") x))) - (str-float real-tn offset nfp)) - (let ((imag-tn (,(symbolicate type "-REG-IMAG-TN") x))) - (str-float imag-tn - (+ offset (* ,(/ size 2) n-word-bytes)) - nfp)))))))) - (def-move-fun load complex-single 2 stack reg) - (def-move-fun store complex-single 2 reg stack) - (def-move-fun load complex-double 4 stack reg) - (def-move-fun store complex-double 4 reg stack)) - -;;; Complex float register to register moves. -(define-vop (complex-single-move) - (:args (x :scs (complex-single-reg) :target y - :load-if (not (location= x y)))) - (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) - (:note "complex single float move") - (:generator 0 - (unless (location= x y) - ;; Note the complex-float-regs are aligned to every second - ;; float register so there is not need to worry about overlap. - (let ((x-real (complex-single-reg-real-tn x)) - (y-real (complex-single-reg-real-tn y))) - (inst funop :copy x-real y-real)) - (let ((x-imag (complex-single-reg-imag-tn x)) - (y-imag (complex-single-reg-imag-tn y))) - (inst funop :copy x-imag y-imag))))) -(define-move-vop complex-single-move :move - (complex-single-reg) (complex-single-reg)) - -(define-vop (complex-double-move) - (:args (x :scs (complex-double-reg) - :target y :load-if (not (location= x y)))) - (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) - (:note "complex double float move") - (:generator 0 - (unless (location= x y) - ;; Note the complex-float-regs are aligned to every second - ;; float register so there is not need to worry about overlap. - (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (inst funop :copy x-real y-real)) - (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst funop :copy x-imag y-imag))))) -(define-move-vop complex-double-move :move - (complex-double-reg) (complex-double-reg)) - -;;; Move from a complex float to a descriptor register allocating a -;;; new complex float object in the process. -(define-vop (move-from-complex-single) - (:args (x :scs (complex-single-reg) :to :save)) - (:results (y :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:note "complex single float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y nil ndescr complex-single-float-widetag - complex-single-float-size nil) - nil) - (let ((real-tn (complex-single-reg-real-tn x))) - (inst fsts real-tn (- (* complex-single-float-real-slot n-word-bytes) - other-pointer-lowtag) y)) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (inst fsts imag-tn (- (* complex-single-float-imag-slot n-word-bytes) - other-pointer-lowtag) y)))) -(define-move-vop move-from-complex-single :move - (complex-single-reg) (descriptor-reg)) - -(define-vop (move-from-complex-double) - (:args (x :scs (complex-double-reg) :to :save)) - (:results (y :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:note "complex double float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y nil ndescr complex-double-float-widetag - complex-double-float-size nil) - nil) - (let ((real-tn (complex-double-reg-real-tn x))) - (inst fsts real-tn (- (* complex-double-float-real-slot n-word-bytes) - other-pointer-lowtag) y)) - (let ((imag-tn (complex-double-reg-imag-tn x))) - (inst fsts imag-tn (- (* complex-double-float-imag-slot n-word-bytes) - other-pointer-lowtag) y)))) -(define-move-vop move-from-complex-double :move - (complex-double-reg) (descriptor-reg)) - -;;; Move from a descriptor to a complex float register -(define-vop (move-to-complex-single) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (complex-single-reg))) - (:note "pointer to complex float coercion") - (:generator 2 - (let ((real-tn (complex-single-reg-real-tn y))) - (inst flds (- (* complex-single-float-real-slot n-word-bytes) - other-pointer-lowtag) - x real-tn)) - (let ((imag-tn (complex-single-reg-imag-tn y))) - (inst flds (- (* complex-single-float-imag-slot n-word-bytes) - other-pointer-lowtag) - x imag-tn)))) -(define-move-vop move-to-complex-single :move - (descriptor-reg) (complex-single-reg)) - -(define-vop (move-to-complex-double) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (complex-double-reg))) - (:note "pointer to complex float coercion") - (:generator 2 - (let ((real-tn (complex-double-reg-real-tn y))) - (inst flds (- (* complex-double-float-real-slot n-word-bytes) - other-pointer-lowtag) - x real-tn)) - (let ((imag-tn (complex-double-reg-imag-tn y))) - (inst flds (- (* complex-double-float-imag-slot n-word-bytes) - other-pointer-lowtag) - x imag-tn)))) -(define-move-vop move-to-complex-double :move - (descriptor-reg) (complex-double-reg)) - -;;; Complex float move-arg vop -(define-vop (move-complex-single-float-arg) - (:args (x :scs (complex-single-reg) :target y) - (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) - (:results (y)) - (:note "float argument move") - (:generator 1 - (sc-case y - (complex-single-reg - (unless (location= x y) - (let ((x-real (complex-single-reg-real-tn x)) - (y-real (complex-single-reg-real-tn y))) - (inst funop :copy x-real y-real)) - (let ((x-imag (complex-single-reg-imag-tn x)) - (y-imag (complex-single-reg-imag-tn y))) - (inst funop :copy x-imag y-imag)))) - (complex-single-stack - (let ((offset (tn-byte-offset y))) - (let ((real-tn (complex-single-reg-real-tn x))) - (str-float real-tn offset nfp)) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (str-float imag-tn (+ offset n-word-bytes) nfp))))))) -(define-move-vop move-complex-single-float-arg :move-arg - (complex-single-reg descriptor-reg) (complex-single-reg)) - -(define-vop (move-complex-double-float-arg) - (:args (x :scs (complex-double-reg) :target y) - (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) - (:results (y)) - (:note "float argument move") - (:generator 1 - (sc-case y - (complex-double-reg - (unless (location= x y) - (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (inst funop :copy x-real y-real)) - (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst funop :copy x-imag y-imag)))) - (complex-double-stack - (let ((offset (tn-byte-offset y))) - (let ((real-tn (complex-double-reg-real-tn x))) - (str-float real-tn offset nfp)) - (let ((imag-tn (complex-double-reg-imag-tn x))) - (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp))))))) -(define-move-vop move-complex-double-float-arg :move-arg - (complex-double-reg descriptor-reg) (complex-double-reg)) - -(define-move-vop move-arg :move-arg - (single-reg double-reg complex-single-reg complex-double-reg) - (descriptor-reg)) - -;;;; stuff for c-call float-in-int-register arguments -(define-vop (move-to-single-int-reg) - (:note "pointer to float-in-int coercion") - (:args (x :scs (single-reg descriptor-reg))) - (:results (y :scs (single-int-carg-reg) :load-if nil)) - (:generator 1 - (sc-case x - (single-reg - (inst funop :copy x y)) - (descriptor-reg - (inst ldw (- (* single-float-value-slot n-word-bytes) - other-pointer-lowtag) x y))))) -(define-move-vop move-to-single-int-reg - :move (single-reg descriptor-reg) (single-int-carg-reg)) - -(define-vop (move-single-int-reg) - (:args (x :target y :scs (single-int-carg-reg) :load-if nil) - (fp :scs (any-reg) :load-if (not (sc-is y single-int-carg-reg)))) - (:results (y :scs (single-int-carg-reg) :load-if nil)) - (:ignore fp) - (:generator 1 - (unless (location= x y) - (error "Huh? why did it do that?")))) -(define-move-vop move-single-int-reg :move-arg - (single-int-carg-reg) (single-int-carg-reg)) - -; move contents of float register x to register y -(define-vop (move-to-double-int-reg) - (:note "pointer to float-in-int coercion") - (:args (x :scs (double-reg descriptor-reg))) - (:results (y :scs (double-int-carg-reg) :load-if nil)) - (:temporary (:scs (signed-stack) :to (:result 0)) temp) - (:temporary (:scs (signed-reg) :to (:result 0) :target y) old1) - (:temporary (:scs (signed-reg) :to (:result 0) :target y) old2) - (:vop-var vop) - (:save-p :compute-only) - (:generator 2 - (sc-case x - (double-reg - (let* ((nfp (current-nfp-tn vop)) - (stack-tn (sc-case y - (double-stack y) - (double-int-carg-reg temp))) - (offset (tn-byte-offset stack-tn))) - ;; save 8 bytes of stack to two register, - ;; write down float in stack and load it back - ;; into result register. Notice the result hack, - ;; we are writing to one extra register. - ;; Double float argument convention uses two registers, - ;; but we only know about one (thanks to c-call). - (inst ldw offset nfp old1) - (inst ldw (+ offset n-word-bytes) nfp old2) - (str-float x offset nfp) ; writes 8 bytes - (inst ldw offset nfp y) - (inst ldw (+ offset n-word-bytes) nfp - (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32) - unsigned-reg-sc-number - (+ 1 (tn-offset y)))) - (inst stw old1 offset nfp) - (inst stw old2 (+ offset n-word-bytes) nfp))) - (descriptor-reg - (inst ldw (- (* double-float-value-slot n-word-bytes) - other-pointer-lowtag) x y) - (inst ldw (- (* (1+ double-float-value-slot) n-word-bytes) - other-pointer-lowtag) x - (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32) - unsigned-reg-sc-number - (+ 1 (tn-offset y)))))))) -(define-move-vop move-to-double-int-reg - :move (double-reg descriptor-reg) (double-int-carg-reg)) - -(define-vop (move-double-int-reg) - (:args (x :target y :scs (double-int-carg-reg) :load-if nil) - (fp :scs (any-reg) :load-if (not (sc-is y double-int-carg-reg)))) - (:results (y :scs (double-int-carg-reg) :load-if nil)) - (:ignore fp) - (:generator 2 - (unless (location= x y) - (error "Huh? why did it do that?")))) -(define-move-vop move-double-int-reg :move-arg - (double-int-carg-reg) (double-int-carg-reg)) - -;;;; Arithmetic VOPs. - -(define-vop (float-op) - (:args (x) (y)) - (:results (r)) - (:variant-vars operation) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (note-this-location vop :internal-error) - (inst fbinop operation x y r))) - -(macrolet ((frob (name sc zero-sc ptype) - `(define-vop (,name float-op) - (:args (x :scs (,sc ,zero-sc)) - (y :scs (,sc ,zero-sc))) - (:results (r :scs (,sc))) - (:arg-types ,ptype ,ptype) - (:result-types ,ptype)))) - (frob single-float-op single-reg fp-single-zero single-float) - (frob double-float-op double-reg fp-double-zero double-float)) - -(macrolet ((frob (translate op sname scost dname dcost) - `(progn - (define-vop (,sname single-float-op) - (:translate ,translate) - (:variant ,op) - (:variant-cost ,scost)) - (define-vop (,dname double-float-op) - (:translate ,translate) - (:variant ,op) - (:variant-cost ,dcost))))) - (frob + :add +/single-float 2 +/double-float 2) - (frob - :sub -/single-float 2 -/double-float 2) - (frob * :mpy */single-float 4 */double-float 5) - (frob / :div //single-float 12 //double-float 19)) - -(macrolet ((frob (name translate sc type inst) - `(define-vop (,name) - (:args (x :scs (,sc))) - (:results (y :scs (,sc))) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (note-this-location vop :internal-error) - ,inst)))) - (frob abs/single-float abs single-reg single-float - (inst funop :abs x y)) - (frob abs/double-float abs double-reg double-float - (inst funop :abs x y))) - -(macrolet ((frob (name translate sc type zero-tn) - `(define-vop (,name) - (:args (x :scs (,sc))) - (:results (y :scs (,sc))) - (:temporary (:scs (,sc)) float-temp) - (:temporary (:scs (signed-reg)) reg-temp) - (:temporary (:scs (signed-stack)) stack-temp) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (note-this-location vop :internal-error) - ;; KLUDGE: Subtracting the input from zero fails to - ;; produce negative zero from positive zero. - ;; Multiplying by -1 causes overflow conditions on - ;; some inputs. The FNEG instruction is available - ;; in PA-RISC 2.0 only, and we're supposed to be - ;; PA-RISC 1.1 compatible. To do the negation as an - ;; integer operation requires writing out the value - ;; (or its high bits) to memory, reading them up - ;; into a non-descriptor-reg, flipping the sign bit - ;; (most likely requiring another unsigned-reg to - ;; hold a constant to XOR with), then getting the - ;; result back to the FPU via memory again. So - ;; instead we test for zeroness explicitly and - ;; decide which of the two FPU-based strategies to - ;; use. I feel unclean for having implemented this, - ;; but it seems to be the least dreadful option. - ;; Help? -- AB, 2015-11-26 - (inst fcmp #b00111 x ,zero-tn) - (inst ftest) - (inst b SUBTRACT-FROM-ZERO :nullify t) - - MULTIPLY-BY-NEGATIVE-ONE - (let ((nfp (current-nfp-tn vop)) - (short-float-temp (make-random-tn :kind :normal - :sc (sc-or-lose 'single-reg) - :offset (tn-offset reg-temp)))) - (inst li -1 reg-temp) - (storew reg-temp nfp (tn-offset stack-temp)) - (ld-float (tn-byte-offset stack-temp) nfp short-float-temp) - (inst fcnvxf short-float-temp float-temp) - (inst fbinop :mpy x float-temp y)) - (inst b DONE :nullify t) - - SUBTRACT-FROM-ZERO - (inst fbinop :sub ,zero-tn x y) - - DONE)))) - (frob %negate/single-float %negate single-reg single-float fp-single-zero-tn) - (frob %negate/double-float %negate double-reg double-float fp-double-zero-tn)) - -;;;; Comparison: - -(define-vop (float-compare) - (:args (x) (y)) - (:conditional) - (:info target not-p) - (:variant-vars condition complement) - (:policy :fast-safe) - (:note "inline float comparison") - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (note-this-location vop :internal-error) - ;; This is the condition to nullify the branch, so it is inverted. - (inst fcmp (if not-p condition complement) x y) - (inst ftest) - (inst b target :nullify t))) - -(macrolet ((frob (name sc zero-sc ptype) - `(define-vop (,name float-compare) - (:args (x :scs (,sc ,zero-sc)) - (y :scs (,sc ,zero-sc))) - (:arg-types ,ptype ,ptype)))) - (frob single-float-compare single-reg fp-single-zero single-float) - (frob double-float-compare double-reg fp-double-zero double-float)) - -(macrolet ((frob (translate condition complement sname dname) - `(progn - (define-vop (,sname single-float-compare) - (:translate ,translate) - (:variant ,condition ,complement)) - (define-vop (,dname double-float-compare) - (:translate ,translate) - (:variant ,condition ,complement))))) - ;; FIXME-lav: let 'inst cmp' translate keywords into raw binary instead of giving it here - (frob < #b01001 #b10101 #b10001 #b01101 >/single-float >/double-float) - (frob = #b00101 #b11001 =/single-float =/double-float)) - - -;;;; Conversion: - -(macrolet ((frob (name translate from-sc from-type to-sc to-type) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (,to-sc))) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator 2 - (note-this-location vop :internal-error) - (inst fcnvff x y))))) - (frob %single-float/double-float %single-float - double-reg double-float - single-reg single-float) - (frob %double-float/single-float %double-float - single-reg single-float - double-reg double-float)) - -; convert register-integer to registersingle/double by -; putting it on single-float-stack and then float-loading it into -; an float register, and finally convert the float-register and -; storing the result into y -(macrolet ((frob (name translate to-sc to-type) - `(define-vop (,name) - (:args (x :scs (signed-reg) - :load-if (not (sc-is x signed-stack)) - :target stack-temp)) - (:arg-types signed-num) - (:results (y :scs (,to-sc))) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (signed-stack) :from (:argument 0)) - stack-temp) - (:temporary (:scs (single-reg) :to (:result 0) :target y) - fp-temp) - (:temporary (:scs (any-reg) :from (:argument 0) - :to (:result 0)) index) - (:generator 5 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn - (sc-case x - (signed-stack - x) - (signed-reg - (storew x nfp (tn-offset stack-temp)) - stack-temp))) - (offset (tn-byte-offset stack-tn))) - (cond ((< offset (ash 1 4)) - (inst flds offset nfp fp-temp)) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - (inst fldx index nfp fp-temp)) - (t - (error "in vop ~s offset ~s is out-of-range" ',name offset))) - (note-this-location vop :internal-error) - (inst fcnvxf fp-temp y)))))) - (frob %single-float/signed %single-float - single-reg single-float) - (frob %double-float/signed %double-float - double-reg double-float)) - -(macrolet ((frob (trans from-sc from-type inst note) - `(define-vop (,(symbolicate trans "/" from-type)) - (:args (x :scs (,from-sc) - :target fp-temp)) - (:results (y :scs (signed-reg) - :load-if (not (sc-is y signed-stack)))) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate ,trans) - (:policy :fast-safe) - (:note ,note) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp) - (:temporary (:scs (signed-stack) :to (:result 0) :target y) - stack-temp) - (:temporary (:scs (any-reg) :from (:argument 0) - :to (:result 0)) index) - (:generator 3 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn - (sc-case y - (signed-stack y) - (signed-reg stack-temp))) - (offset (tn-byte-offset stack-tn))) - (inst ,inst x fp-temp) - (cond ((< offset (ash 1 4)) - (note-next-instruction vop :internal-error) - (inst fsts fp-temp offset nfp)) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - (note-next-instruction vop :internal-error) - (inst fstx fp-temp index nfp)) - (t - (error "unary error, ldo offset too high"))) - (unless (eq y stack-tn) - (loadw y nfp (tn-offset stack-tn)))))))) - (frob %unary-round single-reg single-float fcnvfx "inline float round") - (frob %unary-round double-reg double-float fcnvfx "inline float round") - (frob %unary-truncate/single-float single-reg single-float fcnvfxt - "inline float truncate") - (frob %unary-truncate/double-float double-reg double-float fcnvfxt - "inline float truncate")) - -(define-vop (make-single-float) - (:args (bits :scs (signed-reg) - :load-if (or (not (sc-is bits signed-stack)) - (sc-is res single-stack)) - :target res)) - (:results (res :scs (single-reg) - :load-if (not (sc-is bits single-stack)))) - (:arg-types signed-num) - (:result-types single-float) - (:translate make-single-float) - (:policy :fast-safe) - (:vop-var vop) - (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:generator 2 - (let ((nfp (current-nfp-tn vop))) - (sc-case bits - (signed-reg - (sc-case res - (single-reg - (let ((offset (tn-byte-offset temp))) - (inst stw bits offset nfp) - (cond ((< offset (ash 1 4)) - (inst flds offset nfp res)) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - (inst fldx index nfp res)) - (t - (error "make-single-float error, ldo offset too large"))))) - (single-stack - (inst stw bits (tn-byte-offset res) nfp)))) - (signed-stack - (sc-case res - (single-reg - (let ((offset (tn-byte-offset bits))) - (cond ((< offset (ash 1 4)) - (inst flds offset nfp res)) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - (inst fldx index nfp res)) - (t - (error "make-single-float error, ldo offset too large"))))))))))) - -(define-vop (make-double-float) - (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) - (:results (res :scs (double-reg) - :load-if (not (sc-is res double-stack)))) - (:arg-types signed-num unsigned-num) - (:result-types double-float) - (:translate make-double-float) - (:policy :fast-safe) - (:temporary (:scs (double-stack) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:vop-var vop) - (:generator 2 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn (sc-case res - (double-stack res) - (double-reg temp))) - (offset (tn-byte-offset stack-tn))) - (inst stw hi-bits offset nfp) - (inst stw lo-bits (+ offset n-word-bytes) nfp) - (cond ((eq stack-tn res)) - ((< offset (ash 1 4)) - (inst flds offset nfp res)) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - (inst fldx index nfp res)) - (t - (error "make-single-float error, ldo offset too large")))))) - -(macrolet - ((float-bits (name reg rreg stack rstack atype anum side offset) - `(define-vop (,name) - (:args (float :scs (,reg) - :load-if (not (sc-is float ,stack)))) - (:results (bits :scs (,rreg) - :load-if (or (not (sc-is bits ,rstack)) - (sc-is float ,stack)))) - (:arg-types ,atype) - (:result-types ,anum) - (:translate ,name) - (:policy :fast-safe) - (:vop-var vop) - (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:generator 2 - (let ((nfp (current-nfp-tn vop))) - (sc-case float - (,reg - (sc-case bits - (,rreg - (let ((offset (tn-byte-offset temp))) - (cond ((< offset (ash 1 4)) - ,@(if side - `((inst fsts float offset nfp :side ,side)) - `((inst fsts float offset nfp)))) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - ,@(if side - `((inst fstx float index nfp :side ,side)) - `((inst fstx float index nfp)))) - (t - (error ,(format nil "~s,~s: inst-LDO offset too large" - name rreg)))) - (inst ldw offset nfp bits))) - (,rstack - (let ((offset (tn-byte-offset bits))) - (cond ((< offset (ash 1 4)) - ,@(if side - `((inst fsts float offset nfp :side ,side)) - `((inst fsts float offset nfp)))) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - ,@(if side - `((inst fstx float index nfp :side ,side)) - `((inst fstx float index nfp)))) - (t - (error ,(format nil "~s,~s: inst-LDO offset too large" - name rstack)))))))) - (,stack - (sc-case bits - (,rreg - (inst ldw (* (+ (tn-offset float) ,offset) n-word-bytes) - nfp bits)))))))))) - (float-bits single-float-bits single-reg signed-reg single-stack - signed-stack single-float signed-num nil 0) - (float-bits double-float-high-bits double-reg signed-reg - double-stack signed-stack double-float signed-num 0 0) - (float-bits double-float-low-bits double-reg unsigned-reg - double-stack unsigned-stack double-float unsigned-num 1 1)) - -;;;; Float mode hackery: - -(sb-xc:deftype float-modes () '(unsigned-byte 32)) -(defknown floating-point-modes () float-modes (flushable)) -(defknown ((setf floating-point-modes)) (float-modes) - float-modes) - -(define-vop (floating-point-modes) - (:results (res :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate floating-point-modes) - (:policy :fast-safe) - (:temporary (:scs (double-stack)) temp) - (:temporary (:scs (any-reg) :to (:result 0)) index) - (:vop-var vop) - (:generator 3 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn (sc-case res - (unsigned-stack res) - (unsigned-reg temp))) - (offset (tn-byte-offset stack-tn))) - (cond ((< offset (ash 1 4)) - (inst fsts fp-double-zero-tn offset nfp)) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - (inst fstx fp-double-zero-tn index nfp)) - (t - (error "floating-point-modes error, ldo offset too large"))) - (ecase *backend-byte-order* - (:big-endian - (inst ldw offset nfp res)) - (:little-endian - (inst ldw (+ offset 4) nfp res)))))) - -(define-vop (set-floating-point-modes) - (:args (new :scs (unsigned-reg) :target res)) - (:results (res :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:result-types unsigned-num) - (:translate (setf floating-point-modes)) - (:policy :fast-safe) - (:temporary (:scs (double-stack)) stack-tn) - (:temporary (:scs (any-reg)) index) - (:vop-var vop) - (:generator 3 - (let* ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset stack-tn))) - (ecase *backend-byte-order* - (:big-endian - (inst stw new offset nfp) - (inst stw zero-tn (+ offset 4) nfp)) - (:little-endian - (inst stw zero-tn offset nfp) - (inst stw new (+ offset 4) nfp))) - (cond ((< offset (ash 1 4)) - (inst flds offset nfp fp-double-zero-tn)) - ((and (< offset (ash 1 13)) - (> offset 0)) - (inst ldo offset zero-tn index) - (inst fldx index nfp fp-double-zero-tn)) - (t - (error "set-floating-point-modes error, ldo offset too large"))) - (move new res)))) - -;;;; Complex float VOPs - -(define-vop (make-complex-single-float) - (:translate complex) - (:args (real :scs (single-reg) :target r) - (imag :scs (single-reg) :to :save)) - (:arg-types single-float single-float) - (:results (r :scs (complex-single-reg) :from (:argument 0) - :load-if (not (sc-is r complex-single-stack)))) - (:result-types complex-single-float) - (:note "inline complex single-float creation") - (:policy :fast-safe) - (:vop-var vop) - (:generator 5 - (sc-case r - (complex-single-reg - (let ((r-real (complex-single-reg-real-tn r))) - (unless (location= real r-real) - (inst funop :copy real r-real))) - (let ((r-imag (complex-single-reg-imag-tn r))) - (unless (location= imag r-imag) - (inst funop :copy imag r-imag)))) - (complex-single-stack - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset r))) - (str-float real offset nfp) - (str-float imag (+ offset n-word-bytes) nfp)))))) - -(define-vop (make-complex-double-float) - (:translate complex) - (:args (real :scs (double-reg) :target r) - (imag :scs (double-reg) :to :save)) - (:arg-types double-float double-float) - (:results (r :scs (complex-double-reg) :from (:argument 0) - :load-if (not (sc-is r complex-double-stack)))) - (:result-types complex-double-float) - (:note "inline complex double-float creation") - (:policy :fast-safe) - (:vop-var vop) - (:generator 5 - (sc-case r - (complex-double-reg - (let ((r-real (complex-double-reg-real-tn r))) - (unless (location= real r-real) - (inst funop :copy real r-real))) - (let ((r-imag (complex-double-reg-imag-tn r))) - (unless (location= imag r-imag) - (inst funop :copy imag r-imag)))) - (complex-double-stack - (let ((nfp (current-nfp-tn vop)) - (offset (tn-byte-offset r))) - (str-float real offset nfp) - (str-float imag (+ offset (* 2 n-word-bytes)) nfp)))))) - -(define-vop (complex-single-float-value) - (:args (x :scs (complex-single-reg) :target r - :load-if (not (sc-is x complex-single-stack)))) - (:arg-types complex-single-float) - (:results (r :scs (single-reg))) - (:result-types single-float) - (:variant-vars slot) - (:policy :fast-safe) - (:vop-var vop) - (:generator 3 - (sc-case x - (complex-single-reg - (let ((value-tn (ecase slot - (:real (complex-single-reg-real-tn x)) - (:imag (complex-single-reg-imag-tn x))))) - (unless (location= value-tn r) - (inst funop :copy value-tn r)))) - (complex-single-stack - (ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x)) - n-word-bytes) - (current-nfp-tn vop) r))))) - -(define-vop (realpart/complex-single-float complex-single-float-value) - (:translate realpart) - (:note "complex single float realpart") - (:variant :real)) - -(define-vop (imagpart/complex-single-float complex-single-float-value) - (:translate imagpart) - (:note "complex single float imagpart") - (:variant :imag)) - -(define-vop (complex-double-float-value) - (:args (x :scs (complex-double-reg) :target r - :load-if (not (sc-is x complex-double-stack)))) - (:arg-types complex-double-float) - (:results (r :scs (double-reg))) - (:result-types double-float) - (:variant-vars slot) - (:policy :fast-safe) - (:vop-var vop) - (:generator 3 - (sc-case x - (complex-double-reg - (let ((value-tn (ecase slot - (:real (complex-double-reg-real-tn x)) - (:imag (complex-double-reg-imag-tn x))))) - (unless (location= value-tn r) - (inst funop :copy value-tn r)))) - (complex-double-stack - (ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x)) - n-word-bytes) - (current-nfp-tn vop) r))))) - -(define-vop (realpart/complex-double-float complex-double-float-value) - (:translate realpart) - (:note "complex double float realpart") - (:variant :real)) - -(define-vop (imagpart/complex-double-float complex-double-float-value) - (:translate imagpart) - (:note "complex double float imagpart") - (:variant :imag)) diff -Nru sbcl-2.0.6/src/compiler/hppa/insts.lisp sbcl-2.1.1/src/compiler/hppa/insts.lisp --- sbcl-2.0.6/src/compiler/hppa/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/insts.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1629 +0,0 @@ -;;;; the instruction set definition for HPPA - -;;;; 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-HPPA-ASM") - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Imports from this package into SB-VM - (import '(reg-tn-encoding) "SB-VM") - ;; Imports from SB-VM into this package - (import '(sb-vm::zero sb-vm::registers sb-vm::float-registers - sb-vm::single-reg sb-vm::double-reg - sb-vm::complex-single-reg sb-vm::complex-double-reg - sb-vm::fp-single-zero sb-vm::fp-double-zero - sb-vm::zero-tn - sb-vm::null-offset sb-vm::code-offset sb-vm::zero-offset))) - - -;;;; Utility functions. - -(defun reg-tn-encoding (tn) - (declare (type tn tn)) - (sc-case tn - (null null-offset) - (zero zero-offset) - (t - (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) - (tn-offset tn)))) - -(defun fp-reg-tn-encoding (tn) - (declare (type tn tn)) - (sc-case tn - (fp-single-zero (values 0 nil)) - (single-reg (values (tn-offset tn) nil)) - (fp-double-zero (values 0 t)) - (double-reg (values (tn-offset tn) t)) - (complex-single-reg (values (tn-offset tn) nil)) - (complex-double-reg (values (tn-offset tn) t)))) - -(defconstant-eqx compare-conditions - '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev) - #'equalp) - -(deftype compare-condition () - `(member nil ,@compare-conditions)) - -(defun compare-condition (cond) - (declare (type compare-condition cond)) - (if cond - (let ((result (or (position cond compare-conditions :test #'eq) - (error "Bogus Compare/Subtract condition: ~S" cond)))) - (values (ldb (byte 3 0) result) - (logbitp 3 result))) - (values 0 nil))) - -(defconstant-eqx add-conditions - '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev) - #'equalp) - -(deftype add-condition () - `(member nil ,@add-conditions)) - -(defun add-condition (cond) - (declare (type add-condition cond)) - (if cond - (let ((result (or (position cond add-conditions :test #'eq) - (error "Bogus Add condition: ~S" cond)))) - (values (ldb (byte 3 0) result) - (logbitp 3 result))) - (values 0 nil))) - -(defconstant-eqx logical-conditions - '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev) - #'equalp) - -(deftype logical-condition () - `(member nil ,@(remove nil logical-conditions))) - -(defun logical-condition (cond) - (declare (type logical-condition cond)) - (if cond - (let ((result (or (position cond logical-conditions :test #'eq) - (error "Bogus Logical condition: ~S" cond)))) - (values (ldb (byte 3 0) result) - (logbitp 3 result))) - (values 0 nil))) - -(defconstant-eqx unit-conditions - '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc) - #'equalp) - -(deftype unit-condition () - `(member nil ,@(remove nil unit-conditions))) - -(defun unit-condition (cond) - (declare (type unit-condition cond)) - (if cond - (let ((result (or (position cond unit-conditions :test #'eq) - (error "Bogus Unit condition: ~S" cond)))) - (values (ldb (byte 3 0) result) - (logbitp 3 result))) - (values 0 nil))) - -(defconstant-eqx extract/deposit-conditions - '(:never := :< :od :tr :<> :>= :ev) - #'equalp) - -(deftype extract/deposit-condition () - `(member nil ,@extract/deposit-conditions)) - -(defun extract/deposit-condition (cond) - (declare (type extract/deposit-condition cond)) - (if cond - (or (position cond extract/deposit-conditions :test #'eq) - (error "Bogus Extract/Deposit condition: ~S" cond)) - 0)) - - -(defun space-encoding (space) - (declare (type (unsigned-byte 3) space)) - (dpb (ldb (byte 2 0) space) - (byte 2 1) - (ldb (byte 1 2) space))) - - -;;;; Initial disassembler setup. - -(defvar *disassem-use-lisp-reg-names* t) - -; In each define-instruction the form (:dependencies ...) -; contains read and write howto that passed as LOC here. -; Example: (:dependencies (reads src) (writes dst) (writes temp)) -; src, dst and temp is passed each in loc, and can be a register -; immediate or anything else. -; this routine will return an location-number -; this number must be less than +assem-max-locations+ -(defun location-number (loc) - (etypecase loc - (null) - (number) - (label) - (fixup) - (tn - (ecase (sb-name (sc-sb (tn-sc loc))) - (immediate-constant - ;; Can happen if $ZERO or $NULL are passed in. - nil) - (registers - (unless (zerop (tn-offset loc)) - (tn-offset loc))))) - (symbol - (ecase loc - (:memory 0))))) - -(defparameter reg-symbols - (map 'vector - (lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "$" name))))) - sb-vm::*register-names*)) - -(define-arg-type reg - :printer (lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (maybe-note-associated-storage-ref - value - 'registers - regname - dstate)))) - -(defparameter float-reg-symbols - #.(coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n))) - 'vector)) - -(define-arg-type fp-reg - :printer (lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref float-reg-symbols value))) - (princ regname stream) - (maybe-note-associated-storage-ref - value - 'float-registers - regname - dstate)))) - -(define-arg-type fp-fmt-0c - :printer (lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (ecase value - (0 (format stream "~A" '\,SGL)) - (1 (format stream "~A" '\,DBL)) - (3 (format stream "~A" '\,QUAD))))) - -(defun low-sign-extend (x n) - (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x)))) - (if (logbitp 0 x) - (logior (ash -1 (1- n)) normal) - normal))) - -(defun assemble-bits (x list) - (let ((result 0) - (offset 0)) - (dolist (e (reverse list)) - (setf result (logior result (ash (ldb e x) offset))) - (incf offset (byte-size e))) - result)) - -(macrolet ((define-imx-decode (name bits) - `(define-arg-type ,name - :printer (lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" (low-sign-extend value ,bits)))))) - (define-imx-decode im5 5) - (define-imx-decode im11 11) - (define-imx-decode im14 14)) - -(define-arg-type im3 - :printer (lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" (assemble-bits value `(,(byte 1 0) - ,(byte 2 1)))))) - -(define-arg-type im21 - :printer (lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" - (assemble-bits value `(,(byte 1 0) ,(byte 11 1) - ,(byte 2 14) ,(byte 5 16) - ,(byte 2 12)))))) - -(define-arg-type cp - :printer (lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" (- 31 value)))) - -(define-arg-type clen - :printer (lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" (- 32 value)))) - -(define-arg-type compare-condition - :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>= - \,> \,>>= \,>> \,NSV \,EV)) - -(define-arg-type compare-condition-false - :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV - "" \,= \,< \,<= \,<< \,<<= \,SV \,OD)) - -(define-arg-type add-condition - :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV - \,VNZ \,NSV \,EV)) - -(define-arg-type add-condition-false - :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV - "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD)) - -(define-arg-type logical-condition - :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV)) - -(define-arg-type unit-condition - :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC - \,NBC \,NHC)) - -(define-arg-type extract/deposit-condition - :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV)) - -(define-arg-type extract/deposit-condition-false - :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD)) - -(define-arg-type nullify - :printer #("" \,N)) - -(define-arg-type fcmp-cond - :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?< - \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>= - \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE)) - -(define-arg-type integer - :printer (lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" value))) - -(define-arg-type space - :printer #("" |1,| |2,| |3,|)) - -(define-arg-type memory-address-annotation - :printer (lambda (value stream dstate) - (declare (ignore stream)) - (destructuring-bind (reg raw-offset) value - (let ((offset (low-sign-extend raw-offset 14))) - (cond - ((= reg code-offset) - (note-code-constant offset dstate)) - ((= reg null-offset) - (maybe-note-nil-indexed-object offset dstate))))))) - - -;;;; Define-instruction-formats for disassembler. - -(define-instruction-format (load/store 32) - (op :field (byte 6 26)) - (b :field (byte 5 21) :type 'reg) - (t/r :field (byte 5 16) :type 'reg) - (s :field (byte 2 14) :type 'space) - (im14 :field (byte 14 0) :type 'im14) - (memory-address-annotation :fields (list (byte 5 21) (byte 14 0)) - :type 'memory-address-annotation)) - -(defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S)) - (:cond ((m :constant 1) '\,M))) - #'equalp) - -(defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1) - (:cond ((s :constant 0) '\,MA) - (t '\,MB))))) - #'equalp) - -(defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B) - (t '\,E)) - (:cond ((m :constant 1) '\,M))) - #'equalp) - -(define-instruction-format (extended-load/store 32) - (op1 :field (byte 6 26) :value 3) - (b :field (byte 5 21) :type 'reg) - (x/im5/r :field (byte 5 16) :type 'reg) - (s :field (byte 2 14) :type 'space) - (u :field (byte 1 13)) - (op2 :field (byte 3 10)) - (ext4/c :field (byte 4 6)) - (m :field (byte 1 5)) - (t/im5 :field (byte 5 0) :type 'reg)) - -(define-instruction-format (ldil 32 :default-printer '(:name :tab im21 "," t)) - (op :field (byte 6 26)) - (t :field (byte 5 21) :type 'reg) - (im21 :field (byte 21 0) :type 'im21)) - -(define-instruction-format (branch17 32) - (op1 :field (byte 6 26)) - (t :field (byte 5 21) :type 'reg) - (w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0)) - :use-label - (lambda (value dstate) - (declare (type disassem-state dstate) (list value)) - (let ((x (logior (ash (first value) 12) (ash (second value) 1) - (third value)))) - (+ (ash (sign-extend - (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1) - ,(byte 10 2))) 17) 2) - (dstate-cur-addr dstate) 8)))) - (op2 :field (byte 3 13)) - (n :field (byte 1 1) :type 'nullify)) - -(define-instruction-format (branch12 32) - (op1 :field (byte 6 26)) - (r2 :field (byte 5 21) :type 'reg) - (r1 :field (byte 5 16) :type 'reg) - (w :fields `(,(byte 11 2) ,(byte 1 0)) - :use-label - (lambda (value dstate) - (declare (type disassem-state dstate) (list value)) - (let ((x (logior (ash (first value) 1) (second value)))) - (+ (ash (sign-extend - (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2))) - 12) 2) - (dstate-cur-addr dstate) 8)))) - (c :field (byte 3 13)) - (n :field (byte 1 1) :type 'nullify)) - -(define-instruction-format (branch 32) - (op1 :field (byte 6 26)) - (t :field (byte 5 21) :type 'reg) - (x :field (byte 5 16) :type 'reg) - (op2 :field (byte 3 13)) - (x1 :field (byte 11 2)) - (n :field (byte 1 1) :type 'nullify) - (x2 :field (byte 1 0))) - -(define-instruction-format (r3-inst 32 - :default-printer '(:name c :tab r1 "," r2 "," t)) - (r3 :field (byte 6 26) :value 2) - (r2 :field (byte 5 21) :type 'reg) - (r1 :field (byte 5 16) :type 'reg) - (c :field (byte 3 13)) - (f :field (byte 1 12)) - (op :field (byte 7 5)) - (t :field (byte 5 0) :type 'reg)) - -(define-instruction-format (imm-inst 32 - :default-printer '(:name c :tab im11 "," r "," t)) - (op :field (byte 6 26)) - (r :field (byte 5 21) :type 'reg) - (t :field (byte 5 16) :type 'reg) - (c :field (byte 3 13)) - (f :field (byte 1 12)) - (o :field (byte 1 11)) - (im11 :field (byte 11 0) :type 'im11)) - -(define-instruction-format (extract/deposit-inst 32) - (op1 :field (byte 6 26)) - (r2 :field (byte 5 21) :type 'reg) - (r1 :field (byte 5 16) :type 'reg) - (c :field (byte 3 13) :type 'extract/deposit-condition) - (op2 :field (byte 3 10)) - (cp :field (byte 5 5) :type 'cp) - (t/clen :field (byte 5 0) :type 'clen)) - -(define-instruction-format (break 32 - :default-printer '(:name :tab im13 "," im5)) - (op1 :field (byte 6 26) :value 0) - (im13 :field (byte 13 13)) - (q2 :field (byte 8 5) :value 0) - (im5 :field (byte 5 0) :reader break-im5)) - -(define-instruction-format (system-inst 32) - (op1 :field (byte 6 26) :value 0) - (r1 :field (byte 5 21) :type 'reg) - (r2 :field (byte 5 16) :type 'reg) - (s :field (byte 3 13)) - (op2 :field (byte 8 5)) - (r3 :field (byte 5 0) :type 'reg)) - -(define-instruction-format (fp-load/store 32) - (op :field (byte 6 26)) - (b :field (byte 5 21) :type 'reg) - (x :field (byte 5 16) :type 'reg) - (s :field (byte 2 14) :type 'space) - (u :field (byte 1 13)) - (x1 :field (byte 1 12)) - (x2 :field (byte 2 10)) - (x3 :field (byte 1 9)) - (x4 :field (byte 3 6)) - (m :field (byte 1 5)) - (t :field (byte 5 0) :type 'fp-reg)) - -(define-instruction-format (fp-class-0-inst 32) - (op1 :field (byte 6 26)) - (r :field (byte 5 21) :type 'fp-reg) - (x1 :field (byte 5 16) :type 'fp-reg) - (op2 :field (byte 3 13)) - (fmt :field (byte 2 11) :type 'fp-fmt-0c) - (x2 :field (byte 2 9)) - (x3 :field (byte 3 6)) - (x4 :field (byte 1 5)) - (t :field (byte 5 0) :type 'fp-reg)) - -(define-instruction-format (fp-class-1-inst 32) - (op1 :field (byte 6 26)) - (r :field (byte 5 21) :type 'fp-reg) - (x1 :field (byte 4 17) :value 0) - (x2 :field (byte 2 15)) - (df :field (byte 2 13) :type 'fp-fmt-0c) - (sf :field (byte 2 11) :type 'fp-fmt-0c) - (x3 :field (byte 2 9) :value 1) - (x4 :field (byte 3 6) :value 0) - (x5 :field (byte 1 5) :value 0) - (t :field (byte 5 0) :type 'fp-reg)) - - - -;;;; Load and Store stuff. - -(define-bitfield-emitter emit-load/store 32 - (byte 6 26) - (byte 5 21) - (byte 5 16) - (byte 2 14) - (byte 14 0)) - -(defun encode-imm21 (segment value) - (declare (type (or fixup (signed-byte 32) (unsigned-byte 32)) value)) - (cond ((fixup-p value) - (note-fixup segment :hi value) - (aver (zerop (fixup-offset value))) - 0) - (t - (let ((hi (ldb (byte 21 11) value))) - (logior (ash (ldb (byte 5 2) hi) 16) - (ash (ldb (byte 2 7) hi) 14) - (ash (ldb (byte 2 0) hi) 12) - (ash (ldb (byte 11 9) hi) 1) - (ldb (byte 1 20) hi)))))) - -(defun encode-imm11 (value) - (declare (type (signed-byte 11) value)) - (dpb (ldb (byte 10 0) value) - (byte 10 1) - (ldb (byte 1 10) value))) - -(defun encode-imm11u (value) - (declare (type (or (signed-byte 32) (unsigned-byte 32)) value)) - (declare (type (unsigned-byte 11) value)) - (dpb (ldb (byte 11 0) value) - (byte 11 1) - 0)) - -(defun encode-imm14 (value) - (declare (type (signed-byte 14) value)) - (dpb (ldb (byte 13 0) value) - (byte 13 1) - (ldb (byte 1 13) value))) - -(defun encode-disp/fixup (segment disp imm-bits) - (cond - ((fixup-p disp) - (aver (zerop (fixup-offset disp))) - (if imm-bits - (note-fixup segment :load11u disp) - (note-fixup segment :load disp)) - 0) - (t - (if imm-bits - (encode-imm11u disp) - (encode-imm14 disp))))) - -; LDO can be used in two ways: to load an 14bit-signed value -; or load an 11bit-unsigned value. The latter is used for -; example in an LDIL/LDO pair. The key :unsigned specifies this. -(macrolet ((define-load-inst (name opcode &optional imm-bits) - (declare (ignore imm-bits)) ; what? - `(define-instruction ,name (segment disp base reg &key unsigned) - (:declare (type tn reg base) - (type (member t nil) unsigned) - (type (or fixup (signed-byte 14)) disp)) - (:delay 0) - (:printer load/store ((op ,opcode) (s 0)) - '(:name :tab im14 "(" s b ")," t/r memory-address-annotation)) - (:dependencies (reads base) (reads :memory) (writes reg)) - (:emitter - (emit-load/store segment ,opcode - (reg-tn-encoding base) (reg-tn-encoding reg) 0 - (if unsigned - (encode-disp/fixup segment disp t) - (encode-disp/fixup segment disp nil)))))) - (define-store-inst (name opcode &optional imm-bits) - `(define-instruction ,name (segment reg disp base) - (:declare (type tn reg base) - (type (or fixup (signed-byte 14)) disp)) - (:delay 0) - (:printer load/store ((op ,opcode) (s 0)) - '(:name :tab t/r "," im14 "(" s b ")" memory-address-annotation)) - (:dependencies (reads base) (reads reg) (writes :memory)) - (:emitter - (emit-load/store segment ,opcode - (reg-tn-encoding base) (reg-tn-encoding reg) 0 - (encode-disp/fixup segment disp ,imm-bits)))))) - (define-load-inst ldw #x12) - (define-load-inst ldh #x11) - (define-load-inst ldb #x10) - (define-load-inst ldwm #x13) - (define-load-inst ldo #x0D) - (define-store-inst stw #x1A) - (define-store-inst sth #x19) - (define-store-inst stb #x18) - (define-store-inst stwm #x1B)) - -(define-bitfield-emitter emit-extended-load/store 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) - (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0)) - -(macrolet ((define-load-indexed-inst (name opcode) - `(define-instruction ,name (segment index base reg &key modify scale) - (:declare (type tn reg base index) - (type (member t nil) modify scale)) - (:delay 0) - (:dependencies (reads index) (reads base) (writes reg) (reads :memory)) - (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg) - (op2 0)) - `(:name ,@cmplt-index-print :tab x/im5/r - "(" s b ")" t/im5)) - (:emitter - (emit-extended-load/store - segment #x03 (reg-tn-encoding base) (reg-tn-encoding index) - 0 (if scale 1 0) 0 ,opcode (if modify 1 0) - (reg-tn-encoding reg)))))) - (define-load-indexed-inst ldwx 2) - (define-load-indexed-inst ldhx 1) - (define-load-indexed-inst ldbx 0) - (define-load-indexed-inst ldcwx 7)) - -(defun short-disp-encoding (segment disp) - (declare (type (or fixup (signed-byte 5)) disp)) - (cond ((fixup-p disp) - (note-fixup segment :load-short disp) - (aver (zerop (fixup-offset disp))) - 0) - (t - (dpb (ldb (byte 4 0) disp) - (byte 4 1) - (ldb (byte 1 4) disp))))) - -(macrolet ((define-load-short-inst (name opcode) - `(define-instruction ,name (segment base disp reg &key modify) - (:declare (type tn base reg) - (type (or fixup (signed-byte 5)) disp) - (type (member :before :after nil) modify)) - (:delay 0) - (:dependencies (reads base) (writes reg) (reads :memory)) - (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5) - (op2 4)) - `(:name ,@cmplt-disp-print :tab x/im5/r - "(" s b ")" t/im5)) - (:emitter - (multiple-value-bind - (m a) - (ecase modify - ((nil) (values 0 0)) - (:after (values 1 0)) - (:before (values 1 1))) - (emit-extended-load/store segment #x03 (reg-tn-encoding base) - (short-disp-encoding segment disp) - 0 a 4 ,opcode m - (reg-tn-encoding reg)))))) - (define-store-short-inst (name opcode) - `(define-instruction ,name (segment reg base disp &key modify) - (:declare (type tn reg base) - (type (or fixup (signed-byte 5)) disp) - (type (member :before :after nil) modify)) - (:delay 0) - (:dependencies (reads base) (reads reg) (writes :memory)) - (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5) - (op2 4)) - `(:name ,@cmplt-disp-print :tab x/im5/r - "," t/im5 "(" s b ")")) - (:emitter - (multiple-value-bind - (m a) - (ecase modify - ((nil) (values 0 0)) - (:after (values 1 0)) - (:before (values 1 1))) - (emit-extended-load/store segment #x03 (reg-tn-encoding base) - (short-disp-encoding segment disp) - 0 a 4 ,opcode m - (reg-tn-encoding reg))))))) - (define-load-short-inst ldws 2) - (define-load-short-inst ldhs 1) - (define-load-short-inst ldbs 0) - (define-load-short-inst ldcws 7) - - (define-store-short-inst stws 10) - (define-store-short-inst sths 9) - (define-store-short-inst stbs 8)) - -(define-instruction stbys (segment reg base disp where &key modify) - (:declare (type tn reg base) - (type (signed-byte 5) disp) - (type (member :begin :end) where) - (type (member t nil) modify)) - (:delay 0) - (:dependencies (reads base) (reads reg) (writes :memory)) - (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4)) - `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")")) - (:emitter - (emit-extended-load/store segment #x03 (reg-tn-encoding base) - (reg-tn-encoding reg) 0 - (ecase where (:begin 0) (:end 1)) - 4 #xC (if modify 1 0) - (short-disp-encoding segment disp)))) - - -;;;; Immediate 21-bit Instructions. -;;; Note the heavy scrambling of the immediate value to instruction memory - -(define-bitfield-emitter emit-imm21 32 - (byte 6 26) - (byte 5 21) - (byte 21 0)) - -(define-instruction ldil (segment value reg) - (:declare (type tn reg) - (type (or (signed-byte 32) (unsigned-byte 32) fixup) value)) - (:delay 0) - (:dependencies (writes reg)) - (:printer ldil ((op #x08))) - (:emitter - (emit-imm21 segment #x08 (reg-tn-encoding reg) - (encode-imm21 segment value)))) - -; this one overwrites number stack ? -(define-instruction addil (segment value reg) - (:declare (type tn reg) - (type (or (signed-byte 32) (unsigned-byte 32) fixup) value)) - (:delay 0) - (:dependencies (writes reg)) - (:printer ldil ((op #x0A))) - (:emitter - (emit-imm21 segment #x0A (reg-tn-encoding reg) - (encode-imm21 segment value)))) - - -;;;; Branch instructions. - -(define-bitfield-emitter emit-branch 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) - (byte 11 2) (byte 1 1) (byte 1 0)) - -(defun label-relative-displacement (label posn &optional delta-if-after) - (declare (type label label) (type index posn)) - (ash (- (if delta-if-after - (label-position label posn delta-if-after) - (label-position label)) - (+ posn 8)) -2)) - -(defun decompose-branch-disp (segment disp) - (declare (type (or fixup (signed-byte 17)) disp)) - (cond ((fixup-p disp) - (note-fixup segment :branch disp) - (aver (zerop (fixup-offset disp))) - (values 0 0 0)) - (t - (values (ldb (byte 5 11) disp) - (dpb (ldb (byte 10 0) disp) - (byte 10 1) - (ldb (byte 1 10) disp)) - (ldb (byte 1 16) disp))))) - -(defun emit-relative-branch (segment opcode link sub-opcode target nullify) - (declare (type (unsigned-byte 6) opcode) - (type (unsigned-byte 5) link) - (type (unsigned-byte 1) sub-opcode) - (type label target) - (type (member t nil) nullify)) - (emit-back-patch segment 4 - (lambda (segment posn) - (let ((disp (label-relative-displacement target posn))) - (aver (typep disp '(signed-byte 17))) - (multiple-value-bind - (w1 w2 w) - (decompose-branch-disp segment disp) - (emit-branch segment opcode link w1 sub-opcode w2 - (if nullify 1 0) w)))))) - -(define-instruction b (segment target &key nullify) - (:declare (type label target) (type (member t nil) nullify)) - (:delay 0) - (:emitter - (emit-relative-branch segment #x3A 0 0 target nullify))) - -(define-instruction bl (segment target reg &key nullify) - (:declare (type tn reg) (type label target) (type (member t nil) nullify)) - (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t)) - (:delay 0) - (:dependencies (writes reg)) - (:emitter - (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify))) - -(define-instruction gateway (segment target reg &key nullify) - (:declare (type tn reg) (type label target) (type (member t nil) nullify)) - (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t)) - (:delay 0) - (:dependencies (writes reg)) - (:emitter - (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify))) - -;;; BLR is useless because we have no way to generate the offset. - -(define-instruction bv (segment base &key nullify offset) - (:declare (type tn base) - (type (member t nil) nullify) - (type (or tn null) offset)) - (:delay 0) - (:dependencies (reads base)) - (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")")) - (:emitter - (emit-branch segment #x3A (reg-tn-encoding base) - (if offset (reg-tn-encoding offset) 0) - 6 0 (if nullify 1 0) 0))) - -(define-instruction be (segment disp space base &key nullify) - (:declare (type (or fixup (signed-byte 17)) disp) - (type tn base) - (type (unsigned-byte 3) space) - (type (member t nil) nullify)) - (:delay 0) - (:dependencies (reads base)) - (:printer branch17 ((op1 #x38) (op2 nil :type 'im3)) - '(:name n :tab w "(" op2 "," t ")")) - (:emitter - (multiple-value-bind - (w1 w2 w) - (decompose-branch-disp segment disp) - (emit-branch segment #x38 (reg-tn-encoding base) w1 - (space-encoding space) w2 (if nullify 1 0) w)))) - -(define-instruction ble (segment disp space base &key nullify) - (:declare (type (or fixup (signed-byte 17)) disp) - (type tn base) - (type (unsigned-byte 3) space) - (type (member t nil) nullify)) - (:delay 0) - (:dependencies (reads base)) - (:printer branch17 ((op1 #x39) (op2 nil :type 'im3)) - '(:name n :tab w "(" op2 "," t ")")) - (:dependencies (writes lip-tn)) - (:emitter - (multiple-value-bind - (w1 w2 w) - (decompose-branch-disp segment disp) - (emit-branch segment #x39 (reg-tn-encoding base) w1 - (space-encoding space) w2 (if nullify 1 0) w)))) - -(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify) - (emit-back-patch segment 4 - (lambda (segment posn) - (let ((disp (label-relative-displacement target posn))) - ; emit-conditional-branch is used by instruction emitters: MOVB, COMB, ADDB and BB - ; which assembles an immediate of total 12 bits (including sign bit). - (aver (typep disp '(signed-byte 12))) - (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1) - (ldb (byte 1 10) disp))) - (w (ldb (byte 1 11) disp))) ; take out the sign bit - (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w)))))) - -(defun im5-encoding (value) - (declare (type (signed-byte 5) value) - #+nil (values (unsigned-byte 5))) - (dpb (ldb (byte 4 0) value) - (byte 4 1) - (ldb (byte 1 4) value))) - -(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind - writes-reg) - (let* ((conditional (symbolicate cond-kind "-CONDITION")) - (false-conditional (symbolicate conditional "-FALSE"))) - `(progn - (define-instruction ,r-name (segment cond r1 r2 target &key nullify) - (:declare (type ,conditional cond) - (type tn r1 r2) - (type label target) - (type (member t nil) nullify)) - (:delay 0) - ,@(ecase writes-reg - (:write-reg - '((:dependencies (reads r1) (reads r2) (writes r2)))) - (:pinned - '(:pinned)) - (nil - '((:dependencies (reads r1) (reads r2))))) -; ,@(if writes-reg -; '((:dependencies (reads r1) (reads r2) (writes r2))) -; '((:dependencies (reads r1) (reads r2)))) - (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional)) - '(:name c n :tab r1 "," r2 "," w)) - ,@(unless (= r-opcode #x32) - `((:printer branch12 ((op1 ,(+ 2 r-opcode)) - (c nil :type ',false-conditional)) - '(:name c n :tab r1 "," r2 "," w)))) - (:emitter - (multiple-value-bind - (cond-encoding false) - (,conditional cond) - (emit-conditional-branch - segment (if false ,(+ r-opcode 2) ,r-opcode) - (reg-tn-encoding r2) (reg-tn-encoding r1) - cond-encoding target nullify)))) - (define-instruction ,i-name (segment cond imm reg target &key nullify) - (:declare (type ,conditional cond) - (type (signed-byte 5) imm) - (type tn reg) - (type (member t nil) nullify)) - (:delay 0) -; ,@(if writes-reg -; '((:dependencies (reads reg) (writes reg))) -; '((:dependencies (reads reg)))) - ,@(ecase writes-reg - (:write-reg - '((:dependencies (reads r1) (reads r2) (writes r2)))) - (:pinned - '(:pinned)) - (nil - '((:dependencies (reads r1) (reads r2))))) - (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5) - (c nil :type ',conditional)) - '(:name c n :tab r1 "," r2 "," w)) - ,@(unless (= r-opcode #x32) - `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5) - (c nil :type ',false-conditional)) - '(:name c n :tab r1 "," r2 "," w)))) - (:emitter - (multiple-value-bind - (cond-encoding false) - (,conditional cond) - (emit-conditional-branch - segment (if false (+ ,i-opcode 2) ,i-opcode) - (reg-tn-encoding reg) (im5-encoding imm) - cond-encoding target nullify)))))))) - (define-branch-inst movb #x32 movib #x33 extract/deposit :write-reg) - (define-branch-inst comb #x20 comib #x21 compare :pinned) - (define-branch-inst addb #x28 addib #x29 add :write-reg)) - -(define-instruction bb (segment cond reg posn target &key nullify) - (:declare (type (member t nil) cond nullify) - (type tn reg) - (type (or (member :variable) (unsigned-byte 5)) posn)) - (:delay 0) - (:dependencies (reads reg)) - (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition)) - '('BVB c n :tab r1 "," w)) - (:emitter - (multiple-value-bind - (opcode posn-encoding) - (if (eq posn :variable) - (values #x30 0) - (values #x31 posn)) - (emit-conditional-branch segment opcode posn-encoding - (reg-tn-encoding reg) - (if cond 2 6) target nullify)))) - - -;;;; Computation Instructions - -(define-bitfield-emitter emit-r3-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) - (byte 1 12) (byte 7 5) (byte 5 0)) - -(macrolet ((define-r3-inst (name cond-kind opcode &optional pinned) - `(define-instruction ,name (segment r1 r2 res &optional cond) - (:declare (type tn res r1 r2)) - (:delay 0) - ,@(if pinned - '(:pinned) - '((:dependencies (reads r1) (reads r2) (writes res)))) - (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate - cond-kind - "-CONDITION")))) - ,@(when (eq name 'or) - `((:printer r3-inst ((op ,opcode) (r2 0) - (c nil :type ',(symbolicate cond-kind - "-CONDITION"))) - `('COPY :tab r1 "," t)))) - (:emitter - (multiple-value-bind - (cond false) - (,(symbolicate cond-kind "-CONDITION") cond) - (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1) - cond (if false 1 0) ,opcode - (reg-tn-encoding res))))))) - (define-r3-inst add add #x30) - (define-r3-inst addl add #x50) - (define-r3-inst addo add #x70) - (define-r3-inst addc add #x38) - (define-r3-inst addco add #x78) - (define-r3-inst sh1add add #x32) - (define-r3-inst sh1addl add #x52) - (define-r3-inst sh1addo add #x72) - (define-r3-inst sh2add add #x34) - (define-r3-inst sh2addl add #x54) - (define-r3-inst sh2addo add #x74) - (define-r3-inst sh3add add #x36) - (define-r3-inst sh3addl add #x56) - (define-r3-inst sh3addo add #x76) - (define-r3-inst sub compare #x20) - (define-r3-inst subo compare #x60) - (define-r3-inst subb compare #x28) - (define-r3-inst subbo compare #x68) - (define-r3-inst subt compare #x26) - (define-r3-inst subto compare #x66) - (define-r3-inst ds compare #x22) - (define-r3-inst comclr compare #x44) - (define-r3-inst or logical #x12 t) ; as a nop it must be pinned - (define-r3-inst xor logical #x14) - (define-r3-inst and logical #x10) - (define-r3-inst andcm logical #x00) - (define-r3-inst uxor unit #x1C) - (define-r3-inst uaddcm unit #x4C) - (define-r3-inst uaddcmt unit #x4E) - (define-r3-inst dcor unit #x5C) - (define-r3-inst idcor unit #x5E)) - -(define-bitfield-emitter emit-imm-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) - (byte 1 12) (byte 1 11) (byte 11 0)) - -(macrolet ((define-imm-inst (name cond-kind opcode subcode &optional pinned) - (declare (ignorable pinned)) - `(define-instruction ,name (segment imm src dst &optional cond) - (:declare (type tn dst src) - (type (signed-byte 11) imm)) - (:delay 0) - (:printer imm-inst ((op ,opcode) (o ,subcode) - (c nil :type - ',(symbolicate cond-kind "-CONDITION")))) - (:dependencies (reads imm) (reads src) (writes dst)) - (:emitter - (multiple-value-bind (cond false) - (,(symbolicate cond-kind "-CONDITION") cond) - (emit-imm-inst segment ,opcode (reg-tn-encoding src) - (reg-tn-encoding dst) cond - (if false 1 0) ,subcode - (encode-imm11 imm))))))) - (define-imm-inst addi add #x2D 0) - (define-imm-inst addio add #x2D 1) - (define-imm-inst addit add #x2C 0) - (define-imm-inst addito add #x2C 1) - (define-imm-inst subi compare #x25 0) - (define-imm-inst subio compare #x25 1) - (define-imm-inst comiclr compare #x24 0)) - -(define-bitfield-emitter emit-extract/deposit-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) - (byte 3 10) (byte 5 5) (byte 5 0)) - -(define-instruction shd (segment r1 r2 count res &optional cond) - (:declare (type tn res r1 r2) - (type (or (member :variable) (integer 0 31)) count)) - (:delay 0) - :pinned - (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg)) - '(:name c :tab r1 "," r2 "," cp "," t/clen)) - (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg)) - '('VSHD c :tab r1 "," r2 "," t/clen)) - (:emitter - (etypecase count - ((member :variable) - (emit-extract/deposit-inst segment #x34 - (reg-tn-encoding r2) (reg-tn-encoding r1) - (extract/deposit-condition cond) - 0 0 (reg-tn-encoding res))) - ((integer 0 31) - (emit-extract/deposit-inst segment #x34 - (reg-tn-encoding r2) (reg-tn-encoding r1) - (extract/deposit-condition cond) - 2 (- 31 count) - (reg-tn-encoding res)))))) - -(macrolet ((define-extract-inst (name opcode) - `(define-instruction ,name (segment src posn len res &optional cond) - (:declare (type tn res src) - (type (or (member :variable) (integer 0 31)) posn) - (type (integer 1 32) len)) - (:delay 0) - (:dependencies (reads src) (writes res)) - (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer) - (op2 ,opcode)) - '(:name c :tab r2 "," cp "," t/clen "," r1)) - (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2))) - '('V :name c :tab r2 "," t/clen "," r1)) - (:emitter - (etypecase posn - ((member :variable) - (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src) - (reg-tn-encoding res) - (extract/deposit-condition cond) - ,(- opcode 2) 0 (- 32 len))) - ((integer 0 31) - (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src) - (reg-tn-encoding res) - (extract/deposit-condition cond) - ,opcode posn (- 32 len)))))))) - (define-extract-inst extru 6) - (define-extract-inst extrs 7)) - -(macrolet ((define-deposit-inst (name opcode) - `(define-instruction ,name (segment src posn len res &optional cond) - (:declare (type tn res) - (type (or tn (signed-byte 5)) src) - (type (or (member :variable) (integer 0 31)) posn) - (type (integer 1 32) len)) - (:delay 0) - (:dependencies (reads src) (writes res)) - (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode)) - ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2))) - (if (= opcode 0) (cons ''Z base) base))) - (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode))) - ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2))) - (if (= opcode 0) (cons ''Z base) base))) - (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5) - (op2 ,(+ 4 opcode))) - ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2))) - (if (= opcode 0) (cons ''Z base) base))) - (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5) - (op2 ,(+ 6 opcode))) - ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2))) - (if (= opcode 0) (cons ''Z base) base))) - (:emitter - (multiple-value-bind - (opcode src-encoding) - (etypecase src - (tn - (values ,opcode (reg-tn-encoding src))) - ((signed-byte 5) - (values ,(+ opcode 4) (im5-encoding src)))) - (multiple-value-bind - (opcode posn-encoding) - (etypecase posn - ((member :variable) - (values opcode 0)) - ((integer 0 31) - (values (+ opcode 2) (- 31 posn)))) - (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res) - src-encoding - (extract/deposit-condition cond) - opcode posn-encoding (- 32 len)))))))) - - (define-deposit-inst dep 1) - (define-deposit-inst zdep 0)) - - - -;;;; System Control Instructions. - -(define-bitfield-emitter emit-break 32 - (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0)) - -(define-instruction break (segment &optional (im5 0) (im13 0)) - (:declare (type (unsigned-byte 13) im13) - (type (unsigned-byte 5) im5)) - (:cost 0) - (:delay 0) - :pinned - (:printer break () :default :control #'break-control) - (:emitter - (emit-break segment 0 im13 0 im5))) - -(define-bitfield-emitter emit-system-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0)) - -(define-instruction ldsid (segment res base &optional (space 0)) - (:declare (type tn res base) - (type (integer 0 3) space)) - (:delay 0) - :pinned - (:printer system-inst ((op2 #x85) (c nil :type 'space) - (s nil :printer #(0 0 1 1 2 2 3 3))) - `(:name :tab "(" s r1 ")," r3)) - (:emitter - (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85 - (reg-tn-encoding res)))) - -(define-instruction mtsp (segment reg space) - (:declare (type tn reg) (type (integer 0 7) space)) - (:delay 0) - :pinned - (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s)) - (:emitter - (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space) - #xC1 0))) - -(define-instruction mfsp (segment space reg) - (:declare (type tn reg) (type (integer 0 7) space)) - (:delay 0) - :pinned - (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3)) - (:emitter - (emit-system-inst segment 0 0 0 (space-encoding space) #x25 - (reg-tn-encoding reg)))) - -(deftype control-reg () - '(or (unsigned-byte 5) (member :sar))) - -(defun control-reg (reg) - (declare (type control-reg reg) - #+nil (values (unsigned-byte 32))) - (if (typep reg '(unsigned-byte 5)) - reg - (ecase reg - (:sar 11)))) - -(define-instruction mtctl (segment reg ctrl-reg) - (:declare (type tn reg) (type control-reg ctrl-reg)) - (:delay 0) - :pinned - (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1)) - (:emitter - (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg) - 0 #xC2 0))) - -(define-instruction mfctl (segment ctrl-reg reg) - (:declare (type tn reg) (type control-reg ctrl-reg)) - (:delay 0) - :pinned - (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3)) - (:emitter - (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45 - (reg-tn-encoding reg)))) - - - -;;;; Floating point instructions. - -(define-bitfield-emitter emit-fp-load/store 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12) - (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0)) - -(define-instruction fldx (segment index base result &key modify scale side) - (:declare (type tn index base result) - (type (member t nil) modify scale) - (type (member nil 0 1) side)) - (:delay 0) - :pinned - (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0)) - `('FLDD ,@cmplt-index-print :tab x "(" s b ")" "," t)) - (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0)) - `('FLDW ,@cmplt-index-print :tab x "(" s b ")" "," t)) - (:emitter - (multiple-value-bind - (result-encoding double-p) - (fp-reg-tn-encoding result) - (when side - (aver double-p) - (setf double-p nil)) - (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) - (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0 - (or side 0) (if modify 1 0) result-encoding)))) - -(define-instruction fstx (segment value index base &key modify scale side) - (:declare (type tn index base value) - (type (member t nil) modify scale) - (type (member nil 0 1) side)) - (:delay 0) - :pinned - (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1)) - `('FSTD ,@cmplt-index-print :tab t "," x "(" s b ")")) - (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1)) - `('FSTW ,@cmplt-index-print :tab t "," x "(" s b ")")) - (:emitter - (multiple-value-bind - (value-encoding double-p) - (fp-reg-tn-encoding value) - (when side - (aver double-p) - (setf double-p nil)) - (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) - (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1 - (or side 0) (if modify 1 0) value-encoding)))) - -(define-instruction flds (segment disp base result &key modify side) - (:declare (type tn base result) - (type (signed-byte 5) disp) - (type (member :before :after nil) modify) - (type (member nil 0 1) side)) - (:delay 0) - :pinned - (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0)) - `('FLDD ,@cmplt-disp-print :tab x "(" s b ")," t)) - (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0)) - `('FLDW ,@cmplt-disp-print :tab x "(" s b ")," t)) - (:emitter - (multiple-value-bind - (result-encoding double-p) - (fp-reg-tn-encoding result) - (when side - (aver double-p) - (setf double-p nil)) - (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) - (short-disp-encoding segment disp) 0 - (if (eq modify :before) 1 0) 1 0 0 - (or side 0) (if modify 1 0) result-encoding)))) - -(define-instruction fsts (segment value disp base &key modify side) - (:declare (type tn base value) - (type (signed-byte 5) disp) - (type (member :before :after nil) modify) - (type (member nil 0 1) side)) - (:delay 0) - :pinned - (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1)) - `('FSTD ,@cmplt-disp-print :tab t "," x "(" s b ")")) - (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1)) - `('FSTW ,@cmplt-disp-print :tab t "," x "(" s b ")")) - (:emitter - (multiple-value-bind - (value-encoding double-p) - (fp-reg-tn-encoding value) - (when side - (aver double-p) - (setf double-p nil)) - (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) - (short-disp-encoding segment disp) 0 - (if (eq modify :before) 1 0) 1 0 1 - (or side 0) (if modify 1 0) value-encoding)))) - - -(define-bitfield-emitter emit-fp-class-0-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9) - (byte 3 6) (byte 1 5) (byte 5 0)) - -(define-bitfield-emitter emit-fp-class-1-inst 32 - (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11) - (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0)) - -;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need -;;; seperate emitters. - -(defconstant-eqx funops '(:copy :abs :sqrt :rnd) - #'equalp) - -(deftype funop () - `(member ,@funops)) - -(define-instruction funop (segment op from to) - (:declare (type funop op) - (type tn from to)) - (:delay 0) - :pinned - (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0)) - '('FCPY fmt :tab r "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0)) - '('FABS fmt :tab r "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0)) - '('FSQRT fmt :tab r "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0)) - '('FRND fmt :tab r "," t)) - (:emitter - (multiple-value-bind - (from-encoding from-double-p) - (fp-reg-tn-encoding from) - (multiple-value-bind - (to-encoding to-double-p) - (fp-reg-tn-encoding to) - (aver (eq from-double-p to-double-p)) - (emit-fp-class-0-inst segment #x0C from-encoding 0 - (+ 2 (or (position op funops) - (error "Bogus FUNOP: ~S" op))) - (if to-double-p 1 0) 0 0 0 to-encoding))))) - -(macrolet ((define-class-1-fp-inst (name subcode) - `(define-instruction ,name (segment from to) - (:declare (type tn from to)) - (:delay 0) - (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode)) - '(:name sf df :tab r "," t)) - (:emitter - (multiple-value-bind - (from-encoding from-double-p) - (fp-reg-tn-encoding from) - (multiple-value-bind - (to-encoding to-double-p) - (fp-reg-tn-encoding to) - (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode - (if to-double-p 1 0) (if from-double-p 1 0) - 1 0 0 to-encoding))))))) - - (define-class-1-fp-inst fcnvff 0) - (define-class-1-fp-inst fcnvxf 1) - (define-class-1-fp-inst fcnvfx 2) - (define-class-1-fp-inst fcnvfxt 3)) - -(define-instruction fcmp (segment cond r1 r2) - (:declare (type (unsigned-byte 5) cond) - (type tn r1 r2)) - (:delay 0) - :pinned - (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond)) - '(:name fmt t :tab r "," x1)) - (:emitter - (multiple-value-bind - (r1-encoding r1-double-p) - (fp-reg-tn-encoding r1) - (multiple-value-bind - (r2-encoding r2-double-p) - (fp-reg-tn-encoding r2) - (aver (eq r1-double-p r2-double-p)) - (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0 - (if r1-double-p 1 0) 2 0 0 cond))))) - -(define-instruction ftest (segment) - (:delay 0) - :pinned - (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name)) - (:emitter - (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0))) - -(defconstant-eqx fbinops '(:add :sub :mpy :div) - #'equalp) - -(deftype fbinop () - `(member ,@fbinops)) - -(define-instruction fbinop (segment op r1 r2 result) - (:declare (type fbinop op) - (type tn r1 r2 result)) - (:delay 0) - :pinned - (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3)) - '('FADD fmt :tab r "," x1 "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3)) - '('FSUB fmt :tab r "," x1 "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3)) - '('FMPY fmt :tab r "," x1 "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3)) - '('FDIV fmt :tab r "," x1 "," t)) - (:emitter - (multiple-value-bind - (r1-encoding r1-double-p) - (fp-reg-tn-encoding r1) - (multiple-value-bind - (r2-encoding r2-double-p) - (fp-reg-tn-encoding r2) - (aver (eq r1-double-p r2-double-p)) - (multiple-value-bind - (result-encoding result-double-p) - (fp-reg-tn-encoding result) - (aver (eq r1-double-p result-double-p)) - (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding - (or (position op fbinops) - (error "Bogus FBINOP: ~S" op)) - (if r1-double-p 1 0) 3 0 0 - result-encoding)))))) - - - -;;;; Instructions built out of other insts. - -(define-instruction-macro move (src dst &optional cond) - `(inst or ,src zero-tn ,dst ,cond)) - -(define-instruction-macro nop (&optional cond) - `(inst or zero-tn zero-tn zero-tn ,cond)) - -(define-instruction li (segment value reg) - (:declare (type tn reg) - (type (or fixup (signed-byte 32) (unsigned-byte 32)) value)) - (:delay 0) - (:dependencies (reads reg)) - (:vop-var vop) - (:emitter - (assemble (segment vop) - (etypecase value - (fixup - (inst ldil value reg) - (inst ldo value reg reg :unsigned t)) - ((signed-byte 14) - (inst ldo value zero-tn reg)) - ((or (signed-byte 32) (unsigned-byte 32)) - (let ((lo (ldb (byte 11 0) value))) - (inst ldil value reg) - (inst ldo lo reg reg :unsigned t))))))) - -(define-instruction-macro sll (src count result &optional cond) - (once-only ((result result) (src src) (count count) (cond cond)) - `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) - -(define-instruction-macro sra (src count result &optional cond) - (once-only ((result result) (src src) (count count) (cond cond)) - `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) - -(define-instruction-macro srl (src count result &optional cond) - (once-only ((result result) (src src) (count count) (cond cond)) - `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) - -(defun maybe-negate-cond (cond negate) - (if negate - (multiple-value-bind - (value negate) - (compare-condition cond) - (if negate - (nth value compare-conditions) - (nth (+ value 8) compare-conditions))) - cond)) - -(define-instruction bc (segment cond not-p r1 r2 target) - (:declare (type compare-condition cond) - (type (member t nil) not-p) - (type tn r1 r2) - (type label target)) - (:delay 0) - (:dependencies (reads r1) (reads r2)) - (:vop-var vop) - (:emitter - (emit-chooser segment 8 2 - (lambda (segment chooser posn delta) - (declare (ignore chooser)) - (let ((disp (label-relative-displacement target posn delta))) - (when (<= 0 disp (1- (ash 1 11))) - (assemble (segment vop) - (inst comb (maybe-negate-cond cond not-p) r1 r2 target - :nullify t)) - t))) - (lambda (segment posn) - (let ((disp (label-relative-displacement target posn))) - (assemble (segment vop) - (cond ((typep disp '(signed-byte 12)) - (inst comb (maybe-negate-cond cond not-p) r1 r2 target) - (inst nop)) ; FIXME-lav, cant nullify when backward branch - (t - (inst comclr r1 r2 zero-tn - (maybe-negate-cond cond (not not-p))) - (inst b target :nullify t))))))))) - -(define-instruction bci (segment cond not-p imm reg target) - (:declare (type compare-condition cond) - (type (member t nil) not-p) - (type (signed-byte 11) imm) - (type tn reg) - (type label target)) - (:delay 0) - (:dependencies (reads reg)) - (:vop-var vop) - (:emitter - (emit-chooser segment 8 2 - (lambda (segment chooser posn delta-if-after) - (declare (ignore chooser)) - (let ((disp (label-relative-displacement target posn delta-if-after))) - (when (and (<= 0 disp (1- (ash 1 11))) - (typep imm '(signed-byte 5))) - (assemble (segment vop) - (inst comib (maybe-negate-cond cond not-p) imm reg target - :nullify t)) - t))) - (lambda (segment posn) - (let ((disp (label-relative-displacement target posn))) - (assemble (segment vop) - (cond ((and (typep disp '(signed-byte 12)) - (typep imm '(signed-byte 5))) - (inst comib (maybe-negate-cond cond not-p) imm reg target) - (inst nop)) - (t - (inst comiclr imm reg zero-tn - (maybe-negate-cond cond (not not-p))) - (inst b target :nullify t))))))))) - - -;;;; Instructions to convert between code ptrs, functions, and lras. - -(defun emit-header-data (segment type) - (emit-back-patch - segment 4 - (lambda (segment posn) - (emit-word segment - (logior type - (ash (+ posn (component-header-length)) - (- n-widetag-bits word-shift))))))) - -(define-instruction simple-fun-header-word (segment) - :pinned - (:cost 0) - (:delay 0) - (:emitter - (emit-header-data segment simple-fun-widetag))) - -(define-instruction lra-header-word (segment) - :pinned - (:cost 0) - (:delay 0) - (:emitter - (emit-header-data segment return-pc-widetag))) - - -(defun emit-compute-inst (segment vop src label temp dst calc) - (emit-chooser - ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments. - segment 12 3 - ;; This is the best-case that emits one instruction ( 4 bytes ) - (lambda (segment chooser posn delta-if-after) - (declare (ignore chooser)) - (let ((delta (funcall calc label posn delta-if-after))) - ;; WHEN, Why not AVER ? - (when (typep delta '(signed-byte 11)) - (emit-back-patch segment 4 - (lambda (segment posn) - (assemble (segment vop) - (inst addi (funcall calc label posn 0) src - dst)))) - t))) - ;; This is the worst-case that emits three instruction ( 12 bytes ) - (lambda (segment posn) - (let ((delta (funcall calc label posn 0))) - ;; FIXME-lav: why do we hit below check ? - ;; (when (<= (- (ash 1 10)) delta (1- (ash 1 10))) - ;; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta)) - ;; Note: if we used addil/ldo to do this in 2 instructions then the - ;; intermediate value would be tagged but pointing into space. - ;; Does above note mean that the intermediate value would be - ;; a bogus pointer that would be GCed wrongly ? - ;; Also what I can see addil would also overwrite NFP (r1) ??? - (assemble (segment vop) - ;; Three instructions (4 * 3) this is the reason for 12 bytes - (inst ldil delta temp) - (inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t) - (inst add src temp dst)))))) - -(macrolet ((compute ((name) &body body) - `(define-instruction ,name (segment src label temp dst) - (:declare (type tn src dst temp) (type label label)) - (:attributes variable-length) - (:dependencies (reads src) (writes dst) (writes temp)) - (:delay 0) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop src label temp dst - ,@body))))) - (compute (compute-code-from-lip) - (lambda (label posn delta-if-after) - (- other-pointer-lowtag - (label-position label posn delta-if-after) - (component-header-length)))) - (compute (compute-code-from-lra) - (lambda (label posn delta-if-after) - (- (+ (label-position label posn delta-if-after) - (component-header-length))))) - (compute (compute-lra-from-code) - (lambda (label posn delta-if-after) - (+ (label-position label posn delta-if-after) - (component-header-length))))) - -;;;; Data instructions. -(define-bitfield-emitter emit-word 32 - (byte 32 0)) - -(macrolet ((data (size type) - `(define-instruction ,size (segment ,size) - (:declare (type ,type ,size)) - (:cost 0) - (:delay 0) - :pinned - (:emitter - (etypecase ,size - ,@(when (eq size 'word) - '((fixup - (note-fixup segment :absolute word) - (emit-word segment 0)))) - (integer - (,(symbolicate "EMIT-" size) segment ,size))))))) - (data byte (or (unsigned-byte 8) (signed-byte 8))) - (data short (or (unsigned-byte 16) (signed-byte 16))) - (data word (or (unsigned-byte 32) (signed-byte 32) fixup))) diff -Nru sbcl-2.0.6/src/compiler/hppa/macros.lisp sbcl-2.1.1/src/compiler/hppa/macros.lisp --- sbcl-2.0.6/src/compiler/hppa/macros.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/macros.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,386 +0,0 @@ -;;;; various useful macros for generating HPPA code - -;;;; 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") - - - -(defmacro expand (expr) - (let ((gensym (gensym))) - `(macrolet - ((,gensym () - ,expr)) - (,gensym)))) - -;;; Instruction-like macros. -;;; FIXME-lav: add if always-emit-code-p is :e= then error if location= -(defmacro move (src dst &optional always-emit-code-p) - "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P is nil)." - (once-only ((n-src src) - (n-dst dst)) - `(if (location= ,n-dst ,n-src) - (when ,always-emit-code-p - (inst nop)) - (inst move ,n-src ,n-dst)))) - -(defmacro loadw (result base &optional (offset 0) (lowtag 0)) - (once-only ((result result) (base base)) - `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result))) - -(defmacro storew (value base &optional (offset 0) (lowtag 0)) - (once-only ((value value) (base base) (offset offset) (lowtag lowtag)) - `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base))) - -(defmacro load-symbol (reg symbol) - (once-only ((reg reg) (symbol symbol)) - `(let ((offset (static-symbol-offset ,symbol))) - (cond - ((typep offset '(signed-byte 11)) - (inst addi offset null-tn ,reg)) - (t - (inst ldil offset ,reg) - (inst ldo offset null-tn ,reg :unsigned t)))))) - -(defmacro load-symbol-value (reg symbol) - `(inst ldw - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag)) - null-tn ,reg)) - -(defmacro store-symbol-value (reg symbol) - `(inst stw ,reg (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag)) - null-tn)) - -(defmacro load-type (target source &optional (offset 0)) - "Loads the type bits of a pointer into target independent of -byte-ordering issues." - (once-only ((n-target target) - (n-source source) - (n-offset offset)) - (ecase *backend-byte-order* - (:little-endian - `(inst ldb ,n-offset ,n-source ,n-target)) - (:big-endian - `(inst ldb (+ ,n-offset (1- n-word-bytes)) ,n-source ,n-target))))) - -(defmacro set-lowtag (tag src dst) - `(progn - (inst move ,src ,dst) - (inst dep ,tag 31 n-lowtag-bits ,dst))) - -;;; Macros to handle the fact that we cannot use the machine native call and -;;; return instructions. - -(defmacro lisp-jump (function) - "Jump to the lisp function FUNCTION." - `(progn - (inst addi (- (ash simple-fun-insts-offset word-shift) - fun-pointer-lowtag) ,function lip-tn) - (inst bv lip-tn) - (move ,function code-tn t))) - -(defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) - "Return to RETURN-PC." - `(progn - (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) - ,return-pc lip-tn) - (inst bv lip-tn ,@(unless frob-code '(:nullify t))) - ,@(if frob-code - `((move ,return-pc code-tn t))))) - -(defmacro emit-return-pc (label) - "Emit a return-pc header word. LABEL is the label to use for this - return-pc." - `(progn - ;; alignment causes the return point to land on two address, - ;; where the first must be nop pad. - (emit-alignment n-lowtag-bits) - (emit-label ,label) - (inst lra-header-word))) - - -;;;; Stack TN's - -;;; Move a stack TN to a register and vice-versa. -(defmacro load-stack-tn (reg stack) - `(let ((reg ,reg) - (stack ,stack)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (loadw reg cfp-tn offset)))))) - -(defmacro store-stack-tn (stack reg) - `(let ((stack ,stack) - (reg ,reg)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (storew reg cfp-tn offset)))))) - -(defmacro maybe-load-stack-tn (reg reg-or-stack) - "Move the TN Reg-Or-Stack into Reg if it isn't already there." - (once-only ((n-reg reg) - (n-stack reg-or-stack)) - `(sc-case ,n-reg - ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) - - -;;;; Storage allocation: - -(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code - size dynamic-extent-p - &key (lowtag other-pointer-lowtag) - maybe-write) - &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 -Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used -by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably -initializes the object." - (declare (ignore flag-tn)) - (once-only ((result-tn result-tn) (temp-tn temp-tn) - (type-code type-code) (size size) - (lowtag lowtag)) - (let ((write-body `((inst li (compute-object-header ,size ,type-code) ,temp-tn) - (storew ,temp-tn ,result-tn 0 ,lowtag)))) - `(if ,dynamic-extent-p - (pseudo-atomic () - (align-csp ,temp-tn) - (set-lowtag ,lowtag csp-tn ,result-tn) - (inst addi (pad-data-block ,size) csp-tn csp-tn) - ,@(if maybe-write - `((when ,type-code ,@write-body)) - write-body) - ,@body) - (pseudo-atomic (:extra (pad-data-block ,size)) - (set-lowtag ,lowtag alloc-tn ,result-tn) - ,@(if maybe-write - `((when ,type-code ,@write-body)) - write-body) - ,@body))))) - -;;; is used for stack allocation of dynamic-extent objects -;;; FIXME-lav, if using defun, atleast surround in assembly-form ? macro better ? -(defun align-csp (temp) - (declare (ignore temp)) - (let ((aligned (gen-label))) - (inst extru csp-tn 31 n-lowtag-bits zero-tn :<>) - (inst b aligned :nullify t) - (inst addi n-word-bytes csp-tn csp-tn) - (storew zero-tn csp-tn -1) - (emit-label aligned))) - - -;;;; Error Code -(defun emit-error-break (vop kind code values) - (assemble () - (when vop - (note-this-location vop :internal-error)) - (emit-internal-error kind code values - :trap-emitter (lambda (trap-number) - (inst break trap-number)) - :compact-error-trap nil) - (emit-alignment word-shift))) - -(defun generate-error-code (vop error-code &rest values) - "Generate-Error-Code Error-code Value* - Emit code for an error with the specified Error-Code and context Values." - (assemble (:elsewhere) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (apply #'error-call vop error-code values) - start-lab))) - -;;;; PSEUDO-ATOMIC - -;;; handy macro for making sequences look atomic -(defmacro pseudo-atomic ((&key (extra 0)) &rest forms) - (let ((n-extra (gensym))) - `(let ((,n-extra ,extra)) - (inst addi 4 alloc-tn alloc-tn) - ,@forms - (cond - ((typep ,n-extra '(signed-byte 11)) - (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od)) - ((typep ,n-extra '(signed-byte 14)) - (inst ldo ,n-extra alloc-tn alloc-tn) - (inst addit -4 alloc-tn alloc-tn :od)) - (t - ;; FIXME: Make this case work, somehow - (error "EXTRA out-of-range in PSEUDO-ATOMIC")))))) - -;;;; indexed references - -(sb-xc:deftype load/store-index (scale lowtag min-offset - &optional (max-offset min-offset)) - `(integer ,(- (truncate (+ (ash 1 14) - (* min-offset n-word-bytes) - (- lowtag)) - scale)) - ,(truncate (- (+ (1- (ash 1 14)) lowtag) - (* max-offset n-word-bytes)) - scale))) - -(defmacro define-full-reffer (name type offset lowtag scs el-type - &optional translate) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types ,type tagged-num) - (:temporary (:scs (interior-reg)) lip) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst add object index lip) - (loadw value lip ,offset ,lowtag))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 4 - (loadw value object (+ ,offset index) ,lowtag))))) - -(defmacro define-full-setter (name type offset lowtag scs el-type - &optional translate) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type tagged-num ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 2 - (inst add object index lip) - (storew value lip ,offset ,lowtag) - (move value result))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 1 - (storew value object (+ ,offset index) ,lowtag) - (move value result))))) - - -(defmacro define-partial-reffer (name type size signed offset lowtag scs - el-type &optional translate) - (let ((scale (ecase size (:byte 1) (:short 2)))) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:generator 5 - (inst ,(ecase size (:byte 'add) (:short 'sh1add)) - index object lip) - (inst ,(ecase size (:byte 'ldb) (:short 'ldh)) - (- (* ,offset n-word-bytes) ,lowtag) lip value) - ,@(when signed - `((inst extrs value 31 ,(* scale n-byte-bits) value))))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst ,(ecase size (:byte 'ldb) (:short 'ldh)) - (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) - object value) - ,@(when signed - `((inst extrs value 31 ,(* scale n-byte-bits) value)))))))) - -(defmacro define-partial-setter (name type size offset lowtag scs el-type - &optional translate) - (let ((scale (ecase size (:byte 1) (:short 2)))) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type positive-fixnum ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst ,(ecase size (:byte 'add) (:short 'sh1add)) - index object lip) - (inst ,(ecase size (:byte 'stb) (:short 'sth)) - value (- (* ,offset n-word-bytes) ,lowtag) lip) - (move value result))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs :target result)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst ,(ecase size (:byte 'stb) (:short 'sth)) - value - (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) - object) - (move value result)))))) diff -Nru sbcl-2.0.6/src/compiler/hppa/memory.lisp sbcl-2.1.1/src/compiler/hppa/memory.lisp --- sbcl-2.0.6/src/compiler/hppa/memory.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/memory.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -(in-package "SB-VM") - -;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to -;;; be read or written is a property of the VOP used. Cell-Setf is similar to -;;; Cell-Set, but delivers the new value as the result. -;;; -(define-vop (cell-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (loadw value object offset lowtag))) -;;; -(define-vop (cell-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg null zero))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 1 - (storew value object offset lowtag))) diff -Nru sbcl-2.0.6/src/compiler/hppa/move.lisp sbcl-2.1.1/src/compiler/hppa/move.lisp --- sbcl-2.0.6/src/compiler/hppa/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/move.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,296 +0,0 @@ -;;;; the HPPA VM definition of operand loading/saving and the Move VOP - -;;;; 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") - -(define-move-fun (load-immediate 1) (vop x y) - ((null zero immediate) - (any-reg descriptor-reg)) - (let ((val (tn-value x))) - (etypecase val - (integer - (inst li (fixnumize val) y)) - (null - (move null-tn y)) - (symbol - (load-symbol y val)) - (character - (inst li (logior (ash (char-code val) n-widetag-bits) - character-widetag) y))))) - -(define-move-fun (load-number 1) (vop x y) - ((zero immediate) - (signed-reg unsigned-reg)) - (inst li (tn-value x) y)) - -(define-move-fun (load-character 1) (vop x y) - ((immediate) (character-reg)) - (inst li (char-code (tn-value x)) y)) - -(define-move-fun (load-system-area-pointer 1) (vop x y) - ((immediate) (sap-reg)) - (inst li (sap-int (tn-value x)) y)) - -(define-move-fun (load-constant 5) (vop x y) - ((constant) (descriptor-reg any-reg)) - (let ((offset (- (tn-byte-offset x) other-pointer-lowtag))) - (cond - ((typep offset '(signed-byte 11)) - (inst ldw offset code-tn y)) - (t - (inst li offset lip-tn) - (inst ldwx lip-tn code-tn y))))) - -(define-move-fun (load-stack 5) (vop x y) - ((control-stack) (any-reg descriptor-reg)) - (load-stack-tn y x)) - -(define-move-fun (load-number-stack 5) (vop x y) - ((character-stack) (character-reg) - (sap-stack) (sap-reg) - (signed-stack) (signed-reg) - (unsigned-stack) (unsigned-reg)) - (let ((nfp (current-nfp-tn vop))) - (loadw y nfp (tn-offset x)))) - -(define-move-fun (store-stack 5) (vop x y) - ((any-reg descriptor-reg null zero) (control-stack)) - (store-stack-tn y x)) - -(define-move-fun (store-number-stack 5) (vop x y) - ((character-reg) (character-stack) - (sap-reg) (sap-stack) - (signed-reg) (signed-stack) - (unsigned-reg) (unsigned-stack)) - (let ((nfp (current-nfp-tn vop))) - (storew x nfp (tn-offset y)))) - - -;;;; The Move VOP: -(define-vop (move) - (:args (x :target y - :scs (any-reg descriptor-reg zero null) - :load-if (not (location= x y)))) - (:results (y :scs (any-reg descriptor-reg control-stack) - :load-if (not (location= x y)))) - (:generator 0 - (unless (location= x y) - (sc-case y - ((any-reg descriptor-reg) - (inst move x y)) - (control-stack - (store-stack-tn y x)))))) - -(define-move-vop move :move - (any-reg descriptor-reg zero null) - (any-reg descriptor-reg)) - -;;; The MOVE-ARG VOP is used for moving descriptor values into another -;;; frame for argument or known value passing. -(define-vop (move-arg) - (:args (x :target y - :scs (any-reg descriptor-reg null zero)) - (fp :scs (any-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - ((any-reg descriptor-reg) - (move x y)) - (control-stack - (storew x fp (tn-offset y)))))) -(define-move-vop move-arg :move-arg - (any-reg descriptor-reg null zero) - (any-reg descriptor-reg)) - -;;;; Moves and coercions: - -;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word -;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer -;;; to a tagged bignum or fixnum. - -;;; ARG is a fixnum, so just shift it. We need a type restriction -;;; because some possible arg SCs (control-stack) overlap with -;;; possible bignum arg SCs. -(define-vop (move-to-word/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:arg-types tagged-num) - (:note "fixnum untagging") - (:generator 1 - (inst sra x n-fixnum-tag-bits y))) - -(define-move-vop move-to-word/fixnum :move - (any-reg descriptor-reg) (signed-reg unsigned-reg)) - -;;; ARG is a non-immediate constant, load it. -(define-vop (move-to-word-c) - (:args (x :scs (constant))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "constant load") - (:generator 1 - (cond ((sb-c::tn-leaf x) - (inst li (tn-value x) y)) - (t - (loadw y code-tn (tn-offset x) other-pointer-lowtag) - (inst sra y n-fixnum-tag-bits y))))) - -(define-move-vop move-to-word-c :move - (constant) (signed-reg unsigned-reg)) - -;;; ARG is a fixnum or bignum, figure out which and load if necessary. -(define-vop (move-to-word/integer) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "integer to untagged word coercion") - (:generator 3 - (inst sra x n-fixnum-tag-bits y) - (inst extru x 31 2 zero-tn :=) - (loadw y x bignum-digits-offset other-pointer-lowtag))) - -(define-move-vop move-to-word/integer :move - (descriptor-reg) (signed-reg unsigned-reg)) - -;;; RESULT is a fixnum, so we can just shift. We need the result type -;;; restriction because of the control-stack ambiguity noted above. -(define-vop (move-from-word/fixnum) - (:args (x :scs (signed-reg unsigned-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "fixnum tagging") - (:generator 1 - (inst sll x n-fixnum-tag-bits y))) - -(define-move-vop move-from-word/fixnum :move - (signed-reg unsigned-reg) (any-reg descriptor-reg)) - -;;; RESULT may be a bignum, so we have to check. Use a worst-case -;;; cost to make sure people know they may be number consing. -(define-vop (move-from-signed) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - (:note "signed word to integer coercion") - (:generator 18 - (move arg x) - ;; Extract the top three bits. - (inst extrs x 2 3 temp :=) - ;; Invert them (unless they are already zero). - (inst uaddcm zero-tn temp temp) - ;; If we are left with zero, it will fit in a fixnum. So branch around - ;; the bignum-construction, doing the shift in the delay slot. - (inst comb := temp zero-tn done) - (inst sll x n-fixnum-tag-bits y) - ;; Make a single-digit bignum. - (with-fixed-allocation - (y nil temp bignum-widetag (1+ bignum-digits-offset) nil) - (storew x y bignum-digits-offset other-pointer-lowtag)) - DONE)) - -(define-move-vop move-from-signed :move - (signed-reg) (descriptor-reg)) - -(define-vop (move-from-fixnum+1) - (:args (x :scs (signed-reg unsigned-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:generator 4 - ;; Extract the top three bits. - (inst extrs x 2 3 temp :=) - ;; Invert them (unless they are already zero). - (inst uaddcm zero-tn temp temp) - ;; If we are left with zero, it will fit in a fixnum. So branch around - ;; the bignum-construction, doing the shift in the delay slot. - (inst comb := temp zero-tn done) - (inst sll x n-fixnum-tag-bits y) - (load-constant vop (emit-constant (1+ sb-xc:most-positive-fixnum)) - y) - DONE)) - -(define-vop (move-from-fixnum-1 move-from-fixnum+1) - (:generator 4 - ;; Extract the top three bits. - (inst extrs x 2 3 temp :=) - ;; Invert them (unless they are already zero). - (inst uaddcm zero-tn temp temp) - ;; If we are left with zero, it will fit in a fixnum. So branch around - ;; the bignum-construction, doing the shift in the delay slot. - (inst comb := temp zero-tn done) - (inst sll x n-fixnum-tag-bits y) - (load-constant vop (emit-constant (1- sb-xc:most-negative-fixnum)) - y) - DONE)) - -;;; Check for fixnum, and possibly allocate one or two word bignum -;;; result. Use a worst-case cost to make sure people know they may -;;; be number consing. -(define-vop (move-from-unsigned) - (:note "unsigned word to integer coercion") - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - (:generator 20 - (move arg x) - (inst srl x n-positive-fixnum-bits temp) - (inst comb := temp zero-tn done) - (inst sll x n-fixnum-tag-bits y) - (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 2))) - (set-lowtag other-pointer-lowtag alloc-tn y) - (inst xor temp temp temp) - (inst comclr x zero-tn zero-tn :>=) - (inst li 1 temp) - (inst sll temp n-widetag-bits temp) - (inst addi (logior (ash 1 n-widetag-bits) bignum-widetag) temp temp) - (storew temp y 0 other-pointer-lowtag)) - - (storew x y bignum-digits-offset other-pointer-lowtag) - DONE)) - -(define-move-vop move-from-unsigned :move - (unsigned-reg) (descriptor-reg)) - -;;; Move untagged numbers. -(define-vop (word-move) - (:args (x :target y - :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:results (y :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:note "word integer move") - (:generator 0 - (move x y))) - -(define-move-vop word-move :move - (signed-reg unsigned-reg) (signed-reg unsigned-reg)) - -;;; Move untagged number args/return-values. -(define-vop (move-word-arg) - (:args (x :target y - :scs (signed-reg unsigned-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y signed-reg unsigned-reg)))) - (:results (y)) - (:note "word integer argument move") - (:generator 0 - (sc-case y - ((signed-reg unsigned-reg) - (move x y)) - ((signed-stack unsigned-stack) - (storew x fp (tn-offset y)))))) - -(define-move-vop move-word-arg :move-arg - (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) - -;;; Use standard MOVE-ARG + coercion to move an untagged number to a -;;; descriptor passing location. -(define-move-vop move-arg :move-arg - (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff -Nru sbcl-2.0.6/src/compiler/hppa/nlx.lisp sbcl-2.1.1/src/compiler/hppa/nlx.lisp --- sbcl-2.0.6/src/compiler/hppa/nlx.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/nlx.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,240 +0,0 @@ -(in-package "SB-VM") - -;;; 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 ocfp-offset)) - -;;; Save and restore dynamic environment. -;;; -;;; These VOPs are used in the reentered function to restore the appropriate -;;; dynamic environment. Currently we only save the Current-Catch and binding -;;; stack pointer. We don't need to save/restore the current unwind-protect, -;;; since unwind-protects are implicitly processed during unwinding. If there -;;; were any additional stacks, then this would be the place to restore the top -;;; pointers. - -(define-vop (save-dynamic-state) - (:results (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg))) - (:vop-var vop) - (:generator 13 - (load-symbol-value catch *current-catch-block*) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nfp))) - (move nsp-tn nsp))) - -(define-vop (restore-dynamic-state) - (:args (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg))) - (:vop-var vop) - (:generator 10 - (store-symbol-value catch *current-catch-block*) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move nfp cur-nfp))) - (move nsp nsp-tn))) - -(define-vop (current-stack-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move csp-tn res))) - -(define-vop (current-binding-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move bsp-tn res))) - -(define-vop (current-nsp) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move res nsp-tn))) - -(define-vop (set-nsp) - (:args (nsp :scs (any-reg descriptor-reg))) - (:generator 1 - (move nsp-tn nsp))) - -;;;; Unwind block hackery: - -;;; Compute the address of the catch block from its TN, then store into the -;;; block the current Fp, Env, Unwind-Protect, and the entry PC. -;;; -(define-vop (make-unwind-block) - (:args (tn)) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 22 - (inst ldo (tn-byte-offset tn) cfp-tn block) - (load-symbol-value temp *current-unwind-protect-block*) - (storew temp block unwind-block-uwp-slot) - (storew cfp-tn block unwind-block-cfp-slot) - (storew code-tn block unwind-block-code-slot) - (inst compute-lra-from-code code-tn entry-label ndescr temp) - (storew temp block catch-block-entry-pc-slot))) - -;;; Like Make-Unwind-Block, except that we also store in the specified tag, and -;;; link the block into the Current-Catch list. -;;; -(define-vop (make-catch-block) - (:args (tn) - (tag :scs (any-reg descriptor-reg))) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 44 - (inst ldo (tn-byte-offset tn) cfp-tn result) - (load-symbol-value temp *current-unwind-protect-block*) - (storew temp result catch-block-uwp-slot) - (storew cfp-tn result catch-block-cfp-slot) - (storew code-tn result catch-block-code-slot) - (inst compute-lra-from-code code-tn entry-label ndescr temp) - (storew temp result catch-block-entry-pc-slot) - - (storew tag result catch-block-tag-slot) - (load-symbol-value temp *current-catch-block*) - (storew temp result catch-block-previous-catch-slot) - (store-symbol-value result *current-catch-block*) - (move result block))) - -;;; Just set the current unwind-protect to UWP. This instantiates an -;;; unwind block as an unwind-protect. -;;; -(define-vop (set-unwind-protect) - (:args (uwp :scs (any-reg))) - (:generator 7 - (store-symbol-value uwp *current-unwind-protect-block*))) - - -(define-vop (%catch-breakup) - (:args (current-block)) - (:ignore current-block) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:generator 17 - (load-symbol-value block *current-catch-block*) - (loadw block block catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) - -(define-vop (%unwind-protect-breakup) - (:args (current-block)) - (:ignore current-block) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:generator 17 - (load-symbol-value block *current-unwind-protect-block*) - (loadw block block unwind-block-uwp-slot) - (store-symbol-value block *current-unwind-protect-block*))) - - -;;;; NLX entry VOPs: - - -(define-vop (nlx-entry) - (:args (sp) ;; Note: we can't list an sc-restriction, 'cause any load vops - ;; would be inserted before the LRA. - (start) - (count)) - (:results (values :more t)) - (:temporary (:scs (descriptor-reg)) move-temp) - (:info label nvals) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (cond ((zerop nvals)) - ((= nvals 1) - (loadw (tn-ref-tn values) start) - (inst comclr count zero-tn zero-tn :<>) - (move null-tn (tn-ref-tn values) t)) - (t - (collect ((defaults)) - (do ((i 0 (1+ i)) - (tn-ref values (tn-ref-across tn-ref))) - ((null tn-ref)) - (let ((default-lab (gen-label)) - (tn (tn-ref-tn tn-ref))) - (defaults (cons default-lab tn)) - (inst comb := zero-tn count default-lab) - (inst addi (fixnumize -1) count count) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start i)) - (control-stack - (loadw move-temp start i) - (store-stack-tn tn move-temp))))) - (let ((defaulting-done (gen-label))) - (emit-label defaulting-done) - (assemble (:elsewhere) - (dolist (def (defaults)) - (emit-label (car def)) - (let ((tn (cdr def))) - (sc-case tn - ((descriptor-reg any-reg) - (move null-tn tn)) - (control-stack - (store-stack-tn tn null-tn))))) - (inst b defaulting-done :nullify t)))))) - (load-stack-tn csp-tn sp))) - - -(define-vop (nlx-entry-multiple) - (:args (top :target dst) (start :target src) (count :target num)) - ;; Again, no SC restrictions for the args, 'cause the loading would - ;; happen before the entry label. - (:info label) - (:temporary (:scs (any-reg) :from (:argument 0)) dst) - (:temporary (:scs (any-reg) :from (:argument 1)) src) - (:temporary (:scs (any-reg) :from (:argument 2)) num) - (:temporary (:scs (descriptor-reg)) temp) - (:results (new-start) (new-count)) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (let ((loop (gen-label)) - (done (gen-label))) - - ;; Copy args. - (load-stack-tn dst top) - (move start src) - (move count num) - - ;; Establish results. - (sc-case new-start - (any-reg (move dst new-start)) - (control-stack (store-stack-tn new-start dst))) - (inst comb := num zero-tn done :nullify t) - (sc-case new-count - (any-reg (move num new-count)) - (control-stack (store-stack-tn new-count num))) - - ;; Copy stuff on stack. - (emit-label loop) - (inst ldwm n-word-bytes src temp) - (inst addib :<> (fixnumize -1) num loop) - (inst stwm temp n-word-bytes dst) - - (emit-label done) - (move dst csp-tn)))) - -;;; This VOP is just to force the TNs used in the cleanup onto the stack. -;;; -(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) - (note-this-location vop :non-local-entry))) diff -Nru sbcl-2.0.6/src/compiler/hppa/parms.lisp sbcl-2.1.1/src/compiler/hppa/parms.lisp --- sbcl-2.0.6/src/compiler/hppa/parms.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/parms.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,143 +0,0 @@ -(in-package "SB-VM") - -; normally assem-scheduler-p is t, and nil if debugging the assembler -; but apparently we don't trust any of the instruction definitions. -(defconstant sb-assem:assem-scheduler-p nil) -(defconstant sb-assem:+inst-alignment-bytes+ 4) -(defconstant sb-assem:+assem-max-locations+ 68) ; see number-location - -(defconstant +backend-fasl-file-implementation+ :hppa) -(defconstant +backend-page-bytes+ 4096) - -;;;; Machine Architecture parameters: -(eval-when (:compile-toplevel :load-toplevel :execute) - -;;; number of bits per word where a word holds one lisp descriptor -(defconstant n-word-bits 32) - -;;; the natural width of a machine word (as seen in e.g. register width, -;;; address space) -(defconstant n-machine-word-bits 32) - -(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)) - -(defconstant float-inexact-trap-bit (ash 1 0)) -(defconstant float-underflow-trap-bit (ash 1 1)) -(defconstant float-overflow-trap-bit (ash 1 2)) -(defconstant float-divide-by-zero-trap-bit (ash 1 3)) -(defconstant float-invalid-trap-bit (ash 1 4)) - -(defconstant float-round-to-nearest 0) -(defconstant float-round-to-zero 1) -(defconstant float-round-to-positive 2) -(defconstant float-round-to-negative 3) - -(defconstant-eqx float-rounding-mode (byte 2 7) #'equalp) -(defconstant-eqx float-sticky-bits (byte 5 27) #'equalp) -(defconstant-eqx float-traps-byte (byte 5 0) #'equalp) -(defconstant-eqx float-exceptions-byte (byte 5 27) #'equalp) -(defconstant-eqx float-condition-bit (ash 1 26) #'equalp) -(defconstant float-fast-bit 0) ; No fast mode on HPPA. - - - -;;;; Description of the target address space. - -;;; Where to put the different spaces. -;;; -(defconstant linkage-table-space-start #x1000) -(defconstant linkage-table-space-end linkage-table-space-start) ; 0 size - -(defconstant read-only-space-start #x4b000000) -(defconstant read-only-space-end #x4dff0000) - -(defconstant static-space-start #x4e000000) -(defconstant static-space-end #x4fff0000) - -(defparameter dynamic-0-space-start #x50000000) -(defparameter dynamic-0-space-end #x5fff0000) - -); eval-when - -;;; When doing external branching on hppa (e.g. inst ble) -;;; we must know which space we want to jump into (text, code) - -;; The space-register holding the lisp heap. -(defconstant lisp-heap-space 5) - -;; The space-register holding the C text heap. -(defconstant c-text-space 4) - - -;;;; Other random constants. - -(defenum () - atomic-flag - interrupted-flag) - -(defenum (:start 8) - halt-trap - pending-interrupt-trap - cerror-trap - breakpoint-trap - fun-end-breakpoint-trap - single-step-breakpoint-trap - single-step-around-trap - single-step-before-trap - single-step-after-trap - error-trap) - -;;;; Static symbols. - -;;; These symbols are loaded into static space directly after NIL so -;;; that the system can compute their address by adding a constant -;;; amount to NIL. -;;; -;;; The fdefn objects for the static functions are loaded into static -;;; space directly after the static symbols. That way, the raw-addr -;;; can be loaded directly out of them by indirecting relative to NIL. -(defconstant-eqx +static-symbols+ - `#(,@+common-static-symbols+) - #'equalp) - -(defconstant-eqx +static-fdefns+ - #(length - two-arg-+ - two-arg-- - two-arg-* - two-arg-/ - two-arg-< - two-arg-> - two-arg-= - two-arg-<= - two-arg->= - two-arg-/= - eql - %negate - two-arg-and - two-arg-ior - two-arg-xor - two-arg-gcd - two-arg-lcm) - #'equalp) - diff -Nru sbcl-2.0.6/src/compiler/hppa/pred.lisp sbcl-2.1.1/src/compiler/hppa/pred.lisp --- sbcl-2.0.6/src/compiler/hppa/pred.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/pred.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -(in-package "SB-VM") - - -;;;; The Branch VOP. - -;;; The unconditional branch, emitted when we can't drop through to the desired -;;; destination. Dest is the continuation we transfer control to. -;;; -(define-vop (branch) - (:info dest) - (:generator 5 - (inst b dest :nullify t))) - - -;;;; Generic conditional VOPs - -;;; The generic conditional branch, emitted immediately after test -;;; VOPs that only set flags. - -(define-vop (branch-if) - (:info dest not-p flags) - (:ignore dest not-p flags) - (:generator 0 - (error "BRANCH-IF not yet implemented"))) - -(defun convert-conditional-move-p (node dst-tn x-tn y-tn) - (declare (ignore node dst-tn x-tn y-tn)) - nil) - - -;;;; Conditional VOPs: - -(define-vop (if-eq) - (:args (x :scs (any-reg descriptor-reg zero null)) - (y :scs (any-reg descriptor-reg zero null))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:translate eq) - (:generator 3 - (inst bc := not-p x y target))) diff -Nru sbcl-2.0.6/src/compiler/hppa/sap.lisp sbcl-2.1.1/src/compiler/hppa/sap.lisp --- sbcl-2.0.6/src/compiler/hppa/sap.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/sap.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,252 +0,0 @@ -;;;; the HPPA VM definition of SAP operations - -;;;; 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") - -;;;; Moves and coercions: - -;;; Move a tagged SAP to an untagged representation. -(define-vop (move-to-sap) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (sap-reg))) - (:note "system area pointer indirection") - (:generator 1 - (loadw y x sap-pointer-slot other-pointer-lowtag))) - -(define-move-vop move-to-sap :move - (descriptor-reg) (sap-reg)) - -;;; Move an untagged SAP to a tagged representation. -(define-vop (move-from-sap) - (:args (sap :scs (sap-reg) :to :save)) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (res :scs (descriptor-reg))) - (:note "system area pointer allocation") - (:generator 20 - (with-fixed-allocation (res nil ndescr sap-widetag sap-size nil) - (storew sap res sap-pointer-slot other-pointer-lowtag)))) - -(define-move-vop move-from-sap :move - (sap-reg) (descriptor-reg)) - -;;; Move untagged sap values. -(define-vop (sap-move) - (:args (x :target y - :scs (sap-reg) - :load-if (not (location= x y)))) - (:results (y :scs (sap-reg) - :load-if (not (location= x y)))) - (:note "SAP move") - (:generator 0 - (move x y))) - -(define-move-vop sap-move :move - (sap-reg) (sap-reg)) - -;;; Move untagged sap args/return-values. -(define-vop (move-sap-arg) - (:args (x :target y - :scs (sap-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:note "SAP argument move") - (:generator 0 - (sc-case y - (sap-reg - (move x y)) - (sap-stack - (storew x fp (tn-offset y)))))) - -(define-move-vop move-sap-arg :move-arg - (descriptor-reg sap-reg) (sap-reg)) - -;;; Use standard MOVE-ARG + coercion to move an untagged sap to a -;;; descriptor passing location. -(define-move-vop move-arg :move-arg - (sap-reg) (descriptor-reg)) - -;;;; SAP-INT and INT-SAP -(define-vop (sap-int) - (:args (sap :scs (sap-reg) :target int)) - (:arg-types system-area-pointer) - (:results (int :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate sap-int) - (:policy :fast-safe) - (:generator 1 - (move sap int))) - -(define-vop (int-sap) - (:args (int :scs (unsigned-reg) :target sap)) - (:arg-types unsigned-num) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate int-sap) - (:policy :fast-safe) - (:generator 1 - (move int sap))) - -;;;; POINTER+ and POINTER- -(define-vop (pointer+) - (:translate sap+) - (:args (ptr :scs (sap-reg)) - (offset :scs (signed-reg immediate))) - (:arg-types system-area-pointer signed-num) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:policy :fast-safe) - (:generator 1 - (sc-case offset - (signed-reg - (inst add ptr offset res)) - (immediate - (cond - ((and (< (tn-value offset) (ash 1 10)) - (> (tn-value offset) (- (ash 1 10)))) - (inst addi (tn-value offset) ptr res)) - (t - (inst li (tn-value offset) res) - (inst add ptr res res))))))) - -(define-vop (pointer-) - (:translate sap-) - (:args (ptr1 :scs (sap-reg)) - (ptr2 :scs (sap-reg))) - (:arg-types system-area-pointer system-area-pointer) - (:policy :fast-safe) - (:results (res :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (inst sub ptr1 ptr2 res))) - -;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET -(macrolet ((def-system-ref-and-set - (ref-name set-name sc type size &optional signed) - (let ((ref-name-c (symbolicate ref-name "-C")) - (set-name-c (symbolicate set-name "-C"))) - `(progn - (define-vop (,ref-name) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg)) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - (inst ,(ecase size - (:byte 'ldbx) - (:short 'ldhx) - (:long 'ldwx) - (:float 'fldx)) - offset object result) - ,@(when (and signed (not (eq size :long))) - `((inst extrs result 31 ,(ecase size - (:byte 8) - (:short 16)) - result))))) - (define-vop (,ref-name-c) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg))) - (:arg-types system-area-pointer - (:constant ,(if (eq size :float) - '(signed-byte 5) - '(signed-byte 14)))) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 4 - (inst ,(ecase size - (:byte 'ldb) - (:short 'ldh) - (:long 'ldw) - (:float 'flds)) - offset object result) - ,@(when (and signed (not (eq size :long))) - `((inst extrs result 31 ,(ecase size - (:byte 8) - (:short 16)) - result))))) - (define-vop (,set-name) - (:translate ,set-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg) - ,@(unless (eq size :float) '(:target sap))) - (offset :scs (signed-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer signed-num ,type) - (:results (result :scs (,sc))) - (:result-types ,type) - ,@(unless (eq size :float) - '((:temporary (:scs (sap-reg) :from (:argument 0)) sap))) - (:generator 5 - ,@(if (eq size :float) - `((inst fstx value offset object) - (unless (location= value result) - (inst funop :copy value result))) - `((inst add object offset sap) - (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw)) - value 0 sap) - (move value result))))) - (define-vop (,set-name-c) - (:translate ,set-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer - (:constant ,(if (eq size :float) - '(signed-byte 5) - '(signed-byte 14))) - ,type) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - ,@(if (eq size :float) - `((inst fsts value offset object) - (unless (location= value result) - (inst funop :copy value result))) - `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw)) - value offset object) - (move value result))))))))) - (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 - unsigned-reg positive-fixnum :byte nil) - (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 - signed-reg tagged-num :byte t) - (def-system-ref-and-set sap-ref-16 %set-sap-ref-16 - unsigned-reg positive-fixnum :short nil) - (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 - signed-reg tagged-num :short t) - (def-system-ref-and-set sap-ref-32 %set-sap-ref-32 - unsigned-reg unsigned-num :long nil) - (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 - signed-reg signed-num :long t) - (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap - sap-reg system-area-pointer :long) - (def-system-ref-and-set sap-ref-lispobj %set-sap-ref-lispobj - descriptor-reg * :long) - (def-system-ref-and-set sap-ref-single %set-sap-ref-single - single-reg single-float :float) - (def-system-ref-and-set sap-ref-double %set-sap-ref-double - double-reg double-float :float)) - -;;; Noise to convert normal lisp data objects into SAPs. -(define-vop (vector-sap) - (:translate vector-sap) - (:policy :fast-safe) - (:args (vector :scs (descriptor-reg))) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - vector sap))) diff -Nru sbcl-2.0.6/src/compiler/hppa/show.lisp sbcl-2.1.1/src/compiler/hppa/show.lisp --- sbcl-2.0.6/src/compiler/hppa/show.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/show.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -(in-package "SB-VM") - -(define-vop (print) - (:args (object :scs (descriptor-reg any-reg) :target nl0)) - (:results) - (:save-p t) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0) - (:temporary (:sc any-reg :offset cfunc-offset) cfunc) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:generator 100 - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move object nl0) - (inst li (make-fixup "debug_print" :foreign) cfunc) - (let ((fixup (make-fixup "call_into_c" :foreign))) - (inst ldil fixup temp) - (inst ble fixup c-text-space temp)) - (inst addi 64 nsp-tn nsp-tn) - (inst addi -64 nsp-tn nsp-tn) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - diff -Nru sbcl-2.0.6/src/compiler/hppa/subprim.lisp sbcl-2.1.1/src/compiler/hppa/subprim.lisp --- sbcl-2.0.6/src/compiler/hppa/subprim.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/subprim.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -(in-package "SB-VM") - - - -;;;; Length - -(define-vop (length/list) - (:translate length) - (:args (object :scs (descriptor-reg) :target ptr)) - (:arg-types list) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (any-reg) :to (:result 0) :target result) - count) - (:results (result :scs (any-reg descriptor-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:generator 50 - (move object ptr) - (inst comb := ptr null-tn done) - (inst li 0 count) - - (inst extru ptr 31 3 temp) - (inst comib :<> list-pointer-lowtag temp lose :nullify t) - (loadw ptr ptr cons-cdr-slot list-pointer-lowtag) - - LOOP - (inst addi (fixnumize 1) count count) - (inst comb := ptr null-tn done :nullify t) - (inst extru ptr 31 3 temp) - (inst comib := list-pointer-lowtag temp loop :nullify t) - (loadw ptr ptr cons-cdr-slot list-pointer-lowtag) - - LOSE - (cerror-call vop 'object-not-list-error ptr) - - DONE - (move count result))) diff -Nru sbcl-2.0.6/src/compiler/hppa/system.lisp sbcl-2.1.1/src/compiler/hppa/system.lisp --- sbcl-2.0.6/src/compiler/hppa/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/system.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,228 +0,0 @@ -(in-package "SB-VM") - - -;;;; Type frobbing VOPs - -;FIX this vop got instruction-exploded after mips convert, look at old hppa -(define-vop (widetag-of) - (:translate widetag-of) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp1 temp2) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (inst li lowtag-mask temp1) - (inst li other-pointer-lowtag temp2) - (inst and temp1 object temp1) - (inst xor temp1 temp2 temp1) - (inst comb := temp1 zero-tn OTHER-PTR) - (inst li (logxor other-pointer-lowtag fun-pointer-lowtag) temp2) - (inst xor temp1 temp2 temp1) - (inst comb := temp1 zero-tn FUNCTION-PTR) - (inst li fixnum-tag-mask temp1) ; pick off fixnums - (inst li 1 temp2) - (inst and temp1 object result) - (inst comb := result zero-tn DONE) - - (inst and object temp2 result) - (inst comb :<> result zero-tn LOWTAG-ONLY :nullify t) - - ;; must be an other immediate - (inst li widetag-mask temp2) - (inst b DONE) - (inst and temp2 object result) - - FUNCTION-PTR - (load-type result object (- fun-pointer-lowtag)) - (inst b done :nullify t) - - LOWTAG-ONLY - (inst li lowtag-mask temp1) - (inst b done) - (inst and object temp1 result) - - OTHER-PTR - (load-type result object (- other-pointer-lowtag)) - - DONE)) - -(define-vop (%other-pointer-widetag) - (:translate %other-pointer-widetag) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (load-type result object (- other-pointer-lowtag)))) - -(define-vop (fun-subtype) - (:translate fun-subtype) - (:policy :fast-safe) - (:args (function :scs (descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (load-type result function (- fun-pointer-lowtag)))) - -(define-vop (get-header-data) - (:translate get-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 other-pointer-lowtag) - (inst srl res n-widetag-bits res))) - -;;; FIXME-lav, not sure we need data of type immediate and zero, test without, -;;; if so revert to old hppa code -(define-vop (set-header-data) - (:translate set-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res) - (data :scs (any-reg immediate zero))) - (:arg-types * positive-fixnum) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) t1 t2) - (:generator 6 - (loadw t1 x 0 other-pointer-lowtag) - ;; replace below 2 inst with: (mask widetag-mask t1 t1) - (inst li widetag-mask t2) - (inst and t1 t2 t1) - (sc-case data - (any-reg - (inst sll data (- n-widetag-bits 2) t2) - (inst or t1 t2 t1)) - (immediate - (inst li (ash (tn-value data) n-widetag-bits) t2) - (inst or t1 t2 t1)) - (zero)) - - (storew t1 x 0 other-pointer-lowtag) - (move x res))) - -(define-vop (pointer-hash) - (:translate pointer-hash) - (:args (ptr :scs (any-reg descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:policy :fast-safe) - (:generator 1 - (inst zdep ptr n-positive-fixnum-bits n-positive-fixnum-bits res))) - -;;;; Allocation - -(define-vop (dynamic-space-free-pointer) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate dynamic-space-free-pointer) - (:policy :fast-safe) - (:generator 1 - (move alloc-tn int))) - -(define-vop (binding-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate binding-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move bsp-tn int))) - -(define-vop (control-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate control-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move csp-tn int))) - - -;;;; Code object frobbing. - -(define-vop (code-instructions) - (:translate code-instructions) - (:policy :fast-safe) - (:args (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 10 - (loadw ndescr code 0 other-pointer-lowtag) - (inst srl ndescr n-widetag-bits ndescr) - (inst sll ndescr word-shift ndescr) - (inst addi (- other-pointer-lowtag) ndescr ndescr) - (inst add code ndescr sap))) - -(define-vop (compute-fun) - (:args (code :scs (descriptor-reg)) - (offset :scs (signed-reg unsigned-reg))) - (:arg-types * positive-fixnum) - (:results (func :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 10 - (loadw ndescr code 0 other-pointer-lowtag) - ;; FIXME-lav: replace below two with DEPW - (inst srl ndescr n-widetag-bits ndescr) - (inst sll ndescr word-shift ndescr) - (inst add ndescr offset ndescr) - (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr) - (inst add ndescr code func))) - - -;;;; Other random VOPs. - - -(defknown sb-unix::receive-pending-interrupt () (values)) -(define-vop (sb-unix::receive-pending-interrupt) - (:policy :fast-safe) - (:translate sb-unix::receive-pending-interrupt) - (:generator 1 - (inst break pending-interrupt-trap))) - - -(define-vop (halt) - (:generator 1 - (inst break halt-trap))) - -#+hpux -(define-vop (setup-return-from-lisp-stub) - (:results) - (:save-p t) - (:temporary (:sc any-reg :offset nl0-offset) nl0) - (:temporary (:sc any-reg :offset cfunc-offset) cfunc) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:generator 100 - (let ((stub (make-fixup 'return-from-lisp-stub :assembly-routine))) - (inst li stub nl0)) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (inst li (make-fixup "setup_return_from_lisp_stub" :foreign) cfunc) - (let ((fixup (make-fixup "call_into_c" :foreign))) - (inst ldil fixup temp) - (inst ble fixup c-text-space temp)) - (inst addi 64 nsp-tn nsp-tn) - (inst addi -64 nsp-tn nsp-tn) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - -;;;; Dynamic vop count collection support - -(define-vop (count-me) - (:args (count-vector :scs (descriptor-reg))) - (:info index) - (:temporary (:scs (non-descriptor-reg)) count) - (:generator 1 - (let ((offset - (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag))) - (inst ldw offset count-vector count) - (inst addi 1 count count) - (inst stw count offset count-vector)))) - -;;;; Dummy definition for a spin-loop hint VOP -(define-vop () - (:translate spin-loop-hint) - (:policy :fast-safe) - (:generator 0)) diff -Nru sbcl-2.0.6/src/compiler/hppa/target-insts.lisp sbcl-2.1.1/src/compiler/hppa/target-insts.lisp --- sbcl-2.0.6/src/compiler/hppa/target-insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/target-insts.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -;;;; This file is for stuff which was in CMU CL's insts.lisp -;;;; file, but which in the SBCL build process can't be compiled -;;;; into code for the cross-compilation host. - -;;;; 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-HPPA-ASM") - -(defun break-control (chunk inst stream dstate) - (declare (ignore inst)) - (flet ((nt (x) (if stream (note x dstate)))) - (let ((trap (break-im5 chunk dstate))) - (case trap - (#.cerror-trap - (nt "Cerror trap") - (handle-break-args #'snarf-error-junk trap stream dstate)) - (#.breakpoint-trap - (nt "Breakpoint trap")) - (#.pending-interrupt-trap - (nt "Pending interrupt trap")) - (#.halt-trap - (nt "Halt trap")) - (#.fun-end-breakpoint-trap - (nt "Function end breakpoint trap")) - (#.single-step-around-trap - (nt "Single step around trap")) - (#.error-trap - (nt "Error trap") - (handle-break-args (lambda (sap offset trap &optional length-only) - (snarf-error-junk sap offset trap length-only nil)) - trap - stream dstate)))))) diff -Nru sbcl-2.0.6/src/compiler/hppa/type-vops.lisp sbcl-2.1.1/src/compiler/hppa/type-vops.lisp --- sbcl-2.0.6/src/compiler/hppa/type-vops.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/type-vops.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,164 +0,0 @@ -;;;; type testing and checking VOPs for the HPPA VM - -;;;; 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") - -;;; Test generation utilities. -(defun %test-fixnum (value temp target not-p) - (declare (ignore temp)) - (assemble () - (inst extru value 31 2 zero-tn (if not-p := :<>)) - (inst b target :nullify t))) - -(defun %test-fixnum-and-headers (value temp target not-p headers &key value-tn-ref) - (let ((drop-through (gen-label))) - (assemble () - (inst extru value 31 2 zero-tn :<>) - (inst b (if not-p drop-through target) :nullify t)) - (%test-headers value temp target not-p nil headers - :drop-through drop-through - :value-tn-ref value-tn-ref))) - -(defun %test-immediate (value temp target not-p immediate) - (assemble () - (inst extru value 31 8 temp) - (inst bci := not-p immediate temp target))) - -(defun %test-lowtag (value temp target not-p lowtag &key temp-loaded) - (assemble () - (unless temp-loaded - (inst extru value 31 3 temp)) - (inst bci := not-p lowtag temp target))) - -(defun %test-headers (value temp target not-p function-p headers - &key (drop-through (gen-label)) temp-loaded - value-tn-ref) - (declare (ignore value-tn-ref)) - (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) - (multiple-value-bind - (equal greater-or-equal when-true when-false) - ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to - ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when - ;; we know it's true and when we know it's false respectively. - (if not-p - (values :<> :< drop-through target) - (values := :>= target drop-through)) - (assemble () - (%test-lowtag value temp when-false t lowtag - :temp-loaded temp-loaded) - (inst ldb (- 3 lowtag) value temp) - (do ((remaining headers (cdr remaining))) - ((null remaining)) - (let ((header (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom header) - (if last - (inst bci equal nil header temp target) - (inst bci := nil header temp when-true))) - (t - (let ((start (car header)) - (end (cdr header))) - (unless (= start bignum-widetag) - (inst bci :> nil start temp when-false)) - (if last - (inst bci greater-or-equal nil end temp target) - (inst bci :>= nil end temp when-true))))))) - (emit-label drop-through))))) - -;;;; Other integer ranges. - -;;; A (signed-byte 32) can be represented with either fixnum or a bignum with -;;; exactly one digit. -(defun signed-byte-32-test (value temp not-p target not-target) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - (assemble () - (inst extru value 31 2 zero-tn :<>) - (inst b yep :nullify t) - (inst extru value 31 3 temp) - (inst bci :<> nil other-pointer-lowtag temp nope) - (loadw temp value 0 other-pointer-lowtag) - (inst bci := not-p (+ (ash 1 n-widetag-bits) bignum-widetag) temp target))) - (values)) - -(define-vop (signed-byte-32-p type-predicate) - (:translate signed-byte-32-p) - (:generator 45 - (signed-byte-32-test value temp not-p target not-target) - NOT-TARGET)) - -;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a -;;; bignum with exactly one positive digit, or a bignum with exactly two digits -;;; and the second digit all zeros. -(defun unsigned-byte-32-test (value temp not-p target not-target) - (let ((nope (if not-p target not-target))) - (assemble () - ;; Is it a fixnum? - (inst extru value 31 2 zero-tn :<>) - (inst b fixnum) - (move value temp t) - - ;; If not, is it an other pointer? - (inst extru value 31 3 temp) - (inst bci :<> nil other-pointer-lowtag temp nope) - ;; Get the header. - (loadw temp value 0 other-pointer-lowtag) - ;; Is it one? - (inst bci := nil (+ (ash 1 n-widetag-bits) bignum-widetag) temp single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst bci :<> nil (+ (ash 2 n-widetag-bits) bignum-widetag) temp nope) - ;; Get the second digit. - (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag) - ;; All zeros, its an (unsigned-byte 32). - ;; Dont nullify comb here, because we cant guarantee target is forward - (inst comb (if not-p := :<>) temp zero-tn not-target) - (inst nop) - (inst b target) - - SINGLE-WORD - ;; Get the single digit. - (loadw temp value bignum-digits-offset other-pointer-lowtag) - - ;; positive implies (unsigned-byte 32). - FIXNUM - (inst bc :>= not-p temp zero-tn target))) - (values)) - -(define-vop (unsigned-byte-32-p type-predicate) - (:translate unsigned-byte-32-p) - (:generator 45 - (unsigned-byte-32-test value temp not-p target not-target) - NOT-TARGET)) - -;;;; List/symbol types: -;;; -;;; symbolp (or symbol (eq nil)) -;;; consp (and list (not (eq nil))) - -(define-vop (symbolp type-predicate) - (:translate symbolp) - (:generator 12 - (inst bc := nil value null-tn (if not-p drop-thru target)) - (test-type value temp target not-p (symbol-widetag)) - DROP-THRU)) - -(define-vop (consp type-predicate) - (:translate consp) - (:generator 8 - (inst bc := nil value null-tn (if not-p target drop-thru)) - (test-type value temp target not-p (list-pointer-lowtag)) - DROP-THRU)) - - diff -Nru sbcl-2.0.6/src/compiler/hppa/values.lisp sbcl-2.1.1/src/compiler/hppa/values.lisp --- sbcl-2.0.6/src/compiler/hppa/values.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/values.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,136 +0,0 @@ -(in-package "SB-VM") - -(define-vop (reset-stack-pointer) - (:args (ptr :scs (any-reg))) - (:generator 1 - (move ptr csp-tn))) - -(define-vop (%%nip-values) - (:args (last-nipped-ptr :scs (any-reg) :target dest) - (last-preserved-ptr :scs (any-reg) :target src) - (moved-ptrs :scs (any-reg) :more t)) - (:results (r-moved-ptrs :scs (any-reg) :more t)) - (:temporary (:sc any-reg) src) - (:temporary (:sc any-reg) dest) - (:temporary (:sc descriptor-reg) temp) - (:ignore r-moved-ptrs) - (:generator 1 - (move last-preserved-ptr src) - (move last-nipped-ptr dest) - (inst comb :>= src csp-tn DONE :nullify t) - LOOP - (inst ldwm n-word-bytes src temp) - (inst addi n-word-bytes dest dest) - (storew temp dest -1) - (inst comb :> csp-tn src LOOP) - (inst nop) - DONE - (move dest csp-tn) - (inst sub src dest src) - (loop for moved = moved-ptrs then (tn-ref-across moved) - while moved do - (sc-case (tn-ref-tn moved) - ((descriptor-reg any-reg) - (inst sub (tn-ref-tn moved) src (tn-ref-tn moved))) - ((control-stack) - (load-stack-tn temp (tn-ref-tn moved)) - (inst sub temp src temp) - (store-stack-tn (tn-ref-tn moved) temp)))))) - -;;; Push some values onto the stack, returning the start and number of values -;;; pushed as results. It is assumed that the Vals are wired to the standard -;;; argument locations. Nvals is the number of values to push. -;;; -;;; The generator cost is pseudo-random. We could get it right by defining a -;;; bogus SC that reflects the costs of the memory-to-memory moves for each -;;; operand, but this seems unworthwhile. -;;; -(define-vop (push-values) - (:args - (vals :more t)) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:info nvals) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) - :to (:result 0) - :target start) - start-temp) - (:generator 20 - (move csp-tn start-temp) - (inst addi (* nvals n-word-bytes) csp-tn csp-tn) - (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-temp i)) - (control-stack - (load-stack-tn temp tn) - (storew temp start-temp i))))) - (move start-temp start) - (inst li (fixnumize nvals) count))) - -;;; Push a list of values on the stack, returning Start and Count as used in -;;; unknown values continuations. -;;; -(define-vop (values-list) - (:args (arg :scs (descriptor-reg) :target list)) - (:arg-types list) - (:policy :fast-safe) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) list) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (move arg list) - (move csp-tn start) - LOOP - (inst comb := list null-tn done) - (loadw temp list cons-car-slot list-pointer-lowtag) - (loadw list list cons-cdr-slot list-pointer-lowtag) - (inst addi n-word-bytes csp-tn csp-tn) - (storew temp csp-tn -1) - (inst extru list 31 n-lowtag-bits ndescr) - (inst comib := list-pointer-lowtag ndescr loop) - (inst nop) - (cerror-call vop 'bogus-arg-to-values-list-error list) - DONE - (inst sub csp-tn start count))) - -;;; Copy the more arg block to the top of the stack so we can use them -;;; as function arguments. -;;; -(define-vop (%more-arg-values) - (:args (context :scs (descriptor-reg any-reg) :target src) - (skip :scs (any-reg zero immediate)) - (num :scs (any-reg) :target count)) - (:arg-types * positive-fixnum positive-fixnum) - (:temporary (:sc any-reg :from (:argument 0)) src) - (:temporary (:sc any-reg :from (:argument 2)) dst end) - (:temporary (:sc descriptor-reg :from (:argument 1)) temp) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:generator 20 - (sc-case skip - (zero - (move context src)) - (immediate - (inst addi (* (tn-value skip) n-word-bytes) context src)) - (any-reg - (inst add skip context src))) - (move num count) - (inst comb := num zero-tn done) - (move csp-tn start t) - (move csp-tn dst) - (inst add count csp-tn csp-tn) - (inst addi (- n-word-bytes) csp-tn end) - LOOP - (inst ldwm n-word-bytes src temp) - (inst comb :<> dst end loop) - (inst stwm temp n-word-bytes dst) - DONE)) diff -Nru sbcl-2.0.6/src/compiler/hppa/vm.lisp sbcl-2.1.1/src/compiler/hppa/vm.lisp --- sbcl-2.0.6/src/compiler/hppa/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/hppa/vm.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,381 +0,0 @@ -;;;; miscellaneous VM definition noise for HPPA - -;;;; 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") - - -;;;; Registers - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *register-names* (make-array 32 :initial-element nil))) - -(macrolet ((defreg (name offset) - (let ((offset-sym (symbolicate name "-OFFSET"))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,offset-sym ,offset) - (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) - (defregset (name &rest regs) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,name - (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))) - ;; Wired-zero - (defreg zero 0) - ;; This gets trashed by the C call convention. - (defreg nfp 1) ;; and saved by lisp before calling C - (defreg cfunc 2) - ;; These are the callee saves, so these registers are stay live over - ;; call-out. - (defreg csp 3) - (defreg cfp 4) - (defreg bsp 5) - (defreg null 6) - (defreg alloc 7) - (defreg code 8) - (defreg fdefn 9) - (defreg lexenv 10) - (defreg nargs 11) - (defreg ocfp 12) - (defreg lra 13) - (defreg a0 14) - (defreg a1 15) - (defreg a2 16) - (defreg a3 17) - (defreg a4 18) - ;; This is where the caller-saves registers start, but we don't - ;; really care because we need to clear the above after call-out to - ;; make sure no pointers into oldspace are kept around. - (defreg a5 19) - (defreg l0 20) - (defreg l1 21) - (defreg l2 22) - ;; These are the 4 C argument registers. - (defreg nl3 23) - (defreg nl2 24) - (defreg nl1 25) - (defreg nl0 26) - ;; The global Data Pointer. We just leave it alone, because we - ;; don't need it. - (defreg dp 27) - ;; These two are use for C return values. - (defreg nl4 28) - (defreg nl5 29) - (defreg nsp 30) - (defreg lip 31) - - (defregset non-descriptor-regs - nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp) - - (defregset descriptor-regs - a0 a1 a2 a3 a4 a5 fdefn lexenv ocfp lra l0 l1 l2) - - (defregset boxed-regs - code fdefn lexenv ocfp lra - a0 a1 a2 a3 a4 a5 - l0 l1 l2 nfp) - - (defregset *register-arg-offsets* - a0 a1 a2 a3 a4 a5) - - (defregset reserve-descriptor-regs - fdefn lexenv) - - (defregset reserve-non-descriptor-regs - cfunc)) - -(!define-storage-bases -(define-storage-base registers :finite :size 32) -(define-storage-base float-registers :finite :size 64) -(define-storage-base control-stack :unbounded :size 8) -(define-storage-base non-descriptor-stack :unbounded :size 0) -(define-storage-base constant :non-packed) -(define-storage-base immediate-constant :non-packed) -) - -(!define-storage-classes - - ;; Non-immediate constants in the constant pool - (constant constant) - - ;; ZERO and NULL are in registers. - (zero immediate-constant) - (null immediate-constant) - (fp-single-zero immediate-constant) - (fp-double-zero immediate-constant) - - ;; Anything else that can be an immediate. - (immediate immediate-constant) - - - ;; **** The stacks. - - ;; The control stack. (Scanned by GC) - (control-stack control-stack) - - ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER - ;; is small and therefore the error trap information is smaller. - ;; Moving them up here from their previous place down below saves - ;; ~250K in core file size. --njf, 2006-01-27 - - ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing - ;; bad will happen if they are. (fixnums, characters, header values, etc). - (any-reg - registers - :locations #.(append non-descriptor-regs descriptor-regs) - :reserve-locations #.(append reserve-non-descriptor-regs - reserve-descriptor-regs) - :constant-scs (constant zero immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Pointer descriptor objects. Must be seen by GC. - (descriptor-reg registers - :locations #.descriptor-regs - :reserve-locations #.reserve-descriptor-regs - :constant-scs (constant null immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; The non-descriptor stacks. - (signed-stack non-descriptor-stack) ; (signed-byte 32) - (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) - (character-stack non-descriptor-stack) ; non-descriptor characters. - (sap-stack non-descriptor-stack) ; System area pointers. - (single-stack non-descriptor-stack) ; single-floats - (double-stack non-descriptor-stack - :element-size 2 :alignment 2) ; double floats. - (complex-single-stack non-descriptor-stack :element-size 2) - (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) - - ;; **** Things that can go in the integer registers. - - ;; Non-Descriptor characters - (character-reg registers - :locations #.non-descriptor-regs - :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (character-stack)) - - ;; Non-Descriptor SAP's (arbitrary pointers into address space) - (sap-reg registers - :locations #.non-descriptor-regs - :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (sap-stack)) - - ;; Non-Descriptor (signed or unsigned) numbers. - (signed-reg registers - :locations #.non-descriptor-regs - :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (signed-stack)) - (unsigned-reg registers - :locations #.non-descriptor-regs - :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (unsigned-stack)) - - ;; Random objects that must not be seen by GC. Used only as temporaries. - (non-descriptor-reg registers - :locations #.non-descriptor-regs) - - ;; Pointers to the interior of objects. Used only as an temporary. - (interior-reg registers - :locations (#.lip-offset)) - - - ;; **** Things that can go in the floating point registers. - - ;; Non-Descriptor single-floats. - (single-reg float-registers - :locations #.(loop for i from 4 to 31 collect i) - :constant-scs (fp-single-zero) - :save-p t - :alternate-scs (single-stack)) - - ;; Non-Descriptor double-floats. - (double-reg float-registers - :locations #.(loop for i from 4 to 31 collect i) - :constant-scs (fp-double-zero) - :save-p t - :alternate-scs (double-stack)) - - (complex-single-reg float-registers - :locations #.(loop for i from 4 to 30 by 2 collect i) - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (complex-single-stack)) - - (complex-double-reg float-registers - :locations #.(loop for i from 4 to 30 by 2 collect i) - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (complex-double-stack)) - - (catch-block control-stack :element-size catch-block-size) - (unwind-block control-stack :element-size unwind-block-size) - - ;; floating point numbers temporarily stuck in integer registers for c-call - (single-int-carg-reg registers - :locations (26 25 24 23) - :alternate-scs () - :constant-scs ()) - (double-int-carg-reg registers - :locations (25 23) - :constant-scs () - :alternate-scs () -; :alignment 2 ;is this needed? -; :element-size 2 - )) - - -;;;; Make some random tns for important registers. - -;;; how can we address reg L0 through L0-offset when it is not -;;; defined here ? do all registers have an -offset and this is -;;; redundant work ? -;;; -;;; FIXME-lav: move this into arch-generic-helpers -(macrolet ((defregtn (name sc) - (let ((offset-sym (symbolicate name "-OFFSET")) - (tn-sym (symbolicate name "-TN"))) - `(defparameter ,tn-sym - (make-random-tn :kind :normal - :sc (sc-or-lose ',sc) - :offset ,offset-sym))))) - - ;; These, we access by foo-TN only - - (defregtn zero any-reg) - (defregtn nargs any-reg) - ;; FIXME-lav: 20080820: not a fix, but fdefn and lexenv is used in assembly-rtns - (defregtn fdefn descriptor-reg) ; FIXME-lav, not used - (defregtn lexenv descriptor-reg) ; FIXME-lav, not used - - (defregtn nfp descriptor-reg) ; why not descriptor-reg ? - (defregtn ocfp any-reg) ; why not descriptor-reg ? - - (defregtn null descriptor-reg) - - (defregtn bsp any-reg) - (defregtn cfp any-reg) - (defregtn csp any-reg) - (defregtn alloc any-reg) - (defregtn nsp any-reg) - - (defregtn code descriptor-reg) - (defregtn lip interior-reg)) - -;; And some floating point values. -(defparameter fp-single-zero-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'single-reg) - :offset 0)) -(defparameter fp-double-zero-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset 0)) - - -;;; If VALUE can be represented as an immediate constant, then return -;;; the appropriate SC number, otherwise return NIL. -(defun immediate-constant-sc (value) - (typecase value - ((integer 0 0) - zero-sc-number) - (null - null-sc-number) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) - #-sb-xc-host system-area-pointer ; no object can be a SAP in the host - character) - immediate-sc-number) - (symbol - (if (static-symbol-p value) - immediate-sc-number - nil)) - (single-float - (if (eql value $0f0) - fp-single-zero-sc-number - nil)) - (double-float - (if (eql value $0d0) - fp-double-zero-sc-number - nil)))) - -(defun boxed-immediate-sc-p (sc) - (or (eql sc zero-sc-number) - (eql sc null-sc-number) - (eql sc immediate-sc-number))) - -;;;; Function Call Parameters - -;;; The SC numbers for register and stack arguments/return values. -;;; -(defconstant immediate-arg-scn any-reg-sc-number) -(defconstant control-stack-arg-scn control-stack-sc-number) - -(eval-when (:compile-toplevel :load-toplevel :execute) - -;;; Offsets of special stack frame locations -(defconstant ocfp-save-offset 0) -(defconstant lra-save-offset 1) -(defconstant nfp-save-offset 2) - -;;; The number of arguments/return values passed in registers. -;;; -(defconstant register-arg-count 6) - -;;; Names to use for the argument registers. -;;; -(defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal) - -) ; EVAL-WHEN - - -;;; A list of TN's describing the register arguments. -;;; -(defparameter *register-arg-tns* - (mapcar (lambda (n) - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset n)) - *register-arg-offsets*)) - -;;; This is used by the debugger. -(defconstant single-value-return-byte-offset 4) - -;;; This function is called by debug output routines that want a pretty name -;;; for a TN's location. It returns a thing that can be printed with PRINC. -(defun location-print-name (tn) - (declare (type tn tn)) - (let ((sb (sb-name (sc-sb (tn-sc tn)))) - (offset (tn-offset tn))) - (ecase sb - (registers (or (svref *register-names* offset) - (format nil "R~D" offset))) - (float-registers (format nil "F~D" offset)) - (control-stack (format nil "CS~D" offset)) - (non-descriptor-stack (format nil "NS~D" offset)) - (constant (format nil "Const~D" offset)) - (immediate-constant "Immed")))) - -(defun combination-implementation-style (node) - (declare (type sb-c::combination node) (ignore node)) - (values :default nil)) - -(defun primitive-type-indirect-cell-type (ptype) - (declare (ignore ptype)) - nil) diff -Nru sbcl-2.0.6/src/compiler/info-functions.lisp sbcl-2.1.1/src/compiler/info-functions.lisp --- sbcl-2.0.6/src/compiler/info-functions.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/info-functions.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -177,7 +177,7 @@ ;;;; ANSI Common Lisp functions which are defined in terms of the info ;;;; database -(defun sb-xc:macro-function (symbol &optional env) +(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." @@ -188,15 +188,15 @@ (multiple-value-bind (kind def) (sb-interpreter:find-lexical-fun env symbol) (when def - (return-from sb-xc:macro-function (when (eq kind :macro) def))))) + (return-from macro-function (when (eq kind :macro) def))))) (lexenv (let ((def (cdr (assoc symbol (lexenv-funs env))))) (when def - (return-from sb-xc:macro-function + (return-from macro-function (when (typep def '(cons (eql macro))) (cdr def))))))) (values (info :function :macro-function symbol))) -(defun (setf sb-xc:macro-function) (function symbol &optional environment) +(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 @@ -215,7 +215,7 @@ #-sb-xc-host (install-guard-function symbol `(:macro ,symbol))) function) -(defun sb-xc:compiler-macro-function (name &optional env) +(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) @@ -234,7 +234,7 @@ (values (info :function :compiler-macro-function name)))) ;;; FIXME: we don't generate redefinition warnings for these. -(defun (setf sb-xc:compiler-macro-function) (function name &optional env) +(defun (setf compiler-macro-function) (function name &optional env) (declare (type (or symbol list) name) (type (or function null) function)) (when env diff -Nru sbcl-2.0.6/src/compiler/info-vector.lisp sbcl-2.1.1/src/compiler/info-vector.lisp --- sbcl-2.0.6/src/compiler/info-vector.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/info-vector.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -150,7 +150,7 @@ (defmacro make-info-descriptor (val shift) (if (> sb-vm:n-fixnum-bits 30) `(ash ,val ,shift) - `(logior (if (logbitp (- 29 ,shift) ,val) sb-xc:most-negative-fixnum 0) + `(logior (if (logbitp (- 29 ,shift) ,val) most-negative-fixnum 0) (ash ,val ,shift)))) ;; Convert unpacked vector to packed vector. @@ -557,9 +557,9 @@ (t (packify-infos new end)))))) ; otherwise repack ;; We need a few magic constants to be shared between the next two functions. -(defconstant-eqx !+pcl-reader-name+ (make-symbol "READER") (constantly t)) -(defconstant-eqx !+pcl-writer-name+ (make-symbol "WRITER") (constantly t)) -(defconstant-eqx !+pcl-boundp-name+ (make-symbol "BOUNDP") (constantly t)) +(defconstant-eqx !+pcl-reader-name+ '#.(make-symbol "READER") (constantly t)) +(defconstant-eqx !+pcl-writer-name+ '#.(make-symbol "WRITER") (constantly t)) +(defconstant-eqx !+pcl-boundp-name+ '#.(make-symbol "BOUNDP") (constantly t)) ;; PCL names are physically 4-lists (see "pcl/slot-name") ;; that get treated as 2-component names for globaldb's purposes. diff -Nru sbcl-2.0.6/src/compiler/integer-tran.lisp sbcl-2.1.1/src/compiler/integer-tran.lisp --- sbcl-2.0.6/src/compiler/integer-tran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/integer-tran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -21,7 +21,7 @@ (if (numeric-type-p type) (let ((limit-high (numeric-type-high (lvar-type limit)))) (aver limit-high) - (if (<= limit-high (1+ sb-xc:most-positive-fixnum)) + (if (<= limit-high (1+ most-positive-fixnum)) '(%inclusive-random-fixnum (1- limit) (or state *random-state*)) '(%inclusive-random-integer (1- limit) diff -Nru sbcl-2.0.6/src/compiler/ir1final.lisp sbcl-2.1.1/src/compiler/ir1final.lisp --- sbcl-2.0.6/src/compiler/ir1final.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir1final.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -194,6 +194,28 @@ (def-two-arg-funs (number number) >= <= /=) +;;; A list of function which always call their functional argument correctly, +;;; meaning that no arg-count-error can occur in the callee +;;; and therefore the callee can skip the check. +(dolist (fun '(sb-thread::call-with-mutex + sb-thread::call-with-recursive-lock + sb-thread::call-with-system-mutex + sb-thread::call-with-system-mutex/allow-with-interrupts + sb-thread::call-with-system-mutex/without-gcing + sb-thread::call-with-recursive-system-lock + ;; wish we had a little more commonality to these names + sb-impl::%with-standard-io-syntax + sb-impl::%with-rebound-io-syntax + sb-debug::funcall-with-debug-io-syntax + sb-impl::call-with-sane-io-syntax + ;; there are others, maybe %with-compilation-unit + sb-impl::%print-unreadable-object + )) + (let ((info (info :function :info fun))) + (when info + (setf (ir1-attributep (fun-info-attributes info) callee-omit-arg-count-check) + t)))) + ;;; Convert function designators to functions in calls to known functions ;;; Also convert to TWO-ARG- variants (defun ir1-optimize-functional-arguments (component) @@ -201,6 +223,7 @@ (do-nodes (node nil block) (when (and (combination-p node) (eq (combination-kind node) :known) + ;; REDUCE can call with zero arguments. (neq (lvar-fun-name (combination-fun node) t) 'reduce)) (map-callable-arguments (lambda (lvar args results &key no-function-conversion &allow-other-keys) @@ -238,7 +261,27 @@ (change-ref-leaf ref replacement :recklessly t) (setf (node-derived-type cast) (lvar-derived-type (cast-value cast))))))))))))) - node))))) + node) + ;; One more thing: builtin higher-order functions utilized by builtin macros + ;; can impart a policy change to the callee, but it can't (easily) be done + ;; strictly lexically, because the policy would leak downward. + ;; e.g. (WITH-SOME-STUFF () ..) -> + ;; -> (DX-FLET ((THUNK () )) (CALL-WITH-STUFF #'THUNK)) + ;; should not inject (OPTIMIZE (VERIFY-ARG-COUNT 0)) at the top of + ;; because every lambda therein would omit the arg-count check. + (when (ir1-attributep (fun-info-attributes (combination-fun-info node)) + callee-omit-arg-count-check) + (let* ((args (combination-args node)) + (arg (if (eq (lvar-fun-name (combination-fun node) t) + 'sb-impl::%print-unreadable-object) + (fourth args) + (first args))) + (ref (and arg (lvar-uses arg)))) + (when (and (ref-p ref) (lambda-p (ref-leaf ref))) + ;; It seems impolite (un-debuggable too) to alter the lexenv-policy + ;; of functional-lexenv, so annotate this differently. + (setf (getf (functional-plist (ref-leaf ref)) 'verify-arg-count) + nil)))))))) (defun rewrite-full-call (combination) (let ((combination-name (lvar-fun-name (combination-fun combination) t)) diff -Nru sbcl-2.0.6/src/compiler/ir1opt.lisp sbcl-2.1.1/src/compiler/ir1opt.lisp --- sbcl-2.0.6/src/compiler/ir1opt.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir1opt.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -38,6 +38,17 @@ ;; 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)))))) + ;;; Are all the uses constant? (defun constant-lvar-uses-p (thing) (declare (type (or lvar null) thing)) @@ -803,13 +814,17 @@ (call (and ref (node-lvar ref) (lvar-dest (node-lvar ref)))) - (vars (lambda-vars original-lambda))) + (all-vars (lambda-vars original-lambda))) (when (and call - (eq var (car (last vars))) - (notany #'lambda-var-specvar vars)) + (eq var (car (last all-vars))) + (notany #'lambda-var-specvar all-vars)) (or (= (count-if #'identity (combination-args call)) 1) (with-ir1-environment-from-node call - (let* ((penultimate (lvar-uses (car (last (combination-args call) 2)))) + (let* ((all-args (combination-args call)) + (penultimate-arg (find-if #'identity all-args + :from-end t + :end (1- (length all-args)))) + (penultimate (lvar-uses penultimate-arg)) (penultimate (if (consp penultimate) (car penultimate) penultimate)) @@ -820,7 +835,7 @@ :pred (block-pred next-block) :succ (list next-block))) (bind (make-bind)) - (vars (butlast vars)) + (vars (butlast all-vars)) (lambda (make-lambda :vars vars :kind :let :bind bind @@ -828,11 +843,11 @@ :%source-name 'split :%debug-name `(split ,(lambda-%debug-name original-lambda)))) (ref (make-ref lambda)) - (args (butlast (combination-args call)))) + (args (butlast all-args))) (push lambda (lambda-lets (lambda-home original-lambda))) (push ref (lambda-refs lambda)) - (setf (combination-args call) (last (combination-args call))) - (setf (lambda-vars original-lambda) (last (lambda-vars original-lambda)) + (setf (combination-args call) (last all-args)) + (setf (lambda-vars original-lambda) (last all-vars) (lambda-tail-set lambda) (make-tail-set :funs (list lambda))) (setf (bind-lambda bind) lambda) (loop for var in vars @@ -956,6 +971,7 @@ #-sb-devel (declaim (start-block ir1-optimize-combination maybe-terminate-block + system-inline-fun-p validate-call-type)) (defun check-important-result (node info) @@ -1044,7 +1060,7 @@ (let ((original-lambda-list (second original-lambda))) ;; KISS - the closure that you're passing can have 0 or more ;; mandatory args and nothing else. - (unless (intersection original-lambda-list sb-xc:lambda-list-keywords) + (unless (intersection original-lambda-list lambda-list-keywords) (push `(,tempname ,original-lambda-list (%funcall ,(nth arg-spec received-args) ,@original-lambda-list)) @@ -1073,6 +1089,20 @@ (give-up-ir1-transform))) :note "auto-DX")) +(defun check-proper-sequences (combination info) + (when (fun-info-annotation info) + (map-combination-args-and-types + (lambda (lvar type lvars annotations) + (declare (ignore type lvars)) + (when (constant-lvar-p lvar) + (loop with value = (lvar-value lvar) + for annotation in annotations + when (improper-sequence-p annotation value) + do + (setf (combination-kind combination) :error) + (return-from check-proper-sequences)))) + combination info))) + ;;; Do IR1 optimizations on a COMBINATION node. (declaim (ftype (function (combination) (values)) ir1-optimize-combination)) (defun ir1-optimize-combination (node) @@ -1090,6 +1120,7 @@ (setf (lvar-reoptimize arg) nil)))) (process-info () (check-important-result node info) + (check-proper-sequences node info) (let ((fun (fun-info-derive-type info))) (when fun (let ((res (funcall fun node))) @@ -1248,6 +1279,13 @@ (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 @@ -1309,6 +1347,7 @@ (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) @@ -1629,12 +1668,13 @@ (with-ir1-environment-from-node call (with-component-last-block (*current-component* (block-next (node-block call))) - (let ((new-fun (ir1-convert-inline-lambda - res - :debug-name (debug-name 'lambda-inlined source-name) - :system-lambda t)) - (type (node-derived-type call)) - (ref (lvar-use (combination-fun call)))) + (let* ((*transforming* t) + (new-fun (ir1-convert-inline-lambda + res + :debug-name (debug-name 'lambda-inlined source-name) + :system-lambda t)) + (type (node-derived-type call)) + (ref (lvar-use (combination-fun call)))) (change-ref-leaf ref new-fun) (setf (combination-kind call) :full) ;; Don't lose the original derived type @@ -1680,11 +1720,11 @@ (declare (ignore type lvars)) (unless (if (eql (car annotation) 'function-designator) (let ((fun (or (lvar-fun-name arg t) - (and (constant-lvar-p arg) + (and (constant-lvar-ignore-types-p arg) (lvar-value arg))))) (and fun (constant-fold-arg-p fun))) - (constant-lvar-p arg)) + (constant-lvar-ignore-types-p arg)) (return-from constant-fold-call-p))) combination info @@ -1692,7 +1732,7 @@ (return-from constant-fold-call-p))) t) (t - (every #'constant-lvar-p args))))) + (every #'constant-lvar-ignore-types-p args))))) ;;; Replace a call to a foldable function of constant arguments with ;;; the result of evaluating the form. If there is an error during the @@ -1716,53 +1756,11 @@ (resolve-key-args args type) args))) (args (mapcar #'value lvar-args))) - (multiple-value-bind (values win) - (careful-call fun-name - args - call - ;; Note: CMU CL had COMPILER-WARN here, and that - ;; seems more natural, but it's probably not. - ;; - ;; It's especially not while bug 173 exists: - ;; Expressions like - ;; (COND (END - ;; (UNLESS (OR UNSAFE? (<= END SIZE))) - ;; ...)) - ;; can cause constant-folding TYPE-ERRORs (in - ;; #'<=) when END can be proved to be NIL, even - ;; though the code is perfectly legal and safe - ;; because a NIL value of END means that the - ;; #'<= will never be executed. - ;; - ;; Moreover, even without bug 173, - ;; quite-possibly-valid code like - ;; (COND ((NONINLINED-PREDICATE END) - ;; (UNLESS (<= END SIZE)) - ;; ...)) - ;; (where NONINLINED-PREDICATE is something the - ;; compiler can't do at compile time, but which - ;; turns out to make the #'<= expression - ;; unreachable when END=NIL) could cause errors - ;; when the compiler tries to constant-fold (<= - ;; END SIZE). - ;; - ;; So, with or without bug 173, it'd be - ;; unnecessarily evil to do a full - ;; COMPILER-WARNING (and thus return FAILURE-P=T - ;; from COMPILE-FILE) for legal code, so we we - ;; use a wimpier COMPILE-STYLE-WARNING instead. - #-sb-xc-host #'compiler-style-warn - ;; On the other hand, for code we control, we - ;; should be able to work around any bug - ;; 173-related problems, and in particular we - ;; want to be alerted to calls to our own - ;; functions which aren't being folded away; a - ;; COMPILER-WARNING is butch enough to stop the - ;; SBCL build itself in its tracks. - #+sb-xc-host #'compiler-warn - "constant folding") + (multiple-value-bind (values win) (careful-call fun-name args) (cond ((not win) - (setf (combination-kind call) :error)) + (setf (combination-kind call) :error + (combination-info call) + (list #'compiler-style-warn "Lisp error during constant folding:~%~A" values))) ((and (proper-list-of-length-p values 1)) (replace-combination-with-constant (first values) call)) (t (let ((dummies (make-gensym-list (length args)))) @@ -2691,8 +2689,15 @@ ;; Combinations have nil-fun-returned-error (setf (cast-%type-check cast) nil)) (t - (let ((context (node-source-form cast)) - (detail (lvar-all-sources (cast-value cast)))) + (let* ((source-form (node-source-form cast)) + (detail (lvar-all-sources (cast-value cast))) + (context (cast-context cast)) + (context (if (opaque-box-p context) + (opaque-box-value context) + context)) + (context (if (local-call-context-p context) + (local-call-context-var context) + context))) (unless (cast-silent-conflict cast) (filter-lvar value @@ -2710,17 +2715,16 @@ ',(type-specifier atype) ',(type-specifier value-type) ',detail - ',(compile-time-type-error-context context) - ',(cast-context cast)))) - ,(internal-type-error-call dummy-sym atype - (cast-context cast)) + ',(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 context) - ',(cast-context cast))))) + ',(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 diff -Nru sbcl-2.0.6/src/compiler/ir1report.lisp sbcl-2.1.1/src/compiler/ir1report.lisp --- sbcl-2.0.6/src/compiler/ir1report.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir1report.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -80,11 +80,16 @@ (args (compiler-error-context-format-args context))) (collect ((full nil cons) (short nil cons)) - (let ((forms (source-path-forms path)) - (n 0)) - (dolist (src (if (member (first forms) args) - (rest forms) - forms)) + (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) @@ -578,10 +583,10 @@ ;;; the compiler, hence the BOUNDP check. (defun note-undefined-reference (name kind) #+sb-xc-host - ;; Whitelist functions are looked up prior to UNCROSS, + ;; Allowlist functions are looked up prior to UNCROSS, ;; so that we can distinguish CL:SOMEFUN from SB-XC:SOMEFUN. (when (and (eq kind :function) - (gethash name sb-cold:*undefined-fun-whitelist*)) + (gethash name sb-cold:*undefined-fun-allowlist*)) (return-from note-undefined-reference (values))) (setq name (uncross name)) (unless (and @@ -640,7 +645,7 @@ ;; The current approach is reliable, at a cost of ~3 words per function. ;; (defun warn-if-compiler-macro-dependency-problem (name) - (unless (sb-xc:compiler-macro-function name) + (unless (compiler-macro-function name) (let ((status (car (info :function :emitted-full-calls name)))) ; TODO use emitted-full-call-count? (when (and (integerp status) (oddp status)) ;; Show the total number of calls, because otherwise the warning diff -Nru sbcl-2.0.6/src/compiler/ir1tran-lambda.lisp sbcl-2.1.1/src/compiler/ir1tran-lambda.lisp --- sbcl-2.0.6/src/compiler/ir1tran-lambda.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir1tran-lambda.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -67,7 +67,8 @@ (add-info (var kind &key (default nil defaultp) suppliedp-var key) (let ((info (make-arg-info :kind kind))) (when defaultp - (setf (arg-info-default info) default)) + (setf (arg-info-default info) default + (arg-info-default-p info) t)) (when suppliedp-var (setf (arg-info-supplied-p info) (varify-lambda-arg suppliedp-var))) @@ -304,7 +305,7 @@ (fun (collect ((default-bindings) (default-vals)) (dolist (default defaults) - (if (sb-xc:constantp default) + (if (constantp default) (default-vals default) (let ((var (sb-xc:gensym))) (default-bindings `(,var ,default)) @@ -358,7 +359,7 @@ (default (arg-info-default info)) (supplied-p (arg-info-supplied-p info)) (force (or force - (not (sb-xc:constantp (arg-info-default info))))) + (not (constantp (arg-info-default info))))) (ep (if supplied-p (ir1-convert-hairy-args res @@ -636,7 +637,7 @@ (dolist (key keys) (let* ((info (lambda-var-arg-info key)) (default (arg-info-default info)) - (hairy-default (not (sb-xc:constantp default))) + (hairy-default (not (constantp default))) (supplied-p (arg-info-supplied-p info)) ;; was: (format nil "~A-DEFAULTING-TEMP" (leaf-source-name key)) (n-val (make-symbol ".DEFAULTING-TEMP.")) @@ -1160,7 +1161,8 @@ :type (if (eq :declared where-from) (leaf-type found) (or (and lp - (ftype-from-lambda-list lambda-list)) + (ignore-errors + (ftype-from-lambda-list lambda-list))) (specifier-type 'function)))))) (substitute-leaf res found) (setf (gethash name free-funs) res))) diff -Nru sbcl-2.0.6/src/compiler/ir1tran.lisp sbcl-2.1.1/src/compiler/ir1tran.lisp --- sbcl-2.0.6/src/compiler/ir1tran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir1tran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -34,10 +34,18 @@ (when (source-form-has-path-p form) (gethash form *source-paths*))) +(defvar *transforming* nil) + (defun ensure-source-path (form) (or (get-source-path form) - (cons (simplify-source-path-form form) - *current-path*))) + (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*)))) (defun simplify-source-path-form (form) (if (consp form) @@ -305,11 +313,6 @@ (type (type-specifier (info :variable :type name)))) `(macro . (the ,type ,expansion)))) (:constant - #+sb-xc-host ; check that we never reference host constants - (unless (member name '(nil t)) ; other than these 2 - (when (eq (find-symbol (string name) "XC-STRICT-CL") - name) - (error "Using a constant from the host ~s" name))) (find-constant (symbol-value name) name)) (t (make-global-var :kind kind @@ -321,36 +324,38 @@ ;;; 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 maybe-emit-make-load-forms (constant &optional (name nil namep)) - (let ((xset (alloc-xset))) - (labels ((grovel (value) - ;; Unless VALUE is an object which which obviously - ;; can't contain other objects - (unless (dumpable-leaflike-p value) - (if (xset-member-p value xset) - (return-from grovel nil) - (add-to-xset value xset)) - (typecase value - (cons - (grovel (car value)) - (grovel (cdr value))) - (simple-vector - (dotimes (i (length value)) - (grovel (svref value i)))) - ((vector t) - (dotimes (i (length value)) - (grovel (aref value i)))) - ((simple-array t) +(defun ensure-externalizable (constant) + (declare (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, + ;; or was visited, or is acccessible in a named constant ... + (unless (or (dumpable-leaflike-p value) + (xset-member-p value xset) + (gethash value (eql-constants *ir1-namespace*))) + (add-to-xset value xset) + ;; FIXME: shouldn't this be something like SB-XC:TYPECASE ? + (typecase value + (cons + (grovel (car value)) + (grovel (cdr value))) + (simple-vector + (dotimes (i (length value)) + (grovel (svref value i)))) + ((vector t) + (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. - (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 + (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 @@ -362,23 +367,36 @@ ;; ;; 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)) - sb-kernel:+layout-all-tagged+)) - (do-instance-tagged-slot (i value) - (grovel (%instance-ref value i))))) - (t - (compiler-error - "Objects of type ~/sb-impl:print-type-specifier/ ~ - can't be dumped into fasl files." - (type-of value))))))) - ;; Dump all non-trivial named constants using the name. - (if (and namep (not (sb-xc:typep constant '(or symbol character fixnum - #+64-bit single-float)))) - (emit-make-load-form constant name) - (grovel constant)))) + (when (emit-make-load-form value) + #+sb-xc-host + (aver (eql (layout-bitmap (%instance-layout value)) + sb-kernel:+layout-all-tagged+)) + (do-instance-tagged-slot (i value) + (grovel (%instance-ref value i))))) + (t + (compiler-error + "Objects of type ~/sb-impl:print-type-specifier/ can't be dumped into fasl files." + (type-of value))))))) (values)) + +;;; 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)) + (dx-let ((xset (alloc-xset))) + (named-let ok ((value constant)) + (if (or (dumpable-leaflike-p value) (xset-member-p value xset)) + t + (progn + (add-to-xset value xset) + (typecase value + (cons (and (ok (car value)) (ok (cdr value)))) + (vector + (dotimes (i (length value) t) + (unless (ok (aref value i)) (return nil)))) + (array + (dotimes (i (array-total-size value) t) + (unless (ok (row-major-aref value i)) (return nil)))))))))) ;;;; some flow-graph hacking utilities @@ -394,7 +412,7 @@ ;;; determine what is evaluated next. If the ctran has no block, then ;;; we make it be in the block that the node is in. If the ctran heads ;;; its block, we end our block and link it to that block. -#-sb-fluid (declaim (inline use-ctran)) +(declaim (inline use-ctran)) (defun use-ctran (node ctran) (declare (type node node) (type ctran ctran)) (if (eq (ctran-kind ctran) :unused) @@ -456,7 +474,7 @@ (setf (lvar-uses lvar) (list node (lvar-uses lvar))))) (reoptimize-lvar lvar))) -#-sb-fluid(declaim (inline use-continuation)) +(declaim (inline use-continuation)) (defun use-continuation (node ctran lvar) (use-ctran node ctran) (use-lvar node lvar)) @@ -649,6 +667,11 @@ (maybe-reanalyze-functional leaf)) leaf)) (ref (make-ref leaf name))) + (when (and result + (lambda-var-p leaf) + (lambda-var-constant leaf)) + (push (make-lvar-lambda-var-annotation :lambda-var leaf) + (lvar-annotations result))) (push ref (leaf-refs leaf)) (when (and (functional-p leaf) (functional-ignore leaf)) @@ -721,17 +744,17 @@ (flet ((legal-cm-name-p (name) (and (legal-fun-name-p name) (or (not (symbolp name)) - (not (sb-xc:macro-function name *lexenv*)))))) + (not (macro-function name *lexenv*)))))) (if (eq opname 'funcall) (let ((fun-form (cadr form))) (cond ((and (consp fun-form) (eq 'function (car fun-form)) (not (cddr fun-form))) (let ((real-fun (cadr fun-form))) (if (legal-cm-name-p real-fun) - (values (sb-xc:compiler-macro-function real-fun *lexenv*) + (values (compiler-macro-function real-fun *lexenv*) real-fun) (values nil nil)))) - ((sb-xc:constantp fun-form *lexenv*) + ((constantp fun-form *lexenv*) (let ((fun (constant-form-value fun-form *lexenv*))) (if (legal-cm-name-p fun) ;; CLHS tells us that local functions must shadow @@ -743,12 +766,12 @@ ;; a list (function name)", that means that ;; (funcall 'name) that gets here doesn't fit the ;; definition. - (values (sb-xc:compiler-macro-function fun nil) fun) + (values (compiler-macro-function fun nil) fun) (values nil nil)))) (t (values nil nil)))) (if (legal-fun-name-p opname) - (values (sb-xc:compiler-macro-function opname *lexenv*) opname) + (values (compiler-macro-function opname *lexenv*) opname) (values nil nil))))) ;;; If FORM has a usable compiler macro, use it; otherwise return FORM itself. @@ -1091,7 +1114,8 @@ (record-call name (ctran-block start) *current-path*)) (when *show-transforms-p* (show-transform "src" name transformed)) - (ir1-convert start next result transformed)))) + (let ((*transforming* t)) + (ir1-convert start next result transformed))))) (ir1-convert-maybe-predicate start next result form var)))))) ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE @@ -1315,6 +1339,10 @@ ;; to be bound... yet nowhere does it say that the special declaration ;; removes the constantness. Call it a spec bug and prohibit it. Same ;; for GLOBAL variables. + (unless (symbolp name) + (compiler-error + "~S is not a symbol and thus can't be declared special." + name)) (let ((kind (info :variable :kind name))) (unless (member kind '(:special :unknown)) (compiler-error @@ -1359,6 +1387,15 @@ (t (setf (lambda-var-no-constraints var) t)))))) +(defun process-constant-decl (spec vars) + (dolist (name (rest spec)) + (let ((var (find-in-bindings vars name))) + (cond + ((not var) + (warn "No ~s variable" name)) + (t + (setf (lambda-var-constant var) t)))))) + ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP ;;; (and TYPE if notinline), plus type-restrictions from the lexenv. (defun make-new-inlinep (var inlinep local-type) @@ -1612,6 +1649,9 @@ (no-constraints (process-no-constraints-decl spec vars) res) + (constant-value + (process-constant-decl spec vars) + res) ;; We may want to detect LAMBDA-LIST and VALUES decls here, ;; and report them as "Misplaced" rather than "Unrecognized". (t diff -Nru sbcl-2.0.6/src/compiler/ir1-translators.lisp sbcl-2.1.1/src/compiler/ir1-translators.lisp --- sbcl-2.0.6/src/compiler/ir1-translators.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir1-translators.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -536,8 +536,8 @@ (lexenv-blocks *lexenv*) :from-end t)) *source-namestring* (awhen (case *name-context-file-path-selector* - (pathname (or sb-xc:*compile-file-pathname* *load-pathname*)) - (truename (or sb-xc:*compile-file-truename* *load-truename*))) + (pathname (or *compile-file-pathname* *load-pathname*)) + (truename (or *compile-file-truename* *load-truename*))) (namestring it))))) (when context (list :in context)))) @@ -613,11 +613,18 @@ (with-fun-name-leaf (leaf thing start :global-function t) (reference-leaf start next result leaf))) -(defun constant-global-fun-name (thing) - (let ((constantp (sb-xc:constantp thing))) +;;; 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). +;;; Note however that whether THING actually names something is irrelevant. +;;; This test is only if it _could_ name something. Return NIL if THING is a function +;;; or a constant form evaluating to a function, or not a legal designator at all. +(defun constant-global-fun-name (thing lexenv extendedp) + (let ((constantp (constantp thing lexenv))) (when constantp - (let ((name (constant-form-value thing))) - (when (legal-fun-name-p name) + (let ((name (constant-form-value thing lexenv))) + (when (if extendedp + (legal-fun-name-p name) + (symbolp name)) name))))) (defun lvar-constant-global-fun-name (lvar) @@ -626,14 +633,15 @@ (when (legal-fun-name-p name) name)))) -(defun ensure-source-fun-form (source &key (coercer '%coerce-callable-for-call) give-up) +(defun ensure-source-fun-form (source lexenv &key (coercer '%coerce-callable-for-call) + (extendedp t) give-up) (let ((op (when (consp source) (car source)))) (cond ((memq op '(%coerce-callable-to-fun %coerce-callable-for-call)) - (ensure-source-fun-form (second source) :coercer coercer)) + (ensure-source-fun-form (second source) lexenv :coercer coercer)) ((member op '(function global-function lambda named-lambda)) (values source nil)) (t - (let ((cname (constant-global-fun-name source))) + (let ((cname (constant-global-fun-name source lexenv extendedp))) (if cname (values `(global-function ,cname) nil) (values `(,coercer ,source) give-up))))))) @@ -691,8 +699,14 @@ ;;; compiler. If the called function is a FUNCTION form, then convert ;;; directly to %FUNCALL, instead of waiting around for type ;;; inference. -(define-source-transform funcall (function &rest args) - `(%funcall ,(ensure-source-fun-form function :coercer '%coerce-callable-for-call) ,@args)) +(define-source-transform funcall (function &rest args &environment env) + ;; This transform should not allow violating the type constraint on FUNCALL + ;; by sneaking in a use of #'name via %FUNCALL in cases where the name is + ;; an extended-function-designator instead of just function-designator. + `(%funcall ,(ensure-source-fun-form function env + :coercer '%coerce-callable-for-call + :extendedp nil) + ,@args)) (deftransform %coerce-callable-to-fun ((thing) * * :node node) "optimize away possible call to FDEFINITION at runtime" @@ -703,8 +717,8 @@ "optimize away possible call to FDEFINITION at runtime" (ensure-lvar-fun-form thing 'thing :give-up t :coercer '%coerce-callable-for-call)) -(define-source-transform %coerce-callable-to-fun (thing) - (ensure-source-fun-form thing :give-up t)) +(define-source-transform %coerce-callable-to-fun (thing &environment env) + (ensure-source-fun-form thing env :give-up t)) ;;;; LET and LET* @@ -974,7 +988,7 @@ (values-subtypep (make-single-value-type (leaf-type value)) type)) (and (not (fun-designator-type-p type)) - (sb-xc:constantp value) + (constantp value) (or (not (values-type-p type)) (values-type-may-be-single-value-p type)) (ctypep (constant-form-value value) @@ -1198,7 +1212,11 @@ ,value)) (let ((res (make-set :var var :value dest-lvar))) (setf (lvar-dest dest-lvar) res) - (setf (leaf-ever-used var) t) + (cond (result ; SETQ with a result counts as a REF also + (setf (leaf-ever-used var) t)) + ((not (leaf-ever-used var)) ; doesn't count as a REF + ;; (EVER-USED might already be T, leave it alone if so) + (setf (leaf-ever-used var) 'set))) (push res (basic-var-sets var)) (link-node-to-previous-ctran res dest-ctran) (use-continuation res next result)))) @@ -1440,7 +1458,10 @@ ;; important for simplifying compilation of ;; MV-COMBINATIONS. (make-combination fun-lvar)))) - (ir1-convert start ctran fun-lvar (ensure-source-fun-form fun :coercer '%coerce-callable-for-call)) + (ir1-convert start ctran fun-lvar + (ensure-source-fun-form fun *lexenv* + :coercer '%coerce-callable-for-call + :extendedp nil)) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) (let ((this-start ctran)) diff -Nru sbcl-2.0.6/src/compiler/ir1util.lisp sbcl-2.1.1/src/compiler/ir1util.lisp --- sbcl-2.0.6/src/compiler/ir1util.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir1util.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -622,7 +622,7 @@ (defun node-physenv (node) (lambda-physenv (node-home-lambda node))) -#-sb-fluid (declaim (inline node-stack-allocate-p)) +(declaim (inline node-stack-allocate-p)) (defun node-stack-allocate-p (node) (awhen (node-lvar node) (lvar-dynamic-extent it))) @@ -1112,7 +1112,7 @@ (defun cast-single-value-p (cast) (not (values-type-p (cast-asserted-type cast)))) -#-sb-fluid (declaim (inline lvar-single-value-p)) +(declaim (inline lvar-single-value-p)) (defun lvar-single-value-p (lvar) (or (not lvar) (%lvar-single-value-p lvar))) (defun %lvar-single-value-p (lvar) @@ -1962,19 +1962,17 @@ ;;; declared IGNORE, then complain. (defun note-unreferenced-vars (vars policy) (dolist (var vars) - (unless (or (leaf-ever-used var) - (lambda-var-ignorep var)) + (unless (or (eq (leaf-ever-used var) t) (lambda-var-ignorep var)) (unless (policy policy (= inhibit-warnings 3)) ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" ;; requires this to be no more than a STYLE-WARNING. - #-sb-xc-host - (compiler-style-warn "The variable ~S is defined but never used." - (leaf-debug-name var)) ;; There's no reason to accept this kind of equivocation ;; when compiling our own code, though. - #+sb-xc-host - (warn "The variable ~S is defined but never used." - (leaf-debug-name var))) + (#-sb-xc-host compiler-style-warn #+sb-xc-host warn + (if (eq (leaf-ever-used var) 'set) + "The variable ~S is assigned but never read." + "The variable ~S is defined but never used.") + (leaf-debug-name var))) (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN (defun note-unreferenced-fun-vars (fun) @@ -2068,7 +2066,8 @@ (let ((pkg (cl:symbol-package first))) (and pkg (neq pkg *keyword-package*)))) (not (member first '(t nil))) - (not (cl:typep first '(or fixnum character))) + (not (cl:typep first '(or fixnum character + #+64-bit single-float))) (every (lambda (x) (present-in-form first x 0)) (source-path-forms path)) @@ -2356,89 +2355,6 @@ (change-ref-leaf ref new-leaf))) (values)) -;;; Do almost the same thing that EQUAL does, but consider strings -;;; to be dissimilar if their element types differ. -;;; When cross-compiling, any STRING= strings are similar -;;; because there is logically only a BASE-STRING type. -;;; ISTM that the language botched this up by not defining a standard -;;; predicate which returns T if and only if objects are similar. -(defun similarp (x y) - #+sb-xc-host (equal x y) - #-sb-xc-host - (named-let recurse ((x x) (y y)) - (cond ((%eql x y) t) - ((consp x) - (and (consp y) - (recurse (car x) (car y)) - (recurse (cdr x) (cdr y)))) - ((stringp x) - (and (stringp y) - ;; (= (widetag-of ...)) would be too strict, because a simple string - ;; can be be similar to a non-simple string. - (eq (array-element-type x) - (array-element-type y)) - (string= x y))) - (t ; PATHNAME and BIT-vector can fall back upon EQUAL - ;; This could be slightly wrong, but so it always was, because we use - ;; (and have used) EQUAL for PATHNAME in SB-C::FIND-CONSTANT, but: - ;; "Two pathnames S and C are similar if all corresponding pathname components are similar." - ;; and we readily admit that similarity of strings requires equal element types. - ;; So this is slightly dubious: - ;; (EQUAL (MAKE-PATHNAME :NAME (COERCE "A" 'SB-KERNEL:SIMPLE-CHARACTER-STRING)) - ;; (MAKE-PATHNAME :NAME (COERCE "A" 'BASE-STRING))) => T - ;; On the other hand, nothing says that the pathname constructors such as - ;; MAKE-PATHNAME and MERGE-PATHNAMES don't convert to a canonical representation - ;; which renders them EQUAL when all strings are STRING=. - ;; This area of the language spec seems to have been a clusterfsck. - (equal x y))))) - -;;; FIXME: FIND-CONSTANT is rife with problems. -;;; -;;; - We sometimes fail to use `(SYMBOL-VALUE ,a-defconstant) when we should, -;;; which can break some EQ tests in user code. [This is not a conformance issue, -;;; but goes against what we try so very hard to do: reference non-EQL-comparable -;;; constants only through the global symbol at load time] -;;; -;;; - We can't detect similar arrays other than BIT-VECTOR and STRING. -;;; -;;; - There is no general notion of similarity for INSTANCE, yet CORE-COALESCE-P used to -;;; return T of instances ever since git rev 45bc305be4 "refactor handling of constants". -;;; What was it trying to achieve? Maybe capture PATHNAME , HASH-TABLE and RANDOM-STATE, -;;; which are implemented as INSTANCE types, except EQUAL does not descend into -;;; any of them but PATHNAME. -;;; -;;; - What was it trying to achieve with SYMBOLS beyond the EQ test? I guess it's ok -;;; to collapse uninterned symbols by STRING=, but EQUAL won't do that. -;;; -;;; - Overall the CORE-COALESCE-P is just massively confusing. The only constants that can -;; legally be collapsed when compiling to memory are numbers. Characters would be EQ -;;; if they were EQL. Symbol and instances, as I expressed already - WTF is up with that? - -;;; I think the only way forward is twofold: -;;; - design a hash-table that correctly implements SIMILAR, -;;; - always prefer a named constant over an anonymous constant when they are similar. -;;; We'll have to do this by never coalescing a named constant with an unnamed, -;;; then postprocess the constants to remove any unnamed that are similar to -;;; a named constant that got inserted later. Minimal problem example: -#| -(defconstant +foo+ (if (boundp '+foo+) +foo+ (cons nil nil))) -;;; A-MACRO by pure coincidence expands to contain a constant that -;;; is similar to +FOO+ but not EQ to it. -(defmacro a-macro () ''(nil)) -;;; Because A-MACRO is opaque, you don't know that it injects a constant -;;; EQUAL to +FOO+. The compiler assumes that the "second" use of the same -;;; constant might as well use the value from the first occurrence, -;;; not realizing that you actually relied on the EQ-ness condition. -(defun getfoo () (values (a-macro) +foo+)) -;;; Counterintuitively, compiled (ISFOO (NTH-VALUE 1 (GETFOO))) returns NIL. -(defun isfoo (x) (eq x +foo+)) -;;; -* (load "try.lisp") -* (ISFOO (NTH-VALUE 1 (GETFOO))) => T -* (load (compile-file "try.lisp")) -* (ISFOO (NTH-VALUE 1 (GETFOO))) => NIL -|# - ;;; 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 @@ -2447,22 +2363,88 @@ ;;; ;;; We are allowed to coalesce things like EQUAL strings and bit-vectors ;;; when file-compiling, but not when using COMPILE. -(defun find-constant (object &optional (name nil namep)) +;;; FIXME: +;;; - EQUAL (the comparator in the similarity hash-table) is both too strict +;;; and not strict enough. Too strict because it won't compare simple-vector; +;;; not strict enough because base-string and character-string can't coalesce. +;;; We deal with this fine, but a real SIMILAR kind of hash-table would be nice. +;;; - arrays other than the handled kinds can be similar. +;;; +;;; If SYMBOL is supplied, then we will never try to match OBJECT against +;;; a constant already present in the FASL-OUTPUT-EQ-TABLE, but we _will_ add +;;; items to the namespace's EQL table. The reason is extremely subtle: +;;; * if an anonymous structure constant happens to be EQ to a named constant +;;; seen first, but there is no applicable make-load-form-method on the type of +;;; the object, we "accidentally" permit the structure lacking a load form +;;; to be used (as if dumped) by virtue of the fact that it sees the named constant. +;;; I can't imagine that the spec wants that to work as if by magic, when it sure +;;; seems like a user error. However, our own code relies on such in a few places: +;;; (1) we want to dump # but only after seeing it referenced +;;; in the same file as SB-KERNEL:*UNIVERSAL-TYPE*. +;;; This occurs where ADD-EQUALITY-CONSTRAINTS calls FIND-CONSTANT. +;;; (2) src/code/aprof would get an error +;;; "don't know how to dump R13 (default MAKE-LOAD-FORM method called)." +;;; in the LIST IR2-converter for +;;; (load-time-value `((xor :qword ,p-a-flag ,(get-gpr :qword rbp-offset)) ...)) +;;; where P-A-FLAG is +;;; (defconstant-eqx p-a-flag `(ea 40 ,(get-gpr :qword ...))) +;;; But it somehow loses the fact that p-a-flag was a defconstant. +;;; +;;; * if within the same file we are willing to coalesce a named constant and +;;; unnamed constant (where the unnamed was dumped first), but in a different file +;;; we did not see a use of a similar unnamed constant, and went directly to +;;; SYMBOL-GLOBAL-VALUE, then two functions which reference the same globally named +;;; constant C might end up seeing two different versions of the load-time constant - +;;; one whose load-time producing form is `(SYMBOL-VALUE ,C) and one whose +;;; producing form is whatever else it was. +;;; 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*))) - ;; Note that we haven't picked off LAYOUT yet for two reasons: - ;; 1. layouts go in the hash-table so that a code component references - ;; any given layout at most once - ;; 2. STANDARD-OBJECT layouts use MAKE-LOAD-FORM - (let ((faslp (producing-fasl-file)) - (ns (if (boundp '*ir1-namespace*) *ir1-namespace*))) - (labels ((core-coalesce-p (x) - (sb-xc:typep x '(or symbol number character instance))) - (cons-coalesce-p (x) + + (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. @@ -2479,60 +2461,52 @@ (atom-colesce-p car)) (return nil)))))) (descend x))))) - (atom-colesce-p (x) - (or (core-coalesce-p x) - (typep x '(or bit-vector string)))) - (file-coalesce-p (x) - ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various - ;; other things when file-compiling. - (if (consp x) - (cons-coalesce-p x) - (atom-colesce-p x)))) - ;; When compiling to core we don't coalesce strings, because - ;; "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." - ;; but in a dumped image, if gc_coalesce_string_literals is 1 then GC will - ;; coalesce similar immutable strings to save memory, - ;; even if not technically permitted. According to CLHS 3.7.1 - ;; "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 (and (not faslp) (simple-string-p object)) - (logically-readonlyize object nil)) - ;; refer to named structured constants through their name - (when (and faslp (not (sb-fasl:dumpable-layout-p object)) namep) - (maybe-emit-make-load-forms object name)) - ;; Has this identical object been seen before? Bail out early if so. - (awhen (and ns (gethash object (eq-constants ns))) - (return-from find-constant it)) - (let* ((coalescep (and ns - (if faslp - (file-coalesce-p object) - (core-coalesce-p object)))) - (effectively-coalescible - (and coalescep - ;; No instance subtype except a pathname can be coalesced - ;; by the similarity table (as currently implemented) - (or (not (sb-xc:typep object 'instance)) - (sb-xc:typep object 'pathname))))) - ;; constants referred to by name must retain their identity: - ;; they must not be coalesced with some other similar-enough - ;; constant. - (when (and effectively-coalescible (not namep)) - (dolist (candidate (gethash object (similar-constants ns))) - (when (similarp (constant-value candidate) object) - (return-from find-constant candidate)))) - (when (and faslp (not (sb-fasl:dumpable-layout-p object)) (not namep)) - (maybe-emit-make-load-forms object)) - (let ((new (make-constant object))) - (when ns - (setf (gethash object (eq-constants ns)) new) - (when effectively-coalescible - (push new (gethash object (similar-constants ns))))) - new))))) + (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)))) ;;; 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 @@ -2795,28 +2769,18 @@ ;;; Apply a function to some arguments, returning a list of the values ;;; resulting of the evaluation. If an error is signalled during the -;;; application, then we produce a warning message using WARN-FUN and -;;; return NIL as our second value to indicate this. NODE is used as -;;; the error context for any error message, and CONTEXT is a string -;;; that is spliced into the warning. -(declaim (ftype (sfunction ((or symbol function) list node function string) - (values list boolean)) +;;; application, then return the condition and NIL as the +;;; second value. +(declaim (ftype (sfunction ((or symbol function) list) + (values t boolean)) careful-call)) -(defun careful-call (function args node warn-fun context) - (declare (ignorable node warn-fun context)) - ;; When cross-compiling, being "careful" is the wrong thing - our code should - ;; not allowed malformed or out-of-order definitions to proceed as if all is well. - #+sb-xc-host - (values (multiple-value-list (apply function args)) t) - #-sb-xc-host - (values - (multiple-value-list - (handler-case (apply function args) - (error (condition) - (let ((*compiler-error-context* node)) - (funcall warn-fun "Lisp error during ~A:~%~A" context condition) - (return-from careful-call (values nil nil)))))) - t)) +(defun careful-call (function args) + (handler-case (values (multiple-value-list (apply function args)) t) + ;; When cross-compiling, being "careful" is the wrong thing - our code should + ;; not allowed malformed or out-of-order definitions to proceed as if all is well. + #-sb-xc-host + (error (condition) + (values condition nil)))) ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong ;;; specifiers. @@ -3204,6 +3168,15 @@ (values :calls constants))))))))) (defun process-lvar-modified-annotation (lvar annotation) + (loop for annot in (lvar-annotations lvar) + when (lvar-lambda-var-annotation-p annot) + do (let ((lambda-var (lvar-lambda-var-annotation-lambda-var annot))) + (when (and (lambda-var-constant lambda-var) + (not (lambda-var-sets lambda-var))) + (warn 'sb-kernel::macro-arg-modified + :fun-name (lvar-modified-annotation-caller annotation) + :variable (lambda-var-original-name lambda-var)) + (return-from process-lvar-modified-annotation)))) (multiple-value-bind (type values) (lvar-constants lvar) (labels ((modifiable-p (value) (or (consp value) @@ -3225,23 +3198,26 @@ (report values))) t))))) +(defun improper-sequence-p (annotation value) + (case annotation + (proper-list + (and (listp value) + (not (proper-list-p value)))) + (proper-sequence + (and (typep value 'sequence) + (not (proper-sequence-p value)))) + (proper-or-circular-list + (and (listp value) + (not (proper-or-circular-list-p value)))) + (proper-or-dotted-list + (and (listp value) + (not (proper-or-dotted-list-p value)))))) + (defun process-lvar-proper-sequence-annotation (lvar annotation) (multiple-value-bind (type values) (lvar-constants lvar) (let ((kind (lvar-proper-sequence-annotation-kind annotation))) (labels ((bad-p (value) - (case kind - (proper-list - (and (listp value) - (not (proper-list-p value)))) - (proper-sequence - (and (typep value 'sequence) - (not (proper-sequence-p value)))) - (proper-or-circular-list - (and (listp value) - (not (proper-or-circular-list-p value)))) - (proper-or-dotted-list - (and (listp value) - (not (proper-or-dotted-list-p value)))))) + (improper-sequence-p kind value)) (report (values) (when (every #'bad-p values) (if (singleton-p values) @@ -3291,7 +3267,11 @@ (cond ((not (types-equal-or-intersect (lvar-type lvar) type)) (%compile-time-type-error-warn annotation (type-specifier type) (type-specifier (lvar-type lvar)) - (lvar-all-sources lvar) + (let ((path (lvar-annotation-source-path annotation))) + (list + (if (eq (car path) 'original-source-start) + (find-original-source path) + (car path)))) :condition condition)) ((consp uses) (loop for use in uses diff -Nru sbcl-2.0.6/src/compiler/ir2opt.lisp sbcl-2.1.1/src/compiler/ir2opt.lisp --- sbcl-2.0.6/src/compiler/ir2opt.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir2opt.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -830,9 +830,19 @@ (reads (tn-reads tn))) (and writes reads (not (tn-ref-next writes)) (not (tn-ref-next reads))))) -(defun next-vop-is (vop name) +(defun next-vop-is (vop names) (let ((next (vop-next vop))) - (and next (eq (vop-name next) name)))) + (and next + (let ((name (vop-name next))) + (if (atom names) (eq name names) (memq name names))) + next))) + +(defun previous-vop-is (vop names) + (let ((prev (vop-prev vop))) + (and prev + (let ((name (vop-name prev))) + (if (atom names) (eq name names) (memq name names))) + prev))) ;;; Possibly replace HOWMANY vops starting at FIRST with a vop named REPLACEMENT. ;;; Each deleted vop must have exactly one argument and one result. diff -Nru sbcl-2.0.6/src/compiler/ir2tran.lisp sbcl-2.1.1/src/compiler/ir2tran.lisp --- sbcl-2.0.6/src/compiler/ir2tran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ir2tran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -449,7 +449,8 @@ ;;; IR2-LVAR-LOCS. Otherwise we make a new list padded as necessary by ;;; discarded TNs. We always return a TN of the specified type, using ;;; the lvar locs only when they are of the correct type. -(defun lvar-result-tns (lvar types &optional primitive-types) +(defun lvar-result-tns (lvar types &optional primitive-types + call) (declare (type (or lvar null) lvar) (type list primitive-types types)) (let ((primitive-types (or primitive-types @@ -466,13 +467,21 @@ for prim-type in primitive-types always (eq (tn-primitive-type loc) prim-type))) locs - (loop for prim-type in primitive-types + (loop with optional = (and call + (vop-info-p (combination-info call)) + (vop-info-optional-results (combination-info call))) + for prim-type in primitive-types for type in types + for i from 0 for loc = (pop locs) - collect (if (and loc - (eq (tn-primitive-type loc) prim-type)) - loc - (make-normal-tn prim-type type)))))) + collect (cond ((and loc + (eq (tn-primitive-type loc) prim-type)) + loc) + ((and (not loc) + (member i optional)) + (make-unused-tn)) + (t + (make-normal-tn prim-type type))))))) (:unknown (mapcar #'make-normal-tn primitive-types types)))) (mapcar #'make-normal-tn primitive-types types)))) @@ -513,6 +522,7 @@ (ndest (length dest))) (mapc (lambda (from to) (unless (or (eq from to) + (eq (tn-kind from) :unused) (eq (tn-kind to) :unused)) (emit-move node block from to))) (if (> ndest nsrc) @@ -590,7 +600,7 @@ (lvar-value bound)) ((and (integer-type-p bound-type) (nth-value 1 (integer-type-numeric-bounds bound-type)))) - (sb-xc:array-dimension-limit)))))) + (array-dimension-limit)))))) (index-type (lvar-type index))) (when (eq (type-intersection bound-type index-type) *empty-type*) @@ -713,7 +723,9 @@ (return nil)))) locs (lvar-result-tns lvar - (find-template-result-types call rtypes))))) + (find-template-result-types call rtypes) + nil + call)))) ;;; Get the operands into TNs, make TN-REFs for them, and then call ;;; the template emit function. @@ -1245,8 +1257,8 @@ (warn-if-inline-failed/call fname (node-lexenv node) cell)) (case *track-full-called-fnames* (:detailed - (when (boundp 'sb-xc:*compile-file-pathname*) - (pushnew sb-xc:*compile-file-pathname* (cdr cell) + (when (boundp '*compile-file-pathname*) + (pushnew *compile-file-pathname* (cdr cell) :test #'equal))) (:very-detailed (pushnew (component-name *component-being-compiled*) @@ -1303,7 +1315,9 @@ ;;;; entering functions (defun xep-verify-arg-count (node block fun arg-count-location) - (when (policy fun (plusp verify-arg-count)) + (when (and (policy fun (plusp verify-arg-count)) + ;; this property will be absent in most cases + (getf (functional-plist fun) 'verify-arg-count t)) (let* ((ef (functional-entry-fun fun)) (optional (optional-dispatch-p ef)) (min (and optional @@ -1350,7 +1364,7 @@ ;; not all backends have been updated yet. On backends ;; that have not been updated, we still need to use ;; XEP-SETUP-SP here. - #+(or alpha hppa mips sparc) + #+(or mips sparc) (vop xep-setup-sp node block) (vop copy-more-arg node block (optional-dispatch-max-args ef) #+x86-64 verified)) @@ -1472,7 +1486,7 @@ (setf (ir2-physenv-environment-start env) lab) (vop note-environment-start node block lab) #+sb-safepoint - (unless (policy fun (>= inhibit-safepoints 2)) + (when (policy fun (/= insert-safepoints 0)) (vop sb-vm::insert-safepoint node block)))) (values)) @@ -1733,17 +1747,16 @@ (loop for loc in (ir2-lvar-locs 2lvar) for idx upfrom 0 unless (eq (tn-kind loc) :unused) - do #+(vop-named sb-vm::more-arg-or-nil) - (vop sb-vm::more-arg-or-nil node block - (lvar-tn node block context) - (lvar-tn node block count) - idx - loc) - #-(vop-named sb-vm::more-arg-or-nil) - (vop sb-vm::more-arg node block - (lvar-tn node block context) - (emit-constant idx) - loc))) + do (if-vop-existsp (:named sb-vm::more-arg-or-nil) + (vop sb-vm::more-arg-or-nil node block + (lvar-tn node block context) + (lvar-tn node block count) + idx + loc) + (vop sb-vm::more-arg node block + (lvar-tn node block context) + (emit-constant idx) + loc)))) (:unknown (let ((locs (ir2-lvar-locs 2lvar))) (vop* %more-arg-values node block @@ -1787,9 +1800,9 @@ (defoptimizer (%special-unbind ir2-convert) ((&rest symbols) node block) (declare (ignorable symbols)) - #-(vop-named sb-c:unbind-n) (vop unbind node block) - #+(vop-named sb-c:unbind-n) (vop unbind-n node block - (mapcar #'lvar-value symbols))) + (if-vop-existsp (:named sb-c:unbind-n) + (vop unbind-n node block (mapcar #'lvar-value symbols)) + (vop unbind node block))) ;;; ### It's not clear that this really belongs in this file, or ;;; should really be done this way, but this is the least violation of @@ -2203,7 +2216,7 @@ (member (loop-kind (block-loop block)) '(:natural :strange)) (eq block (loop-head (block-loop block))) - (policy first-node (< inhibit-safepoints 2))) + (policy first-node (/= insert-safepoints 0))) (vop sb-vm::insert-safepoint first-node 2block)))) (ir2-convert-block block) (incf num)))))) diff -Nru sbcl-2.0.6/src/compiler/knownfun.lisp sbcl-2.1.1/src/compiler/knownfun.lisp --- sbcl-2.0.6/src/compiler/knownfun.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/knownfun.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -413,7 +413,7 @@ (and (proper-sequence-p value) (let ((length (length value))) (values length length)))) - (let ((max 0) (min sb-xc:array-total-size-limit)) + (let ((max 0) (min array-total-size-limit)) (block nil (labels ((max-dim (type) ;; This can deal with just enough hair to handle type STRING, @@ -427,12 +427,11 @@ (process-dim (array-type-dimensions type)))) (t (return '*)))) (process-dim (dim) - (let ((length (car dim))) - (if (and (singleton-p dim) - (integerp length)) + (if (typep dim '(cons integer null)) + (let ((length (car dim))) (setf max (max max length) - min (min min length)) - (return '*))))) + min (min min length))) + (return '*)))) ;; If type derivation were able to notice that non-simple arrays can ;; be mutated (changing the type), we could safely use LVAR-TYPE on ;; any vector type. But it doesn't notice. diff -Nru sbcl-2.0.6/src/compiler/locall.lisp sbcl-2.1.1/src/compiler/locall.lisp --- sbcl-2.0.6/src/compiler/locall.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/locall.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -166,7 +166,7 @@ (declare (type functional fun)) (etypecase fun (clambda - (let* ((n-supplied (gensym)) + (let* ((n-supplied (sb-xc:gensym)) (nargs (length (lambda-vars fun))) (temps (make-gensym-list nargs))) `(lambda (,n-supplied ,@temps) @@ -174,12 +174,12 @@ (ignore ,n-supplied)) (%funcall ,fun ,@temps)))) (optional-dispatch - ;; Force convertion of all entries + ;; Force conversion of all entries (optional-dispatch-entry-point-fun fun 0) (let* ((min (optional-dispatch-min-args fun)) (max (optional-dispatch-max-args fun)) (more (optional-dispatch-more-entry fun)) - (n-supplied (gensym)) + (n-supplied (sb-xc:gensym)) (temps (make-gensym-list max)) (main (optional-dispatch-main-entry fun)) (optional-vars (nthcdr min (lambda-vars main))) @@ -425,9 +425,12 @@ (multiple-value-bind (losing-local-object converted-lambda) (catch 'locall-already-let-converted (with-ir1-environment-from-node call - (let ((*inline-expansions* - (register-inline-expansion original-functional call)) - (*lexenv* (functional-lexenv original-functional))) + (let* ((*inline-expansions* + (register-inline-expansion original-functional call)) + (*lexenv* (functional-lexenv original-functional)) + (*transforming* + (and (functional-inline-expanded original-functional) + (system-inline-fun-p (leaf-source-name original-functional))))) (values nil (ir1-convert-lambda (functional-inline-expansion original-functional) @@ -1049,32 +1052,42 @@ ;;; the RETURN-RESULT, because the return might have been deleted (if ;;; all calls were TR.) (defun unconvert-tail-calls (fun call next-block) - (do-sset-elements (called (lambda-calls-or-closes fun)) - (when (lambda-p called) - (dolist (ref (leaf-refs called)) - (let ((this-call (node-dest ref))) - (when (and this-call - (node-tail-p this-call) - (not (node-to-be-deleted-p this-call)) - (eq (node-home-lambda this-call) fun)) - (setf (node-tail-p this-call) nil) - (ecase (functional-kind called) - ((nil :cleanup :optional) - (let ((block (node-block this-call)) - (lvar (node-lvar call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block next-block) - (if (eq (node-derived-type this-call) *empty-type*) - (maybe-terminate-block this-call nil) - (add-lvar-use this-call lvar)))) - (:deleted) - ;; The called function might be an assignment in the - ;; case where we are currently converting that function. - ;; In steady-state, assignments never appear as a called - ;; function. - (:assignment - (aver (eq called fun))))))))) - (values)) + (let (maybe-terminate) + (do-sset-elements (called (lambda-calls-or-closes fun)) + (when (lambda-p called) + (dolist (ref (leaf-refs called)) + (let ((this-call (node-dest ref))) + (when (and this-call + (node-tail-p this-call) + (not (node-to-be-deleted-p this-call)) + (eq (node-home-lambda this-call) fun)) + (setf (node-tail-p this-call) nil) + (ecase (functional-kind called) + ((nil :cleanup :optional) + (let ((block (node-block this-call)) + (lvar (node-lvar call))) + (unlink-blocks block (first (block-succ block))) + (link-blocks block next-block) + (if (eq (node-derived-type this-call) *empty-type*) + ;; Delay terminating the block, because there may be more calls + ;; to be processed here and this may prematurely delete NEXT-BLOCK + ;; before we attach more preceding blocks to it. + ;; Although probably if one call to a function + ;; is derived to be NIL all other calls would + ;; be NIL too, but that may not be available at the same time. + ;; (Or something is smart in the future to + ;; derive different results from different + ;; calls.) + (push this-call maybe-terminate) + (add-lvar-use this-call lvar)))) + (:deleted) + ;; The called function might be an assignment in the + ;; case where we are currently converting that function. + ;; In steady-state, assignments never appear as a called + ;; function. + (:assignment + (aver (eq called fun))))))))) + maybe-terminate)) ;;; Deal with returning from a LET or assignment that we are ;;; converting. FUN is the function we are calling, CALL is a call to @@ -1102,9 +1115,9 @@ (defun move-return-stuff (fun call next-block) (declare (type clambda fun) (type basic-combination call) (type (or cblock null) next-block)) - (when next-block - (unconvert-tail-calls fun call next-block)) - (let* ((return (lambda-return fun)) + (let* ((maybe-terminate-calls (when next-block + (unconvert-tail-calls fun call next-block))) + (return (lambda-return fun)) (call-fun (node-home-lambda call)) (call-return (lambda-return call-fun))) (when (and call-return @@ -1129,8 +1142,11 @@ (aver (node-tail-p call)) (setf (lambda-return call-fun) return) (setf (return-lambda return) call-fun) - (setf (lambda-return fun) nil)))) - (delete-lvar-use call) ; LET call does not have value semantics + (setf (lambda-return fun) nil))) + ;; Delayed because otherwise next-block could become deleted + (dolist (call maybe-terminate-calls) + (maybe-terminate-block call nil))) + (delete-lvar-use call) ; LET call does not have value semantics (values)) ;;; Actually do LET conversion. We call subfunctions to do most of the diff -Nru sbcl-2.0.6/src/compiler/ltn.lisp sbcl-2.1.1/src/compiler/ltn.lisp --- sbcl-2.0.6/src/compiler/ltn.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ltn.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -95,7 +95,7 @@ (link-blocks node-block next-block))) ;;; an annotated lvar's primitive-type -#-sb-fluid (declaim (inline lvar-ptype)) +(declaim (inline lvar-ptype)) (defun lvar-ptype (lvar) (declare (type lvar lvar)) (ir2-lvar-primitive-type (lvar-info lvar))) @@ -198,6 +198,11 @@ (setf (node-tail-p call) nil)))) (values)) +(defun signal-delayed-combination-condition (call) + (let ((*compiler-error-context* call) + (delayed (combination-info call))) + (apply #'funcall delayed))) + ;;; We set the kind to :FULL or :FUNNY, depending on whether there is ;;; an IR2-CONVERT method. If a funny function, then we inhibit tail ;;; recursion normally, since the IR2 convert method is going to want @@ -225,6 +230,8 @@ (setf (node-tail-p call) nil)) (t (when (eq kind :error) + (when (basic-combination-info call) + (signal-delayed-combination-condition call)) (setf (basic-combination-kind call) :full)) (setf (basic-combination-info call) :full) (rewrite-full-call call)))) @@ -369,13 +376,13 @@ (primitive-types)) (let ((n-values (nth-value 1 (values-types (lvar-derived-type arg))))) - (loop for (prim-type . lvar-type) = (pop types) - repeat n-values + (loop repeat n-values do - (primitive-types (or prim-type - *backend-t-primitive-type*)) - (lvar-types (or lvar-type - *universal-type*))) + (destructuring-bind (&optional prim-type . lvar-type) (pop types) + (primitive-types (or prim-type + *backend-t-primitive-type*)) + (lvar-types (or lvar-type + *universal-type*)))) (annotate-fixed-values-lvar arg (primitive-types) (lvar-types)))))))) diff -Nru sbcl-2.0.6/src/compiler/macros.lisp sbcl-2.1.1/src/compiler/macros.lisp --- sbcl-2.0.6/src/compiler/macros.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/macros.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -747,7 +747,7 @@ ;;;; functions on directly-linked lists (linked through specialized ;;;; NEXT operations) -#-sb-fluid (declaim (inline find-in position-in)) +(declaim (inline find-in position-in)) ;;; Find ELEMENT in a null-terminated LIST linked by the accessor ;;; function NEXT. KEY and TEST are the same as for generic sequence functions. @@ -783,7 +783,7 @@ (defmacro deletef-in (next place item &environment env) (multiple-value-bind (temps vals stores store access) - (#+sb-xc sb-xc:get-setf-expansion #-sb-xc get-setf-expansion place env) + (#-sb-xc-host get-setf-expansion #+sb-xc-host cl:get-setf-expansion place env) (when (cdr stores) (error "multiple store variables for ~S" place)) (let ((n-item (gensym)) @@ -809,7 +809,7 @@ ;;; (defmacro push-in (next item place &environment env) (multiple-value-bind (temps vals stores store access) - (#+sb-xc sb-xc:get-setf-expansion #-sb-xc get-setf-expansion place env) + (#-sb-xc-host get-setf-expansion #+sb-xc-host cl:get-setf-expansion place env) (when (cdr stores) (error "multiple store variables for ~S" place)) `(let (,@(mapcar #'list temps vals) diff -Nru sbcl-2.0.6/src/compiler/main.lisp sbcl-2.1.1/src/compiler/main.lisp --- sbcl-2.0.6/src/compiler/main.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/main.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -29,25 +29,25 @@ ;;; FIXME: should probably have no value outside the compiler. (defvar *top-level-form-noted* nil) -(defvar sb-xc:*compile-verbose* t +(defvar *compile-verbose* t "The default for the :VERBOSE argument to COMPILE-FILE.") -(defvar sb-xc:*compile-print* t +(defvar *compile-print* t "The default for the :PRINT argument to COMPILE-FILE.") (defvar *compile-progress* nil "When this is true, the compiler prints to *STANDARD-OUTPUT* progress information about the phases of compilation of each function. (This is useful mainly in large block compilations.)") -(defvar sb-xc:*compile-file-pathname* nil +(defvar *compile-file-pathname* nil "The defaulted pathname of the file currently being compiled, or NIL if not compiling.") -(defvar sb-xc:*compile-file-truename* nil +(defvar *compile-file-truename* nil "The TRUENAME of the file currently being compiled, or NIL if not compiling.") (declaim (type (or pathname null) - sb-xc:*compile-file-pathname* - sb-xc:*compile-file-truename*)) + *compile-file-pathname* + *compile-file-truename*)) ;;; the SOURCE-INFO structure for the current compilation. This is ;;; null globally to indicate that we aren't currently in any @@ -87,7 +87,7 @@ ;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES -(defmacro sb-xc:with-compilation-unit (options &body body) +(defmacro with-compilation-unit (options &body body) "Affects compilations that take place within its dynamic extent. It is intended to be eg. wrapped around the compilation of all files in the same system. @@ -459,31 +459,43 @@ (defparameter *reoptimize-limit* 10) (defun ir1-optimize-phase-1 (component) - (let ((loop-count 0)) - (loop - (ir1-optimize-until-done component) - (when (or (component-new-functionals component) - (component-reanalyze-functionals component)) - (maybe-mumble "Locall ") - (locall-analyze-component component)) - (eliminate-dead-code component) - (dfo-as-needed component) - (when *constraint-propagate* - (maybe-mumble "Constraint ") - (constraint-propagate component)) - (when (retry-delayed-ir1-transforms :constraint) - (setf loop-count 0) ;; otherwise nothing may get retried - (maybe-mumble "Rtran ")) - (unless (or (component-reoptimize component) - (component-reanalyze component) - (component-new-functionals component) - (component-reanalyze-functionals component)) - (return)) - (when (> loop-count *reoptimize-limit*) - (maybe-mumble "[Reoptimize Limit]") - (event reoptimize-maxed-out) - (return)) - (incf loop-count)))) + (let ((loop-count 0) + (*constraint-propagate* *constraint-propagate*)) + (tagbody + again + (loop + (ir1-optimize-until-done component) + (when (or (component-new-functionals component) + (component-reanalyze-functionals component)) + (maybe-mumble "Locall ") + (locall-analyze-component component)) + (eliminate-dead-code component) + (dfo-as-needed component) + (when *constraint-propagate* + (maybe-mumble "Constraint ") + (constraint-propagate component) + (when (retry-delayed-ir1-transforms :constraint) + (setf loop-count 0) ;; otherwise nothing may get retried + (maybe-mumble "Rtran "))) + (unless (or (component-reoptimize component) + (component-reanalyze component) + (component-new-functionals component) + (component-reanalyze-functionals component)) + (return)) + (when (> loop-count *reoptimize-limit*) + (maybe-mumble "[Reoptimize Limit]") + (event reoptimize-maxed-out) + (return)) + (incf loop-count)) + ;; Do it once more for the transforms that will produce code + ;; that loses some information for further optimizations and + ;; it's better to insert it at the last moment. + ;; Such code shouldn't need constraint propagation, the slowest + ;; part, so avoid it. + (when (retry-delayed-ir1-transforms :ir1-phases) + (setf loop-count 0 + *constraint-propagate* nil) + (go again))))) ;;; Do all the IR1 phases for a non-top-level component. (defun ir1-phases (component) @@ -701,7 +713,7 @@ (aver (eql (node-component (lambda-bind lambda)) component))) (let* ((*component-being-compiled* component)) - (when (and sb-xc:*compile-print* (block-compile *compilation*)) + (when (and *compile-print* (block-compile *compilation*)) (with-compiler-io-syntax (compiler-mumble "~&; compiling ~A" (component-name component)))) @@ -769,7 +781,7 @@ (maphash (lambda (k v) (declare (ignore k)) (setf (leaf-info v) nil)) - (eq-constants ns)) + (eql-constants ns)) (maphash (lambda (k v) (declare (ignore k)) (when (constant-p v) @@ -795,10 +807,10 @@ (eq (node-component x) component))) (blast (free-vars ns)) (blast (free-funs ns)) - ;; There can be more constants to blast when considering them by EQ rather + ;; There can be more constants to blast when considering them by EQL rather ;; than similarity. But it's totally OK to visit a # twice. ;; Its refs will be scanned redundantly, which is harmless. - (blast (eq-constants ns))) + (blast (eql-constants ns))) (values)) ;;;; trace output @@ -869,8 +881,8 @@ (let* ((file-info (source-info-file-info info)) (name (file-info-name file-info)) (external-format (file-info-external-format file-info))) - (setf sb-xc:*compile-file-truename* name - sb-xc:*compile-file-pathname* (file-info-untruename file-info) + (setf *compile-file-truename* name + *compile-file-pathname* (file-info-untruename file-info) (source-info-stream info) (let ((stream (open name @@ -1232,7 +1244,7 @@ result)))))) (defun note-top-level-form (form &optional finalp) - (when sb-xc:*compile-print* + (when *compile-print* (cond ((not *top-level-form-noted*) (let ((*print-length* 2) (*print-level* 2) @@ -1241,7 +1253,7 @@ (compiler-mumble "~&; processing ~S" form))) form) ((and finalp - (eq :top-level-forms sb-xc:*compile-print*) + (eq :top-level-forms *compile-print*) (neq form *top-level-form-noted*)) (let ((*print-length* 1) (*print-level* 1) @@ -1401,7 +1413,7 @@ ;; +SLOT-UNBOUND+ is not a constant, ;; but is trivially dumpable. (or (eql x 'sb-pcl:+slot-unbound+) - (sb-xc:constantp x))) + (constantp x))) value-forms)) (dolist (form value-forms) (unless (eq form 'sb-pcl:+slot-unbound+) @@ -1595,8 +1607,8 @@ (declare (type source-info info)) (let ((*package* (sane-package)) (*readtable* *readtable*) - (sb-xc:*compile-file-pathname* nil) ; set by GET-SOURCE-STREAM - (sb-xc:*compile-file-truename* nil) ; " + (*compile-file-pathname* nil) ; set by GET-SOURCE-STREAM + (*compile-file-truename* nil) ; " (*policy* *policy*) (*macro-policy* *macro-policy*) @@ -1623,14 +1635,14 @@ (declare (ignore error)) (return-from sub-compile-file (values t t t)))) (*current-path* nil) - (sb-xc:*gensym-counter* 0) + (*gensym-counter* 0) (sb-impl::*eval-source-info* nil) (sb-impl::*eval-tlf-index* nil) (sb-impl::*eval-source-context* nil)) (handler-case (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) (with-compilation-values - (sb-xc:with-compilation-unit () + (with-compilation-unit () (with-world-lock () (setf (sb-fasl::fasl-output-source-info *compile-object*) (debug-source-for-info info)) @@ -1639,7 +1651,7 @@ 'input-error-in-compile-file) (with-source-paths (find-source-paths form current-index) - (let ((sb-xc:*gensym-counter* 0)) + (let ((*gensym-counter* 0)) (process-toplevel-form form `(original-source-start 0 ,current-index) nil)))) (let ((*source-info* info)) @@ -1650,7 +1662,7 @@ ;; Dump the code coverage records into the fasl. (with-source-paths (fopcompile `(record-code-coverage - ',(namestring sb-xc:*compile-file-pathname*) + ',(namestring *compile-file-pathname*) ',(let (list) (maphash (lambda (k v) (declare (ignore k)) @@ -1692,8 +1704,8 @@ (defun elapsed-time-to-string (internal-time-delta) (multiple-value-bind (tsec remainder) - (truncate internal-time-delta sb-xc:internal-time-units-per-second) - (let ((ms (truncate remainder (/ sb-xc:internal-time-units-per-second 1000)))) + (truncate internal-time-delta internal-time-units-per-second) + (let ((ms (truncate remainder (/ internal-time-units-per-second 1000)))) (multiple-value-bind (tmin sec) (truncate tsec 60) (multiple-value-bind (thr min) (truncate tmin 60) (format nil "~D:~2,'0D:~2,'0D.~3,'0D" thr min sec ms)))))) @@ -1728,7 +1740,7 @@ ;;; Open some files and call SUB-COMPILE-FILE. If something unwinds ;;; out of the compile, then abort the writing of the output file, so ;;; that we don't overwrite it with known garbage. -(defun sb-xc:compile-file +(defun compile-file (input-file &key @@ -1737,8 +1749,8 @@ ;; FIXME: ANSI doesn't seem to say anything about ;; *COMPILE-VERBOSE* and *COMPILE-PRINT* being rebound by this ;; function.. - ((:verbose sb-xc:*compile-verbose*) sb-xc:*compile-verbose*) - ((:print sb-xc:*compile-print*) sb-xc:*compile-print*) + ((:verbose *compile-verbose*) *compile-verbose*) + ((:print *compile-print*) *compile-print*) ((:progress *compile-progress*) *compile-progress*) (external-format :default) @@ -1810,7 +1822,7 @@ (progn (when output-file (setq output-file-name - (sb-xc:compile-file-pathname input-file + (compile-file-pathname input-file :output-file output-file)) (setq fasl-output (open-fasl-output output-file-name @@ -1832,7 +1844,7 @@ (fasl-output-stream fasl-output))) :if-exists :supersede :direction :output)))) - (when sb-xc:*compile-verbose* + (when *compile-verbose* (print-compile-start-note source-info)) (let ((*compile-object* fasl-output)) @@ -1845,15 +1857,15 @@ (close-fasl-output fasl-output abort-p) (setq output-file-name (pathname (fasl-output-stream fasl-output))) - (when (and (not abort-p) sb-xc:*compile-verbose*) + (when (and (not abort-p) *compile-verbose*) (compiler-mumble "~2&; wrote ~A~%" (namestring output-file-name)))) (when cfasl-output (close-fasl-output cfasl-output abort-p) - (when (and (not abort-p) sb-xc:*compile-verbose*) + (when (and (not abort-p) *compile-verbose*) (compiler-mumble "; wrote ~A~%" (namestring coutput-file-name)))) - (when sb-xc:*compile-verbose* + (when *compile-verbose* (print-compile-end-note source-info (not abort-p))) ;; Don't nuke stdout if you use :trace-file *standard-output* @@ -1893,10 +1905,10 @@ ;;; at the level of e.g. whether it returns logical pathname or a ;;; physical pathname. Patches to make it more correct are welcome. ;;; -- WHN 2000-12-09 -(defun sb-xc:compile-file-pathname (input-file - &key - (output-file nil output-file-p) - &allow-other-keys) +(defun compile-file-pathname (input-file + &key + (output-file nil output-file-p) + &allow-other-keys) "Return a pathname describing what file COMPILE-FILE would write to given these arguments." (if output-file-p @@ -1953,8 +1965,7 @@ (defvar *constants-being-created* nil) (defvar *constants-created-since-last-init* nil) ;;; FIXME: Shouldn't these^ variables be unbound outside LET forms? -(defun emit-make-load-form (constant &optional (name nil namep) - &aux (fasl *compile-object*)) +(defun emit-make-load-form (constant &aux (fasl *compile-object*)) (aver (fasl-output-p fasl)) (unless (fasl-constant-already-dumped-p constant fasl) (let ((circular-ref (assoc constant *constants-being-created* :test #'eq))) @@ -1962,20 +1973,7 @@ (when (find constant *constants-created-since-last-init* :test #'eq) (throw constant t)) (throw 'pending-init circular-ref))) - ;; If this is a global constant reference, we can call SYMBOL-GLOBAL-VALUE - ;; during LOAD as a fasl op, and not compile a lambda. - ;; However: the cross-compiler can not always emit fop-funcall for this, - ;; because the order of load-time actions is not strictly preserved as it - ;; would be for normal compilation. If the symbol's value needs computation, - ;; then it is unbound during genesis. - ;; So check if assignment was deferred, and if so, also defer the use. - (when (and namep #+sb-xc-host (not (member name *!const-value-deferred*))) - (fopcompile `(symbol-global-value ',name) nil t nil) - (fasl-note-handle-for-constant constant (sb-fasl::dump-pop fasl) fasl) - (return-from emit-make-load-form nil)) - (multiple-value-bind (creation-form init-form) - (cond (namep (values `(symbol-global-value ',name) nil)) - (t (%make-load-form constant))) + (multiple-value-bind (creation-form init-form) (%make-load-form constant) (cond ((eq init-form 'sb-fasl::fop-struct) (fasl-note-dumpable-instance constant fasl) diff -Nru sbcl-2.0.6/src/compiler/meta-vmdef.lisp sbcl-2.1.1/src/compiler/meta-vmdef.lisp --- sbcl-2.0.6/src/compiler/meta-vmdef.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/meta-vmdef.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -302,6 +302,8 @@ (more-results nil :type (or operand-parse null)) ;; a list of all the above together (operands nil :type list) + ;; Which results can accept :unused TNs + (optional-results nil :type list) ;; names of variables that should be declared IGNORE (ignores () :type list) ;; true if this is a :CONDITIONAL VOP. T if a branchful VOP, @@ -371,7 +373,7 @@ ;;; Order here is insignificant; it happens to be alphabetical. (defglobal vop-parse-slot-names '(arg-types args args-var before-load body conditional-p cost guard ignores info-args inherits - ltn-policy more-args more-results move-args name node-var note result-types + ltn-policy more-args more-results move-args name node-var note optional-results result-types results results-var save-p source-location temps translate variant variant-vars vop-var)) ;; A sanity-check. Of course if this fails, the likelihood is that you can't even ;; get this far in cross-compilaion. So it's probably not worth much. @@ -607,7 +609,7 @@ :num-results ,num-results :ref-ordering ,ordering ,@(when (targets) - `(:targets ,(sb-xc:coerce (targets) `(vector ,te-type))))))))) + `(:targets ,(coerce (targets) `(vector ,te-type))))))))) (defun make-emit-function-and-friends (parse) `(:temps ,(compute-temporaries-description parse) @@ -1039,6 +1041,10 @@ (setf (vop-parse-save-p parse) (vop-spec-arg spec '(member t nil :compute-only :force-to-stack)))) + (:optional-results + (setf (vop-parse-optional-results parse) + (append (vop-parse-optional-results parse) + (rest spec)))) (t (error "unknown option specifier: ~S" (first spec))))) (values))) @@ -1096,11 +1102,11 @@ (values costs load-scs))) (defconstant-eqx +no-costs+ - (make-array sb-vm:sc-number-limit :initial-element 0) + #.(make-array sb-vm:sc-number-limit :initial-element 0) #'equalp) (defconstant-eqx +no-loads+ - (make-array sb-vm:sc-number-limit :initial-element t) + #.(make-array sb-vm:sc-number-limit :initial-element t) #'equalp) ;;; Pick off the case of operands with no restrictions. @@ -1141,7 +1147,9 @@ :more-result-costs ',(if (vop-parse-more-results parse) (compute-loading-costs-if-any (vop-parse-more-results parse) nil) - nil))))) + nil) + :optional-results ',(loop for name in (vop-parse-optional-results parse) + collect (position name (vop-parse-results parse) :key #'operand-parse-name)))))) ;;;; operand checking and stuff diff -Nru sbcl-2.0.6/src/compiler/mips/arith.lisp sbcl-2.1.1/src/compiler/mips/arith.lisp --- sbcl-2.0.6/src/compiler/mips/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/mips/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -581,33 +581,19 @@ ;;;; 32-bit logical operations -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (ecase *backend-byte-order* - (:big-endian - (inst sll r num amount)) - (:little-endian - (inst srl r num amount))))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (ecase *backend-byte-order* - (:big-endian - (inst srl r num amount)) - (:little-endian - (inst sll r num amount))))) +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 (inst ,operation r num amount))))) + (define shift-towards-start #+big-endian sll #+little-endian srl) + (define shift-towards-end #+big-endian srl #+little-endian sll)) ;;;; Modular arithmetic (define-modular-fun +-mod32 (x y) + :untagged nil 32) diff -Nru sbcl-2.0.6/src/compiler/mips/array.lisp sbcl-2.1.1/src/compiler/mips/array.lisp --- sbcl-2.0.6/src/compiler/mips/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/mips/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -26,8 +26,10 @@ lowtag-mask)) (inst srl bytes n-lowtag-bits) (inst sll bytes n-lowtag-bits) - (inst addu header rank (fixnumize (1- array-dimensions-offset))) - (inst sll header n-widetag-bits) + ;; Compute the encoded rank. See ENCODE-ARRAY-RANK. + (inst addu header rank (fixnumize -1)) + (inst and header header (fixnumize array-rank-mask)) + (inst sll header header array-rank-byte-pos) (inst or header type) ;; Remove the extraneous fixnum tag bits because TYPE and RANK ;; were fixnums @@ -46,17 +48,19 @@ array-dimensions-offset other-pointer-lowtag (any-reg) positive-fixnum %set-array-dimension) -(define-vop (array-rank-vop) +(define-vop () (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) (:generator 6 - (loadw temp x 0 other-pointer-lowtag) - (inst sra temp n-widetag-bits) - (inst subu temp (1- array-dimensions-offset)) - (inst sll res temp n-fixnum-tag-bits))) + ;; ASSUMPTION: n-widetag-bits = 8 + (inst lbu res x #+little-endian (- 2 other-pointer-lowtag) + #+big-endian (- 1 other-pointer-lowtag)) + (inst nop) + (inst addu res 1) + (inst and res array-rank-mask))) ;;;; Bounds checking routine. (define-vop (check-bound) diff -Nru sbcl-2.0.6/src/compiler/mips/insts.lisp sbcl-2.1.1/src/compiler/mips/insts.lisp --- sbcl-2.0.6/src/compiler/mips/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/mips/insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -223,19 +223,9 @@ (load-store-annotation :fields (list (byte 5 21) (byte 16 0)) :type 'load-store-annotation)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter jump-printer - #'(lambda (value stream dstate) - (let ((addr (ash value 2))) - (cond (stream - (maybe-note-assembler-routine addr t dstate) - (write addr :base 16 :radix t :stream stream)) - (t - (operand addr dstate))))))) - (define-instruction-format (jump 32 :default-printer '(:name :tab target)) (op :field (byte 6 26)) - (target :field (byte 26 0) :printer jump-printer)) + (target :field (byte 26 0) :printer #'jump-printer)) (defconstant-eqx reg-printer '(:name :tab rd (:unless (:same-as rd) ", " rs) ", " rt) @@ -1035,41 +1025,6 @@ ;;;; Random system hackery and other noise -(define-instruction-macro entry-point () - nil) - -(defmacro break-cases (breaknum &body cases) - (let ((bn-temp (gensym))) - (collect ((clauses)) - (dolist (case cases) - (clauses `((= ,bn-temp ,(car case)) ,@(cdr case)))) - `(let ((,bn-temp ,breaknum)) - (cond ,@(clauses)))))) - -(defun break-control (chunk inst stream dstate) - (declare (ignore inst)) - (flet ((nt (x) (if stream (note x dstate)))) - (let ((trap (break-subcode chunk dstate))) - (case trap - (#.halt-trap - (nt "Halt trap")) - (#.pending-interrupt-trap - (nt "Pending interrupt trap")) - (#.breakpoint-trap - (nt "Breakpoint trap")) - (#.fun-end-breakpoint-trap - (nt "Function end breakpoint trap")) - (#.after-breakpoint-trap - (nt "After breakpoint trap")) - (#.single-step-around-trap - (nt "Single step around trap")) - (#.single-step-before-trap - (nt "Single step before trap")) - (t - (when (or (and (= trap cerror-trap) (progn (nt "cerror trap") t)) - (>= trap error-trap)) - (handle-break-args #'snarf-error-junk trap stream dstate))))))) - (define-instruction break (segment code &optional (subcode 0)) (:declare (type (unsigned-byte 10) code subcode)) (:printer break ((op special-op) (funct #b001101)) @@ -1247,12 +1202,21 @@ (define-instruction lw (segment reg base &optional (index 0)) (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) + (type (or (signed-byte 16) fixup label) index)) (:printer load-store ((op #b100011))) (:dependencies (reads base) (reads :memory) (writes reg)) (:delay 1) (:emitter - (emit-load/store-inst segment #b100011 base reg index))) + (if (and (label-p index) (eq base sb-vm::code-tn)) + (emit-back-patch segment 4 + (lambda (segment posn) + (declare (ignore posn)) + (emit-load/store-inst segment #b100011 + base reg + (+ (component-header-length) + (label-position index) + (- sb-vm:other-pointer-lowtag))))) + (emit-load/store-inst segment #b100011 base reg index)))) ;; next is just for ease of coding double-in-int c-call convention (define-instruction lw-odd (segment reg base &optional (index 0)) @@ -1377,3 +1341,64 @@ (:emitter (emit-fp-load/store-inst segment #b111001 reg 1 base index))) +;;; This mechanism is more complicated than minimally necessary for it to do its job. +;;; Consequently each backend has its own completely screwy way of canonicalizing +;;; because each one is better than the other. +;;; CONSTANT is just the &REST list passed to REGISTER-INLINE-CONSTANT which acts as +;;; a key in an EQUAL table for collapsing multiple references to the same data +;;; so that we only emit it once (or possibly not even once, if we fuse bytes from +;;; adjacent constants as suggested by comments in codegen. e.g. an 8-byte constant +;;; may contain a naturally-aligned 4-byte constant whose bytes match). +;;; The question is - why doesn't the vop just pass the proper key in the first place? +(defun canonicalize-inline-constant (constant) + constant) + +;;; Again this is too complex in the simplest case- you return an assembler label, +;;; and a cookie to hand to the consumer of the constant, which is {often,always} +;;; redundant, because the consumer knows what shape the value is - float, octaword, etc. +;;; The label alone conveys enough data to access the bits stored, however +;;; in some cases the sorting logic might need a way to determine the storage size. +(defun inline-constant-value (constant) + (declare (ignore constant)) + (let ((label (gen-label))) + (values label label))) + +;;; Trivial "sort" +(defun sort-inline-constants (constants) constants) + +;;; This is called once per unboxed constant, to emit its bytes. +;;; In general the bytes may be literal octets, or a fixup (as here) +;;; which is in turn emitted with a pseudo-instruction. +(defun emit-inline-constant (section constant label) + (aver (typep constant '(cons (eql :layout-id) (cons t null)))) + (emit section + `(.align 2) ; 2 bits of alignment (just to be pedantic I suppose) + label + `(.layout-id ,(cadr constant)))) + +(sb-assem::%def-inst-encoder + '.layout-id + (lambda (segment layout) + (sb-c:note-fixup segment :absolute (sb-c:make-fixup layout :layout-id)) + (sb-assem::%emit-skip segment 4))) + +(defun sb-vm:fixup-code-object (code offset value kind flavor) + (declare (type index offset)) + (declare (ignore flavor)) + (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) + (error "Unaligned instruction? offset=#x~X." offset)) + (let ((sap (code-instructions code))) + (ecase kind + (:absolute + (setf (sap-ref-32 sap offset) value)) + (:jump + (aver (zerop (ash value -28))) + (setf (ldb (byte 26 0) (sap-ref-32 sap offset)) + (ash value -2))) + (:lui + (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) + (ash (1+ (ash value -15)) -1))) + (:addi + (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) + (ldb (byte 16 0) value))))) + nil) diff -Nru sbcl-2.0.6/src/compiler/mips/move.lisp sbcl-2.1.1/src/compiler/mips/move.lisp --- sbcl-2.0.6/src/compiler/mips/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/mips/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -208,7 +208,7 @@ (inst beq temp done) (inst sll y x n-fixnum-tag-bits) - (load-constant vop (emit-constant (1+ sb-xc:most-positive-fixnum)) + (load-constant vop (emit-constant (1+ most-positive-fixnum)) y) (inst b done) (inst nop) @@ -225,7 +225,7 @@ (inst beq temp done) (inst sll y x n-fixnum-tag-bits) - (load-constant vop (emit-constant (1- sb-xc:most-negative-fixnum)) + (load-constant vop (emit-constant (1- most-negative-fixnum)) y) (inst b done) (inst nop) diff -Nru sbcl-2.0.6/src/compiler/mips/system.lisp sbcl-2.1.1/src/compiler/mips/system.lisp --- sbcl-2.0.6/src/compiler/mips/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/mips/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -57,6 +57,28 @@ DONE)) +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:policy :fast-safe) + (:conditional) + ;; "extra" info in conditional vops follows the 2 super-magical info args + (:info target not-p test-layout) + (:temporary (:sc unsigned-reg) this-id test-id) + (:generator 4 + (let ((label (register-inline-constant :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) + (- instance-pointer-lowtag)))) + (inst lw test-id sb-vm::code-tn label) + (inst lw this-id x offset) + (inst nop) + (inst* (if not-p 'bne 'beq) this-id test-id target) + (inst nop)))) + (define-vop (%other-pointer-widetag) (:translate %other-pointer-widetag) (:policy :fast-safe) diff -Nru sbcl-2.0.6/src/compiler/mips/target-insts.lisp sbcl-2.1.1/src/compiler/mips/target-insts.lisp --- sbcl-2.0.6/src/compiler/mips/target-insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/mips/target-insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,5 +11,36 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-VM") +(in-package "SB-MIPS-ASM") +(defun jump-printer (value stream dstate) + (let ((addr (ash value 2))) + (cond (stream + (maybe-note-assembler-routine addr t dstate) + (write addr :base 16 :radix t :stream stream)) + (t + (operand addr dstate))))) + +(defun break-control (chunk inst stream dstate) + (declare (ignore inst)) + (flet ((nt (x) (if stream (note x dstate)))) + (let ((trap (break-subcode chunk dstate))) + (case trap + (#.halt-trap + (nt "Halt trap")) + (#.pending-interrupt-trap + (nt "Pending interrupt trap")) + (#.breakpoint-trap + (nt "Breakpoint trap")) + (#.fun-end-breakpoint-trap + (nt "Function end breakpoint trap")) + (#.after-breakpoint-trap + (nt "After breakpoint trap")) + (#.single-step-around-trap + (nt "Single step around trap")) + (#.single-step-before-trap + (nt "Single step before trap")) + (t + (when (or (and (= trap cerror-trap) (progn (nt "cerror trap") t)) + (>= trap error-trap)) + (handle-break-args #'snarf-error-junk trap stream dstate))))))) diff -Nru sbcl-2.0.6/src/compiler/mips/vm.lisp sbcl-2.1.1/src/compiler/mips/vm.lisp --- sbcl-2.0.6/src/compiler/mips/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/mips/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,8 @@ (in-package "SB-VM") +(defconstant-eqx +fixup-kinds+ #(:absolute :jmp :lui :addi) #'equalp) + ;;;; Registers @@ -291,7 +293,7 @@ (if (static-symbol-p value) immediate-sc-number nil)) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) #-sb-xc-host ; There is no such object type in the host diff -Nru sbcl-2.0.6/src/compiler/modarith.lisp sbcl-2.1.1/src/compiler/modarith.lisp --- sbcl-2.0.6/src/compiler/modarith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/modarith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -96,7 +96,7 @@ (check-type kind (member :untagged :tagged)) (when lambda-list-p (dolist (arg lambda-list) - (when (member arg sb-xc:lambda-list-keywords) + (when (member arg lambda-list-keywords) (error "Lambda list keyword ~S is not supported for modular ~ function lambda lists." arg)))))) diff -Nru sbcl-2.0.6/src/compiler/node.lisp sbcl-2.1.1/src/compiler/node.lisp --- sbcl-2.0.6/src/compiler/node.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/node.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -138,21 +138,26 @@ (:include lvar-type-annotation) (:copier nil))) +(defstruct (lvar-lambda-var-annotation + (:include lvar-annotation) + (:copier nil)) + lambda-var) + (defmethod print-object ((x lvar) stream) (print-unreadable-object (x stream :type t :identity t) (when (boundp '*compilation*) (format stream "~D" (cont-num x))))) -#-sb-fluid (declaim (inline lvar-has-single-use-p)) +(declaim (inline lvar-has-single-use-p)) (defun lvar-has-single-use-p (lvar) (typep (lvar-uses lvar) '(not list))) ;;; Return the unique node, delivering a value to LVAR. -#-sb-fluid (declaim (inline lvar-use)) +(declaim (inline lvar-use)) (defun lvar-use (lvar) (the (not list) (lvar-uses lvar))) -#-sb-fluid (declaim (inline lvar-derived-type)) +(declaim (inline lvar-derived-type)) (defun lvar-derived-type (lvar) (declare (type lvar lvar)) (or (lvar-%derived-type lvar) @@ -211,7 +216,7 @@ ;; can null out this slot. (tail-p nil :type boolean)) -#-sb-fluid (declaim (inline node-block)) +(declaim (inline node-block)) (defun node-block (node) (ctran-block (node-prev node))) @@ -234,7 +239,7 @@ ;; the value is unused. (lvar nil :type (or lvar null))) -#-sb-fluid (declaim (inline node-dest)) +(declaim (inline node-dest)) (defun node-dest (node) (awhen (node-lvar node) (lvar-dest it))) @@ -740,9 +745,12 @@ (where-from :assumed :type (member :declared :assumed :defined-here :defined :defined-method)) ;; list of the REF nodes for this leaf (refs () :type list) - ;; true if there was ever a REF or SET node for this leaf. This may - ;; be true when REFS and SETS are null, since code can be deleted. - (ever-used nil :type boolean) + ;; For tracking whether to warn about unused variables: + ;; NIL if there was never a REF or SET. + ;; SET if there was a set but no REF. + ;; T if there was a REF. + ;; This may be non-nil when REFS and SETS are null, since code can be deleted. + (ever-used nil :type (member nil set t)) ;; is it declared dynamic-extent, or truly-dynamic-extent? (extent nil :type (member nil truly-dynamic-extent dynamic-extent indefinite-extent)) ;; some kind of info used by the back end @@ -762,20 +770,20 @@ (leaf-%source-name leaf)) ;;; The CONSTANT structure is used to represent known constant values. -;;; Since the same constant leaf may be shared between named and anonymous -;;; constants, %SOURCE-NAME is never used. +;;; When compiling to a file, named named and anonymous constants with the +;;; same value will not necessarily share the same leaf. (defstruct (constant (:constructor make-constant (value &optional (type (ctype-of value)) - &aux (%source-name '.anonymous.) + &aux (where-from :defined))) (:copier nil) (:include leaf)) ;; the value of the constant (value (missing-arg) :type t)) (defprinter (constant :identity t) - value) + value (%source-name :test (neq %source-name '.anonymous.))) ;;; The BASIC-VAR structure represents information common to all ;;; variables which don't correspond to known local functions. @@ -1249,6 +1257,7 @@ ;; For &REST arguments this may contain information about more context ;; the rest list comes from. (default nil :type t) + (default-p nil :type boolean) ;; the actual key for a &KEY argument. Note that in ANSI CL this is ;; not necessarily a keyword: (DEFUN FOO (&KEY ((BAR BAR))) ...). (key nil :type symbol)) @@ -1286,7 +1295,9 @@ ;; attributes must be set for the value-cell object to be created. explicit-value-cell ;; Do not propagate constraints for this var - no-constraints) + no-constraints + ;; Does it hold a constant that should't be destructively modified + constant) (defstruct (lambda-var (:include basic-var) (:copier nil)) (flags (lambda-var-attributes) @@ -1341,6 +1352,9 @@ `(lambda-var-attributep (lambda-var-flags ,var) explicit-value-cell)) (defmacro lambda-var-no-constraints (var) `(lambda-var-attributep (lambda-var-flags ,var) no-constraints)) +(defmacro lambda-var-constant (var) + `(lambda-var-attributep (lambda-var-flags ,var) constant)) + ;;;; basic node types @@ -1438,7 +1452,7 @@ ;; Untrusted type we have asserted for this combination. (type-validated-for-leaf nil) ;; some kind of information attached to this node by the back end - ;; or by CHECK-IMPORTANT-RESULT + ;; or by CHECK-IMPORTANT-RESULT, or by anything else that may need to. (info nil) (step-info nil) ;; A plist of inline expansions @@ -1627,6 +1641,5 @@ ;;;; Freeze some structure types to speed type testing. -#-sb-fluid (declaim (freeze-type node lexenv ctran lvar cblock component cleanup physenv tail-set nlx-info leaf)) diff -Nru sbcl-2.0.6/src/compiler/pack.lisp sbcl-2.1.1/src/compiler/pack.lisp --- sbcl-2.0.6/src/compiler/pack.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/pack.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1200,7 +1200,7 @@ ;;; the restriction, we pack a Load-TN and load the operand into it. ;;; If a load-tn has already been allocated, we can assume that the ;;; restriction is satisfied. -#-sb-fluid (declaim (inline check-operand-restrictions)) +(declaim (inline check-operand-restrictions)) (defun check-operand-restrictions (scs ops) (declare (list scs) (type (or tn-ref null) ops)) @@ -1582,7 +1582,7 @@ (walk-tn-refs (tn-reads tn)) (walk-tn-refs (tn-writes tn)) (if (eql path t) - sb-xc:most-positive-fixnum + most-positive-fixnum (length path))))) (declaim (type (member :iterative :greedy :adaptive) diff -Nru sbcl-2.0.6/src/compiler/parse-lambda-list.lisp sbcl-2.1.1/src/compiler/parse-lambda-list.lisp --- sbcl-2.0.6/src/compiler/parse-lambda-list.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/parse-lambda-list.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -17,7 +17,7 @@ ;; Return a bitmask representing the LIST of lambda list keywords. (defmacro lambda-list-keyword-mask (list) - (if (constantp list) + (if (cl:constantp list) ;; When invoked with a quoted constant, some flexibility ;; is allowed, in that the input may be a single symbol. (let ((val (#+sb-xc constant-form-value #-sb-xc eval list))) @@ -119,7 +119,7 @@ (char= (char name 0) #\&))))) (check-suspicious (kind form) (and (probably-ll-keyword-p form) - (member form sb-xc:lambda-list-keywords) + (member form lambda-list-keywords) (report-suspicious kind form))) (report-suspicious (kind what) (style-warn-once list "suspicious ~A ~S in lambda list: ~S." @@ -308,10 +308,13 @@ ;; (This is not a regression) (destructuring-bind (var &optional default sup-p) arg (if (and (consp var) (eq what-kind '&key)) - (destructuring-bind (keyword-name var) var - (unless (symbolp keyword-name) - (croak "keyword-name in ~S is not a symbol" arg)) - (need-bindable var description)) + (cond ((singleton-p (cdr var)) + (destructuring-bind (keyword-name var) var + (unless (symbolp keyword-name) + (croak "keyword-name in ~S is not a symbol" arg)) + (need-bindable var description))) + (t + (croak "invalid &KEY syntax: ~S" var))) (need-bindable var description)) ;; Inform the user about a possibly malformed ;; destructuring list (&OPTIONAL (A &OPTIONAL B)). @@ -413,7 +416,7 @@ (when (and (not silent) (vectorp parse)) ; is destructuring (let ((default (and (cdr arg-specifier) ; have an explicit default (cadr arg-specifier)))) - (when (and (constantp default) + (when (and (cl:constantp default) (not (ds-lambda-list-match-p (#+sb-xc constant-form-value #-sb-xc eval default) @@ -1056,7 +1059,7 @@ (pop plist) (unless (or (keywordp key) (and (symbolp key) - (constantp key) + (cl:constantp key) (eq key (symbol-value key)))) (signal 'compiler-macro-keyword-problem :argument key)))) @@ -1151,7 +1154,8 @@ (loop for (declare . declarations) in decls collect (list* declare (remove 'lambda-list declarations :key #'car))) - decls))))) + decls)))) + (variables (ds-lambda-list-variables parse nil))) ;; Signal a style warning for duplicate names, but disregard &AUX variables ;; because most folks agree that (LET* ((X (F)) (X (G X))) ..) makes sense ;; - some would even say that it is idiomatic - and &AUX bindings are just @@ -1163,7 +1167,7 @@ (when (memq (car tail) (cdr tail)) (style-warn-once lambda-list "variable ~S occurs more than once" (car tail)))) - (append whole env (ds-lambda-list-variables parse nil))) + (append whole env variables)) ;; Maybe kill docstring, but only under the cross-compiler. #+(and (not sb-doc) sb-xc-host) (setq docstring nil) ;; Note that we *NEVER* declare macro lambdas as a toplevel named lambda. @@ -1190,7 +1194,9 @@ `(:special-form . ,name) `(:macro ,name . ,kind))) '(destructuring-bind)) - ,new-ll (,accessor ,ll-whole) + ,new-ll (,accessor ,ll-whole) + #-sb-xc-host + (declare (constant-value ,@variables)) ,@decls ,@(if wrap-block `((block ,(fun-name-block-name name) ,@forms)) @@ -1273,3 +1279,18 @@ (unless allow-special (lose "special variable")))) (values name kind)))) + +;; This is a variant of destructuring-bind that provides the name +;; of the containing construct in generated error messages. +(macrolet (#+sb-xc-host ; Bootstrap NAMED-DS-BIND + (named-ds-bind (name lambda-list expression &body body) + (declare (ignore name)) + `(cl:destructuring-bind ,lambda-list ,expression ,@body))) + (defmacro named-ds-bind (name lambda-list expression &body body + &environment env) + (declare (ignore env)) ; could be policy-sensitive (but isn't) + `(binding* ,(sb-c::expand-ds-bind lambda-list expression t nil name + (and (eq (car name) :macro) + (eq (cddr name) 'deftype) + ''*)) + ,@body))) diff -Nru sbcl-2.0.6/src/compiler/physenvanal.lisp sbcl-2.1.1/src/compiler/physenvanal.lisp --- sbcl-2.0.6/src/compiler/physenvanal.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/physenvanal.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -484,8 +484,7 @@ (:restore-nsp (code `(%primitive set-nsp ,(ref-leaf node)))))))) (flet ((coalesce-unbinds (code) - code - #+(vop-named sb-c:unbind-n) + (if (vop-existsp :named sb-c:unbind-n) (loop with cleanup while code do (setf cleanup (pop code)) @@ -495,7 +494,8 @@ ,@(loop while (eq (caar code) '%special-unbind) collect (cadar code) do (pop code))) - cleanup)))) + cleanup)) + code))) (when (code) (aver (not (node-tail-p (block-last (car pred-blocks))))) (insert-cleanup-code diff -Nru sbcl-2.0.6/src/compiler/policies.lisp sbcl-2.1.1/src/compiler/policies.lisp --- sbcl-2.0.6/src/compiler/policies.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/policies.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -142,10 +142,10 @@ ("no" "no" "yes" "yes")) #+sb-safepoint -(define-optimization-quality inhibit-safepoints - 0 - ("no" "no" "yes" "yes") - "When disabled, the compiler will insert safepoints at strategic +(define-optimization-quality insert-safepoints + 1 + ("no" "yes" "yes" "yes") + "When enabled, the compiler will insert safepoints at strategic points (loop edges, function prologues) to ensure that potentially long-running code can be interrupted. diff -Nru sbcl-2.0.6/src/compiler/ppc/arith.lisp sbcl-2.1.1/src/compiler/ppc/arith.lisp --- sbcl-2.0.6/src/compiler/ppc/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -977,27 +977,21 @@ ;;;; 32-bit logical operations -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "shift-towards-start") - (:generator 1 - (inst rlwinm amount amount 0 27 31) - (inst slw r num amount))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "shift-towards-end") - (:generator 1 - (inst rlwinm amount amount 0 27 31) - (inst srw r num amount))) +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst rlwinm amount amount 0 27 31) + (inst ,operation r num amount))))) + (define shift-towards-start slw) + (define shift-towards-end srw)) ;;;; Bignum stuff. diff -Nru sbcl-2.0.6/src/compiler/ppc/array.lisp sbcl-2.1.1/src/compiler/ppc/array.lisp --- sbcl-2.0.6/src/compiler/ppc/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -33,8 +33,12 @@ (allocation nil ndescr other-pointer-lowtag header :temp-tn gc-temp :flag-tn pa-flag) - (inst addi ndescr rank (fixnumize (1- array-dimensions-offset))) - (inst slwi ndescr ndescr n-widetag-bits) + ;; Compute the encoded rank. See ENCODE-ARRAY-RANK. + (inst subi ndescr rank (fixnumize 1)) + ;; Exercise for the reader: these next 4 instructions can be + ;; replaced by just 2: one RLWINM and one RLWIMI + (inst andi. ndescr ndescr (fixnumize array-rank-mask)) + (inst slwi ndescr ndescr array-rank-byte-pos) (inst or ndescr ndescr type) (inst srwi ndescr ndescr n-fixnum-tag-bits) (storew ndescr header 0 other-pointer-lowtag)) @@ -52,17 +56,16 @@ (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) -(define-vop (array-rank-vop) +(define-vop () (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) (:generator 6 - (loadw temp x 0 other-pointer-lowtag) - (inst srawi temp temp n-widetag-bits) - (inst subi temp temp (1- array-dimensions-offset)) - (inst slwi res temp n-fixnum-tag-bits))) + (inst lbz res x (- 1 other-pointer-lowtag)) ; big-endian only + (inst addi res res 1) + (inst andi. res res array-rank-mask))) ;;;; Bounds checking routine. diff -Nru sbcl-2.0.6/src/compiler/ppc/cell.lisp sbcl-2.1.1/src/compiler/ppc/cell.lisp --- sbcl-2.0.6/src/compiler/ppc/cell.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc/cell.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -449,6 +449,15 @@ (:translate %instance-cas) (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types instance tagged-num * *)) +(define-vop (%raw-instance-cas/word %instance-cas) + (:args (object) + (index) + (old-value :scs (unsigned-reg)) + (new-value :scs (unsigned-reg))) + (:arg-types * tagged-num unsigned-num unsigned-num) + (:results (result :scs (unsigned-reg) :from :load)) + (:result-types unsigned-num) + (:translate %raw-instance-cas/word)) ;;;; Code object frobbing. diff -Nru sbcl-2.0.6/src/compiler/ppc/move.lisp sbcl-2.1.1/src/compiler/ppc/move.lisp --- sbcl-2.0.6/src/compiler/ppc/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -203,7 +203,7 @@ (inst addo. temp temp temp) ; set CR0 SO if any top three bits differ (inst slwi y x n-fixnum-tag-bits) ; assume fixnum (tagged ok, maybe lost some high bits) (inst bns done) - (load-constant vop (emit-constant (1+ sb-xc:most-positive-fixnum)) + (load-constant vop (emit-constant (1+ most-positive-fixnum)) y) DONE)) @@ -215,7 +215,7 @@ (inst addo. temp temp temp) ; set CR0 SO if any top three bits differ (inst slwi y x n-fixnum-tag-bits) ; assume fixnum (tagged ok, maybe lost some high bits) (inst bns done) - (load-constant vop (emit-constant (1- sb-xc:most-negative-fixnum)) + (load-constant vop (emit-constant (1- most-negative-fixnum)) y) DONE)) diff -Nru sbcl-2.0.6/src/compiler/ppc/system.lisp sbcl-2.1.1/src/compiler/ppc/system.lisp --- sbcl-2.0.6/src/compiler/ppc/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -48,6 +48,35 @@ DONE)) +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:policy :fast-safe) + (:conditional) + ;; "extra" info in conditional vops follows the 2 super-magical info args + (:info target not-p test-layout) + (:temporary (:scs (non-descriptor-reg)) this-id that-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) + (- instance-pointer-lowtag)))) + (inst lwz this-id x offset) + ;; Always prefer 'cmpwi' if compiling to memory. + ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those. + (cond ((or (typep test-id '(and (signed-byte 8) (not (eql 0)))) + (and (not (sb-c::producing-fasl-file)) + (typep test-id '(signed-byte 16)))) + (inst cmpwi this-id test-id)) + (t + (inst lwz that-id code-tn + (register-inline-constant `(:layout-id . ,test-layout) :word)) + (inst cmpw this-id that-id)))) + (inst b? (if not-p :ne :eq) target))) + (define-vop (%other-pointer-widetag) (:translate %other-pointer-widetag) (:policy :fast-safe) diff -Nru sbcl-2.0.6/src/compiler/ppc/vm.lisp sbcl-2.1.1/src/compiler/ppc/vm.lisp --- sbcl-2.0.6/src/compiler/ppc/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,8 @@ (in-package "SB-VM") +(defconstant-eqx +fixup-kinds+ #(:absolute :absolute64 :layout-id :b :ba :ha :l) #'equalp) + ;;; NUMBER-STACK-DISPLACEMENT ;;; ;;; The number of bytes reserved above the number stack pointer. These @@ -263,7 +265,7 @@ zero-sc-number) (null null-sc-number) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) (symbol diff -Nru sbcl-2.0.6/src/compiler/ppc64/arith.lisp sbcl-2.1.1/src/compiler/ppc64/arith.lisp --- sbcl-2.0.6/src/compiler/ppc64/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc64/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -834,32 +834,22 @@ ;;;; 64-bit logical operations -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:temporary (:sc unsigned-reg) temp) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "shift-towards-start") - (:generator 1 - (inst andi. temp amount #b111111) - (ecase *backend-byte-order* - (:big-endian (inst sld r num temp)) - (:little-endian (inst srd r num temp))))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "shift-towards-end") - (:generator 1 - (inst andi. temp amount #b111111) - (ecase *backend-byte-order* - (:big-endian (inst srd r num temp)) - (:little-endian (inst sld r num temp))))) +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:temporary (:sc unsigned-reg) temp) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst andi. temp amount #b111111) + (inst ,operation r num temp))))) + (define shift-towards-start #+big-endian sld #+little-endian srd) + (define shift-towards-end #+big-endian srd #+little-endian sld)) ;;;; Bignum stuff. diff -Nru sbcl-2.0.6/src/compiler/ppc64/array.lisp sbcl-2.1.1/src/compiler/ppc64/array.lisp --- sbcl-2.0.6/src/compiler/ppc64/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc64/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -35,8 +35,12 @@ (allocation nil ndescr other-pointer-lowtag header :temp-tn gc-temp :flag-tn pa-flag) - (inst addi ndescr rank (fixnumize (1- array-dimensions-offset))) - (inst slwi ndescr ndescr n-widetag-bits) + ;; Compute the encoded rank. See ENCODE-ARRAY-RANK. + (inst subi ndescr rank (fixnumize 1)) + ;; Exercise for the reader: these next 4 instructions can be + ;; replaced by just 2: one RLWINM and one RLWIMI + (inst andi. ndescr ndescr (fixnumize array-rank-mask)) + (inst slwi ndescr ndescr array-rank-byte-pos) (inst or ndescr ndescr type) (inst srwi ndescr ndescr n-fixnum-tag-bits) (storew ndescr header 0 other-pointer-lowtag)) @@ -54,17 +58,17 @@ (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) -(define-vop (array-rank-vop) +(define-vop () (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) (:generator 6 - (loadw temp x 0 other-pointer-lowtag) - (inst srawi temp temp n-widetag-bits) - (inst subi temp temp (1- array-dimensions-offset)) - (inst slwi res temp n-fixnum-tag-bits))) + (inst lbz res x #+little-endian (- 2 other-pointer-lowtag) + #+big-endian (- 5 other-pointer-lowtag)) + (inst addi res res 1) + (inst andi. res res array-rank-mask))) ;;;; Bounds checking routine. diff -Nru sbcl-2.0.6/src/compiler/ppc64/cell.lisp sbcl-2.1.1/src/compiler/ppc64/cell.lisp --- sbcl-2.0.6/src/compiler/ppc64/cell.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc64/cell.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -549,6 +549,15 @@ (:translate %instance-cas) (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types instance tagged-num * *)) +(define-vop (%raw-instance-cas/word %instance-cas) + (:args (object) + (index) + (old-value :scs (unsigned-reg)) + (new-value :scs (unsigned-reg))) + (:arg-types * tagged-num unsigned-num unsigned-num) + (:results (result :scs (unsigned-reg) :from :load)) + (:result-types unsigned-num) + (:translate %raw-instance-cas/word)) ;;;; Code object frobbing. diff -Nru sbcl-2.0.6/src/compiler/ppc64/insts.lisp sbcl-2.1.1/src/compiler/ppc64/insts.lisp --- sbcl-2.0.6/src/compiler/ppc64/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc64/insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -625,7 +625,8 @@ (emit-d-form-inst segment opcode rt ra (+ (component-header-length) (segment-header-skew segment) - (label-position si)))))) + (label-position si) + (- sb-vm::code-tn-lowtag)))))) (t (when (typep si 'fixup) (note-fixup segment :l si) @@ -2369,16 +2370,60 @@ (defun sort-inline-constants (constants) (stable-sort constants #'> :key (lambda (x) (align-of (car x))))) +(sb-assem::%def-inst-encoder + '.layout-id + (lambda (segment layout) + (sb-c:note-fixup segment :layout-id (sb-c:make-fixup layout :layout-id)) + (sb-assem::%emit-skip segment 4))) + (defun emit-inline-constant (section constant label) (let ((size (align-of constant))) (emit section `(.align ,(integer-length (1- size))) label - (if (eq (car constant) :jump-table) - `(.lispword ,@(coerce (cdr constant) 'list)) - (let* ((val (cdr constant)) - (bytes (loop repeat size - collect (prog1 (ldb (byte 8 0) val) - (setf val (ash val -8)))))) - #+big-endian (setq bytes (nreverse bytes)) - `(.byte ,@bytes)))))) + (cond ((eq (car constant) :jump-table) + `(.lispword ,@(coerce (cdr constant) 'list))) + ((typep (cdr constant) '(cons (eql :layout-id))) + `(.layout-id ,(cddr constant))) + (t + (let* ((val (cdr constant)) + (bytes (loop repeat size + collect (prog1 (ldb (byte 8 0) val) + (setf val (ash val -8)))))) + #+big-endian (setq bytes (nreverse bytes)) + `(.byte ,@bytes))))))) + +(defun sb-vm:fixup-code-object (code offset value kind flavor) + (declare (type index offset) (ignore flavor)) + (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) + (error "Unaligned instruction? offset=#x~X." offset)) + (let ((sap (code-instructions code))) + (ecase kind + (:absolute + ;; There is an implicit addend currently stored in the fixup location. + (incf (sap-ref-32 sap offset) value)) + (:absolute64 + (incf (sap-ref-64 sap offset) value)) + (:layout-id + (aver (zerop (sap-ref-32 sap offset))) + (setf (signed-sap-ref-32 sap offset) (the layout-id value))) + (:b + (error "Can't deal with CALL fixups, yet.")) + (:ba + (setf (ldb (byte 24 2) (sap-ref-32 sap offset)) (ash value -2))) + (:ha + (let* ((h (ldb (byte 16 16) value)) + (l (ldb (byte 16 0) value))) + ; Compensate for possible sign-extension when the low half + ; is added to the high. We could avoid this by ORI-ing + ; the low half in 32-bit absolute loads, but it'd be + ; nice to be able to do: + ; lis rX,foo@ha + ; lwz rY,foo@l(rX) + ; and lwz/stw and friends all use a signed 16-bit offset. + (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) + (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) + (:l + (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) + (ldb (byte 16 0) value))))) + nil) diff -Nru sbcl-2.0.6/src/compiler/ppc64/move.lisp sbcl-2.1.1/src/compiler/ppc64/move.lisp --- sbcl-2.0.6/src/compiler/ppc64/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc64/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -208,7 +208,7 @@ (2 '((inst addo x arg arg) (inst addo. y x x))) (3 '((inst addo x arg arg) (inst addo x x x) (inst addo. y x x)))) (inst bns done) ; branch if no summary overflow - (load-constant vop (emit-constant (1+ sb-xc:most-positive-fixnum)) y) + (load-constant vop (emit-constant (1+ most-positive-fixnum)) y) DONE)))) (define-move-from-fixnum+1)) @@ -221,7 +221,7 @@ (2 '((inst addo x arg arg) (inst addo. y x x))) (3 '((inst addo x arg arg) (inst addo x x x) (inst addo. y x x)))) (inst bns done) ; branch if no summary overflow - (load-constant vop (emit-constant (1- sb-xc:most-negative-fixnum)) y) + (load-constant vop (emit-constant (1- most-negative-fixnum)) y) DONE)))) (define-move-from-fixnum-1)) diff -Nru sbcl-2.0.6/src/compiler/ppc64/system.lisp sbcl-2.1.1/src/compiler/ppc64/system.lisp --- sbcl-2.0.6/src/compiler/ppc64/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc64/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -63,6 +63,35 @@ instance-pointer-lowtag)) (inst lwax res object temp))) +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:policy :fast-safe) + (:conditional) + ;; "extra" info in conditional vops follows the 2 super-magical info args + (:info target not-p test-layout) + (:temporary (:scs (non-descriptor-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) + (- instance-pointer-lowtag)))) + (inst lwa this-id x offset) + ;; Always prefer 'cmpwi' if compiling to memory. + ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those. + (cond ((or (typep test-id '(and (signed-byte 8) (not (eql 0)))) + (and (not (sb-c::producing-fasl-file)) + (typep test-id '(signed-byte 16)))) + (inst cmpwi this-id test-id)) + (t + (inst lwa temp-reg-tn code-tn + (register-inline-constant `(:layout-id . ,test-layout) :word)) + (inst cmpw this-id temp-reg-tn)))) + (inst b? (if not-p :ne :eq) target))) + (define-vop (%other-pointer-widetag) (:translate %other-pointer-widetag) (:policy :fast-safe) diff -Nru sbcl-2.0.6/src/compiler/ppc64/vm.lisp sbcl-2.1.1/src/compiler/ppc64/vm.lisp --- sbcl-2.0.6/src/compiler/ppc64/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/ppc64/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,8 @@ (in-package "SB-VM") +(defconstant-eqx +fixup-kinds+ #(:absolute :absolute64 :layout-id :b :ba :ha :l) #'equalp) + ;;; NUMBER-STACK-DISPLACEMENT ;;; ;;; The number of bytes reserved above the number stack pointer. These @@ -251,7 +253,7 @@ (typecase value (null null-sc-number) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) (symbol diff -Nru sbcl-2.0.6/src/compiler/proclaim.lisp sbcl-2.1.1/src/compiler/proclaim.lisp --- sbcl-2.0.6/src/compiler/proclaim.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/proclaim.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -339,6 +339,7 @@ (ftype #'proclaim-ftype)) ctype type :declared))) (push raw-form *queued-proclaims*))) + #-sb-fluid (freeze-type (map-args #'process-freeze-type-declaration)) ((start-block end-block) @@ -371,7 +372,7 @@ ((disable-package-locks enable-package-locks) (setq *disabled-package-locks* (process-package-lock-decl form *disabled-package-locks*))) - ((inline notinline maybe-inline) + ((#-sb-fluid inline notinline #-sb-fluid maybe-inline) (map-args #'process-inline-declaration kind)) (deprecated (destructuring-bind (state since &rest things) args diff -Nru sbcl-2.0.6/src/compiler/represent.lisp sbcl-2.1.1/src/compiler/represent.lisp --- sbcl-2.0.6/src/compiler/represent.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/represent.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -295,7 +295,7 @@ t) - (let ((min sb-xc:most-positive-fixnum) + (let ((min most-positive-fixnum) (min-scn nil) (unique nil)) (dolist (scn scs) @@ -593,13 +593,15 @@ (let ((type (tn-ref-type x-tn-ref))) (cond ((not type) nil) + ((csubtypep type (specifier-type 'fixnum)) + (template-or-lose 'sb-vm::move-from-word/fixnum)) ((csubtypep type - (specifier-type `(integer ,sb-xc:most-negative-fixnum - ,(1+ sb-xc:most-positive-fixnum)))) + (specifier-type `(integer ,most-negative-fixnum + ,(1+ most-positive-fixnum)))) (template-or-lose 'sb-vm::move-from-fixnum+1)) ((csubtypep type - (specifier-type `(integer ,(1- sb-xc:most-negative-fixnum) - ,sb-xc:most-positive-fixnum))) + (specifier-type `(integer ,(1- most-negative-fixnum) + ,most-positive-fixnum))) (template-or-lose 'sb-vm::move-from-fixnum-1)))))) (defun coerce-from-constant (x-tn-ref y) @@ -737,7 +739,7 @@ ;;; If TN is in a number stack SC, make all the right annotations. ;;; Note that this should be called after TN has been referenced, ;;; since it must iterate over the referencing environments. -#-sb-fluid (declaim (inline note-if-number-stack)) +(declaim (inline note-if-number-stack)) (defun note-if-number-stack (tn 2comp restricted) (declare (type tn tn) (type ir2-component 2comp)) (when (if restricted diff -Nru sbcl-2.0.6/src/compiler/riscv/arith.lisp sbcl-2.1.1/src/compiler/riscv/arith.lisp --- sbcl-2.0.6/src/compiler/riscv/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -532,26 +532,19 @@ ;;;; Logical operations -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (inst srl r num amount))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (inst sll r num amount))) - +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 (inst ,operation r num amount))))) + (define shift-towards-start srl) + (define shift-towards-end sll)) ;;;; Modular arithmetic (defmacro define-mod-binop ((name prototype) function) diff -Nru sbcl-2.0.6/src/compiler/riscv/array.lisp sbcl-2.1.1/src/compiler/riscv/array.lisp --- sbcl-2.0.6/src/compiler/riscv/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -31,34 +31,15 @@ (allocation nil ndescr other-pointer-lowtag header :flag-tn pa-flag) ;; Now that we have the space allocated, compute the header ;; value. - (inst slli ndescr rank (- n-widetag-bits n-fixnum-tag-bits)) - (inst addi ndescr ndescr (ash (1- array-dimensions-offset) n-widetag-bits)) - (inst srli pa-flag type n-fixnum-tag-bits) - (inst or ndescr ndescr pa-flag) + ;; Compute the encoded rank. See ENCODE-ARRAY-RANK. + (inst subi ndescr rank (fixnumize 1)) + (inst andi ndescr ndescr (fixnumize array-rank-mask)) + (inst slli ndescr ndescr array-rank-byte-pos) + (inst or ndescr ndescr type) + (inst srli ndescr ndescr n-fixnum-tag-bits) ;; And store the header value. (storew ndescr header 0 other-pointer-lowtag)) (move result header))) - -(define-vop (make-array-header/c) - (:translate make-array-header) - (:policy :fast-safe) - (:arg-types (:constant t) (:constant t)) - (:info type rank) - (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) - (:temporary (:sc non-descriptor-reg) pa-flag) - (:results (result :scs (descriptor-reg))) - (:generator 4 - (let* ((header-size (+ rank (1- array-dimensions-offset))) - (bytes (logandc2 (+ (* (1+ header-size) n-word-bytes) - lowtag-mask) - lowtag-mask)) - (header-bits (logior (ash header-size n-widetag-bits) type))) - (pseudo-atomic (pa-flag) - (allocation nil bytes other-pointer-lowtag header :flag-tn pa-flag) - (inst li pa-flag header-bits) - (storew pa-flag header 0 other-pointer-lowtag))) - (move result header))) - ;;;; Additional accessors and setters for the array header. (define-full-reffer %array-dimension * @@ -69,17 +50,16 @@ array-dimensions-offset other-pointer-lowtag (any-reg) positive-fixnum sb-kernel:%set-array-dimension) -(define-vop (array-rank-vop) - (:translate sb-kernel:%array-rank) +(define-vop () + (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) (:generator 6 - (loadw temp x 0 other-pointer-lowtag) - (inst srai temp temp n-widetag-bits) - (inst subi temp temp (1- array-dimensions-offset)) - (inst slli res temp n-fixnum-tag-bits))) + (inst lbu res x (- 2 other-pointer-lowtag)) + (inst addi res res 1) + (inst andi res res array-rank-mask))) ;;;; Bounds checking routine. (define-vop (check-bound) diff -Nru sbcl-2.0.6/src/compiler/riscv/c-call.lisp sbcl-2.1.1/src/compiler/riscv/c-call.lisp --- sbcl-2.0.6/src/compiler/riscv/c-call.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/c-call.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -13,25 +13,24 @@ (defconstant-eqx c-saved-registers - (list* lip-offset - 8 9 (loop for i from 18 to 27 collect i)) + '#.`(,lip-offset 8 9 ,@(loop for i from 18 to 27 collect i)) #'equal) (defconstant-eqx c-unsaved-registers - (append (list lip-offset) - (loop for i from 5 to 7 collect i) - (loop for i from 10 to 17 collect i) - (loop for i from 28 to 31 collect i)) + '#.`(,lip-offset + ,@(loop for i from 5 to 7 collect i) + ,@(loop for i from 10 to 17 collect i) + ,@(loop for i from 28 to 31 collect i)) #'equal) (defconstant-eqx c-saved-float-registers - (list* 8 9 (loop for i from 18 to 27 collect i)) + '#.`(8 9 ,@(loop for i from 18 to 27 collect i)) #'equal) (defconstant-eqx c-unsaved-float-registers - (append (loop for i from 0 to 7 collect i) - (loop for i from 10 to 17 collect i) - (loop for i from 28 to 31 collect i)) + '#.`(,@(loop for i from 0 to 7 collect i) + ,@(loop for i from 10 to 17 collect i) + ,@(loop for i from 28 to 31 collect i)) #'equal) (defun make-reg-tn (offset &optional (sc 'any-reg)) diff -Nru sbcl-2.0.6/src/compiler/riscv/insts.lisp sbcl-2.1.1/src/compiler/riscv/insts.lisp --- sbcl-2.0.6/src/compiler/riscv/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -911,3 +911,37 @@ (define-instruction lra-header-word (segment) (:emitter (emit-header-data segment return-pc-widetag))) + +(define-instruction-macro load-layout-id (reg layout) + `(progn (inst .layout-id-fixup ,layout) + (inst lui ,reg #xfffff) + (inst addi ,reg ,reg -1))) + +(define-instruction .layout-id-fixup (segment layout) + (:emitter (sb-c:note-fixup segment :u+i-type (sb-c:make-fixup layout :layout-id)))) + +(defun sb-vm:fixup-code-object (code offset value kind flavor) + (declare (type index offset)) + (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) + (error "Unaligned instruction? offset=#x~X." offset)) + #+64-bit + (unless (typep value 'u+i-immediate) + (error "Tried to fixup with ~a." value)) + (let ((sap (code-instructions code))) + (multiple-value-bind (u i) (u-and-i-inst-immediate value) + (ecase kind + (:absolute + (setf (sap-ref-32 sap offset) value)) + (:u-type + (setf (ldb (byte 20 12) (sap-ref-32 sap offset)) u)) + (:i-type + (setf (ldb (byte 12 20) (sap-ref-32 sap offset)) i)) + (:u+i-type + (sb-vm:fixup-code-object code offset u :u-type flavor) + (sb-vm:fixup-code-object code (+ offset 4) i :i-type flavor)) + (:s-type + (setf (ldb (byte 5 7) (sap-ref-32 sap offset)) + (ldb (byte 5 0) i)) + (setf (ldb (byte 7 25) (sap-ref-32 sap offset)) + (ldb (byte 7 5) i)))))) + nil) diff -Nru sbcl-2.0.6/src/compiler/riscv/move.lisp sbcl-2.1.1/src/compiler/riscv/move.lisp --- sbcl-2.0.6/src/compiler/riscv/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -232,10 +232,10 @@ DONE)) (define-vop (move-from-fixnum+1 move-from-fixnum+/-1) - (:variant (1+ sb-xc:most-positive-fixnum))) + (:variant (1+ most-positive-fixnum))) (define-vop (move-from-fixnum-1 move-from-fixnum+/-1) - (:variant (1- sb-xc:most-negative-fixnum))) + (:variant (1- most-negative-fixnum))) ;;; Check for fixnum, and possibly allocate one or two word bignum ;;; result. Use a worst-case cost to make sure people know they may diff -Nru sbcl-2.0.6/src/compiler/riscv/parms.lisp sbcl-2.1.1/src/compiler/riscv/parms.lisp --- sbcl-2.0.6/src/compiler/riscv/parms.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/parms.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -144,14 +144,14 @@ ;;; can be loaded directly out of them by indirecting relative to NIL. ;;; (defconstant-eqx +static-symbols+ - `#(,@+common-static-symbols+ - *allocation-pointer* - #-sb-thread - ,@'(*binding-stack-pointer* - ;; interrupt handling - *pseudo-atomic-atomic* - *pseudo-atomic-interrupted*) - ,@*runtime-asm-routines*) + #.`#(,@+common-static-symbols+ + *allocation-pointer* + #-sb-thread + ,@'(*binding-stack-pointer* + ;; interrupt handling + *pseudo-atomic-atomic* + *pseudo-atomic-interrupted*) + ,@*runtime-asm-routines*) #'equalp) (defconstant-eqx +static-fdefns+ diff -Nru sbcl-2.0.6/src/compiler/riscv/system.lisp sbcl-2.1.1/src/compiler/riscv/system.lisp --- sbcl-2.0.6/src/compiler/riscv/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -53,6 +53,28 @@ (load-type result lip) DONE)) +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:policy :fast-safe) + (:conditional) + ;; "extra" info in conditional vops follows the 2 super-magical info args + (:info target not-p test-layout) + (:temporary (:sc unsigned-reg) this-id temp) + (:generator 4 + (let ((offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0) + instance-slots-offset) + word-shift) + (ash (- (layout-depthoid test-layout) 2) 2) + (- instance-pointer-lowtag)))) + (inst lw this-id x offset) + (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0)))) + (not (sb-c::producing-fasl-file))) + (inst li temp (layout-id test-layout)) + (inst load-layout-id temp test-layout)) + (inst* (if not-p 'bne 'beq) this-id temp target)))) + #+64-bit (define-vop (layout-depthoid) (:translate layout-depthoid) diff -Nru sbcl-2.0.6/src/compiler/riscv/target-insts.lisp sbcl-2.1.1/src/compiler/riscv/target-insts.lisp --- sbcl-2.0.6/src/compiler/riscv/target-insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/target-insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -33,16 +33,15 @@ function addresses and register values.") (defconstant-eqx lisp-reg-symbols - (map 'vector - (lambda (name) - (and name (make-symbol (concatenate 'string "$" name)))) - sb-vm::*register-names*) + #.(map 'vector + (lambda (name) + (and name (make-symbol (concatenate 'string "$" name)))) + sb-vm::*register-names*) #'equalp) (defconstant-eqx riscv-reg-symbols - (coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "x~d" n))) - 'vector) + #.(coerce (loop for n from 0 to 31 collect (make-symbol (format nil "x~d" n))) + 'vector) #'equalp) (defun print-reg (value stream dstate) @@ -75,9 +74,8 @@ (coerce-signed u-imm 12)))) (defconstant-eqx float-reg-symbols - (coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "ft~d" n))) - 'vector) + #.(coerce (loop for n from 0 to 31 collect (make-symbol (format nil "ft~d" n))) + 'vector) #'equalp) (defun print-fp-reg (value stream dstate) diff -Nru sbcl-2.0.6/src/compiler/riscv/vm.lisp sbcl-2.1.1/src/compiler/riscv/vm.lisp --- sbcl-2.0.6/src/compiler/riscv/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/riscv/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -10,7 +10,22 @@ ;;;; files for more information. (in-package "SB-VM") - + +(defconstant-eqx +fixup-kinds+ #(:absolute :i-type :s-type :u-type :u+i-type) #'equalp) + +(defun u-and-i-inst-immediate (value) + (let ((hi (ash (+ value (expt 2 11)) -12))) + (values hi (- value (ash hi 12))))) + +(def!type short-immediate () `(signed-byte 12)) +(def!type short-immediate-fixnum () `(signed-byte ,(- 12 n-fixnum-tag-bits))) + +(deftype u+i-immediate () + #-64-bit `(or (signed-byte 32) (unsigned-byte 32)) + #+64-bit `(or (integer #x-80000800 #x7ffff7ff) + (integer ,(+ (ash 1 64) #x-80000800) + ,(1- (ash 1 64))))) + (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *register-names* (make-array 32 :initial-element nil))) @@ -206,7 +221,7 @@ (typecase value (null (values descriptor-reg-sc-number null-offset)) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) (symbol diff -Nru sbcl-2.0.6/src/compiler/saptran.lisp sbcl-2.1.1/src/compiler/saptran.lisp --- sbcl-2.0.6/src/compiler/saptran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/saptran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -13,7 +13,6 @@ ;;;; DEFKNOWNs -#+linkage-table (deftransform foreign-symbol-address ((symbol &optional datap) ((constant-arg simple-string) &optional (constant-arg boolean))) @@ -23,11 +22,6 @@ (deftransform foreign-symbol-sap ((symbol &optional datap) (simple-string &optional boolean)) - #-linkage-table - (if (null datap) - (give-up-ir1-transform) - `(foreign-symbol-sap symbol)) - #+linkage-table (if (and (constant-lvar-p symbol) (constant-lvar-p datap)) (if (lvar-value datap) `(foreign-symbol-dataref-sap symbol) diff -Nru sbcl-2.0.6/src/compiler/seqtran.lisp sbcl-2.1.1/src/compiler/seqtran.lisp --- sbcl-2.0.6/src/compiler/seqtran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/seqtran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -61,7 +61,8 @@ arglists `(,n-first ,@(rest arglists)))) (let ((v (gensym))) - (do-clauses `(,v ,a (cdr ,v))) + (do-clauses `(,v (the* (list :use-annotations t :source-form ,a) ,a) + (cdr ,v))) (tests `(endp ,v)) (args-to-fn (if take-car `(car ,v) v)))) @@ -288,9 +289,12 @@ (let* ((all-seqs (cons seq seqs)) (seq-args (make-gensym-list (length all-seqs)))) `(lambda (result-type fun ,@seq-args) - (map-into (make-sequence result-type - (min ,@(loop for arg in seq-args - collect `(length ,arg)))) + (map-into (locally + #-sb-xc-host + (declare (muffle-conditions array-initial-element-mismatch)) + (make-sequence result-type + (min ,@(loop for arg in seq-args + collect `(length ,arg))))) fun ,@seq-args)))) (t (let* ((all-seqs (cons seq seqs)) @@ -1183,7 +1187,7 @@ (j (+ ,dst-offset ,length) (1- j))) ((<= i ,src-offset)) (declare (optimize (insert-array-bounds-checks 0)) - (type (integer 0 #.sb-xc:array-dimension-limit) j i)) + (type (integer 0 #.array-dimension-limit) j i)) (setf (aref ,dst (1- j)) (aref ,src (1- i)))))) ;;; MAKE-SEQUENCE, SUBSEQ, COPY-SEQ @@ -1252,8 +1256,9 @@ ;; As with MAKE-ARRAY, this is merely undefined ;; behavior, not an error. (compiler-style-warn - "The default initial element ~S is not a ~S." - default-initial-element elt-type)))) + 'initial-element-mismatch-style-warning + :format-control "The default initial element ~S is not a ~S." + :format-arguments (list default-initial-element elt-type))))) ;; In would be possible in some cases, ;; like :INITIAL-ELEMENT (IF X #\x #\y) in a call ;; to MAKE-SEQUENCE '(VECTOR (MEMBER #\A #\B)) @@ -1263,10 +1268,10 @@ (not (ctypep (lvar-value initial-element) elt-ctype))) ;; MAKE-ARRAY considers this a warning, not an error. - (compiler-warn "~S ~S is not a ~S" - :initial-element - (lvar-value initial-element) - elt-type))))) + (compiler-warn 'array-initial-element-mismatch + :format-control "~S ~S is not a ~S" + :format-arguments + (list :initial-element (lvar-value initial-element) elt-type)))))) (give-up-ir1-transform))))))) (deftransform subseq ((seq start &optional end) @@ -1334,7 +1339,8 @@ (t (give-up-ir1-transform)))) (pattern-end (cond ((constant-lvar-p end1) - (lvar-value end1)) + (or (lvar-value end1) + (length pattern))) ((not end1) (length pattern)) (t @@ -1457,7 +1463,7 @@ (and (constant-lvar-p from-end) (not (lvar-value from-end))))) (min-result (or constant-start2 0)) - (max-result (or constant-end2 (1- sb-xc:array-dimension-limit))) + (max-result (or constant-end2 (1- array-dimension-limit))) (max2 (sequence-lvar-dimensions sequence2)) (max-result (if (integerp max2) (min max-result max2) @@ -1493,7 +1499,7 @@ (constant-end (and (constant-lvar-p end) (lvar-value end))) (min-result (or constant-start 0)) - (max-result (or constant-end (1- sb-xc:array-dimension-limit))) + (max-result (or constant-end (1- array-dimension-limit))) (max (sequence-lvar-dimensions sequence)) (max-result (if (integerp max) (min max-result max) @@ -2139,8 +2145,7 @@ (if (eq '* (upgraded-element-type-specifier sequence)) (let ((form `(sb-impl::string-dispatch ((simple-array character (*)) - (simple-array base-char (*)) - (simple-array nil (*))) + (simple-array base-char (*))) sequence (%find-position item sequence from-end start end key test)))) (if (csubtypep (lvar-type sequence) (specifier-type 'simple-string)) @@ -2188,6 +2193,8 @@ key test test-not) (t (or list vector) &rest t)) (when (and (constant-lvar-p sequence) + (or (proper-sequence-p (lvar-value sequence)) + (give-up-ir1-transform)) (zerop (length (lvar-value sequence)))) (if (and test test-not) ;; even though one kwd arg could legit be NIL, it's not interesting. @@ -2390,6 +2397,12 @@ ;;; (partially) constant-fold backq-* functions, or convert to their ;;; plain CL equivalent (now that they're not needed for pprinting). +;;; There's too much ambiguity around semantics of backquoted expressions +;;; as pertains to constant-ness, and on top of that, how "folding" affects +;;; whether any of the elements need a load-time-value of a global +;;; defconstant that is not trivially dumpable. +;;; Refer to the test case in backq-const-fold.impure-cload. + ;; Pop constant values from the end, list/list* them if any, and link ;; the remainder with list* at runtime. (defun transform-backq-list-or-list* (function values) @@ -2420,6 +2433,28 @@ (deftransform sb-impl::|List*| ((&rest elts)) (transform-backq-list-or-list* 'list* elts)) +(deftransform sb-impl::|Vector| ((&rest elts)) + (let ((gensyms (make-gensym-list (length elts))) + constants) + ;; There's not much that can be done with semi-constant vectors- + ;; either we're going to call VECTOR at compile-time or runtime. + ;; There's little point to building up intermediate lists in the partially + ;; constant case. There are ways to expand using MULTIPLE-VALUE-CALL that + ;; might avoid consing intermediate lists if ,@ is involved + ;; though I doubt it would provide benefit to many real-world scenarios. + (dolist (elt elts) + (cond ((constant-lvar-p elt) + (push (lvar-value elt) constants)) + (t + (setq constants :fail) + (return)))) + `(lambda ,gensyms + ,@(cond ((listp constants) + `((declare (ignore ,@gensyms)) + ,(apply 'vector (nreverse constants)))) + (t + `((vector ,@gensyms))))))) + ;; Merge adjacent constant values (deftransform sb-impl::|Append| ((&rest elts)) (let ((gensyms (make-gensym-list (length elts))) diff -Nru sbcl-2.0.6/src/compiler/sparc/arith.lisp sbcl-2.1.1/src/compiler/sparc/arith.lisp --- sbcl-2.0.6/src/compiler/sparc/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sparc/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -769,25 +769,19 @@ ;;;; 32-bit logical operations -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "shift-towards-start") - (:generator 1 - (inst sll r num amount))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "shift-towards-end") - (:generator 1 - (inst srl r num amount))) +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 (inst ,operation r num amount))))) + (define shift-towards-start sll) + (define shift-towards-end srl)) ;;;; Bignum stuff. (define-vop (bignum-length get-header-data) diff -Nru sbcl-2.0.6/src/compiler/sparc/array.lisp sbcl-2.1.1/src/compiler/sparc/array.lisp --- sbcl-2.0.6/src/compiler/sparc/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sparc/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -28,8 +28,10 @@ lowtag-mask)) (inst andn ndescr lowtag-mask) (allocation nil ndescr other-pointer-lowtag header :temp-tn gencgc-temp) - (inst add ndescr rank (fixnumize (1- array-dimensions-offset))) - (inst sll ndescr ndescr n-widetag-bits) + ;; Compute the encoded rank. See ENCODE-ARRAY-RANK. + (inst sub ndescr rank (fixnumize 1)) + (inst and ndescr ndescr (fixnumize array-rank-mask)) + (inst sll ndescr ndescr array-rank-byte-pos) (inst or ndescr ndescr type) ;; Remove the extraneous fixnum tag bits because TYPE and RANK ;; were fixnums @@ -48,17 +50,16 @@ (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) -(define-vop (array-rank-vop) +(define-vop () (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) (:generator 6 - (loadw temp x 0 other-pointer-lowtag) - (inst sra temp n-widetag-bits) - (inst sub temp (1- array-dimensions-offset)) - (inst sll res temp n-fixnum-tag-bits))) + (inst ldub res x (- 1 other-pointer-lowtag)) ; big-endian only + (inst add res res 1) + (inst and res res array-rank-mask))) ;;;; Bounds checking routine. (define-vop (check-bound) diff -Nru sbcl-2.0.6/src/compiler/sparc/insts.lisp sbcl-2.1.1/src/compiler/sparc/insts.lisp --- sbcl-2.0.6/src/compiler/sparc/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sparc/insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -200,8 +200,6 @@ (define-arg-type branch-fp-condition :printer (coerce branch-fp-conditions 'vector)) -(define-arg-type call-fixup :use-label t) - (deftype fp-branch-condition () `(member ,@branch-fp-conditions)) @@ -247,7 +245,7 @@ #'equalp) (defconstant-eqx integer-cond-reg-name-vec - (coerce integer-condition-registers 'vector) + #.(coerce integer-condition-registers 'vector) #'equalp) (deftype integer-condition-register () @@ -310,7 +308,7 @@ #'equalp) (defconstant-eqx fp-cond-reg-name-vec - (coerce fp-condition-registers 'vector) + #.(coerce fp-condition-registers 'vector) #'equalp) (defparameter fp-condition-reg-symbols @@ -487,7 +485,7 @@ #'equalp) (defconstant-eqx cond-move-cond-reg-name-vec - (coerce cond-move-condition-registers 'vector) + #.(coerce cond-move-condition-registers 'vector) #'equalp) (deftype cond-move-condition-register () @@ -1940,3 +1938,38 @@ (define-cond-fp-move-integer fmovrs #b0101) (define-cond-fp-move-integer fmovrd #b0110 :extended t) (define-cond-fp-move-integer fmovrq #b0111 :extended t)) + +(define-instruction-macro load-layout-id (reg layout) + `(without-scheduling () + (inst .layout-id-fixup ,layout) + (inst sethi ,reg 0) + (inst add ,reg #x3ff))) + +;;; The architectures which use the scheduler get angry if DEFINE-INSTRUCTION +;;; lacks the read/write dependency specifications. +;;; But this isn't a real instruction, it's just marks where to fixup. +(sb-assem::%def-inst-encoder + '.layout-id-fixup + (lambda (segment layout) + (sb-c:note-fixup segment :sethi+add (sb-c:make-fixup layout :layout-id)))) + +(defun sb-vm:fixup-code-object (code offset value kind flavor) + (declare (type index offset)) + (unless (zerop (rem offset sb-assem:+inst-alignment-bytes+)) + (error "Unaligned instruction? offset=#x~X." offset)) + (let ((sap (code-instructions code))) + (ecase kind + (:call + (error "Can't deal with CALL fixups, yet.")) + (:sethi + (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) + (ldb (byte 22 10) value))) + (:add + (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) + (ldb (byte 10 0) value))) + (:sethi+add + (sb-vm:fixup-code-object code offset value :sethi flavor) + (sb-vm:fixup-code-object code (+ offset 4) value :add flavor)) + (:absolute + (setf (sap-ref-32 sap offset) value)))) + nil) diff -Nru sbcl-2.0.6/src/compiler/sparc/macros.lisp sbcl-2.1.1/src/compiler/sparc/macros.lisp --- sbcl-2.0.6/src/compiler/sparc/macros.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sparc/macros.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -227,8 +227,6 @@ ;; the branch delay slot to write back the free-pointer ;; (on overflow restore it the trap handler to a good value), ;; and fold the lowtag addition into the size subtraction. - ;; (Possibly not ok for the sprof_alloc_region, - ;; but sb-sprof didn't work on sparc prior to this change) (storew result-tn null-tn 0 (- nil-value boxed-region)) ;; Compute the base pointer and add lowtag. (cond ((integerp size) diff -Nru sbcl-2.0.6/src/compiler/sparc/move.lisp sbcl-2.1.1/src/compiler/sparc/move.lisp --- sbcl-2.0.6/src/compiler/sparc/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sparc/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -241,7 +241,7 @@ (inst b :eq done) (inst sll y x n-fixnum-tag-bits) - (load-constant vop (emit-constant (1+ sb-xc:most-positive-fixnum)) + (load-constant vop (emit-constant (1+ most-positive-fixnum)) y) (inst b done) (inst nop) @@ -259,7 +259,7 @@ (inst b :eq done) (inst sll y x n-fixnum-tag-bits) - (load-constant vop (emit-constant (1- sb-xc:most-negative-fixnum)) + (load-constant vop (emit-constant (1- most-negative-fixnum)) y) (inst b done) (inst nop) diff -Nru sbcl-2.0.6/src/compiler/sparc/system.lisp sbcl-2.1.1/src/compiler/sparc/system.lisp --- sbcl-2.0.6/src/compiler/sparc/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sparc/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -49,6 +49,30 @@ DONE)) +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:policy :fast-safe) + (:conditional) + ;; "extra" info in conditional vops follows the 2 super-magical info args + (:info target not-p test-layout) + (:temporary (:sc unsigned-reg) this-id temp) + (:generator 4 + (let ((offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0) + instance-slots-offset) + word-shift) + (ash (- (layout-depthoid test-layout) 2) 2) + (- instance-pointer-lowtag)))) + (inst ld this-id x offset) + (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0)))) + (not (sb-c::producing-fasl-file))) + (inst li temp (layout-id test-layout)) + (inst load-layout-id temp test-layout)) + (inst cmp this-id temp) + (inst b (if not-p :ne :eq) target) + (inst nop)))) + (define-vop (%other-pointer-widetag) (:translate %other-pointer-widetag) (:policy :fast-safe) diff -Nru sbcl-2.0.6/src/compiler/sparc/vm.lisp sbcl-2.1.1/src/compiler/sparc/vm.lisp --- sbcl-2.0.6/src/compiler/sparc/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sparc/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,8 @@ (in-package "SB-VM") +(defconstant-eqx +fixup-kinds+ #(:call :sethi :add :absolute :sethi+add) #'equalp) + ;;;; Additional constants ;;; NUMBER-STACK-DISPLACEMENT @@ -294,7 +296,7 @@ zero-sc-number) (null null-sc-number) - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) (symbol diff -Nru sbcl-2.0.6/src/compiler/srctran.lisp sbcl-2.1.1/src/compiler/srctran.lisp --- sbcl-2.0.6/src/compiler/srctran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/srctran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -20,17 +20,21 @@ (define-source-transform values (x) `(prog1 ,x)) (deftransform constantly ((value) * * :node node) - (let ((lvar (node-lvar node))) - (map-all-lvar-dests - lvar - (lambda (lvar node) - (unless (lvar-called-by-node-p lvar node) - (give-up-ir1-transform)))) - `#'(lambda (&rest rest) - (declare (ignore rest)) - value))) + (if (constant-lvar-p value) + `#'(lambda (&rest rest) + (declare (ignore rest)) + ',(lvar-value value)) + (let ((lvar (node-lvar node))) + ;; Is it destined to a funcall? Then don't create a closure + (map-all-lvar-dests + lvar + (lambda (lvar node) + (unless (lvar-called-by-node-p lvar node) + (give-up-ir1-transform)))) + `#'(lambda (&rest rest) + (declare (ignore rest)) + value)))) -;;; CONSTANTLY is pretty much never worth transforming, but it's good to get the type. (defoptimizer (constantly derive-type) ((value)) (specifier-type `(function (&rest t) (values ,(type-specifier (lvar-type value)) &optional)))) @@ -158,7 +162,7 @@ ;; Something fishy here- If THE is removed, OPERAND-RESTRICTION-OK ;; returns NIL because type inference on MAKE-LIST never happens. ;; But the fndb entry for %MAKE-LIST is right, so I'm slightly bewildered. - `(%make-list (the (integer 0 (,(1- sb-xc:array-dimension-limit))) ,length) + `(%make-list (the (integer 0 (,(1- array-dimension-limit))) ,length) ,(second rest)) (values nil t))) ; give up @@ -472,7 +476,7 @@ (defun safe-double-coercion-p (x) (or (typep x 'double-float) - (sb-xc:<= sb-xc:most-negative-double-float x sb-xc:most-positive-double-float))) + (sb-xc:<= most-negative-double-float x most-positive-double-float))) (defun safe-single-coercion-p (x) (or (typep x 'single-float) @@ -506,7 +510,7 @@ #+x86 (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum)) (integer (,most-positive-exactly-single-float-fixnum) *)))) - (sb-xc:<= sb-xc:most-negative-single-float x sb-xc:most-positive-single-float)))) + (sb-xc:<= most-negative-single-float x most-positive-single-float)))) ;;; Apply a binary operator OP to two bounds X and Y. The result is ;;; NIL if either is NIL. Otherwise bound is computed and the result @@ -586,12 +590,12 @@ (if (coercion-loses-precision-p (car val) type) xbound (list xbound)))) - ((sb-xc:subtypep type 'double-float) - (if (sb-xc:<= sb-xc:most-negative-double-float val sb-xc:most-positive-double-float) + ((subtypep type 'double-float) + (if (sb-xc:<= most-negative-double-float val most-positive-double-float) (coerce val type))) - ((or (sb-xc:subtypep type 'single-float) (sb-xc:subtypep type 'float)) + ((or (subtypep type 'single-float) (subtypep type 'float)) ;; coerce to float returns a single-float - (if (sb-xc:<= sb-xc:most-negative-single-float val sb-xc:most-positive-single-float) + (if (sb-xc:<= most-negative-single-float val most-positive-single-float) (coerce val type))) (t (coerce val type)))) @@ -603,17 +607,17 @@ xbound (list xbound))) (cond - ((sb-xc:subtypep type 'double-float) - (if (sb-xc:<= sb-xc:most-negative-double-float val sb-xc:most-positive-double-float) + ((subtypep type 'double-float) + (if (sb-xc:<= most-negative-double-float val most-positive-double-float) (coerce val type) - (if (sb-xc:< val sb-xc:most-negative-double-float) - sb-xc:most-negative-double-float sb-xc:most-positive-double-float))) - ((or (sb-xc:subtypep type 'single-float) (sb-xc:subtypep type 'float)) + (if (sb-xc:< val most-negative-double-float) + most-negative-double-float most-positive-double-float))) + ((or (subtypep type 'single-float) (subtypep type 'float)) ;; coerce to float returns a single-float - (if (sb-xc:<= sb-xc:most-negative-single-float val sb-xc:most-positive-single-float) + (if (sb-xc:<= most-negative-single-float val most-positive-single-float) (coerce val type) - (if (sb-xc:< val sb-xc:most-negative-single-float) - sb-xc:most-negative-single-float sb-xc:most-positive-single-float))) + (if (sb-xc:< val most-negative-single-float) + most-negative-single-float most-positive-single-float))) (t (coerce val type)))))) ;;; Convert a numeric-type object to an interval object. @@ -1483,14 +1487,14 @@ (flet ((ash-outer (n s) (when (and (fixnump s) (<= s 64) - (> s sb-xc:most-negative-fixnum)) + (> s most-negative-fixnum)) (ash n s))) ;; KLUDGE: The bare 64's here should be related to ;; symbolic machine word size values somehow. (ash-inner (n s) (if (and (fixnump s) - (> s sb-xc:most-negative-fixnum)) + (> s most-negative-fixnum)) (ash n (min s 64)) (if (minusp n) -1 0)))) (or (and (csubtypep n-type (specifier-type 'integer)) @@ -1632,9 +1636,12 @@ (number-interval (numeric-type->interval number-type)) (divisor-interval (numeric-type->interval divisor-type)) (rem (truncate-rem-bound number-interval divisor-interval))) - ;;(declare (type (member '(integer rational float)) rem-type)) - ;; We have real numbers now. - (cond ((eq rem-type 'integer) + (cond ((and (numberp (interval-low divisor-interval)) + (numberp (interval-high divisor-interval)) + (zerop (interval-low divisor-interval)) + (zerop (interval-high divisor-interval))) + nil) + ((eq rem-type 'integer) ;; Since the remainder type is INTEGER, both args are ;; INTEGERs. (specifier-type `(,rem-type ,(or (interval-low rem) '*) @@ -1688,33 +1695,6 @@ (when (and quot rem) (make-values-type :required (list quot rem))))) -(defun ftruncate-derive-type-quot (number-type divisor-type) - ;; The bounds are the same as for truncate. However, the first - ;; result is a float of some type. We need to determine what that - ;; type is. Basically it's the more contagious of the two types. - (let ((q-type (truncate-derive-type-quot number-type divisor-type)) - (format (numeric-type-format - (numeric-contagion number-type divisor-type)))) - (make-numeric-type :class 'float - :format format - :low (coerce-for-bound (numeric-type-low q-type) format) - :high (coerce-for-bound (numeric-type-high q-type) format)))) - -(defun ftruncate-derive-type-quot-aux (n d same-arg) - (declare (ignore same-arg)) - (when (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (ftruncate-derive-type-quot n d))) - -(defoptimizer (ftruncate derive-type) ((number divisor)) - (let ((quot - (two-arg-derive-type number divisor - #'ftruncate-derive-type-quot-aux #'ftruncate)) - (rem (two-arg-derive-type number divisor - #'truncate-derive-type-rem-aux #'rem))) - (when (and quot rem) - (make-values-type :required (list quot rem))))) - (defun %unary-truncate-derive-type-aux (number) (truncate-derive-type-quot number (specifier-type '(integer 1 1)))) @@ -1732,13 +1712,69 @@ (one-arg-derive-type number #'%unary-truncate-derive-type-aux #'%unary-truncate)) +#-round-float +(progn + (defun ftruncate-derive-type-quot (number-type divisor-type) + ;; The bounds are the same as for truncate. However, the first + ;; result is a float of some type. We need to determine what that + ;; type is. Basically it's the more contagious of the two types. + (let ((q-type (truncate-derive-type-quot number-type divisor-type)) + (format (numeric-type-format + (numeric-contagion number-type divisor-type)))) + (make-numeric-type :class 'float + :format format + :low (coerce-for-bound (numeric-type-low q-type) format) + :high (coerce-for-bound (numeric-type-high q-type) format)))) -(defoptimizer (%unary-ftruncate derive-type) ((number)) - (let ((divisor (specifier-type '(integer 1 1)))) - (one-arg-derive-type number - #'(lambda (n) - (ftruncate-derive-type-quot-aux n divisor nil)) - #'%unary-ftruncate))) + (defun ftruncate-derive-type-quot-aux (n d same-arg) + (declare (ignore same-arg)) + (when (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (ftruncate-derive-type-quot n d))) + + + (defoptimizer (ftruncate derive-type) ((number divisor)) + (let ((quot + (two-arg-derive-type number divisor + #'ftruncate-derive-type-quot-aux #'ftruncate)) + (rem (two-arg-derive-type number divisor + #'truncate-derive-type-rem-aux #'rem))) + (when (and quot rem) + (make-values-type :required (list quot rem))))) + + + (defoptimizer (%unary-ftruncate derive-type) ((number)) + (let ((divisor (specifier-type '(integer 1 1)))) + (one-arg-derive-type number + #'(lambda (n) + (ftruncate-derive-type-quot-aux n divisor nil)) + #'%unary-ftruncate)))) + +#+round-float +(macrolet ((derive (type) + `(case (lvar-value mode) + ,@(loop for mode in '(:round :floor :ceiling :truncate) + for fun in '(fround ffloor fceiling ftruncate) + collect + `(,mode + (one-arg-derive-type number + (lambda (type) + (when (numeric-type-p type) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (specifier-type (list ',type + (if lo + (,fun (type-bound-number lo)) + '*) + (if hi + (,fun (type-bound-number hi)) + '*)))))) + (lambda (x) + (values (,fun x))))))))) + (defoptimizer (round-single derive-type) ((number mode)) + (derive single-float)) + (defoptimizer (round-double derive-type) ((number mode)) + (derive double-float))) (defoptimizer (%unary-round derive-type) ((number)) (one-arg-derive-type number @@ -1835,55 +1871,6 @@ (def floor floor-quotient-bound floor-rem-bound) (def ceiling ceiling-quotient-bound ceiling-rem-bound)) -;;; Define optimizers for FFLOOR and FCEILING -(macrolet ((def (name q-name r-name) - (let ((q-aux (symbolicate "F" q-name "-AUX")) - (r-aux (symbolicate r-name "-AUX"))) - `(progn - ;; Compute type of quotient (first) result. - (defun ,q-aux (number-type divisor-type) - (let* ((number-interval - (numeric-type->interval number-type)) - (divisor-interval - (numeric-type->interval divisor-type)) - (quot (,q-name (interval-div number-interval - divisor-interval))) - (res-type (numeric-contagion number-type - divisor-type)) - (format (numeric-type-format res-type))) - (make-numeric-type - :class (numeric-type-class res-type) - :format format - :low (coerce-for-bound (interval-low quot) format) - :high (coerce-for-bound (interval-high quot) format)))) - - (defoptimizer (,name derive-type) ((number divisor)) - (flet ((derive-q (n d same-arg) - (declare (ignore same-arg)) - (when (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,q-aux n d))) - (derive-r (num div same-arg) - (declare (ignore same-arg)) - (cond ((not (and (numeric-type-real-p num) - (numeric-type-real-p div))) - nil) - ;; Floats introduce rounding errors - ((and (memq (numeric-type-class num) '(integer rational)) - (memq (numeric-type-class div) '(integer rational))) - (,r-aux num div)) - (t - (numeric-contagion num div))))) - (let ((quot (two-arg-derive-type - number divisor #'derive-q #',name)) - (rem (two-arg-derive-type - number divisor #'derive-r #'mod))) - (when (and quot rem) - (make-values-type :required (list quot rem)))))))))) - - (def ffloor floor-quotient-bound floor-rem-bound) - (def fceiling ceiling-quotient-bound ceiling-rem-bound)) - ;;; The quotient for floats depends on the divisor, ;;; make the result conservative, without letting it cross 0 (defmacro conservative-quotient-bound (result direction bound) @@ -2300,7 +2287,7 @@ `(mod ,base-char-code-limit))) (t (specifier-type - `(mod ,sb-xc:char-code-limit)))))) + `(mod ,char-code-limit)))))) (defoptimizer (code-char derive-type) ((code)) (let ((type (lvar-type code))) @@ -2546,12 +2533,7 @@ ;;; Rightward ASH -;;; Assert correctness of build order. (Need not be exhaustive) -#-(vop-translates sb-kernel:%ash/right) -(eval-when (:compile-toplevel) #+x86-64 (error "Expected %ASH/RIGHT vop")) - -#+(vop-translates sb-kernel:%ash/right) -(progn +(when-vop-existsp (:translate sb-kernel:%ash/right) (defun %ash/right (integer amount) (ash integer (- amount))) @@ -2690,22 +2672,22 @@ (give-up-ir1-transform "BOOLE code is not a constant.")) (let ((control (lvar-value op))) (case control - (#.sb-xc:boole-clr 0) - (#.sb-xc:boole-set -1) - (#.sb-xc:boole-1 'x) - (#.sb-xc:boole-2 'y) - (#.sb-xc:boole-c1 '(lognot x)) - (#.sb-xc:boole-c2 '(lognot y)) - (#.sb-xc:boole-and '(logand x y)) - (#.sb-xc:boole-ior '(logior x y)) - (#.sb-xc:boole-xor '(logxor x y)) - (#.sb-xc:boole-eqv '(logeqv x y)) - (#.sb-xc:boole-nand '(lognand x y)) - (#.sb-xc:boole-nor '(lognor x y)) - (#.sb-xc:boole-andc1 '(logandc1 x y)) - (#.sb-xc:boole-andc2 '(logandc2 x y)) - (#.sb-xc:boole-orc1 '(logorc1 x y)) - (#.sb-xc:boole-orc2 '(logorc2 x y)) + (#.boole-clr 0) + (#.boole-set -1) + (#.boole-1 'x) + (#.boole-2 'y) + (#.boole-c1 '(lognot x)) + (#.boole-c2 '(lognot y)) + (#.boole-and '(logand x y)) + (#.boole-ior '(logior x y)) + (#.boole-xor '(logxor x y)) + (#.boole-eqv '(logeqv x y)) + (#.boole-nand '(lognand x y)) + (#.boole-nor '(lognor x y)) + (#.boole-andc1 '(logandc1 x y)) + (#.boole-andc2 '(logandc2 x y)) + (#.boole-orc1 '(logorc1 x y)) + (#.boole-orc2 '(logorc2 x y)) (t (abort-ir1-transform "~S is an illegal control arg to BOOLE." control))))) @@ -2938,13 +2920,96 @@ `(ash (%multiply-high (logandc2 x ,(1- (ash 1 shift1))) ,m) ,(- (+ shift1 shift2))))))))) -#-(vop-translates sb-kernel:%multiply-high) -(progn -;;; Assert correctness of build order. (Need not be exhaustive) -(eval-when (:compile-toplevel) #+x86-64 (error "Expected %MULTIPLY-HIGH vop")) -(define-source-transform %multiply-high (x y) - `(values (sb-bignum:%multiply ,x ,y))) -) +(when-vop-existsp (:translate %signed-multiply-high) + (defun %signed-multiply-high (x y) + (%signed-multiply-high x y)) + + (defun gen-signed-truncate-by-constant-expr (y precision) + (declare (type sb-vm:signed-word y) + (type fixnum precision)) + (aver (not (zerop (logand y (1- y))))) + (labels ((ld (x) + ;; the floor of the binary logarithm of (positive) X + (integer-length (1- x))) + (choose-multiplier (y precision) + (do* ((l (ld y)) + (shift l (1- shift)) + (expt-2-n+l (expt 2 (+ sb-vm:n-word-bits l))) + (m-low (truncate expt-2-n+l y) (ash m-low -1)) + (m-high (truncate (+ expt-2-n+l + (ash expt-2-n+l (- precision))) + y) + (ash m-high -1))) + ((not (and (< (ash m-low -1) (ash m-high -1)) + (> shift 0))) + (values m-high shift))))) + (let ((n (expt 2 sb-vm:n-word-bits)) + (n-1 (expt 2 (1- sb-vm:n-word-bits)))) + (multiple-value-bind (m shift) (choose-multiplier (abs y) precision) + (let ((code + (cond ((< m n-1) + `(ash (%signed-multiply-high x ,m) + ,(- shift))) + (t + `(ash (truly-the sb-vm:signed-word + (+ x (%signed-multiply-high x ,(- m n)))) + ,(- shift)))))) + (if (minusp y) + `(- (ash x (- 1 sb-vm:n-word-bits)) ,code) + `(- ,code (ash x (- 1 sb-vm:n-word-bits))))))))) + + (deftransform truncate ((x y) (sb-vm:signed-word + (constant-arg sb-vm:signed-word)) + * + :policy (and (> speed compilation-speed) + (> speed space))) + "convert integer division to multiplication" + (let* ((y (lvar-value y)) + (abs-y (abs y)) + (x-type (lvar-type x))) + (multiple-value-bind (precision max-x) + (if (and (numeric-type-p x-type) + (numeric-type-high x-type) + (numeric-type-low x-type)) + (values (max (integer-length (numeric-type-high x-type)) + (integer-length (numeric-type-low x-type))) + (max (numeric-type-high x-type) + (abs (numeric-type-low x-type)))) + (values (1- sb-vm:n-word-bits) + (expt 2 (1- sb-vm:n-word-bits)))) + ;; Division by zero, one or powers of two is handled elsewhere. + (when (or (zerop (logand y (1- y))) + ;; Leave it for the unsigned transform + (and (plusp y) + (not (types-equal-or-intersect x-type + (specifier-type + '(and sb-vm:signed-word + (not unsigned-byte))))))) + (give-up-ir1-transform)) + `(let* ((quot (truly-the + (integer ,(- (truncate max-x abs-y)) ,(truncate max-x abs-y)) + ,(gen-signed-truncate-by-constant-expr y precision))) + (rem (truly-the (integer ,(- 1 abs-y) ,(1- abs-y)) + (- x (truly-the sb-vm:signed-word (* quot ,y)))))) + (values quot rem)))))) + +;;; The paper also has this, +;;; but it seems to overflow when adding to X +;; (defun gen-signed-floor-by-constant-expr (y max-x) +;; (declare (type sb-vm:signed-word y) +;; (type word max-x)) +;; (let ((trunc (gen-signed-truncate-by-constant-expr y +;; max-x))) +;; (let ((y-sign (xsign y))) +;; `(let* ((x-sign (xsign (logior x (+ x ,y-sign)))) +;; (x (+ ,y-sign (- x-sign) x))) +;; (truly-the sb-vm:signed-word +;; (+ ,trunc +;; (logxor x-sign ,y-sign))))))) + +(unless-vop-existsp (:translate %multiply-high) + (define-source-transform %multiply-high (x y) + `(values (sb-bignum:%multiply ,x ,y)))) ;;; If the divisor is constant and both args are positive and fit in a ;;; machine word, replace the division by a multiplication and possibly @@ -2968,10 +3033,12 @@ ;; Division by zero, one or powers of two is handled elsewhere. (when (zerop (logand y (1- y))) (give-up-ir1-transform)) - `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x)) - (rem (ldb (byte #.sb-vm:n-word-bits 0) - (- x (* quot ,y))))) + `(let* ((quot (truly-the (integer 0 ,(truncate max-x y)) + ,(gen-unsigned-div-by-constant-expr y max-x))) + (rem (truly-the (mod ,y) + (- x (* quot ,y))))) (values quot rem)))) + ;;;; arithmetic and logical identity operation elimination @@ -3293,12 +3360,12 @@ ((same-leaf-ref-p x y) t) ((not (types-equal-or-intersect (lvar-type x) (lvar-type y))) nil) - #+(vop-translates sb-kernel:%instance-ref-eq) ;; Reduce (eq (%instance-ref x i) Y) to 1 instruction ;; if possible, but do not defer the memory load unless doing ;; so can have no effect, i.e. Y is a constant or provably not ;; effectful. For now, just handle constant Y. - ((and (constant-lvar-p y) + ((and (vop-existsp :translate %instance-ref-eq) + (constant-lvar-p y) (combination-p use) (almost-immediately-used-p x use) (eql '%instance-ref (lvar-fun-name (combination-fun use))) @@ -3610,11 +3677,11 @@ (csubtypep y-type (specifier-type 'float))) (and (csubtypep x-type (specifier-type '(complex float))) (csubtypep y-type (specifier-type '(complex float)))) - #+(vop-named sb-vm::=/complex-single-float) - (and (csubtypep x-type (specifier-type '(or single-float (complex single-float)))) + (and (vop-existsp :named sb-vm::=/complex-single-float) + (csubtypep x-type (specifier-type '(or single-float (complex single-float)))) (csubtypep y-type (specifier-type '(or single-float (complex single-float))))) - #+(vop-named sb-vm::=/complex-double-float) - (and (csubtypep x-type (specifier-type '(or double-float (complex double-float)))) + (and (vop-existsp :named sb-vm::=/complex-double-float) + (csubtypep x-type (specifier-type '(or double-float (complex double-float)))) (csubtypep y-type (specifier-type '(or double-float (complex double-float)))))) ;; They are both floats. Leave as = so that -0.0 is ;; handled correctly. @@ -3975,7 +4042,7 @@ (source-transform-transitive 'logxor args 0 'integer)) (define-source-transform logand (&rest args) (source-transform-transitive 'logand args -1 'integer)) -#-(or arm arm64 hppa mips x86 x86-64 riscv) ; defined in compiler/target/arith.lisp +#-(or arm arm64 mips x86 x86-64 riscv) ; defined in compiler/target/arith.lisp (define-source-transform logeqv (&rest args) (source-transform-transitive 'logeqv args -1 'integer)) (define-source-transform gcd (&rest args) @@ -4011,7 +4078,7 @@ ((and (typep (abs low) `(integer 0 ,(min (expt 2 32) - sb-xc:most-positive-fixnum))) + most-positive-fixnum))) ;; Get some extra points (positive-primep (abs low))) (pushnew (abs low) primes))) @@ -4091,7 +4158,7 @@ (case (let ((name (lvar-fun-name (combination-fun thing)))) (or (modular-version-info name :untagged nil) name)) ((+ -) - (let ((min sb-xc:most-positive-fixnum) + (let ((min most-positive-fixnum) (itype (specifier-type 'integer))) (dolist (arg (combination-args thing) min) (if (csubtypep (lvar-type arg) itype) @@ -4118,7 +4185,7 @@ 0))) (integer (if (zerop thing) - sb-xc:most-positive-fixnum + most-positive-fixnum (do ((result 0 (1+ result)) (num thing (ash num -1))) ((logbitp 0 num) result)))) @@ -4792,7 +4859,7 @@ (start-1 (1- ,',start)) (current-heap-size (- ,',end ,',start)) (keyfun ,keyfun)) - (declare (type (integer -1 #.(1- sb-xc:most-positive-fixnum)) + (declare (type (integer -1 #.(1- most-positive-fixnum)) start-1)) (declare (type index current-heap-size)) (declare (type function keyfun)) @@ -4989,7 +5056,8 @@ `(write-string object stream)) #+sb-thread -(defoptimizer (sb-thread::call-with-recursive-lock derive-type) ((function mutex waitp timeout)) +(progn +(defoptimizer (sb-thread::call-with-mutex derive-type) ((function mutex waitp timeout)) (declare (ignore mutex)) (let ((type (lvar-fun-type function))) (when (fun-type-p type) @@ -5002,19 +5070,8 @@ (values-specifier-type '(values null &optional))) (fun-type-returns type)))))) -#+sb-thread -(defoptimizer (sb-thread::call-with-mutex derive-type) ((function mutex value waitp timeout)) - (declare (ignore mutex value)) - (let ((type (lvar-fun-type function))) - (when (fun-type-p type) - (let ((null-p (not (and (constant-lvar-p waitp) - (lvar-value waitp) - (constant-lvar-p timeout) - (null (lvar-value timeout)))))) - (if null-p - (values-type-union (fun-type-returns type) - (values-specifier-type '(values null &optional))) - (fun-type-returns type)))))) +(setf (fun-info-derive-type (fun-info-or-lose 'sb-thread::call-with-recursive-lock)) + (fun-info-derive-type (fun-info-or-lose 'sb-thread::call-with-mutex)))) (deftransform pointerp ((object)) (let ((type (lvar-type object))) diff -Nru sbcl-2.0.6/src/compiler/sset.lisp sbcl-2.1.1/src/compiler/sset.lisp --- sbcl-2.0.6/src/compiler/sset.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sset.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -75,7 +75,7 @@ (set-result (+ result (ash result -9))) (set-result (logxor result (ash result -5))) (set-result (+ result (ash result -2))) - (logand sb-xc:most-positive-fixnum result)))) + (logand most-positive-fixnum result)))) ;;; Secondary hash (for double hash probing). Needs to return an odd ;;; number. diff -Nru sbcl-2.0.6/src/compiler/stack.lisp sbcl-2.1.1/src/compiler/stack.lisp --- sbcl-2.0.6/src/compiler/stack.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/stack.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -148,7 +148,8 @@ t) ((eq (block-flag current-block) flag) t) - ((eq (block-flag current-block) cycle)) + ((eq (block-flag current-block) cycle) + nil) ;; Don't go back past START-BLOCK. ((not (eq current-block start-block)) (setf (block-flag current-block) cycle) @@ -437,7 +438,7 @@ for lvar in after-stack unless (memq lvar before-stack) do (cleanup-code - `(%dummy-dx-alloc ',lvar ',previous-lvar))))) + `(%dummy-dx-alloc ,(opaquely-quote lvar) ,(opaquely-quote previous-lvar)))))) (let* ((end-stack (ir2-block-end-stack (block-info block1))) (start-stack (ir2-block-start-stack (block-info block2))) (pruned-start-stack (ordered-list-intersection diff -Nru sbcl-2.0.6/src/compiler/sxhash.lisp sbcl-2.1.1/src/compiler/sxhash.lisp --- sbcl-2.0.6/src/compiler/sxhash.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/sxhash.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -127,7 +127,7 @@ `(let ((bits (logand (single-float-bits x) ,(1- (ash 1 32))))) (logxor 66194023 (sxhash (the sb-xc:fixnum - (logand sb-xc:most-positive-fixnum + (logand most-positive-fixnum (logxor bits (ash bits -7)))))))) (deftransform sxhash ((x) (single-float)) '#.+sxhash-single-float-expr+) @@ -138,16 +138,16 @@ (hilo (logxor hi lo))) (logxor 475038542 (sxhash (the fixnum - (logand sb-xc:most-positive-fixnum + (logand most-positive-fixnum (logxor hilo (ash hilo -7)))))))) ;;; SXHASH of FIXNUM values is defined as a DEFTRANSFORM because it's so ;;; simple. (defglobal +sxhash-fixnum-expr+ - (let ((c (logand 1193941380939624010 sb-xc:most-positive-fixnum))) + (let ((c (logand 1193941380939624010 most-positive-fixnum))) ;; shift by -1 to get sign bit into hash - `(logand (logxor (ash x 4) (ash x -1) ,c) sb-xc:most-positive-fixnum))) + `(logand (logxor (ash x 4) (ash x -1) ,c) most-positive-fixnum))) (deftransform sxhash ((x) (fixnum)) '#.+sxhash-fixnum-expr+) ;;; Treat double-float essentially the same as a fixnum if words are 64 bits. @@ -155,13 +155,13 @@ (defglobal +sxhash-double-float-expr+ ;; logical negation of magic constant ensures that 0.0d0 hashes to something ;; other than what the fixnum 0 hashes to (as tested in hash.impure.lisp) - (let ((c (logandc1 1193941380939624010 sb-xc:most-positive-fixnum))) + (let ((c (logandc1 1193941380939624010 most-positive-fixnum))) `(let ((x (double-float-bits x))) ;; ensure we mix the sign bit into the hash (logand (logxor (ash x 4) (ash x (- (1+ sb-vm:n-fixnum-tag-bits))) ,c) - sb-xc:most-positive-fixnum)))) + most-positive-fixnum)))) (deftransform sxhash ((x) (double-float)) '#.+sxhash-double-float-expr+) @@ -196,7 +196,7 @@ * :important nil) `(symbol-hash* object 'non-null-symbol-p)) ; etc -;;; To define SB-XC:SXHASH compatibly without repeating the logic in the transforms +;;; To define SXHASH compatibly without repeating the logic in the transforms ;;; that define the numeric cases, we do some monkey business involving #. to paste ;;; in the expressions that the transforms would return. #+sb-xc-host @@ -211,7 +211,7 @@ (t ;; (STRING X) could be a non-simple string, it's OK. (let ((hash (logxor (sb-impl::%sxhash-simple-string (string x)) - sb-xc:most-positive-fixnum))) + most-positive-fixnum))) (aver (ldb-test (byte (- 32 sb-vm:n-fixnum-tag-bits) 0) hash)) hash)))) (sb-xc:fixnum #.+sxhash-fixnum-expr+) diff -Nru sbcl-2.0.6/src/compiler/target-disassem.lisp sbcl-2.1.1/src/compiler/target-disassem.lisp --- sbcl-2.0.6/src/compiler/target-disassem.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/target-disassem.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -106,7 +106,7 @@ ;;;; choosing an instruction -#-sb-fluid (declaim (inline inst-matches-p choose-inst-specialization)) +(declaim (inline inst-matches-p choose-inst-specialization)) ;;; Return non-NIL if all constant-bits in INST match CHUNK. (defun inst-matches-p (inst chunk) @@ -288,7 +288,7 @@ ;;; LRA layout (dual word aligned): ;;; header-word -#-sb-fluid (declaim (inline words-to-bytes)) +(declaim (inline words-to-bytes)) (eval-when (:compile-toplevel :load-toplevel :execute) ;;; Convert a word-offset NUM to a byte-offset. @@ -624,7 +624,7 @@ (rewind-current-segment dstate segment) ;; Do not pin anything yet if using cheneygc, as that would inhibit GC - ;; with a larger scope than intended. + ;; with a larger scope than strictly necessary. (with-pinned-objects (#+gencgc (seg-object (dstate-segment dstate)) #+gencgc dstate) ; for SAP access to SCRATCH-BUF #+gencgc (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment))) @@ -795,7 +795,7 @@ ;; FIXME: this is strictly redundant. ;; You should combine fields in the prefilter ;; so that the labeller receives a single byte. - ;; AARCH64 and HPPA make use of this though. + ;; AARCH64 makes use of this though. (loop for i from 2 below item-length collect (extract-byte i))))) dstate))) @@ -2265,14 +2265,15 @@ name->addr))) (let ((code sb-fasl:*assembler-routines*)) (invert (%code-debug-info code) - (lambda (x) (sap-int (sap+ (code-instructions code) (car x)))))) - #-linkage-table - (invert *static-foreign-symbols* #'identity)) - (loop for name across sb-vm::+all-static-fdefns+ - for address = - #+immobile-code (sb-vm::function-raw-address name) - #-immobile-code (+ sb-vm:nil-value (sb-vm:static-fun-offset name)) - do (setf (gethash address addr->name) name)) + (lambda (x) (sap-int (sap+ (code-instructions code) (car x))))))) + (dovector (name sb-vm::+all-static-fdefns+) + ;; ENTER-ALIEN-CALLBACK is not fboundp until src/code/alien-callback + ;; is compiled, so don't fail in function-raw-address. + (when (fboundp name) + (let ((address + #+immobile-code (sb-vm::function-raw-address name) + #-immobile-code (+ sb-vm:nil-value (sb-vm:static-fun-offset name)))) + (setf (gethash address addr->name) name)))) ;; Not really a routine, but it uses the similar logic for annotations #+sb-safepoint (setf (gethash (+ sb-vm:gc-safepoint-page-addr @@ -2449,7 +2450,7 @@ (let ((base-obj (if (simple-fun-p thing) (fun-code-header thing) thing))) (+ (logandc2 (get-lisp-obj-address base-obj) sb-vm:lowtag-mask) - (sb-vm::primitive-object-size base-obj) + (primitive-object-size base-obj) -1))) (return thing))))))) @@ -2503,7 +2504,6 @@ (unless (typep address 'address) (return-from maybe-note-assembler-routine nil)) (multiple-value-bind (name offs) (find-assembler-routine address) - #+linkage-table (unless name (setq name (sap-foreign-symbol (int-sap address)))) (when name @@ -2587,7 +2587,18 @@ to sb-vm:code-constants-offset for const = (code-header-ref code i) when (eql (get-lisp-obj-address const) address) - do (return-from found const)))) + do (return-from found const)) + ;; Kludge: layout of STREAM, FILE-STREAM, and STRING-STREAM can be used + ;; as immediate operands without a corresponding boxed header constant. + ;; I think we always elide the boxed constant for builtin layouts, + ;; but these three have some slightly unusual codegen that causes a PUSH + ;; instruction to need some help to show its operand as a lisp object. + (dolist (thing (load-time-value (list (find-layout 'stream) + (find-layout 'file-stream) + (find-layout 'string-stream)) + t)) + (when (eql (get-lisp-obj-address thing) address) + (return-from found thing))))) (return-from maybe-note-static-symbol)))) (note (lambda (s) (prin1 symbol s)) dstate))) diff -Nru sbcl-2.0.6/src/compiler/target-main.lisp sbcl-2.1.1/src/compiler/target-main.lisp --- sbcl-2.0.6/src/compiler/target-main.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/target-main.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -26,7 +26,7 @@ (defun compile-in-lexenv (form *lexenv* name source-info tlf ephemeral errorp) (let ((source-paths (when source-info *source-paths*))) (with-compilation-values - (sb-xc:with-compilation-unit () + (with-compilation-unit () ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with ;; few changes. Once things are stable, the shared bindings ;; probably be merged back together into some shared utility @@ -279,7 +279,7 @@ ;; answers. (Modulo any bugs due to near-total lack of testing) (defun compile-file-position-helper (file-info path-to-find) - (let (found-form start-char) + (let (start-char) (labels ((recurse (subpath upper-bound queue) (let ((index -1)) @@ -295,8 +295,7 @@ ;; This does not eagerly declare victory, because we want ;; to find the rightmost match. In "#1=(FOO)" there are two ;; different annotations pointing to (FOO). - (setq found-form (cdr item) - start-char (caar item))) + (setq start-char (caar item))) (unless queue (return)) (let* ((next (car queue)) (next-end (cdar next))) diff -Nru sbcl-2.0.6/src/compiler/typetran.lisp sbcl-2.1.1/src/compiler/typetran.lisp --- sbcl-2.0.6/src/compiler/typetran.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/typetran.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -109,29 +109,6 @@ ;; If it's a lisp-rep-type, the CTYPE should be one already. (aver (not (compute-lisp-rep-type alien-type))) `(sb-alien::alien-value-typep object ',alien-type))) - #+(vop-translates sb-int:fixnump-instance-ref) - ((and (type= type (specifier-type 'fixnum)) - (let ((use (lvar-uses object))) - (and (combination-p use) - (almost-immediately-used-p object use) - (or (and (eq (lvar-fun-name (combination-fun use)) - '%instance-ref) - (constant-lvar-p - (second (combination-args use)))) - (member (lvar-fun-name (combination-fun use)) - '(car cdr)))))) - ;; FIXME: vopcombine should be able to combine a load - ;; and a fixnump test withoot special-casing these three. - (case (lvar-fun-name (combination-fun (lvar-uses object))) - (%instance-ref - (splice-fun-args object '%instance-ref 2) - `(lambda (obj i) (fixnump-instance-ref obj i))) - (car - (splice-fun-args object 'car 1) - `(lambda (obj) (fixnump-car obj))) - (cdr - (splice-fun-args object 'cdr 1) - `(lambda (obj) (fixnump-cdr obj))))) (t (give-up-ir1-transform)))))) @@ -333,18 +310,29 @@ type))) (rational 'rational) (float (or (numeric-type-format type) 'float)) - ((nil) 'real)))) + ((nil) 'real))) + (low (numeric-type-low type)) + (high (numeric-type-high type))) (ecase (numeric-type-complexp type) (:real - (cond #+(or x86 x86-64 arm arm64) ;; Not implemented elsewhere yet - ((and - (eql (numeric-type-class type) 'integer) - (or (eql (numeric-type-low type) 0) - (eql (numeric-type-low type) 1)) - (fixnump (numeric-type-high type))) + (cond ((and (eql (numeric-type-class type) 'integer) + (and (fixnump low) + (fixnump high) + (<= (1+ (- high low)) 2))) + ;; The fixnum-mod-p case is worse than just EQ testing with + ;; only 2 values in the range. (INTEGER 1 2) would have become + ;; (and (not (eq x 0)) (fixnump x) (not (> x 2))). + ;; If exactly 1 value, it should have been picked off by TYPE-SINGLETON-P + ;; in %SOURCE-TRANSFORM-TYPEP, but even if it wasn't, + ;; the OR will drop out due to constraint propagation. + `(or (eq ,object ,low) (eq ,object ,high))) + #+(or x86 x86-64 arm arm64) ;; Not implemented elsewhere yet + ((and (eql (numeric-type-class type) 'integer) + (or (eql low 0) (eql low 1)) + (fixnump (numeric-type-high type))) (let ((mod-p `(fixnum-mod-p ,object ,(numeric-type-high type)))) - (if (eql (numeric-type-low type) 1) + (if (eql low 1) `(and (not (eq ,object 0)) ,mod-p) mod-p))) @@ -607,9 +595,9 @@ #+(and sb-unicode (or x86-64 arm64)) ((= (cdar pairs) (1- base-char-code-limit)) `(base-char-p ,object)) - ((= (cdar pairs) (1- sb-xc:char-code-limit)) + ((= (cdar pairs) (1- char-code-limit)) `(characterp ,object)))) - (let ((n-code (gensym "CODE"))) + (let ((n-code (sb-xc:gensym "CODE"))) `(and (characterp ,object) (let ((,n-code (sb-xc:char-code ,object))) (or @@ -621,7 +609,7 @@ (defun source-transform-simd-pack-typep (object type) (if (type= type (specifier-type 'simd-pack)) `(simd-pack-p ,object) - (let ((n-tag (gensym "TAG"))) + (let ((n-tag (sb-xc:gensym "TAG"))) `(and (simd-pack-p ,object) (let ((,n-tag (%simd-pack-tag ,object))) @@ -634,7 +622,7 @@ (defun source-transform-simd-pack-256-typep (object type) (if (type= type (specifier-type 'simd-pack-256)) `(simd-pack-256-p ,object) - (let ((n-tag (gensym "TAG"))) + (let ((n-tag (sb-xc:gensym "TAG"))) `(and (simd-pack-256-p ,object) (let ((,n-tag (%simd-pack-256-tag ,object))) @@ -677,10 +665,9 @@ (cond ((cdr dims) (values `(,header-test ,@(when (eq (array-type-dimensions stype) '*) - #+x86-64 - `((%array-rank= ,obj ,(length dims))) - #-x86-64 - `((= (%array-rank ,obj) ,(length dims)))) + (if (vop-existsp :translate %array-rank=) + `((%array-rank= ,obj ,(length dims))) + `((= (%array-rank ,obj) ,(length dims))))) ,@(loop for d in dims for i from 0 unless (eq '* d) @@ -838,6 +825,13 @@ ;;; object's layout can ever be EQ to that of the ancestor. ;;; e.g. a fixnum as representative of class REAL. ;;; So in actual practice, you can't make something that is a pure STREAM, etc. +#-(or x86 x86-64) ; vop-translated for these 2 +(defmacro layout-depthoid-ge (layout depthoid) + `(>= (layout-depthoid ,layout) ,depthoid)) +;;; Assert that it is OK to look at element 1 of any INHERITS vector +;;; without pre-checking its length. +(eval-when (:compile-toplevel) + (aver (eql (layout-depthoid (find-layout 'sequence)) 1))) (defun transform-instance-typep (classoid) (binding* ((name (classoid-name classoid)) @@ -848,6 +842,7 @@ (values '(function-with-layout-p object) '(%fun-layout object))) ((or (csubtypep classoid (specifier-type 'instance)) + (eq classoid (specifier-type 'logical-pathname)) ;; CONDITION can't be a funcallable-instance (csubtypep classoid (specifier-type 'condition))) (values '(%instancep object) @@ -868,28 +863,7 @@ ((function-with-layout-p object) (%fun-layout object)) (t (return-from typep nil))))) (depthoid (if layout (layout-depthoid layout) -1)) - (n-layout (gensym)) - ;; In order to efficiently perform the DEEPER-P test without this hack of using - ;; a vop (when available for non-risc machines), we'd have to do two things: - ;; - have instcombine combine the read and compare as one instruction - ;; - implement half-width structure slots - ;; Since both of those are not happening any time soon, ... - (deeper-p - #+(vop-translates sb-c::layout-depthoid-gt) `(layout-depthoid-gt ,n-layout ,depthoid) - #-(vop-translates sb-c::layout-depthoid-gt) `(> (layout-depthoid ,n-layout) ,depthoid)) - (nth-ancestor ; This is possibly unused (if no compile-time layout, or depthoid -1) - ;; Use DATA-VECTOR-REF directly, since that's what SVREF in SAFETY 0 will become. - `(locally (declare (optimize (safety 0))) - (data-vector-ref (layout-inherits ,n-layout) ,depthoid))) - (ancestor-layout-eq - ;; Layouts are immediate constants in immobile space. Again, this is something that - ;; an instcombine pass might be able to recognize as having a single instruction. - #+(and immobile-space x86-64) `(sb-vm::layout-inherits-ref-eq - (layout-inherits ,n-layout) ,depthoid ,layout) - #-(and immobile-space x86-64) `(eq ,nth-ancestor ,layout)) - ;; For shallow depthoid we can avoid checking the depthoid or reading the 'inherits' - ;; slot, because the layout has some number of ancestor layouts directly in it. - (ancestor-slot (layout-nth-ancestor-slot depthoid))) + (n-layout (make-symbol "LAYOUT"))) ;; Easiest case first: single bit test. (cond ((member name '(condition pathname structure-object)) @@ -900,11 +874,10 @@ (pathname +pathname-layout-flag+) (t +structure-layout-flag+))))) - ;; Next easiest: Sealed and at most one subclass. - ((and (eq (classoid-state classoid) :sealed) layout - (or (not (classoid-subclasses classoid)) - (eql (hash-table-count (classoid-subclasses classoid)) - 1))) + ;; Next easiest: Sealed and no subtypes. + ((and layout + (eq (classoid-state classoid) :sealed) + (not (classoid-subclasses classoid))) ;; It's possible to seal a STANDARD-CLASS, not just a STRUCTURE-CLASS, ;; though probably extremely weird. Also the PRED should be set in ;; that event, but it isn't. @@ -912,27 +885,15 @@ ;; (BLOCK (RETURN ...)) seems to emit a forward branch in the ;; passing case, but AND emits a forward branch in the failing ;; case which I believe is the better choice. - (let ((other-layout (and (classoid-subclasses classoid) - (dohash ((classoid layout) - (classoid-subclasses classoid) - :locked t) - (declare (ignore classoid)) - (return layout))))) - (flet ((check-layout (layout-getter) - (cond (other-layout - ;; It's faster to compare two layouts than - ;; doing whatever is done below - `(let ((object-layout ,layout-getter)) - (or (eq object-layout ',layout) - (eq object-layout ',other-layout)))) - #+(vop-named sb-vm::layout-eq) - ((equal layout-getter '(%instance-layout object)) + (flet ((check-layout (layout-getter) + (cond ((and (vop-existsp :named sb-vm::layout-eq) + (equal layout-getter '(%instance-layout object))) `(sb-vm::layout-eq object ',layout)) (t `(eq ,layout-getter ',layout))))) (if primtype-predicate `(and ,primtype-predicate ,(check-layout slot-reader)) - `(block typep ,(check-layout get-layout-or-return-false)))))) + `(block typep ,(check-layout get-layout-or-return-false))))) ;; All other structure types ((and (typep classoid 'structure-classoid) layout) @@ -946,40 +907,36 @@ ;; If we allowed structure classes to be mixed in to standard-object, ;; this might have to change to consider object invalidation. Probably would ;; want to track structure classoids that would render this code inadmissible. - (let ((,n-layout (%instance-layout object))) - ,(cond ((<= 2 depthoid layout-inherits-max-optimized-depth) - `(or (eq (,ancestor-slot ,n-layout) ,layout) - (eq ,n-layout ,layout))) - ((dd-constructors (layout-info layout)) - `(cond ((eq ,n-layout ,layout) t) - (,deeper-p ,ancestor-layout-eq))) - (t ; abstract base type deeper than optimized max. - ;; Assume that no layout is EQ to the base layout, - ;; and unconditionally fetch and dereference layout-inherits. - `(eq (if ,deeper-p ,nth-ancestor ,n-layout) ,layout)))))) - - ((> depthoid 0) ; fixed-depth ancestors of non-structure types: STREAM, FILE-STREAM, - ;; SEQUENCE, CONDITION; all are abstract base types. + (let ((,n-layout (%instance-layout object))) + ,(if (<= depthoid sb-kernel::layout-id-vector-fixed-capacity) + `(%structure-is-a ,n-layout ,layout) + `(and (layout-depthoid-ge ,n-layout ,depthoid) + (%structure-is-a ,n-layout ,layout)))))) + + ((> depthoid 0) + ;; fixed-depth ancestors of non-structure types: + ;; STREAM, FILE-STREAM, STRING-STREAM, and SEQUENCE. #+sb-xc-host (when (typep classoid 'static-classoid) ;; should have use :SEALED code above (bug "Non-frozen static classoids?")) - ;; quasi-hierarchical layout for other things: STREAM, FILE-STREAM, - ;; SEQUENCE, CONDITION; all are abstract base types. - (let ((guts `(,@(unless (eq name 'condition) - `((when (zerop (layout-clos-hash ,n-layout)) - (setq ,n-layout + (let ((guts `((when (zerop (layout-clos-hash ,n-layout)) + (setq ,n-layout (truly-the layout - (update-object-layout-or-invalid - object ',layout)))))) - ;; the Nth ancestor for N=1 is not directly stored in the layout. - ;; But we don't have to check the layout-inherits length because - ;; it has as least two physical data elements even if it has T - ;; as the sole ancestor. - (or ,(if (eql depthoid 1) - ancestor-layout-eq - `(eq (,ancestor-slot ,n-layout) ,layout)) - ;; So that (TYPEP (MAKE-CONDITION 'CONDITION) 'CONDITION) => T - ,@(when (eq name 'condition) `((eq ,n-layout ,layout))))))) + (update-object-layout object)))) + ,(ecase name + (stream + `(logtest (layout-flags ,n-layout) ,+stream-layout-flag+)) + (file-stream + `(logtest (layout-flags ,n-layout) ,+file-stream-layout-flag+)) + (string-stream + `(logtest (layout-flags ,n-layout) ,+string-stream-layout-flag+)) + ;; Testing the type EXTENDED-SEQUENCE tests for #. + ;; It can only arise from a direct invocation of TRANSFORM-INSTANCE-TYPEP, + ;; because the lisp type is not a classoid. It's done this way to define + ;; the logic once only, instead of both here and src/code/pred.lisp. + (sequence + `(eq (data-vector-ref (layout-inherits ,n-layout) 1) + ,layout)))))) (if primtype-predicate `(and ,primtype-predicate (let ((,n-layout ,slot-reader)) ,@guts)) `(block typep @@ -1006,6 +963,10 @@ (let ((ctype (careful-specifier-type type))) (if ctype (or + ;; It's purely a waste of compiler resources to wait for IR1 to + ;; see these 2 edge cases that can be decided right now. + (cond ((eq ctype *universal-type*) t) + ((eq ctype *empty-type*) nil)) (and (not (intersection-type-p ctype)) (multiple-value-bind (constantp value) (type-singleton-p ctype) (and constantp @@ -1033,8 +994,6 @@ (args-type (compiler-warn "illegal type specifier for TYPEP: ~S" type) (return-from %source-transform-typep (values nil t))) - (t nil)) - (typecase ctype (numeric-type (source-transform-numeric-typep object ctype)) (classoid @@ -1058,7 +1017,7 @@ (defun source-transform-typep (object type) (when (typep type 'type-specifier) (check-deprecated-type type)) - (let ((name (gensym "OBJECT"))) + (let ((name (sb-xc:gensym "OBJECT"))) (multiple-value-bind (transform error) (%source-transform-typep name type) (if error @@ -1066,6 +1025,44 @@ (values `(let ((,name ,object)) (%typep-wrapper ,transform ,name ',type))))))) +;;; These things will be removed by the tree shaker, so no #+ needed. +(defvar *interesting-types* nil) +(defun involves-alien-p (ctype) + (sb-kernel::map-type + (lambda (type) + (when (alien-type-type-p type) (return-from involves-alien-p t))) + ctype)) +(defun dump/restore-interesting-types (op) + (declare (ignorable op)) + #+collect-typep-regression-dataset + (ecase op + (write + (when *interesting-types* + (let ((list (sort (loop for k being each hash-key of *interesting-types* collect k) + #'string< :key #'write-to-string))) + (with-open-file (f "interesting-types.lisp-expr" :direction :output + :if-exists :supersede :if-does-not-exist :create) + (let ((*package* #+sb-xc-host (find-package "XC-STRICT-CL") + #-sb-xc-host #.(find-package "SB-KERNEL")) + (*print-pretty* nil) + (*print-length* nil) + (*print-level* nil) + (*print-readably* t)) + (dolist (item list) + (write (uncross item) :stream f) + (terpri f))))))) + (read + (unless (hash-table-p *interesting-types*) + (setq *interesting-types* (make-hash-table :test 'equal :synchronized t))) + (with-open-file (f "interesting-types.lisp-expr" :if-does-not-exist nil) + (when f + (let ((*package* (find-package "SB-KERNEL"))) + (loop (let ((expr (read f nil f))) + (when (eq expr f) (return)) + (format t "Read ~a~%" expr) + (setf (gethash expr *interesting-types*) t)))))) + *interesting-types*))) + (define-source-transform typep (object spec &optional env) ;; KLUDGE: It looks bad to only do this on explicitly quoted forms, ;; since that would overlook other kinds of constants. But it turns @@ -1082,8 +1079,24 @@ ;; during block compilation, we give ourselves a better chance ;; at open-coding the type test. (let ((type (cadr spec))) + ;; + #+collect-typep-regression-dataset + (let ((parse (specifier-type type))) + ;; alien types aren't externalizable as trees of symbols, + ;; and some classoid types aren't defined at the start of warm build, + ;; making it impossible to re-parse a dump produced late in the build. + ;; Luckily there are no cases involving compund types and classoids. + (unless (or (involves-alien-p parse) + (or (classoid-p parse) + (and (cons-type-p parse) + (classoid-p (cons-type-car-type parse))))) + (let ((table *interesting-types*)) + (unless (hash-table-p table) + (setq table (dump/restore-interesting-types 'read))) + (setf (gethash type table) t)))) + ;; (if (and (block-compile *compilation*) - (unknown-type-p (specifier-type type))) + (contains-unknown-type-p (careful-specifier-type type))) (values nil t) (source-transform-typep object type)))) (values nil t))) @@ -1319,3 +1332,6 @@ ((csubtypep (lvar-type object) this-type) nil) ((give-up-ir1-transform))))) + +;;; BIGNUMP is simpler than INTEGERP, so if we can rule out FIXNUM then ... +(deftransform integerp ((x) ((not fixnum)) * :important nil) '(bignump x)) diff -Nru sbcl-2.0.6/src/compiler/vmdef.lisp sbcl-2.1.1/src/compiler/vmdef.lisp --- sbcl-2.0.6/src/compiler/vmdef.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/vmdef.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -196,7 +196,7 @@ ;;; Return a function type specifier describing TEMPLATE's type computed ;;; from the operand type restrictions. -#-sb-fluid (declaim (inline template-conditional-p)) +(declaim (inline template-conditional-p)) (defun template-conditional-p (template) (declare (type template template)) (let ((rtypes (template-result-types template))) diff -Nru sbcl-2.0.6/src/compiler/vop.lisp sbcl-2.1.1/src/compiler/vop.lisp --- sbcl-2.0.6/src/compiler/vop.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/vop.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -576,6 +576,10 @@ (target nil :type (or null tn-ref)) ;; the load TN allocated for this operand, if any (load-tn nil :type (or tn null)) + ;; on CISC microprocessors, a representation of the memory load + ;; (or store) based on this TN-REF (for which its TN is the base register) + ;; and not directly an operand from/into which the TN-REF flows. + (memory-access) ;; The type of the LVAR the TN of this TN-REF is used for. (type nil :type (or ctype null))) @@ -731,6 +735,7 @@ ;; MAX-VOP-TN-REFS) and the dest ref index. (targets nil :type (or null (simple-array (unsigned-byte 16) 1))) (optimizer nil :type (or null function)) + (optional-results nil :type list) move-vop-p) (declaim (inline vop-name)) (defun vop-name (vop) diff -Nru sbcl-2.0.6/src/compiler/x86/alloc.lisp sbcl-2.1.1/src/compiler/x86/alloc.lisp --- sbcl-2.0.6/src/compiler/x86/alloc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -411,7 +411,7 @@ (pseudo-atomic (:elide-if stack-allocate-p) (allocation nil (pad-data-block words) lowtag node stack-allocate-p result) (when type - (storew (logior (ash (1- words) (length-field-shift type)) type) + (storew (compute-object-header words type) result 0 lowtag)))))) diff -Nru sbcl-2.0.6/src/compiler/x86/arith.lisp sbcl-2.1.1/src/compiler/x86/arith.lisp --- sbcl-2.0.6/src/compiler/x86/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1351,30 +1351,23 @@ ;;;; 32-bit logical operations ;;; Only the lower 5 bits of the shift amount are significant. -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg) :target r) - (amount :scs (signed-reg) :target ecx)) - (:arg-types unsigned-num tagged-num) - (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) - (:results (r :scs (unsigned-reg) :from (:argument 0))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (move r num) - (move ecx amount) - (inst shr r :cl))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (move r num) - (move ecx amount) - (inst shl r :cl))) +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg) :target r) + (amount :scs (signed-reg) :target ecx)) + (:arg-types unsigned-num tagged-num) + (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (r :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num) + (:generator 1 + (move r num) + (move ecx amount) + (inst ,operation r :cl))))) + (define shift-towards-start shr) + (define shift-towards-end shl)) ;;;; Modular functions (defmacro define-mod-binop ((name prototype) function) diff -Nru sbcl-2.0.6/src/compiler/x86/array.lisp sbcl-2.1.1/src/compiler/x86/array.lisp --- sbcl-2.0.6/src/compiler/x86/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -29,34 +29,15 @@ :disp (+ (* array-dimensions-offset n-word-bytes) lowtag-mask))) (inst and bytes (lognot lowtag-mask)) - (inst lea header (make-ea :dword :base rank - :disp (fixnumize (1- array-dimensions-offset)))) - (inst shl header n-widetag-bits) + ;; rank 1 is stored as 0, 2 is stored as 1, ... + (inst lea header (make-ea :dword :disp (fixnumize -1) :base rank)) + (inst and header (fixnumize array-rank-mask)) + (inst shl header array-rank-byte-pos) (inst or header type) - (inst shr header 2) + (inst shr header n-fixnum-tag-bits) (pseudo-atomic () (allocation nil bytes other-pointer-lowtag node nil result) (storew header result 0 other-pointer-lowtag)))) - -(define-vop (make-array-header/c) - (:translate make-array-header) - (:policy :fast-safe) - (:arg-types (:constant t) (:constant t)) - (:info type rank) - (:results (result :scs (descriptor-reg))) - (:node-var node) - (:generator 12 - (let* ((header-size (+ rank - (1- array-dimensions-offset))) - (bytes (logandc2 (+ (* (1+ header-size) n-word-bytes) - lowtag-mask) - lowtag-mask)) - (header (logior (ash header-size - n-widetag-bits) - type))) - (pseudo-atomic () - (allocation nil bytes other-pointer-lowtag node nil result) - (storew header result 0 other-pointer-lowtag))))) ;;;; additional accessors and setters for the array header (define-full-reffer %array-dimension * @@ -67,16 +48,29 @@ array-dimensions-offset other-pointer-lowtag (any-reg) positive-fixnum %set-array-dimension) -(define-vop (array-rank-vop) +(define-vop () (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (loadw res x 0 other-pointer-lowtag) - (inst shr res n-widetag-bits) - (inst sub res (1- array-dimensions-offset)))) + (inst movzx res (make-ea :byte :disp (- 2 other-pointer-lowtag) :base x)) + ;; not all registers have an addressable low byte, + ;; so the simple trick used on x86-64 won't work. + (inst inc res) + (inst and res array-rank-mask))) + +(define-vop () + (:translate %array-rank=) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg))) + (:info rank) + (:arg-types * (:constant t)) + (:conditional :e) + (:generator 2 + (inst cmp (make-ea :byte :disp (- 2 other-pointer-lowtag) :base array) + (encode-array-rank rank)))) ;;;; bounds checking routine (define-vop (check-bound) diff -Nru sbcl-2.0.6/src/compiler/x86/insts.lisp sbcl-2.1.1/src/compiler/x86/insts.lisp --- sbcl-2.0.6/src/compiler/x86/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1029,23 +1029,26 @@ (let ((size (matching-operand-size dst src))) (maybe-emit-operand-size-prefix segment size) (cond - ((integerp src) - (cond ((and (not (eq size :byte)) (<= -128 src 127)) + ((or (integerp src) + (and (fixup-p src) (memq (fixup-flavor src) '(:layout-id)))) + (cond ((and (neq size :byte) (typep src '(signed-byte 8))) (emit-byte segment #b10000011) (emit-ea segment dst opcode) (emit-byte segment src)) - ((accumulator-p dst) - (emit-byte segment - (dpb opcode - (byte 3 3) - (if (eq size :byte) - #b00000100 - #b00000101))) - (emit-imm-operand segment src size)) (t - (emit-byte segment (if (eq size :byte) #b10000000 #b10000001)) - (emit-ea segment dst opcode) - (emit-imm-operand segment src size)))) + (cond ((accumulator-p dst) + (emit-byte segment + (dpb opcode + (byte 3 3) + (if (eq size :byte) + #b00000100 + #b00000101)))) + (t + (emit-byte segment (if (eq size :byte) #b10000000 #b10000001)) + (emit-ea segment dst opcode))) + (if (fixup-p src) + (emit-absolute-fixup segment src) + (emit-imm-operand segment src size))))) ((register-p src) (emit-byte segment (dpb opcode @@ -2529,6 +2532,46 @@ collect (prog1 (ldb (byte 8 0) val) (setf val (ash val -8)))))))))) +;;; This gets called by LOAD to resolve newly positioned objects +;;; with things (like code instructions) that have to refer to them. +;;; Return T if and only if the fixup needs to be recorded in %CODE-FIXUPS +(defun fixup-code-object (code offset value kind flavor) + (declare (type index offset)) + #+sb-xc-host (declare (notinline code-object-size)) ; forward ref + (sb-vm::with-code-instructions (sap code) + (ecase kind + (:absolute + (case flavor + (:layout-id + (setf (signed-sap-ref-32 sap offset) value) + nil) ; do not record this + (t + ;; Word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (let ((final-val (+ value (sap-ref-32 sap offset)))) + (setf (sap-ref-32 sap offset) final-val) + ;; Record absolute fixups that point into CODE itself, with one + ;; exception: fixups within the range of unboxed words containing + ;; jump tables are automatically adjusted if the code moves. + (and (sb-vm::self-referential-code-fixup-p final-val code) + (>= offset (ash (code-jump-table-words code) word-shift))))))) + (:relative + ;; VALUE is the actual address wanted. + ;; Replace word with displacement to get there. + (let* ((loc-sap (+ (sap-int sap) offset)) + ;; Use modular arithmetic so that if the offset + ;; doesn't fit into signed-byte-32 it'll wrap around + ;; when added to EIP. + ;; "-4" is for the number of remaining bytes in the current instruction. + ;; The CPU calculates based off the next instruction. + (rel-val (ldb (byte 32 0) (- value loc-sap 4)))) + (declare (type (unsigned-byte 32) loc-sap rel-val)) + (setf (sap-ref-32 sap offset) rel-val)) + ;; Record relative fixups pointing outside of this object. + (when (eq (sb-vm::containing-memory-space code) :dynamic) + (aver (not (sb-vm::self-referential-code-fixup-p value code))) + t))))) + ;;; Perform exhaustive analysis here because of the extreme degree ;;; of confusion I have about what is allowed to reach the instruction ;;; emitter as a raw fixup, a fixup wrapped in an EA, a label wrapped diff -Nru sbcl-2.0.6/src/compiler/x86/move.lisp sbcl-2.1.1/src/compiler/x86/move.lisp --- sbcl-2.0.6/src/compiler/x86/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -222,14 +222,14 @@ (:generator 4 (inst imul y x (ash 1 n-fixnum-tag-bits)) (inst jmp :no done) - (inst mov y (emit-constant (1+ sb-xc:most-positive-fixnum))) + (inst mov y (emit-constant (1+ most-positive-fixnum))) done)) (define-vop (move-from-fixnum-1 move-from-fixnum+1) (:generator 4 (inst imul y x (ash 1 n-fixnum-tag-bits)) (inst jmp :no done) - (inst mov y (emit-constant (1- sb-xc:most-negative-fixnum))) + (inst mov y (emit-constant (1- most-negative-fixnum))) done)) ;;; Convert an untagged unsigned word to a lispobj -- fixnum or bignum diff -Nru sbcl-2.0.6/src/compiler/x86/parms.lisp sbcl-2.1.1/src/compiler/x86/parms.lisp --- sbcl-2.0.6/src/compiler/x86/parms.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/parms.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -128,7 +128,7 @@ ;;; where to put the different spaces ;;; -;;; Note: Mostly these values are black magic, inherited from CMU CL +;;; Note: Mostly these values are magic, inherited from CMU CL ;;; without any documentation. However, there were a few explanatory ;;; comments in the CMU CL sources: ;;; * On Linux, diff -Nru sbcl-2.0.6/src/compiler/x86/system.lisp sbcl-2.1.1/src/compiler/x86/system.lisp --- sbcl-2.0.6/src/compiler/x86/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -48,15 +48,36 @@ word-shift) instance-pointer-lowtag) :base layout))) - (define-vop (sb-c::layout-depthoid-gt) - (:translate sb-c::layout-depthoid-gt) + (define-vop () + (:translate sb-c::layout-depthoid-ge) (:policy :fast-safe) (:args (layout :scs (descriptor-reg))) (:info k) (:arg-types * (:constant (unsigned-byte 16))) - (:conditional :g) + (:conditional :ge) (:generator 1 (inst cmp (read-depthoid) (fixnumize k))))) +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:info test) + (:policy :fast-safe) + (:conditional :e) + (:generator 1 + (inst cmp + (make-ea :dword + :disp (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0) + instance-slots-offset) + word-shift) + (ash (- (layout-depthoid test) 2) 2) + (- instance-pointer-lowtag)) + :base x) + (if (or (typep (layout-id test) '(and (signed-byte 8) (not (eql 0)))) + (not (sb-c::producing-fasl-file))) + (layout-id test) + (make-fixup test :layout-id))))) + (define-vop (%other-pointer-widetag) (:translate %other-pointer-widetag) (:policy :fast-safe) @@ -103,6 +124,19 @@ (load-type al-tn x (- other-pointer-lowtag)) (storew eax x 0 other-pointer-lowtag) (move res x))) + +(define-vop (test-header-bit) + (:translate test-header-bit) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg))) + (:arg-types t (:constant t)) + (:info mask) + (:conditional :ne) + (:generator 1 + ;; Assert that the mask is in header-data byte index 0 + ;; which is byte index 1 of the whole header word. + (aver (typep mask '(unsigned-byte 8))) + (inst test (make-ea :byte :disp (- 1 other-pointer-lowtag) :base array) mask))) (define-vop (pointer-hash) (:translate pointer-hash) diff -Nru sbcl-2.0.6/src/compiler/x86/type-vops.lisp sbcl-2.1.1/src/compiler/x86/type-vops.lisp --- sbcl-2.0.6/src/compiler/x86/type-vops.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/type-vops.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -179,7 +179,7 @@ ;; We could encode this with :Z and SHR, analogously to the signed-byte-32 ;; case below -- as we do on x86-64 -- but that costs us an extra ;; register. Compromises... - (inst cmp value #.sb-xc:most-positive-fixnum))) + (inst cmp value #.most-positive-fixnum))) (define-vop (fixnump/signed-byte-32 type-predicate) (:args (value :scs (signed-reg))) @@ -194,9 +194,9 @@ ;; is equivalent to unsigned ;; ((x-a) >> n) = 0 (inst mov eax-tn value) - (inst sub eax-tn #.sb-xc:most-negative-fixnum) - (inst shr eax-tn #.(integer-length (- sb-xc:most-positive-fixnum - sb-xc:most-negative-fixnum))))) + (inst sub eax-tn #.most-negative-fixnum) + (inst shr eax-tn #.(integer-length (- most-positive-fixnum + most-negative-fixnum))))) ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with ;;; exactly one digit. diff -Nru sbcl-2.0.6/src/compiler/x86/vm.lisp sbcl-2.1.1/src/compiler/x86/vm.lisp --- sbcl-2.0.6/src/compiler/x86/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -347,7 +347,7 @@ ;;; the appropriate SC number, otherwise return NIL. (defun immediate-constant-sc (value) (typecase value - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) (symbol diff -Nru sbcl-2.0.6/src/compiler/x86-64/alloc.lisp sbcl-2.1.1/src/compiler/x86-64/alloc.lisp --- sbcl-2.0.6/src/compiler/x86-64/alloc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -381,9 +381,9 @@ (length :scs (any-reg immediate)) (words :scs (any-reg immediate))) (:results (result :scs (descriptor-reg) :from :load)) - (:temporary (:sc any-reg :offset ecx-offset :from :eval) rcx) - (:temporary (:sc any-reg :offset eax-offset :from :eval) rax) - (:temporary (:sc any-reg :offset edi-offset :from :eval) rdi) + (:temporary (:sc any-reg :offset rcx-offset :from :eval) rcx) + (:temporary (:sc any-reg :offset rax-offset :from :eval) rax) + (:temporary (:sc any-reg :offset rdi-offset :from :eval) rdi) (:temporary (:sc complex-double-reg) zero) (:arg-types positive-fixnum positive-fixnum positive-fixnum) (:translate allocate-vector) @@ -606,33 +606,27 @@ (:results (result :scs (descriptor-reg))) (:node-var node) (:generator 50 - (let* ((instancep (typep type 'layout)) ; is this any instance? - (layoutp #+immobile-space - (eq type #.(find-layout 'layout))) ; " a new LAYOUT instance? + (let* ((instancep (typep type 'layout)) ; is this an instance type? (bytes (pad-data-block words))) (progn name) ; possibly not used - (unless (or stack-allocate-p layoutp) + (unless stack-allocate-p (instrument-alloc bytes node)) (pseudo-atomic (:elide-if stack-allocate-p) - (cond (layoutp - (invoke-asm-routine 'call 'alloc-layout node) - (inst mov result r11-tn)) - (t - ;; If storing a header word, defer ORing in the lowtag until after - ;; the header is written so that displacement can be 0. - (allocation nil bytes (if type 0 lowtag) node stack-allocate-p result) - (when type - (let* ((widetag (if instancep instance-widetag type)) - (header (logior (ash (1- words) (length-field-shift widetag)) widetag))) - (if (or #+compact-instance-header - (and (eq name '%make-structure-instance) stack-allocate-p)) - ;; Write a :DWORD, not a :QWORD, because the high half will be - ;; filled in when the layout is stored. Can't use STOREW* though, - ;; because it tries to store as few bytes as possible, - ;; where this instruction must write exactly 4 bytes. - (inst mov :dword (ea 0 result) header) - (storew* header result 0 0 (not stack-allocate-p))) - (inst or :byte result lowtag)))))) + ;; If storing a header word, defer ORing in the lowtag until after + ;; the header is written so that displacement can be 0. + (allocation nil bytes (if type 0 lowtag) node stack-allocate-p result) + (when type + (let* ((widetag (if instancep instance-widetag type)) + (header (compute-object-header words widetag))) + (if (or #+compact-instance-header + (and (eq name '%make-structure-instance) stack-allocate-p)) + ;; Write a :DWORD, not a :QWORD, because the high half will be + ;; filled in when the layout is stored. Can't use STOREW* though, + ;; because it tries to store as few bytes as possible, + ;; where this instruction must write exactly 4 bytes. + (inst mov :dword (ea 0 result) header) + (storew* header result 0 0 (not stack-allocate-p))) + (inst or :byte result lowtag)))) (when instancep ; store its layout (inst mov :dword (ea (+ 4 (- lowtag)) result) (make-fixup type :layout)))))) @@ -682,22 +676,26 @@ temp-reg-tn))))))) #+immobile-space (define-vop (alloc-immobile-fixedobj) - (:info lowtag size header) - (:temporary (:sc unsigned-reg :to :eval :offset rdi-offset) c-arg1) - (:temporary (:sc unsigned-reg :to :eval :offset rsi-offset) c-arg2) + (:args (size-class :scs (any-reg) :target c-arg1) + (nwords :scs (any-reg) :target c-arg2) + (header :scs (any-reg) :target c-arg3)) + (:temporary (:sc unsigned-reg :from (:argument 0) :to :eval :offset rdi-offset) c-arg1) + (:temporary (:sc unsigned-reg :from (:argument 1) :to :eval :offset rsi-offset) c-arg2) + (:temporary (:sc unsigned-reg :from (:argument 2) :to :eval :offset rdx-offset) c-arg3) (:temporary (:sc unsigned-reg :from :eval :to (:result 0) :offset rax-offset) c-result) (:results (result :scs (descriptor-reg))) (:node-var node) (:generator 50 - (inst mov c-arg1 size) - (inst mov c-arg2 header) + (inst mov c-arg1 size-class) + (inst mov c-arg2 nwords) + (inst mov c-arg3 header) ;; RSP needn't be restored because the allocators all return immediately ;; which has that effect (inst and rsp-tn -16) (pseudo-atomic () - (c-call "alloc_fixedobj") - (inst lea result (ea lowtag c-result))))) + (c-call "alloc_immobile_fixedobj") + (move result c-result)))) (define-vop (alloc-dynamic-space-code) (:args (total-words :scs (signed-reg) :target c-arg1)) diff -Nru sbcl-2.0.6/src/compiler/x86-64/arith.lisp sbcl-2.1.1/src/compiler/x86-64/arith.lisp --- sbcl-2.0.6/src/compiler/x86-64/arith.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/arith.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -482,9 +482,9 @@ (:args (x :scs (unsigned-reg) :target eax) (y :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num unsigned-num) - (:temporary (:sc unsigned-reg :offset eax-offset :target r + (:temporary (:sc unsigned-reg :offset rax-offset :target r :from (:argument 0) :to :result) eax) - (:temporary (:sc unsigned-reg :offset edx-offset + (:temporary (:sc unsigned-reg :offset rdx-offset :from :eval :to :result) edx) (:ignore edx) (:results (r :scs (unsigned-reg))) @@ -502,9 +502,9 @@ (:args (x :scs (unsigned-reg) :target eax)) (:info y) (:arg-types unsigned-num (:constant (unsigned-byte 64))) - (:temporary (:sc unsigned-reg :offset eax-offset :target r + (:temporary (:sc unsigned-reg :offset rax-offset :target r :from (:argument 0) :to :result) eax) - (:temporary (:sc unsigned-reg :offset edx-offset + (:temporary (:sc unsigned-reg :offset rdx-offset :from :eval :to :result) edx) (:ignore edx) (:results (r :scs (unsigned-reg))) @@ -524,9 +524,9 @@ (y :scs (any-reg control-stack))) (:args-var args) (:arg-types tagged-num tagged-num) - (:temporary (:sc signed-reg :offset eax-offset :target quo + (:temporary (:sc signed-reg :offset rax-offset :target quo :from (:argument 0) :to (:result 0)) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :target rem + (:temporary (:sc unsigned-reg :offset rdx-offset :target rem :from (:argument 0) :to (:result 1)) edx) (:results (quo :scs (any-reg)) (rem :scs (any-reg))) @@ -556,9 +556,9 @@ (:args (x :scs (any-reg) :target eax)) (:info y) (:arg-types tagged-num (:constant fixnum)) - (:temporary (:sc signed-reg :offset eax-offset :target quo + (:temporary (:sc signed-reg :offset rax-offset :target quo :from :argument :to (:result 0)) eax) - (:temporary (:sc any-reg :offset edx-offset :target rem + (:temporary (:sc any-reg :offset rdx-offset :target rem :from :eval :to (:result 1)) edx) (:temporary (:sc any-reg :from :eval :to :result) y-arg) (:results (quo :scs (any-reg)) @@ -585,9 +585,9 @@ (y :scs (unsigned-reg signed-stack))) (:arg-types unsigned-num unsigned-num) (:args-var args) - (:temporary (:sc unsigned-reg :offset eax-offset :target quo + (:temporary (:sc unsigned-reg :offset rax-offset :target quo :from (:argument 0) :to (:result 0)) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :target rem + (:temporary (:sc unsigned-reg :offset rdx-offset :target rem :from (:argument 0) :to (:result 1)) edx) (:results (quo :scs (unsigned-reg)) (rem :scs (unsigned-reg))) @@ -613,9 +613,9 @@ (:args (x :scs (unsigned-reg) :target eax)) (:info y) (:arg-types unsigned-num (:constant (unsigned-byte 64))) - (:temporary (:sc unsigned-reg :offset eax-offset :target quo + (:temporary (:sc unsigned-reg :offset rax-offset :target quo :from :argument :to (:result 0)) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :target rem + (:temporary (:sc unsigned-reg :offset rdx-offset :target rem :from :eval :to (:result 1)) edx) (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg) (:results (quo :scs (unsigned-reg)) @@ -638,9 +638,9 @@ (y :scs (signed-reg signed-stack))) (:args-var args) (:arg-types signed-num signed-num) - (:temporary (:sc signed-reg :offset eax-offset :target quo + (:temporary (:sc signed-reg :offset rax-offset :target quo :from (:argument 0) :to (:result 0)) eax) - (:temporary (:sc signed-reg :offset edx-offset :target rem + (:temporary (:sc signed-reg :offset rdx-offset :target rem :from (:argument 0) :to (:result 1)) edx) (:results (quo :scs (signed-reg)) (rem :scs (signed-reg))) @@ -666,9 +666,9 @@ (:args (x :scs (signed-reg) :target eax)) (:info y) (:arg-types signed-num (:constant (signed-byte 64))) - (:temporary (:sc signed-reg :offset eax-offset :target quo + (:temporary (:sc signed-reg :offset rax-offset :target quo :from :argument :to (:result 0)) eax) - (:temporary (:sc signed-reg :offset edx-offset :target rem + (:temporary (:sc signed-reg :offset rdx-offset :target rem :from :eval :to (:result 1)) edx) (:temporary (:sc signed-reg :from :eval :to :result) y-arg) (:results (quo :scs (signed-reg)) @@ -742,7 +742,7 @@ (location= number result)))) (amount :scs (unsigned-reg) :target ecx)) (:arg-types tagged-num positive-fixnum) - (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) ecx) (:results (result :scs (any-reg) :from (:argument 0) :load-if (not (and (sc-is number control-stack) (sc-is result control-stack) @@ -837,7 +837,7 @@ (location= number result)))) (amount :scs (unsigned-reg) :target ecx)) (:arg-types signed-num positive-fixnum) - (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) ecx) (:results (result :scs (signed-reg) :from (:argument 0) :load-if (not (and (sc-is number signed-stack) (sc-is result signed-stack) @@ -858,7 +858,7 @@ (location= number result)))) (amount :scs (unsigned-reg) :target ecx)) (:arg-types unsigned-num positive-fixnum) - (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) ecx) (:results (result :scs (unsigned-reg) :from (:argument 0) :load-if (not (and (sc-is number unsigned-stack) (sc-is result unsigned-stack) @@ -891,7 +891,7 @@ (:arg-types signed-num signed-num) (:results (result :scs (signed-reg) :from (:argument 0))) (:result-types signed-num) - (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) ecx) (:note "inline ASH") (:generator 5 (move result number) @@ -920,7 +920,7 @@ (:arg-types unsigned-num signed-num) (:results (result :scs (unsigned-reg) :from (:argument 0))) (:result-types unsigned-num) - (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) ecx) (:note "inline ASH") (:generator 5 (move result number) @@ -1051,7 +1051,7 @@ (:arg-types unsigned-num signed-num) (:results (result :scs (unsigned-reg) :from (:argument 0))) (:result-types unsigned-num) - (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) ecx) (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero) (:note "inline ASH") (:guard (member :cmov *backend-subfeatures*)) @@ -1180,41 +1180,35 @@ (:policy :fast-safe)) (define-vop (fast-conditional/fixnum fast-conditional) - (:args (x :scs (any-reg) - :load-if (not (and (sc-is x control-stack) - (sc-is y any-reg)))) + (:args (x :scs (any-reg control-stack)) (y :scs (any-reg control-stack))) (:arg-types tagged-num tagged-num) (:note "inline fixnum comparison")) (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg) :load-if t)) + (:args (x :scs (any-reg control-stack))) (:arg-types tagged-num (:constant fixnum)) (:info y)) (define-vop (fast-conditional/signed fast-conditional) - (:args (x :scs (signed-reg) - :load-if (not (and (sc-is x signed-stack) - (sc-is y signed-reg)))) + (:args (x :scs (signed-reg signed-stack)) (y :scs (signed-reg signed-stack))) (:arg-types signed-num signed-num) (:note "inline (signed-byte 64) comparison")) (define-vop (fast-conditional-c/signed fast-conditional/signed) - (:args (x :scs (signed-reg) :load-if t)) + (:args (x :scs (signed-reg signed-stack))) (:arg-types signed-num (:constant (signed-byte 64))) (:info y)) (define-vop (fast-conditional/unsigned fast-conditional) - (:args (x :scs (unsigned-reg) - :load-if (not (and (sc-is x unsigned-stack) - (sc-is y unsigned-reg)))) + (:args (x :scs (unsigned-reg unsigned-stack)) (y :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num unsigned-num) (:note "inline (unsigned-byte 64) comparison")) (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) - (:args (x :scs (unsigned-reg) :load-if t)) + (:args (x :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num (:constant (unsigned-byte 64))) (:info y)) @@ -1298,37 +1292,16 @@ (inst test :byte `(,x . :high-byte) (ash y -8)) (inst test size x y)))))) -;; Stolen liberally from the x86 32-bit implementation. (macrolet ((define-logtest-vops () `(progn ,@(loop for suffix in '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - ;; FIXME: remove, after changing the ancestor vops - ;; to not pessimize their allowable SCs - for scs = (case (let ((s (string suffix))) - (intern (subseq s (1+ (position #\/ s))))) - (fixnum '(any-reg control-stack)) - (signed '(signed-reg signed-stack)) - (unsigned '(unsigned-reg unsigned-stack))) - ;; for cost in '(4 3 6 5 6 5) collect `(define-vop (,(symbolicate "FAST-LOGTEST" suffix) ,(symbolicate "FAST-CONDITIONAL" suffix)) (:translate logtest) - ;; Simplify the lambda made by MAKE-GENERATOR-FUNCTION: - ;; LOAD-IF can be NIL because the only alternate SCs to - ;; register SCs are stack SCs. And since we're pretending - ;; that the CPU can directly receive two stack operands, - ;; loading would just check that each argument individually - ;; is either in a register or on the stack - which it is - - ;; and do nothing. - (:args (x :scs ,scs :load-if nil) - ,@(unless (search "-C/" (string suffix)) `((y :scs ,scs :load-if nil)))) - ;; This temp spec is just being cautious. TEMP-REG-TN is reserved - (:temporary (:sc unsigned-reg :offset #.(tn-offset temp-reg-tn)) scratch) - (:ignore scratch) (:conditional :ne) (:generator ,cost (emit-optimized-test-inst x @@ -1336,6 +1309,77 @@ nil))))))) (define-logtest-vops)) +;;; This works for tagged or untagged values, but the vop optimizer +;;; has to pre-adjust Y if tagged. +(define-vop (logtest-instance-ref fast-conditional) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant integer)) + (:info y) + (:args-var arg-ref) + (:conditional :ne) + (:generator 1 + (let ((disp (cdr (tn-ref-memory-access arg-ref)))) + ;; Try as :BYTE, :WORD, :DWORD + (macrolet ((try (size bits) + `(let ((disp disp) (y y) (mask ,(ldb (byte bits 0) -1))) + (dotimes (i ,(/ 64 bits)) + (when (zerop (logandc2 y mask)) + (inst test ,size (ea disp x) (ash y (* i ,(- bits)))) + (return-from logtest-instance-ref)) + (setq mask (ash mask ,bits)) + (incf disp ,(/ bits 8)))))) + (try :byte 8) + (try :word 16) + (try :dword 32)) + (let ((val (ea disp x)) + (y (constantize y))) + (cond ((integerp y) + (inst test :qword val y)) + (t + (inst mov temp-reg-tn val) + (inst test :qword temp-reg-tn y))))))) + +;;; Try to absorb a memory load into LOGTEST. +;;; This removes one instruction and possibly shortens the TEST by eliding +;;; a REX prefix. +(defoptimizer (sb-c::vop-optimize fast-logtest-c/fixnum) (vop) + (unless (tn-ref-memory-access (sb-c::vop-args vop)) + (let ((prev (sb-c::previous-vop-is + vop '(raw-instance-ref-c/signed-word + raw-instance-ref-c/word + instance-index-ref-c + ;; This would only happen in unsafe code most likely, + ;; because CAR,CDR, etc would need to cast/assert the loaded + ;; value to fixnum. However, in practive it doesn't work anyway + ;; because there seems to be a spurious MOVE vop in between + ;; the SLOT and the FAST-LOGTEST-C/FIXNUM. + slot)))) + (aver (not (sb-c::vop-results vop))) ; is a :CONDITIONAL vop + (when (and prev (eq (vop-block prev) (vop-block vop))) + (let ((arg (sb-c::vop-args vop))) + (when (and (eq (tn-ref-tn (sb-c::vop-results prev)) (tn-ref-tn arg)) + (sb-c::very-temporary-p (tn-ref-tn arg))) + (binding* ((mem-op (cons (vop-name prev) (vop-codegen-info prev))) + (disp (valid-memref-byte-disp mem-op) :exit-if-null) + (arg-ref + (sb-c::reference-tn (tn-ref-tn (sb-c::vop-args prev)) nil)) + (codegen-info + (if (eq (vop-name vop) 'fast-logtest-c/fixnum) + (list (fixnumize (car (vop-codegen-info vop)))) + (vop-codegen-info vop))) + (new (sb-c::emit-and-insert-vop + (sb-c::vop-node vop) (vop-block vop) + (template-or-lose 'logtest-instance-ref) + arg-ref nil prev codegen-info))) + (setf (tn-ref-memory-access arg-ref) `(:read . ,disp)) + (sb-c::delete-vop prev) + (sb-c::delete-vop vop) + new))))))) +(setf (sb-c::vop-info-optimizer (template-or-lose 'fast-logtest-c/signed)) + #'vop-optimize-fast-logtest-c/fixnum-optimizer) +(setf (sb-c::vop-info-optimizer (template-or-lose 'fast-logtest-c/unsigned)) + #'vop-optimize-fast-logtest-c/fixnum-optimizer) + ;;; %LOGBITP has the same argument order as ordinary LOGBITP which is * backwards * ;;; relative to every other architecture. ;;; I suspect the others have a predilection for placing codegen info args last. @@ -1407,23 +1451,14 @@ `(progn ,@(mapcar (lambda (suffix cost signed) - (let ((scs (case (let ((s (string suffix))) - (intern (subseq s (1+ (position #\/ s))))) - (fixnum '(any-reg control-stack)) - (signed '(signed-reg signed-stack)) - (unsigned '(unsigned-reg unsigned-stack))))) `(define-vop (,(symbolicate "FAST-IF-" tran suffix) ,(symbolicate "FAST-CONDITIONAL" suffix)) - (:args (x :scs ,scs :load-if nil) - ,@(unless (search "-C/" (string suffix)) - `((y :scs ,scs :load-if nil)))) (:translate ,tran) (:conditional ,(if signed cond unsigned)) (:generator ,cost (emit-optimized-cmp - x ,(if (eq suffix '-c/fixnum) `(fixnumize y) 'y)))))) + x ,(if (eq suffix '-c/fixnum) `(fixnumize y) 'y))))) '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) -; '(/fixnum /signed /unsigned) '(4 3 6 5 6 5) '(t t t t nil nil))))) @@ -1494,29 +1529,19 @@ (define-vop (fast-if-eql/signed fast-conditional/signed) (:translate eql %eql/integer) - (:generator 6 - (inst cmp x y))) + (:generator 6 (emit-optimized-cmp x y))) (define-vop (fast-if-eql-c/signed fast-conditional-c/signed) (:translate eql %eql/integer) - (:generator 5 - (cond ((and (sc-is x signed-reg) (zerop y)) - (inst test x x)) ; smaller instruction - (t - (inst cmp x (constantize y)))))) + (:generator 5 (emit-optimized-cmp x y))) (define-vop (fast-if-eql/unsigned fast-conditional/unsigned) (:translate eql %eql/integer) - (:generator 6 - (inst cmp x y))) + (:generator 6 (emit-optimized-cmp x y))) (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned) (:translate eql %eql/integer) - (:generator 5 - (cond ((and (sc-is x unsigned-reg) (zerop y)) - (inst test x x)) ; smaller instruction - (t - (inst cmp x (constantize y)))))) + (:generator 5 (emit-optimized-cmp x y))) ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a ;;; known fixnum. @@ -1528,69 +1553,54 @@ ;;; consing the argument. (define-vop (fast-eql/fixnum fast-conditional) - (:args (x :scs (any-reg) - :load-if (not (and (sc-is x control-stack) - (sc-is y any-reg)))) + (:args (x :scs (any-reg control-stack)) (y :scs (any-reg control-stack))) (:arg-types tagged-num tagged-num) (:note "inline fixnum comparison") (:translate eql %eql/integer) - (:generator 4 - (inst cmp x y))) + (:generator 4 (emit-optimized-cmp x y))) (define-vop (generic-eql/fixnum fast-eql/fixnum) - (:args (x :scs (any-reg descriptor-reg) - :load-if (not (and (sc-is x control-stack) - (sc-is y any-reg)))) + (:args (x :scs (any-reg descriptor-reg control-stack)) (y :scs (any-reg control-stack))) (:arg-types * tagged-num) (:variant-cost 7)) (define-vop (fast-eql-c/fixnum fast-conditional-c/fixnum) - (:args (x :scs (any-reg) :load-if t)) + (:args (x :scs (any-reg control-stack))) (:arg-types tagged-num (:constant fixnum)) (:info y) (:conditional :e) (:policy :fast-safe) (:translate eql %eql/integer) - (:generator 2 - (cond ((and (sc-is x any-reg descriptor-reg) (zerop y)) - (inst test x x)) ; smaller instruction - (t - (inst cmp x (constantize (fixnumize y))))))) + (:generator 2 (emit-optimized-cmp x (fixnumize y)))) +;;; FIXME: this seems never to be invoked any more. What did we either break or improve? (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) - (:args (x :scs (any-reg descriptor-reg) :load-if t)) + (:args (x :scs (any-reg descriptor-reg control-stack))) (:arg-types * (:constant fixnum)) (:variant-cost 6)) ;;;; 64-bit logical operations ;;; Only the lower 6 bits of the shift amount are significant. -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg) :target r) - (amount :scs (signed-reg) :target ecx)) - (:arg-types unsigned-num tagged-num) - (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) - (:results (r :scs (unsigned-reg) :from (:argument 0))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (move r num) - (move ecx amount) - (inst shr r :cl))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (move r num) - (move ecx amount) - (inst shl r :cl))) +(macrolet ((define (translate operation) + `(define-vop () + (:translate ,translate) + (:note ,(string translate)) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg) :target r) + (amount :scs (signed-reg) :target rcx)) + (:arg-types unsigned-num tagged-num) + (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx) + (:results (r :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num) + (:generator 1 + (move r num) + (unless (location= rcx amount) (inst mov :dword rcx amount)) + (inst ,operation r :cl))))) + (define shift-towards-start shr) + (define shift-towards-end shl)) ;;;; Modular functions @@ -1858,14 +1868,16 @@ (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp) (:results (result :scs (unsigned-reg) :from (:argument 0)) (carry :scs (unsigned-reg))) + (:optional-results carry) (:result-types unsigned-num positive-fixnum) (:generator 4 (move result a) (move temp c) (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1 (inst adc result b) - (inst set carry :c) - (inst and :dword carry 1))) + (unless (eq (tn-kind carry) :unused) + (inst set carry :c) + (inst and :dword carry 1)))) ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite ;;; of the x86-64 convention. @@ -1878,14 +1890,15 @@ (:arg-types unsigned-num unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg) :from :eval) (borrow :scs (unsigned-reg))) + (:optional-results borrow) (:result-types unsigned-num positive-fixnum) (:generator 5 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0 (move result a) (inst sbb result b) - (inst mov borrow 1) - (inst sbb :dword borrow 0))) - + (unless (eq (tn-kind borrow) :unused) + (inst mov borrow 1) + (inst sbb :dword borrow 0)))) (define-vop (bignum-mult-and-add-3-arg) (:translate sb-bignum:%multiply-and-add) @@ -1894,9 +1907,9 @@ (y :scs (unsigned-reg unsigned-stack)) (carry-in :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num unsigned-num unsigned-num) - (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0) :to (:result 1) :target lo) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1) :to (:result 0) :target hi) edx) (:results (hi :scs (unsigned-reg)) (lo :scs (unsigned-reg))) @@ -1917,9 +1930,9 @@ (prev :scs (unsigned-reg unsigned-stack)) (carry-in :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) - (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0) :to (:result 1) :target lo) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1) :to (:result 0) :target hi) edx) (:results (hi :scs (unsigned-reg)) (lo :scs (unsigned-reg))) @@ -1941,9 +1954,9 @@ (:args (x :scs (unsigned-reg) :target eax) (y :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num unsigned-num) - (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0) :to (:result 1) :target lo) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1) :to (:result 0) :target hi) edx) (:results (hi :scs (unsigned-reg)) (lo :scs (unsigned-reg))) @@ -1960,9 +1973,9 @@ (:args (x :scs (unsigned-reg) :target eax) (y :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num unsigned-num) - (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1) :to (:result 0) :target hi) edx) (:results (hi :scs (unsigned-reg))) (:result-types unsigned-num) @@ -1977,8 +1990,8 @@ (:args (x :scs (any-reg) :target eax) (y :scs (unsigned-reg unsigned-stack))) (:arg-types positive-fixnum unsigned-num) - (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax) - (:temporary (:sc any-reg :offset edx-offset :from (:argument 1) + (:temporary (:sc any-reg :offset rax-offset :from (:argument 0)) eax) + (:temporary (:sc any-reg :offset rdx-offset :from (:argument 1) :to (:result 0) :target hi) edx) (:results (hi :scs (any-reg))) (:result-types positive-fixnum) @@ -1988,6 +2001,23 @@ (move hi edx) (inst and hi (lognot fixnum-tag-mask)))) +(define-vop () + (:translate %signed-multiply-high) + (:policy :fast-safe) + (:args (x :scs (signed-reg) :target eax) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:temporary (:sc signed-reg :offset rax-offset :from (:argument 0)) + eax) + (:temporary (:sc signed-reg :offset rdx-offset :from (:argument 1) + :to (:result 0) :target hi) edx) + (:results (hi :scs (signed-reg))) + (:result-types signed-num) + (:generator 20 + (move eax x) + (inst imul y) + (move hi edx))) + (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned) (:translate sb-bignum:%lognot)) @@ -2012,9 +2042,9 @@ (div-low :scs (unsigned-reg) :target eax) (divisor :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num unsigned-num unsigned-num) - (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1) + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1) :to (:result 0) :target quo) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0) + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 0) :to (:result 1) :target rem) edx) (:results (quo :scs (unsigned-reg)) (rem :scs (unsigned-reg))) @@ -2047,7 +2077,7 @@ (:args (digit :scs (unsigned-reg unsigned-stack) :target result) (count :scs (unsigned-reg) :target ecx)) (:arg-types unsigned-num positive-fixnum) - (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) ecx) (:results (result :scs (unsigned-reg) :from (:argument 0) :load-if (not (and (sc-is result unsigned-stack) (location= digit result))))) diff -Nru sbcl-2.0.6/src/compiler/x86-64/array.lisp sbcl-2.1.1/src/compiler/x86-64/array.lisp --- sbcl-2.0.6/src/compiler/x86-64/array.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/array.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -33,8 +33,10 @@ (ea (+ (* array-dimensions-offset n-word-bytes) lowtag-mask) nil rank (ash 1 (- word-shift n-fixnum-tag-bits)))) (inst and :dword bytes (lognot lowtag-mask)) - (inst lea :dword header (ea (fixnumize (1- array-dimensions-offset)) rank)) - (inst shl :dword header n-widetag-bits) + ;; rank 1 is stored as 0, 2 is stored as 1, ... + (inst lea :dword header (ea (fixnumize -1) rank)) + (inst and :dword header (fixnumize array-rank-mask)) + (inst shl :dword header array-rank-byte-pos) (inst or :dword header type) (inst shr :dword header n-fixnum-tag-bits) (instrument-alloc bytes node) @@ -42,27 +44,6 @@ (allocation nil bytes 0 node nil result) (storew header result 0 0) (inst or :byte result other-pointer-lowtag)))) - -(define-vop (make-array-header/c) - (:translate make-array-header) - (:policy :fast-safe) - (:arg-types (:constant t) (:constant t)) - (:info type rank) - (:results (result :scs (descriptor-reg) :from :eval)) - (:node-var node) - (:generator 12 - (let* ((header-size (+ rank - (1- array-dimensions-offset))) - (bytes (* (align-up (1+ header-size) 2) n-word-bytes)) - (header (logior (ash header-size - n-widetag-bits) - type))) - (instrument-alloc bytes node) - (pseudo-atomic () - (allocation nil bytes 0 node nil result) - (storew* header result 0 0 t) - (inst or :byte result other-pointer-lowtag))))) - ;;;; additional accessors and setters for the array header (define-full-reffer %array-dimension * @@ -73,31 +54,15 @@ array-dimensions-offset other-pointer-lowtag (any-reg) positive-fixnum %set-array-dimension) -(define-vop (array-rank-vop) +(define-vop () (:translate %array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 3 - ;; An unaligned dword read not spanning a 16-byte boundary is as fast as - ;; and shorter by 5 bytes than a qword read and right-shift by 8. - (inst mov :dword res (ea (1+ (- other-pointer-lowtag)) x)) - (inst sub :dword res (1- array-dimensions-offset)))) - -(define-vop (array-rank-vop=>fixnum) - (:translate %array-rank) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:generator 2 - (inst mov :dword res (ea (1+ (- other-pointer-lowtag)) x)) - (inst lea :dword res - (let ((scale (ash 1 n-fixnum-tag-bits))) - ;; Compute [res*N-disp]. for N=2 use [res+res-disp] - (ea (- (* scale (1- array-dimensions-offset))) - (if (= scale 2) res nil) res (if (= scale 2) 1 scale)))))) + (inst movzx '(:byte :dword) res (ea (- 2 other-pointer-lowtag) x)) + (inst inc :byte res))) (define-vop () (:translate %array-rank=) @@ -107,10 +72,8 @@ (:arg-types * (:constant t)) (:conditional :e) (:generator 2 - (inst cmp :dword - (ea (1+ (- other-pointer-lowtag)) array) - (+ rank - (1- array-dimensions-offset))))) + (inst cmp :byte (ea (- 2 other-pointer-lowtag) array) + (encode-array-rank rank)))) ;;;; bounds checking routine (define-vop (check-bound) @@ -296,7 +259,7 @@ (:arg-types ,type positive-fixnum (:constant (integer 0 0))) (:results (result :scs (unsigned-reg) :from (:argument 0))) (:result-types positive-fixnum) - (:temporary (:sc unsigned-reg :offset ecx-offset) ecx) + (:temporary (:sc unsigned-reg :offset rcx-offset) ecx) (:generator 20 (aver (zerop offset)) (move ecx index) @@ -346,7 +309,7 @@ (:result-types positive-fixnum) (:temporary (:sc unsigned-reg) word-index) (:temporary (:sc unsigned-reg) old) - (:temporary (:sc unsigned-reg :offset ecx-offset) ecx) + (:temporary (:sc unsigned-reg :offset rcx-offset) ecx) (:generator 25 (aver (zerop offset)) (move word-index index) @@ -856,7 +819,8 @@ (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 4 - (inst xadd (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - array index (ash 1 (- word-shift n-fixnum-tag-bits))) - diff :lock) + (inst xadd :lock + (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + array index (ash 1 (- word-shift n-fixnum-tag-bits))) + diff) (move result diff))) diff -Nru sbcl-2.0.6/src/compiler/x86-64/avx2-insts.lisp sbcl-2.1.1/src/compiler/x86-64/avx2-insts.lisp --- sbcl-2.0.6/src/compiler/x86-64/avx2-insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/avx2-insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -895,13 +895,13 @@ (define-instruction vzeroupper (segment) (:printer vex2-op ((op #x77) (l 0) (r 1) (pp 0))) (:emitter - (emit-two-byte-vex segment 0 #b1111 0 nil) + (emit-two-byte-vex segment 0 0 0 nil) (emit-byte segment #x77))) (define-instruction vzeroall (segment) (:printer vex2-op ((op #x77) (l 1) (r 1) (pp 0))) (:emitter - (emit-two-byte-vex segment 0 #b1111 1 nil) + (emit-two-byte-vex segment 0 0 1 nil) (emit-byte segment #x77))) (macrolet ((def (name opcode &optional l (mem-size :qword)) diff -Nru sbcl-2.0.6/src/compiler/x86-64/call.lisp sbcl-2.1.1/src/compiler/x86-64/call.lisp --- sbcl-2.0.6/src/compiler/x86-64/call.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/call.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -473,7 +473,7 @@ (emit-label trampoline-label) (popw rbp-tn (frame-word-offset return-pc-save-offset))) (when alignp - (emit-alignment n-lowtag-bits :long-nop)) + (emit-alignment n-lowtag-bits alignp)) (emit-label start-label)) ;;; Non-TR local call for a fixed number of values passed according to diff -Nru sbcl-2.0.6/src/compiler/x86-64/c-call.lisp sbcl-2.1.1/src/compiler/x86-64/c-call.lisp --- sbcl-2.0.6/src/compiler/x86-64/c-call.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/c-call.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -73,8 +73,8 @@ (defun result-reg-offset (slot) (ecase slot - (0 eax-offset) - (1 edx-offset))) + (0 rax-offset) + (1 rdx-offset))) (define-alien-type-method (integer :result-tn) (type state) (let ((num-results (result-state-num-results state))) @@ -124,7 +124,7 @@ (collect ((arg-tns)) (dolist (arg-type (alien-fun-type-arg-types type)) (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) - (values (make-wired-tn* 'positive-fixnum any-reg-sc-number esp-offset) + (values (make-wired-tn* 'positive-fixnum any-reg-sc-number rsp-offset) (* (arg-state-stack-frame-size arg-state) n-word-bytes) (arg-tns) (invoke-alien-type-method :result-tn @@ -200,6 +200,11 @@ (defknown sign-extend ((signed-byte 64) t) fixnum (foldable flushable movable)) +(defoptimizer (sign-extend derive-type) ((x size)) + (declare (ignore x)) + (when (sb-c::constant-lvar-p size) + (specifier-type `(signed-byte ,(sb-c::lvar-value size))))) + (define-vop (sign-extend) (:translate sign-extend) (:policy :fast-safe) @@ -246,6 +251,12 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun destroyed-c-registers () + ;; Safepoints do not save interrupt contexts to be scanned during + ;; GCing, it only looks at the stack, so if a register isn't + ;; spilled it won't be visible to the GC. + #+sb-safepoint + '((:save-p t)) + #-sb-safepoint (let ((gprs (list rcx-offset rdx-offset #-win32 rsi-offset #-win32 rdi-offset r8-offset r9-offset r10-offset r11-offset)) @@ -300,6 +311,11 @@ ;; GC understands #+sb-safepoint (let ((label (gen-label))) + ;; This looks unnecessary. GC can look at the stack word physically below + ;; the CSP-around-foreign-call, which must be a PC pointing into the lisp caller. + ;; A more interesting question would arise if we had callee-saved registers + ;; within lisp code, which we don't at the moment. If we did, those + ;; wouldn't be anywhere on the stack unless C code decides to save them. (inst lea rax (rip-relative-ea label)) (emit-label label) (move pc-save rax)) @@ -320,26 +336,31 @@ while tn-ref count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref)))) 'float-registers)))) + + ;; Store SP in thread struct, unless the enclosing block says not to #+sb-safepoint - ;; Store SP in thread struct - (storew rsp-tn thread-base-tn thread-saved-csp-offset) + (when (policy (sb-c::vop-node vop) (/= sb-c:insert-safepoints 0)) + (storew rsp-tn thread-base-tn thread-saved-csp-offset)) + #+win32 (inst sub rsp-tn #x20) ;MS_ABI: shadow zone + ;; From immobile space we use the "CALL rel32" format to the linkage ;; table jump, and from dynamic space we use "CALL [ea]" format ;; where ea is the address of the linkage table entry's operand. ;; So while the former is a jump to a jump, we can optimize out ;; one jump in a statically linked executable. - (inst call (cond ((tn-p fun) fun) ((sb-c::code-immobile-p vop) (make-fixup fun :foreign)) (t (ea (make-fixup fun :foreign 8))))) ;; For the undefined alien error (note-this-location vop :internal-error) #+win32 (inst add rsp-tn #x20) ;MS_ABI: remove shadow space + + ;; Zero the saved CSP, unless this code shouldn't ever stop for GC #+sb-safepoint - ;; Zero the saved CSP - (inst xor (object-slot-ea thread-base-tn thread-saved-csp-offset 0) - rsp-tn)) + (when (policy (sb-c::vop-node vop) (/= sb-c:insert-safepoints 0)) + (inst xor (object-slot-ea thread-base-tn thread-saved-csp-offset 0) + rsp-tn))) (define-vop (alloc-number-stack-space) (:info amount) diff -Nru sbcl-2.0.6/src/compiler/x86-64/cell.lisp sbcl-2.1.1/src/compiler/x86-64/cell.lisp --- sbcl-2.0.6/src/compiler/x86-64/cell.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/cell.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -89,8 +89,7 @@ (:results (result :scs (descriptor-reg any-reg))) (:generator 5 (move rax old) - (inst cmpxchg (ea (- (* offset n-word-bytes) lowtag) object) - new :lock) + (inst cmpxchg :lock (ea (- (* offset n-word-bytes) lowtag) object) new) (move result rax))) ;;;; symbol hacking VOPs @@ -193,10 +192,10 @@ (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))) #+sb-thread (progn (compute-virtual-symbol) (move rax old) - (inst cmpxchg (symbol-value-slot-ea cell) new :lock)) + (inst cmpxchg :lock (symbol-value-slot-ea cell) new)) #-sb-thread (progn (move rax old) ;; is the :LOCK is necessary? - (inst cmpxchg (symbol-value-slot-ea symbol) new :lock)) + (inst cmpxchg :lock (symbol-value-slot-ea symbol) new)) (inst cmp :byte rax unbound-marker-widetag) (inst jmp :e unbound) (move result rax)))) @@ -212,11 +211,11 @@ (:policy :fast-safe) (:generator 10 (move rax old) - (inst cmpxchg + (inst cmpxchg :lock (if (sc-is symbol immediate) (symbol-slot-ea (tn-value symbol) symbol-value-slot) (symbol-value-slot-ea symbol)) - new :lock) + new) (move result rax))) #+sb-thread @@ -880,7 +879,7 @@ (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 5 - (inst xadd (instance-slot-ea object index) diff :lock) + (inst xadd :lock (instance-slot-ea object index) diff) (move result diff))) (define-vop (raw-instance-atomic-incf-c/word) @@ -896,7 +895,7 @@ (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 4 - (inst xadd (instance-slot-ea object index) diff :lock) + (inst xadd :lock (instance-slot-ea object index) diff) (move result diff)))) ;;;; @@ -912,7 +911,7 @@ (move rdx old-hi) (move rbx new-lo) (move rcx new-hi) - (inst cmpxchg16b memory-operand :lock) + (inst cmpxchg16b :lock memory-operand) ;; RDX:RAX hold the actual old contents of memory. ;; Manually analyze result lifetimes to avoid clobbering. (cond ((and (location= result-lo rdx) (location= result-hi rax)) @@ -937,13 +936,13 @@ (new-hi :scs (descriptor-reg any-reg) :target ecx)) (:results (result-lo :scs (descriptor-reg any-reg)) (result-hi :scs (descriptor-reg any-reg))) - (:temporary (:sc unsigned-reg :offset eax-offset + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 2) :to (:result 0)) eax) - (:temporary (:sc unsigned-reg :offset edx-offset + (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 3) :to (:result 0)) edx) - (:temporary (:sc unsigned-reg :offset ebx-offset + (:temporary (:sc unsigned-reg :offset rbx-offset :from (:argument 4) :to (:result 0)) ebx) - (:temporary (:sc unsigned-reg :offset ecx-offset + (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 5) :to (:result 0)) ecx) (:generator 7 (generate-dblcas ,memory-operand diff -Nru sbcl-2.0.6/src/compiler/x86-64/char.lisp sbcl-2.1.1/src/compiler/x86-64/char.lisp --- sbcl-2.0.6/src/compiler/x86-64/char.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/char.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -56,7 +56,7 @@ (assert (not (logbitp 7 character-widetag)))) (define-vop (tagged-char-code) ; valid only if N-FIXNUM-TAG-BITS = 1 (:args (x :scs (any-reg descriptor-reg control-stack) :target y :load-if nil)) - (:results (y :scs (any-reg control-stack) :load-if nil)) + (:results (y :scs (any-reg descriptor-reg control-stack) :load-if nil)) (:note "character untagging") (:generator 1 (untagify-char y x (- n-widetag-bits n-fixnum-tag-bits)) @@ -108,7 +108,7 @@ (character-reg (move y x)) (character-stack - (if (= (tn-offset fp) esp-offset) + (if (= (tn-offset fp) rsp-offset) (storew x fp (tn-offset y)) ; c-call (storew x fp (frame-word-offset (tn-offset y)))))))) (define-move-vop move-character-arg :move-arg @@ -150,7 +150,7 @@ (:policy :fast-safe) (:note "inline comparison") (:generator 3 - (inst cmp x y))) + (inst cmp :dword x y))) (define-vop (fast-char=/character character-compare) (:translate char=) @@ -171,7 +171,7 @@ (:policy :fast-safe) (:note "inline constant comparison") (:generator 2 - (inst cmp x (sb-xc:char-code y)))) + (inst cmp :dword x (sb-xc:char-code y)))) (define-vop (fast-char=/character/c character-compare/c) (:translate char=) diff -Nru sbcl-2.0.6/src/compiler/x86-64/float.lisp sbcl-2.1.1/src/compiler/x86-64/float.lisp --- sbcl-2.0.6/src/compiler/x86-64/float.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/float.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -112,7 +112,7 @@ (inst movsd (ea-for-df-stack y) x)) (eval-when (:compile-toplevel :execute) - (setf *read-default-float-format* 'cl:single-float)) + (setf cl:*read-default-float-format* 'cl:single-float)) ;;;; complex float move functions @@ -284,7 +284,7 @@ (,sc (move y x)) (,stack-sc - (if (= (tn-offset fp) esp-offset) + (if (= (tn-offset fp) rsp-offset) (let* ((offset (tn-byte-offset y)) (ea (ea offset fp))) ,@(ecase format @@ -1572,3 +1572,43 @@ (:generator 2 (move r x) (inst shufpd r r #b01))) + +#+round-float +(progn + (define-vop () + (:translate round-double) + (:policy :fast-safe) + (:args (x :scs (double-reg) :target r)) + (:arg-types double-float (:constant symbol)) + (:info mode) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:generator 2 + (unless (location= r x) + (inst xorpd r r)) + (inst roundsd r x + (logior #b1000 + (ecase mode + (:round 0) + (:floor 1) + (:ceiling 2) + (:truncate 3)))))) + + (define-vop () + (:translate round-single) + (:policy :fast-safe) + (:args (x :scs (single-reg) :target r)) + (:arg-types single-float (:constant symbol)) + (:info mode) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:generator 2 + (unless (location= r x) + (inst xorps r r)) + (inst roundss r x + (logior #b1000 + (ecase mode + (:round 0) + (:floor 1) + (:ceiling 2) + (:truncate 3))))))) diff -Nru sbcl-2.0.6/src/compiler/x86-64/insts.lisp sbcl-2.1.1/src/compiler/x86-64/insts.lisp --- sbcl-2.0.6/src/compiler/x86-64/insts.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/insts.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -17,7 +17,8 @@ (import '(conditional-opcode plausible-signed-imm32-operand-p ea-p ea-base ea-index size-nbyte alias-p - ea make-ea ea-disp rip-relative-ea) "SB-VM") + ea ea-disp rip-relative-ea) "SB-VM") + (import 'sb-assem::&prefix) ;; Imports from SB-VM into this package #+sb-simd-pack-256 (import '(sb-vm::int-avx2-reg sb-vm::double-avx2-reg sb-vm::single-avx2-reg)) @@ -27,6 +28,41 @@ #+avx2 sb-vm::avx2-reg sb-vm::registers sb-vm::float-registers sb-vm::stack))) ; SB names +(defconstant +lock-prefix-present+ #x80) +;;; v---- size prefix presence bit +(defconstant +byte-size-prefix+ #b100) +(defconstant +word-size-prefix+ #b101) +(defconstant +dword-size-prefix+ #b110) +(defconstant +qword-size-prefix+ #b111) +(defun lockp (prefix) (if (logtest +lock-prefix-present+ prefix) :lock)) +(defmacro opsize-prefix-present (byte) `(logtest ,byte #b100)) +(defmacro opsize-prefix-keyword (byte) + `(svref #(:byte :word :dword :qword) (logand ,byte #b11))) +(defun pick-operand-size (prefix operand1 &optional operand2) + (acond ((logtest prefix #b100) (opsize-prefix-keyword prefix)) + (operand2 (matching-operand-size operand1 operand2)) + (t (operand-size operand1)))) +(defun encode-size-prefix (prefix) + (case prefix + (:byte +byte-size-prefix+) + (:word +word-size-prefix+) + (:dword +dword-size-prefix+) + (:qword +qword-size-prefix+))) +;;; Prefix is a mandatory operand to the encoder, so if none were +;;; written then this correctly prepends a 0. +(defun sb-assem::extract-prefix-keywords (args &aux (lockp 0) (size 0)) + (loop (acond ((eq (car args) :lock) (setq lockp +lock-prefix-present+)) + ((encode-size-prefix (car args)) (setq size it)) + (t (return (cons (logior lockp size) args)))) + (pop args))) +(defun sb-assem::decode-prefix (args) ; for trace file only + (let ((b (car args))) + (if (zerop b) + (cdr args) + (cons (append (if (logtest +lock-prefix-present+ b) '(:lock)) + (if (opsize-prefix-present b) (list (opsize-prefix-keyword b)))) + (cdr args))))) + ;;; a REG object discards all information about a TN except its storage base ;;; (a/k/a register class), size class (for GPRs), and encoding. ;;; The disassembler also uses this structure. @@ -82,8 +118,6 @@ (:oword 16) (:hword 32))) -(defun is-size-p (arg) (member arg '(:byte :word :dword :qword))) - ;;; If chopping IMM to 32 bits and sign-extending is equal to the original value, ;;; return the signed result, which the CPU will always extend to 64 bits. ;;; Notably this allows MOST-POSITIVE-WORD to be an immediate constant. @@ -1023,14 +1057,7 @@ ;;;; the effective-address (ea) structure (defstruct (ea (:constructor %ea (disp base index scale)) - (:constructor %make-ea-dont-use (size disp base index scale)) (:copier nil)) - ;; FIXME: SIZE is unnecessary, but is here for backward-compatibility - ;; temporarily anyway. Our code only creates EAs with :unspecific, - ;; but 3rd-party uses of the assembler might expect the size to do something. - ;; All such code will have to be fixed before removing this slot. - (size :unspecific :type (member :byte :word :dword :qword :unspecific) - :read-only t) (base nil :type (or tn null) :read-only t) (index nil :type (or tn null) :read-only t) (scale 1 :type (member 1 2 4 8) :read-only t) @@ -1428,9 +1455,6 @@ (let ((id (reg-id thing))) (when (is-gpr-id-p id) (aref #(:qword :dword :word :byte) (gpr-id-size-class id))))) - (ea ; FIXME: remove this case, let EA fall through to returning NIL - (unless (eq (ea-size thing) :unspecific) - (ea-size thing))) (fixup ;; GNA. Guess who spelt "flavor" correctly first time round? ;; There's a strong argument in my mind to change all uses of @@ -1441,6 +1465,8 @@ (t nil))) +;;; FIXME: I'm fairly certain that this can be removed, as there should be +;;; no way for operand sizes to differ. (defun matching-operand-size (dst src) (let ((dst-size (operand-size dst)) (src-size (operand-size src))) @@ -1506,9 +1532,12 @@ ;;; This function SHOULD NOT BE USED. It is only for compatibility. (defun sb-vm::reg-in-size (tn size) + ;; We don't put internal functions through a deprecation cycle. + ;; This should annoy maintainers enough to remove their misuses of this. + (warn "Don't use REG-IN-SIZE") (sized-thing (tn-reg tn) size)) -(define-instruction mov (segment maybe-size dst &optional src) +(define-instruction mov (segment &prefix prefix dst src) ;; immediate to register (:printer reg ((op #b1011 :prefilter (lambda (dstate value) (dstate-setprop dstate +allow-qword-imm+) @@ -1520,12 +1549,7 @@ ;; immediate to register/memory (:printer reg/mem-imm/asm-routine ((op '(#b1100011 #b000)))) (:emitter - (let ((size (cond (src - (aver (is-size-p maybe-size)) - maybe-size) - (t - (setq src dst dst maybe-size) - (matching-operand-size dst src))))) + (let ((size (pick-operand-size prefix dst src))) (emit-mov segment size (sized-thing dst size) (sized-thing src size))))) (defun emit-mov (segment size dst src) @@ -1738,7 +1762,7 @@ ;;; The disassembler additionally correctly matches encoding variants ;;; that the assembler doesn't generate, for example 4E90 prints as NOP ;;; and 4F90 as XCHG RAX, R8 (both because REX.R and REX.X are ignored). -(define-instruction xchg (segment operand1 operand2) +(define-instruction xchg (segment &prefix prefix operand1 operand2) ;; This printer matches all patterns that encode exchanging RAX with ;; R8, EAX with R8D, or AX with R8W. These consist of the opcode #x90 ;; with a REX prefix with REX.B = 1, and possibly the #x66 prefix. @@ -1751,7 +1775,11 @@ ;; Register/Memory with Register. (:printer reg-reg/mem ((op #b1000011))) (:emitter - (let ((size (matching-operand-size operand1 operand2))) + ;; Not parsing a :LOCK prefix is ok, because: + ;; "If a memory operand is referenced, the processor's locking protocol is automatically + ;; implemented for the duration of the exchange operation, regardless of the presence + ;; or absence of the LOCK prefix or of the value of the IOPL." + (let ((size (pick-operand-size prefix operand1 operand2))) (labels ((xchg-acc-with-something (acc something) (if (and (not (eq size :byte)) (gpr-p something) @@ -1777,41 +1805,33 @@ (t (error "bogus args to XCHG: ~S ~S" operand1 operand2))))))) -(define-instruction lea (segment maybe-size dst &optional src) +(define-instruction lea (segment &prefix prefix dst src) (:printer reg-reg/mem ((op #b1000110) (width 1) (reg/mem nil :use-label #'lea-compute-label :printer #'lea-print-ea))) (:emitter - (let ((size (cond (src - (aver (is-size-p maybe-size)) - maybe-size) - (t - (setq src dst dst maybe-size) - (operand-size dst))))) + (let ((size (pick-operand-size prefix dst))) (aver (member size '(:dword :qword))) (emit-prefixes segment src dst size) (emit-byte segment #x8D) (emit-ea segment src dst)))) -(define-instruction cmpxchg (segment maybe-size dst &optional src prefix) +(define-instruction cmpxchg (segment &prefix prefix dst src) ;; Register/Memory with Register. (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg)) (:emitter - (let ((size (cond ((is-size-p maybe-size) maybe-size) - (t - (shiftf prefix src dst maybe-size) - (matching-operand-size src dst))))) + (let ((size (pick-operand-size prefix dst src))) (aver (gpr-p src)) - (emit-prefixes segment dst (sized-thing src size) size :lock prefix) + (emit-prefixes segment dst (sized-thing src size) size :lock (lockp prefix)) (emit-bytes segment #x0F (opcode+size-bit #xB0 size)) (emit-ea segment dst src)))) -(define-instruction cmpxchg16b (segment mem &optional prefix) +(define-instruction cmpxchg16b (segment &prefix prefix mem) (:printer ext-reg/mem-no-width ((op '(#xC7 1)))) (:emitter (aver (not (gpr-p mem))) - (emit-prefixes segment mem nil :qword :lock prefix) + (emit-prefixes segment mem nil :qword :lock (lockp prefix)) (emit-bytes segment #x0F #xC7) (emit-ea segment mem 1))) @@ -1847,23 +1867,20 @@ ;;;; arithmetic -(flet ((emit* (name segment maybe-size dst src lockp opcode) - (let ((size (cond ((is-size-p maybe-size) maybe-size) - (t - (shiftf lockp src dst maybe-size) - (matching-operand-size dst src))))) +(flet ((emit* (name segment prefix dst src opcode) + (let ((size (pick-operand-size prefix dst src))) (setq src (sized-thing src size) dst (sized-thing dst size)) (acond ((and (neq size :byte) (plausible-signed-imm8-operand-p src size)) - (emit-prefixes segment dst nil size :lock lockp) + (emit-prefixes segment dst nil size :lock (lockp prefix)) (emit-byte segment #x83) (emit-ea segment dst opcode) (emit-byte segment it)) ((or (integerp src) (and (fixup-p src) - (memq (fixup-flavor src) '(:layout :immobile-symbol)))) - (emit-prefixes segment dst nil size :lock lockp) + (memq (fixup-flavor src) '(:layout-id :layout :immobile-symbol)))) + (emit-prefixes segment dst nil size :lock (lockp prefix)) (cond ((accumulator-p dst) (emit-byte segment (opcode+size-bit (dpb opcode (byte 3 3) #b00000100) @@ -1882,12 +1899,12 @@ (cond ((gpr-p src) (values dst src #b00)) ((gpr-p dst) (values src dst #b10)) (t (error "bogus operands to ~A" name))) - (emit-prefixes segment reg/mem reg size :lock lockp) + (emit-prefixes segment reg/mem reg size :lock (lockp prefix)) (emit-byte segment (opcode+size-bit (dpb opcode (byte 3 3) dir-bit) size)) (emit-ea segment reg/mem reg))))))) (macrolet ((define (name subop) - `(define-instruction ,name (segment maybe-size dst &optional src prefix) + `(define-instruction ,name (segment &prefix prefix dst src) (:printer accum-imm ((op ,(dpb subop (byte 3 2) #b0000010)))) (:printer reg/mem-imm ((op '(#b1000000 ,subop)))) ;; The redundant encoding #x82 is invalid in 64-bit mode, @@ -1895,7 +1912,7 @@ (:printer reg/mem-imm ((op '(#b1000001 ,subop)) (width 1) (imm nil :type 'signed-imm-byte))) (:printer reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))) - (:emitter (emit* ,(string name) segment maybe-size dst src prefix ,subop))))) + (:emitter (emit* ,(string name) segment prefix dst src ,subop))))) (define add #b000) (define adc #b010) (define sub #b101) @@ -1905,28 +1922,25 @@ (define or #b001) (define xor #b110))) -(flet ((emit* (segment maybe-size dst lockp opcode subcode) - (let ((size (cond ((is-size-p maybe-size) maybe-size) - (t - (shiftf lockp dst maybe-size) - (operand-size dst))))) - (emit-prefixes segment (sized-thing dst size) nil size :lock lockp) +(flet ((emit* (segment prefix dst opcode subcode) + (let ((size (pick-operand-size prefix dst))) + (emit-prefixes segment (sized-thing dst size) nil size :lock (lockp prefix)) (emit-byte segment (opcode+size-bit (ash opcode 1) size)) (emit-ea segment dst subcode)))) - (define-instruction not (segment maybe-size &optional dst prefix) + (define-instruction not (segment &prefix prefix dst) (:printer reg/mem ((op '(#b1111011 #b010)))) - (:emitter (emit* segment maybe-size dst prefix #b1111011 #b010))) - (define-instruction neg (segment maybe-size &optional dst prefix) + (:emitter (emit* segment prefix dst #b1111011 #b010))) + (define-instruction neg (segment &prefix prefix dst) (:printer reg/mem ((op '(#b1111011 #b011)))) - (:emitter (emit* segment maybe-size dst prefix #b1111011 #b011))) + (:emitter (emit* segment prefix dst #b1111011 #b011))) ;; The one-byte encodings for INC and DEC are used as REX prefixes ;; in 64-bit mode so we always use the two-byte form. - (define-instruction inc (segment maybe-size &optional dst prefix) + (define-instruction inc (segment &prefix prefix dst) (:printer reg/mem ((op '(#b1111111 #b000)))) - (:emitter (emit* segment maybe-size dst prefix #b1111111 #b000))) - (define-instruction dec (segment maybe-size &optional dst prefix) + (:emitter (emit* segment prefix dst #b1111111 #b000))) + (define-instruction dec (segment &prefix prefix dst) (:printer reg/mem ((op '(#b1111111 #b001)))) - (:emitter (emit* segment maybe-size dst prefix #b1111111 #b001)))) + (:emitter (emit* segment prefix dst #b1111111 #b001)))) (define-instruction mul (segment dst src) (:printer accum-reg/mem ((op '(#b1111011 #b100)))) @@ -1992,13 +2006,10 @@ (:printer accum-reg/mem ((op '(#b1111011 #b111)))) (:emitter (emit* segment dst src #b111)))) -(define-instruction bswap (segment maybe-size &optional (reg nil regp)) +(define-instruction bswap (segment &prefix prefix dst) (:printer ext-reg-no-width ((op #b11001))) (:emitter - (multiple-value-bind (size dst) - (if regp - (values maybe-size reg) - (let ((reg maybe-size)) (values (operand-size reg) reg))) + (let ((size (pick-operand-size prefix dst))) (aver (member size '(:dword :qword))) (emit-prefixes segment dst nil size) (emit-byte segment #x0f) @@ -2042,13 +2053,13 @@ (emit-prefixes segment nil nil :qword) (emit-byte segment #x99))) -(define-instruction xadd (segment dst src &optional prefix) +(define-instruction xadd (segment &prefix prefix dst src) ;; Register/Memory with Register. (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg)) (:emitter (aver (gpr-p src)) - (let ((size (matching-operand-size src dst))) - (emit-prefixes segment dst src size :lock prefix) + (let ((size (pick-operand-size prefix dst src))) + (emit-prefixes segment dst src size :lock (lockp prefix)) (emit-bytes segment #x0F (opcode+size-bit #xC0 size)) (emit-ea segment dst src)))) @@ -2061,13 +2072,8 @@ (op :fields (list (byte 6 2) (byte 3 11))) (variablep :field (byte 1 1))) -(flet ((emit* (segment maybe-size dst amount subcode) - (let ((size (cond (amount - (aver (is-size-p maybe-size)) - maybe-size) - (t - (setq amount dst dst maybe-size) - (operand-size dst))))) +(flet ((emit* (segment prefix dst amount subcode) + (let ((size (pick-operand-size prefix dst))) (multiple-value-bind (opcode immed) (case amount (:cl (values #b11010010 nil)) @@ -2079,11 +2085,11 @@ (when immed (emit-byte segment amount)))))) (macrolet ((define (name subop) - `(define-instruction ,name (segment maybe-size dst &optional amount) + `(define-instruction ,name (segment &prefix prefix dst amount) (:printer shift-inst ((op '(#b110100 ,subop)))) ; shift by CL or 1 (:printer reg/mem-imm ((op '(#b1100000 ,subop)) (imm nil :type 'imm-byte))) - (:emitter (emit* segment maybe-size dst amount ,subop))))) + (:emitter (emit* segment prefix dst amount ,subop))))) (define rol #b000) (define ror #b001) (define rcl #b010) @@ -2092,9 +2098,8 @@ (define shr #b101) (define sar #b111))) -(flet ((emit* (segment opcode dst src amt) - (declare (type (or (member :cl) (mod 64)) amt)) - (let ((size (matching-operand-size dst src))) +(flet ((emit* (segment opcode prefix dst src amt) + (let ((size (pick-operand-size prefix dst src))) (when (eq size :byte) (error "Double shift requires word or larger operand")) (emit-prefixes segment dst src size) @@ -2103,29 +2108,24 @@ (dpb opcode (byte 1 3) (if (eq amt :cl) #xA5 #xA4))) (emit-ea segment dst src) (unless (eq amt :cl) - (emit-byte segment amt))))) + (emit-byte segment (the (mod 64) amt)))))) (macrolet ((define (name direction-bit op) - `(define-instruction ,name (segment dst src amt) + `(define-instruction ,name (segment &prefix prefix dst src amt) (:printer ext-reg-reg/mem-no-width ((op ,(logior op #b100)) (imm nil :type 'imm-byte)) '(:name :tab reg/mem ", " reg ", " imm)) (:printer ext-reg-reg/mem-no-width ((op ,(logior op #b101))) '(:name :tab reg/mem ", " reg ", " 'cl)) - (:emitter (emit* segment ,direction-bit dst src amt))))) + (:emitter (emit* segment ,direction-bit prefix dst src amt))))) (define shld 0 #b10100000) (define shrd 1 #b10101000))) -(define-instruction test (segment maybe-size this &optional that) +(define-instruction test (segment &prefix prefix this that) (:printer accum-imm ((op #b1010100))) (:printer reg/mem-imm ((op '(#b1111011 #b000)))) (:printer reg-reg/mem ((op #b1000010))) (:emitter - (let ((size (cond (that - (aver (is-size-p maybe-size)) - maybe-size) - (t - (setq that this this maybe-size) - (matching-operand-size this that))))) + (let ((size (pick-operand-size prefix this that))) (setq this (sized-thing this size) that (sized-thing that size)) (when (and (gpr-p this) (mem-ref-p that)) @@ -2212,14 +2212,11 @@ (:printer ext-reg-reg/mem-no-width ((op #xBD))) (:emitter (emit* segment #xBD dst src)))) -(flet ((emit* (segment maybe-size src index lockp opcode) - (let ((size (cond ((is-size-p maybe-size) maybe-size) - (t - (shiftf lockp index src maybe-size) - (matching-operand-size src index))))) +(flet ((emit* (segment prefix src index opcode) + (let ((size (pick-operand-size prefix src index))) (when (eq size :byte) (error "can't test byte: ~S" src)) - (emit-prefixes segment src index size :lock lockp) + (emit-prefixes segment src index size :lock (lockp prefix)) (cond ((integerp index) (emit-bytes segment #x0F #xBA) (emit-ea segment src opcode) @@ -2229,7 +2226,7 @@ (emit-ea segment src index)))))) (macrolet ((define (inst opcode-extension) - `(define-instruction ,inst (segment maybe-size src &optional index prefix) + `(define-instruction ,inst (segment &prefix prefix src index) (:printer ext-reg/mem-no-width+imm8 ((op '(#xBA ,opcode-extension)) (reg/mem nil :type 'sized-reg/mem))) @@ -2237,8 +2234,7 @@ ((op ,(dpb opcode-extension (byte 3 3) #b10000011)) (reg/mem nil :type 'sized-reg/mem)) '(:name :tab reg/mem ", " reg)) - (:emitter (emit* segment maybe-size src index prefix - ,opcode-extension))))) + (:emitter (emit* segment prefix src index ,opcode-extension))))) (define bt 4) (define bts 5) (define btr 6) @@ -2373,15 +2369,10 @@ (emit-byte-displacement-backpatch segment target))) ;;;; conditional move -(define-instruction cmov (segment maybe-size cond dst &optional src) +(define-instruction cmov (segment &prefix prefix cond dst src) (:printer cond-move ()) (:emitter - (let ((size (cond (src - (aver (is-size-p maybe-size)) - maybe-size) - (t - (setq src dst dst cond cond maybe-size) - (matching-operand-size dst src))))) + (let ((size (pick-operand-size prefix dst src))) (aver (gpr-p dst)) (aver (neq size :byte)) (emit-prefixes segment src dst size)) @@ -2469,17 +2460,17 @@ (declare (type sb-assem:segment segment) (type index amount)) ;; Pack all instructions into one byte vector to save space. - (let* ((bytes #.(sb-xc:coerce - #(#x90 - #x66 #x90 - #x0f #x1f #x00 - #x0f #x1f #x40 #x00 - #x0f #x1f #x44 #x00 #x00 - #x66 #x0f #x1f #x44 #x00 #x00 - #x0f #x1f #x80 #x00 #x00 #x00 #x00 - #x0f #x1f #x84 #x00 #x00 #x00 #x00 #x00 - #x66 #x0f #x1f #x84 #x00 #x00 #x00 #x00 #x00) - '(vector (unsigned-byte 8)))) + (let* ((bytes #.(coerce + #(#x90 + #x66 #x90 + #x0f #x1f #x00 + #x0f #x1f #x40 #x00 + #x0f #x1f #x44 #x00 #x00 + #x66 #x0f #x1f #x44 #x00 #x00 + #x0f #x1f #x80 #x00 #x00 #x00 #x00 + #x0f #x1f #x84 #x00 #x00 #x00 #x00 #x00 + #x66 #x0f #x1f #x84 #x00 #x00 #x00 #x00 #x00) + '(vector (unsigned-byte 8)))) (max-length (isqrt (* 2 (length bytes))))) (loop (let* ((count (min amount max-length)) @@ -2985,29 +2976,21 @@ &key explicit-qword) `(define-instruction ,name (segment dst src imm) (:printer - ,(if op2 (if explicit-qword - 'ext-rex-2byte-reg/mem-xmm - 'ext-2byte-reg/mem-xmm) - 'ext-reg/mem-xmm) + ,(if explicit-qword + 'ext-rex-2byte-reg/mem-xmm + 'ext-2byte-reg/mem-xmm) ((prefix '(,prefix)) - ,@(if op2 - `((op1 '(,op1)) (op2 '(,op2))) - `((op '(,op1)))) + (op1 '(,op1)) + (op2 '(,op2)) (imm nil :type 'imm-byte)) '(:name :tab reg/mem ", " reg ", " imm)) (:emitter (aver (and (xmm-register-p src) (not (xmm-register-p dst)))) - ,(if op2 - `(emit-sse-inst-2byte segment dst src ,prefix ,op1 ,op2 - :operand-size ,(if explicit-qword - :qword - :do-not-set) - :remaining-bytes 1) - `(emit-sse-inst segment dst src ,prefix ,op1 + (emit-sse-inst-2byte segment src dst ,prefix ,op1 ,op2 :operand-size ,(if explicit-qword :qword :do-not-set) - :remaining-bytes 1)) + :remaining-bytes 1) (emit-byte segment imm)))) (define-insert-sse-instruction (name prefix op1 op2) @@ -3242,7 +3225,6 @@ (flet ((emit* (segment opcode subcode src) (aver (not (register-p src))) - (aver (eq (operand-size src) :byte)) (aver subcode) (emit-prefixes segment src nil :byte) (emit-byte segment #x0f) @@ -3479,6 +3461,63 @@ collect (prog1 (ldb (byte 8 0) val) (setf val (ash val -8)))))))))) +;;; This gets called by LOAD to resolve newly positioned objects +;;; with things (like code instructions) that have to refer to them. +;;; Return KIND if the fixup needs to be recorded in %CODE-FIXUPS. +;;; The code object we're fixing up is pinned whenever this is called. +(defun sb-vm:fixup-code-object (code offset value kind flavor) + (declare (type index offset)) + (sb-vm::with-code-instructions (sap code) + ;; All x86-64 fixup locations contain an implicit addend at the location + ;; to be fixed up. The addend is always zero for certain pairs, + ;; but we don't need to assert that. + (incf value (if (eq kind :absolute64) + (signed-sap-ref-64 sap offset) + (signed-sap-ref-32 sap offset))) + (ecase kind + (:absolute ; 32 bits. most are unsigned, except :layout-id which is signed + (if (eq flavor :layout-id) + (setf (signed-sap-ref-32 sap offset) value) + (setf (sap-ref-32 sap offset) value))) + (:relative + ;; Replace word with the difference between VALUE and current pc. + ;; JMP/CALL are relative to the next instruction, + ;; so add 4 bytes for the size of the displacement itself. + ;; Relative fixups don't exist with movable code, + ;; so in the #-immobile-code case, there's nothing to assert. + #+(and immobile-code (not sb-xc-host)) + (unless (immobile-space-obj-p code) + (error "Can't compute fixup relative to movable object ~S" code)) + (setf (signed-sap-ref-32 sap offset) (- value (+ (sap-int sap) offset 4)))) + (:absolute64 + ;; These are used for jump tables and are not recorded in code fixups. + ;; GC knows to adjust the values if code is moved. + (setf (sap-ref-64 sap offset) value)))) + ;; An absolute fixup is stored in the code header's %FIXUPS slot if it + ;; references an immobile-space (but not static-space) object. + ;; Note that: + ;; (1) Call fixups occur in both :RELATIVE and :ABSOLUTE kinds. + ;; We can ignore the :RELATIVE kind, except for foreign call, + ;; as those point to the linkage table which has an absolute address + ;; and therefore might change in displacement from the call site + ;; if the immobile code space is relocated on startup. + ;; (2) :STATIC-CALL fixups point to immobile space, not static space. + #+immobile-space + (return-from fixup-code-object + (case flavor + ((:named-call :layout :immobile-symbol :symbol-value ; -> fixedobj subspace + :assembly-routine :assembly-routine* :static-call) ; -> varyobj subspace + (if (eq kind :absolute) :absolute)) + (:foreign + ;; linkage-table calls using the "CALL rel32" format need to be saved, + ;; because the linkage table resides at a fixed address. + ;; Space defragmentation can handle the fixup automatically, + ;; but core relocation can't - it can't find all the call sites. + (if (eq kind :relative) :relative)))) + nil) ; non-immobile-space builds never record code fixups + +;;; Coverage support + (defun sb-assem::%mark-used-labels (operand) (when (typep operand 'ea) (let ((disp (ea-disp operand))) @@ -3498,38 +3537,24 @@ ;;; Replace the STATEMENT with an instruction to store a coverage mark ;;; in the OFFSETth byte beyond LABEL. (defun sb-c::replace-coverage-instruction (statement label offset) + ;; This is a bit sucky, but the coverage instruction inserter + ;; does not receive the benefit of parsing prefixes as keywords, + ;; so it has to use the numeric value. (setf (stmt-mnemonic statement) 'mov - (stmt-operands statement) `(:byte ,(rip-relative-ea label offset) 1))) + (stmt-operands statement) `(,+byte-size-prefix+ ,(rip-relative-ea label offset) 1))) - -;;; This constructor is for broken 3rd-party library code. It's fine that we have -;;; some degree of backward-compatibility, but it's another entirely to say that -;;; we allowed code that SHOULD NOT have been allowed to work. -;;; -;;; The problem: MAKE-EA gets called with registers that were resized -;;; using REG-IN-SIZE. The BASE and INDEX parts of an EA are *always* -;;; qwords, and we should have enforced that. Well, it's too late now -;;; to start enforcing. -(defun make-ea (size &key base index (scale 1) (disp 0)) - (flet ((fix (reg) - (if (register-p reg) - (make-random-tn :kind :normal - :sc (sc-or-lose 'sb-vm::unsigned-reg) - :offset (reg-id-num (reg-id reg))) - reg))) - (%make-ea-dont-use size disp (fix base) (fix index) scale))) +;;; Assembly optimizer support (defun parse-2-operands (stmt) (let* ((operands (stmt-operands stmt)) - (size (let* ((first (car operands)) - (second (cadr operands))) - (cond ((is-size-p first) (pop operands) first) - ;; This next case is noise to support obsolete REG-IN-SIZE - ((or (register-p first) (register-p second)) - (matching-operand-size first second)) ; FIXME: remove - (t :qword))))) - ;; Recompute first + second because potentially popped one. - (values size (first operands) (second operands)))) + (first (pop operands)) + (second (pop operands))) + (if (atom (gethash (stmt-mnemonic stmt) sb-assem::*inst-encoder*)) ; no prefixes + (values :qword first second) + (let ((prefix first) + (first second) + (second (pop operands))) + (values (pick-operand-size prefix first second) first second))))) (defun smaller-of (size1 size2) (if (or (eq size1 :dword) (eq size2 :dword)) :dword :qword)) @@ -3553,7 +3578,7 @@ (location= dst2 dst1) (eq size1 :qword) (eq size2 :dword)) - (setf (stmt-operands stmt) `(:dword ,dst1 ,src1)) + (setf (stmt-operands stmt) `(,+dword-size-prefix+ ,dst1 ,src1)) next))) ;;; "AND r, imm1" + "AND r, imm2" -> "AND r, (imm1 & imm2)" @@ -3567,7 +3592,7 @@ (member size2 '(:dword :qword)) (typep src2 '(signed-byte 32))) (setf (stmt-operands next) - `(,(smaller-of size1 size2) ,dst2 ,(logand src1 src2))) + `(,(encode-size-prefix (smaller-of size1 size2)) ,dst2 ,(logand src1 src2))) (add-stmt-labels next (stmt-labels stmt)) (delete-stmt stmt) next))) @@ -3614,7 +3639,7 @@ ;; so I'm constraining this to 31 bits, not 32. (when (<= max-dst1-bit-index 30) (setf (stmt-mnemonic stmt) 'shr - (stmt-operands stmt) `(:dword ,dst1 ,src1)) + (stmt-operands stmt) `(,+dword-size-prefix+ ,dst1 ,src1)) next))))) (defun reg= (a b) ; Return T if A and B are the same register diff -Nru sbcl-2.0.6/src/compiler/x86-64/macros.lisp sbcl-2.1.1/src/compiler/x86-64/macros.lisp --- sbcl-2.0.6/src/compiler/x86-64/macros.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/macros.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -203,6 +203,11 @@ #+sb-safepoint (defun emit-safepoint () + ;; FIXME: need to get the node and policy to decide not to emit this safepoint. + ;; Also, it would be good to emit only the last of consecutive safepoints in + ;; straight-line code, e.g. (LIST (LIST X Y) (LIST Z W)) should emit 1 safepoint + ;; not 3, even if we consider it 3 separate pointer bumps. + ;; (Ideally we'd only do 1 pointer bump, but that's a separate issue) (inst test :byte rax-tn (ea (- static-space-start gc-safepoint-trap-offset)))) (defmacro pseudo-atomic ((&key elide-if) &rest forms) @@ -262,14 +267,14 @@ (:result-types ,el-type) (:generator 5 (move rax old-value) - (inst cmpxchg + (inst cmpxchg :lock (ea (- (* (+ (if (sc-is index immediate) (tn-value index) 0) ,offset) n-word-bytes) ,lowtag) object (unless (sc-is index immediate) index) (ash 1 (- word-shift n-fixnum-tag-bits))) - new-value :lock) + new-value) (move value rax))))) (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) diff -Nru sbcl-2.0.6/src/compiler/x86-64/memory.lisp sbcl-2.1.1/src/compiler/x86-64/memory.lisp --- sbcl-2.0.6/src/compiler/x86-64/memory.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/memory.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -91,7 +91,7 @@ (:policy :fast-safe) (:generator 4 (move result value) - (inst xadd (object-slot-ea object offset lowtag) result :lock))) + (inst xadd :lock (object-slot-ea object offset lowtag) result))) (define-vop (cell-xsub cell-xadd) (:args (object) @@ -103,11 +103,11 @@ (sc-case value (immediate (let ((k (tn-value value))) - (inst mov result (fixnumize (if (= k sb-xc:most-negative-fixnum) k (- k)))))) + (inst mov result (fixnumize (if (= k most-negative-fixnum) k (- k)))))) (t (move result value) (inst neg result))) - (inst xadd (object-slot-ea object offset lowtag) result :lock))) + (inst xadd :lock (object-slot-ea object offset lowtag) result))) (define-vop (atomic-inc-symbol-global-value cell-xadd) (:translate %atomic-inc-symbol-global-value) @@ -149,7 +149,7 @@ (const (if (sc-is delta immediate) (fixnumize ,(if (eq inherit 'cell-xsub) `(let ((x (tn-value delta))) - (if (= x sb-xc:most-negative-fixnum) + (if (= x most-negative-fixnum) x (- x))) `(tn-value delta))))) (retry (gen-label))) @@ -167,9 +167,9 @@ `(progn (move newval rax) (inst sub newval delta)) `(inst lea newval (ea rax delta)))) - (inst cmpxchg + (inst cmpxchg :lock (object-slot-ea cell ,slot list-pointer-lowtag) - newval :lock) + newval) (inst jmp :ne retry) (inst mov result rax))))))) (def-atomic %atomic-inc-car cell-xadd cons-car-slot) @@ -181,8 +181,7 @@ (define-vop (set-instance-hashed) (:args (x :scs (descriptor-reg))) (:generator 1 - (inst or :byte (ea (- 1 instance-pointer-lowtag) x) + (inst or :lock :byte (ea (- 1 instance-pointer-lowtag) x) ;; Bit index is 0-based. Subtract 8 since we're using the EA ;; to select byte 1 of the header word. - (ash 1 (- stable-hash-required-flag 8)) - :lock))) + (ash 1 (- stable-hash-required-flag 8))))) diff -Nru sbcl-2.0.6/src/compiler/x86-64/move.lisp sbcl-2.1.1/src/compiler/x86-64/move.lisp --- sbcl-2.0.6/src/compiler/x86-64/move.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/move.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -130,7 +130,7 @@ (if (eql val 0) (zeroize y) (inst mov y val))) (move y x))) ((control-stack) - (if (= (tn-offset fp) esp-offset) + (if (= (tn-offset fp) rsp-offset) ;; C-call (storew (encode-value-if-immediate x) fp (tn-offset y)) ;; Lisp stack @@ -295,32 +295,30 @@ (define-vop (move-from-fixnum+1) (:args (x :scs (signed-reg unsigned-reg))) (:results (y :scs (any-reg descriptor-reg))) + (:args-var arg-ref) + (:vop-var vop) (:generator 4 - (cond ((= n-fixnum-tag-bits 1) - (move y x) - (inst shl y 1) - (inst cmov :o y (emit-constant (1+ sb-xc:most-positive-fixnum)))) - (t - ;; not worth optimizing into SHL. The processor doesn't set OF for - ;; for shift count > 1 so we'd have to detect overflow differently. - (inst imul y x (ash 1 n-fixnum-tag-bits)) - (inst jmp :no DONE) - (move y (emit-constant (1+ sb-xc:most-positive-fixnum))))) + (let ((const (case (vop-name vop) + (move-from-fixnum-1 (1- most-negative-fixnum)) + (t (1+ most-positive-fixnum))))) + (cond ((= n-fixnum-tag-bits 1) + (cond ((csubtypep (tn-ref-type arg-ref) (specifier-type 'fixnum)) + ;; I think MAYBE-MOVE-FROM-FIXNUM+-1 could select MOVE-FROM-WORD/FIXNUM + ;; if Y is known to fit in a fixnum, but this works, albeit redundant. + (if (location= x y) (inst shl y 1) (inst lea y (ea x x)))) + (t + (move y x) + (inst shl y 1) + (inst cmov :o y (emit-constant const))))) + (t + ;; not worth optimizing into SHL. The processor doesn't set OF for + ;; for shift count > 1 so we'd have to detect overflow differently. + (inst imul y x (ash 1 n-fixnum-tag-bits)) + (inst jmp :no DONE) + (move y (emit-constant const))))) DONE)) -(define-vop (move-from-fixnum-1 move-from-fixnum+1) - (:generator 4 - (cond ((= n-fixnum-tag-bits 1) - (move y x) - (inst shl y 1) - (inst cmov :o y (emit-constant (1- sb-xc:most-negative-fixnum)))) - (t - ;; not worth optimizing into SHL. The processor doesn't set OF for - ;; for shift count > 1 so we'd have to detect overflow differently. - (inst imul y x (ash 1 n-fixnum-tag-bits)) - (inst jmp :no DONE) - (move y (emit-constant (1- sb-xc:most-negative-fixnum))))) - DONE)) +(define-vop (move-from-fixnum-1 move-from-fixnum+1)) ;;; Convert an untagged unsigned word to a lispobj -- fixnum or bignum ;;; as the case may be. Fixnum case inline, bignum case in an assembly @@ -378,7 +376,7 @@ ((signed-reg unsigned-reg) (move y x)) ((signed-stack unsigned-stack) - (if (= (tn-offset fp) esp-offset) + (if (= (tn-offset fp) rsp-offset) (storew x fp (tn-offset y)) ; c-call (storew x fp (frame-word-offset (tn-offset y)))))))) (define-move-vop move-word-arg :move-arg diff -Nru sbcl-2.0.6/src/compiler/x86-64/nlx.lisp sbcl-2.1.1/src/compiler/x86-64/nlx.lisp --- sbcl-2.0.6/src/compiler/x86-64/nlx.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/nlx.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -38,6 +38,15 @@ ;;; Compute the address of the catch block from its TN, then store into the ;;; block the current Fp, Env, Unwind-Protect, and the entry PC. +#+sb-thread +(progn + ;; MOVAPD instruction faults if not properly aligned + (assert (evenp (/ (info :variable :wired-tls '*binding-stack-pointer*) n-word-bytes))) + (assert (= (- (info :variable :wired-tls '*current-catch-block*) + (info :variable :wired-tls '*binding-stack-pointer*)) + n-word-bytes)) + (assert (= (- unwind-block-current-catch-slot unwind-block-bsp-slot) 1))) + (define-vop (make-unwind-block) (:args (tn)) (:info entry-label) @@ -53,9 +62,7 @@ (inst lea temp (rip-relative-ea entry-label)) (storew temp block unwind-block-entry-pc-slot) #+sb-thread - (let ((bsp #1=(info :variable :wired-tls '*binding-stack-pointer*))) - #.(assert (and (= (- (info :variable :wired-tls '*current-catch-block*) #1#) n-word-bytes) - (= (- unwind-block-current-catch-slot unwind-block-bsp-slot) 1))) + (let ((bsp (info :variable :wired-tls '*binding-stack-pointer*))) (inst movapd xmm-temp (thread-tls-ea bsp)) (inst movupd (ea (* unwind-block-bsp-slot n-word-bytes) block) xmm-temp)) #-sb-thread diff -Nru sbcl-2.0.6/src/compiler/x86-64/parms.lisp sbcl-2.1.1/src/compiler/x86-64/parms.lisp --- sbcl-2.0.6/src/compiler/x86-64/parms.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/parms.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -124,7 +124,7 @@ ;;; would be possible, but probably not worth the time and code bloat ;;; it would cause. -- JES, 2005-12-11 -#+linux +#+(or linux darwin) (!gencgc-space-setup #x50000000 :read-only-space-size 0 :fixedobj-space-size #.(* 30 1024 1024) @@ -134,7 +134,7 @@ ;;; The default dynamic space size is lower on OpenBSD to allow SBCL to ;;; run under the default 512M data size limit. -#-linux +#-(or linux darwin) (!gencgc-space-setup #x20000000 #-win32 :read-only-space-size #-win32 0 :dynamic-space-start #x1000000000 @@ -177,6 +177,10 @@ ;;; Note these spaces grow from low to high addresses. (defvar *binding-stack-pointer*) +;;; Bit indices into *CPU-FEATURE-BITS* +(defconstant cpu-has-ymm-registers 0) +(defconstant cpu-has-popcnt 1) + (defconstant-eqx +static-symbols+ `#(,@+common-static-symbols+ #+(and immobile-space (not sb-thread)) function-layout @@ -184,7 +188,7 @@ ;; interrupt handling #-sb-thread *pseudo-atomic-bits* ; ditto #-sb-thread *binding-stack-pointer* ; ditto - *cpuid-fn1-ecx*) + *cpu-feature-bits*) #'equalp) (defconstant-eqx +static-fdefns+ @@ -205,7 +209,7 @@ two-arg-lcm ensure-symbol-hash sb-impl::install-hash-table-lock - update-object-layout-or-invalid + update-object-layout %coerce-callable-to-fun) #'equalp) diff -Nru sbcl-2.0.6/src/compiler/x86-64/pred.lisp sbcl-2.1.1/src/compiler/x86-64/pred.lisp --- sbcl-2.0.6/src/compiler/x86-64/pred.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/pred.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -342,32 +342,6 @@ instance) (encode-value-if-immediate x)))) -(define-vop (fixnump-instance-ref) - (:args (instance :scs (descriptor-reg))) - (:arg-types * (:constant (unsigned-byte 16))) - (:info slot) - (:translate fixnump-instance-ref) - (:conditional :e) - (:policy :fast-safe) - (:generator 1 - (inst test :byte - (ea (+ (- instance-pointer-lowtag) - (ash (+ slot instance-slots-offset) word-shift)) - instance) - fixnum-tag-mask))) -(macrolet ((def-fixnump-cxr (name index) - `(define-vop (,name) - (:args (x :scs (descriptor-reg))) - (:translate ,name) - (:conditional :e) - (:policy :fast-safe) - (:generator 1 - (inst test :byte - (ea (- (ash ,index word-shift) list-pointer-lowtag) x) - fixnum-tag-mask))))) - (def-fixnump-cxr fixnump-car cons-car-slot) - (def-fixnump-cxr fixnump-cdr cons-cdr-slot)) - ;;; See comment below about ASSUMPTIONS (eval-when (:compile-toplevel) (assert (eql other-pointer-lowtag #b1111)) diff -Nru sbcl-2.0.6/src/compiler/x86-64/sap.lisp sbcl-2.1.1/src/compiler/x86-64/sap.lisp --- sbcl-2.0.6/src/compiler/x86-64/sap.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/sap.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -61,7 +61,7 @@ (sap-reg (move y x)) (sap-stack - (if (= (tn-offset fp) esp-offset) + (if (= (tn-offset fp) rsp-offset) (storew x fp (tn-offset y)) ; c-call (storew x fp (frame-word-offset (tn-offset y)))))))) (define-move-vop move-sap-arg :move-arg @@ -355,13 +355,13 @@ (offset :scs (signed-reg) :to (:eval 0)) (oldval :scs (signed-reg) :target eax) (newval :scs (signed-reg) :to (:eval 0))) - (:temporary (:sc unsigned-reg :offset eax-offset + (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 2) :to (:result 0)) eax) (:arg-types system-area-pointer signed-num signed-num signed-num) (:results (result :scs (signed-reg))) (:result-types signed-num) (:generator 5 (inst mov :dword eax oldval) - (inst cmpxchg :dword (ea sap offset) newval :lock) + (inst cmpxchg :lock :dword (ea sap offset) newval) (inst movsx '(:dword :qword) result eax))) diff -Nru sbcl-2.0.6/src/compiler/x86-64/simd-pack-256.lisp sbcl-2.1.1/src/compiler/x86-64/simd-pack-256.lisp --- sbcl-2.0.6/src/compiler/x86-64/simd-pack-256.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/simd-pack-256.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,6 +11,9 @@ (in-package "SB-VM") +(defun ea-for-avx-stack (tn &optional (base rbp-tn)) + (ea (frame-byte-offset (+ (tn-offset tn) 3)) base)) + (defun float-avx2-p (tn) (sc-is tn single-avx2-reg single-avx2-stack single-avx2-immediate double-avx2-reg double-avx2-stack double-avx2-immediate)) @@ -56,19 +59,19 @@ (define-move-fun (load-int-avx2 2) (vop x y) ((int-avx2-stack) (int-avx2-reg)) - (inst vmovdqu y (ea-for-sse-stack x))) + (inst vmovdqu y (ea-for-avx-stack x))) (define-move-fun (load-float-avx2 2) (vop x y) ((single-avx2-stack double-avx2-stack) (single-avx2-reg double-avx2-reg)) - (inst vmovups y (ea-for-sse-stack x))) + (inst vmovups y (ea-for-avx-stack x))) (define-move-fun (store-int-avx2 2) (vop x y) ((int-avx2-reg) (int-avx2-stack)) - (inst vmovdqu (ea-for-sse-stack y) x)) + (inst vmovdqu (ea-for-avx-stack y) x)) (define-move-fun (store-float-avx2 2) (vop x y) ((double-avx2-reg single-avx2-reg) (double-avx2-stack single-avx2-stack)) - (inst vmovups (ea-for-sse-stack y) x)) + (inst vmovups (ea-for-avx-stack y) x)) (define-vop (avx2-move) (:args (x :scs (single-avx2-reg double-avx2-reg int-avx2-reg) @@ -136,8 +139,8 @@ (inst vmovdqu y x)))) ((int-avx2-stack double-avx2-stack single-avx2-stack) (if (float-avx2-p x) - (inst vmovups (ea-for-sse-stack y fp) x) - (inst vmovdqu (ea-for-sse-stack y fp) x)))))) + (inst vmovups (ea-for-avx-stack y fp) x) + (inst vmovdqu (ea-for-avx-stack y fp) x)))))) (define-move-vop move-avx2-arg :move-arg (int-avx2-reg double-avx2-reg single-avx2-reg descriptor-reg) (int-avx2-reg double-avx2-reg single-avx2-reg)) diff -Nru sbcl-2.0.6/src/compiler/x86-64/system.lisp sbcl-2.1.1/src/compiler/x86-64/system.lisp --- sbcl-2.0.6/src/compiler/x86-64/system.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/system.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -52,22 +52,48 @@ word-shift)) instance-pointer-lowtag) layout))) - (define-vop (layout-depthoid) + (define-vop () (:translate layout-depthoid) (:policy :fast-safe) (:args (layout :scs (descriptor-reg))) (:results (res :scs (any-reg))) (:result-types fixnum) (:generator 1 (inst movsx '(:dword :qword) res (read-depthoid)))) - (define-vop (sb-c::layout-depthoid-gt) - (:translate sb-c::layout-depthoid-gt) + (define-vop () + (:translate sb-c::layout-depthoid-ge) (:policy :fast-safe) (:args (layout :scs (descriptor-reg))) (:info k) (:arg-types * (:constant (unsigned-byte 16))) - (:conditional :g) + (:conditional :ge) (:generator 1 (inst cmp :dword (read-depthoid) (fixnumize k))))) +(define-vop () + (:translate sb-c::%structure-is-a) + (:args (x :scs (descriptor-reg))) + (:arg-types * (:constant t)) + (:info test) + (:policy :fast-safe) + (:conditional :e) + (:generator 1 + (inst cmp :dword + (ea (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0) + instance-slots-offset) + word-shift) + (ash (- (layout-depthoid test) 2) 2) + (- instance-pointer-lowtag)) + x) + ;; Small layout-ids can only occur for layouts made in genesis. + ;; Therefore if the compile-time value of the ID is small, + ;; it is permanently assigned to that type. + ;; Otherwise, we allow for the possibility that the compile-time ID + ;; is not the same as the load-time ID. + ;; I don't think layout-id 0 can get here, but be sure to exclude it. + (if (or (typep (layout-id test) '(and (signed-byte 8) (not (eql 0)))) + (not (sb-c::producing-fasl-file))) + (layout-id test) + (make-fixup test :layout-id))))) + #+compact-instance-header ;; ~20 instructions vs. 35 (define-vop (layout-of) ; no translation @@ -166,7 +192,8 @@ (storew temp x 0 other-pointer-lowtag) (move res x))) -;;; These next 2 vops are for manipulating the flag bits of a vector header. +;;; These next 3 vops are for manipulating and reading the flag bits of +;;; arrays headers, or more generally any OTHER-POINTER object. (define-vop (set-header-bits) (:translate set-header-bits) (:policy :fast-safe) @@ -185,9 +212,21 @@ (:info bits) (:generator 1 (if (typep bits '(unsigned-byte 8)) - (inst and :byte (ea (- 1 other-pointer-lowtag) x) (lognot bits)) + (inst and :byte (ea (- 1 other-pointer-lowtag) x) (logandc1 bits #xff)) (inst and :dword (ea (- other-pointer-lowtag) x) (lognot (ash bits n-widetag-bits)))))) +(define-vop (test-header-bit) + (:translate test-header-bit) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg))) + (:arg-types t (:constant t)) + (:info mask) + (:conditional :ne) + (:generator 1 + ;; Assert that the mask is in header-data byte index 0 + ;; which is byte index 1 of the whole header word. + (aver (typep mask '(unsigned-byte 8))) + (inst test :byte (ea (- 1 other-pointer-lowtag) array) mask))) (define-vop (pointer-hash) (:translate pointer-hash) @@ -382,10 +421,10 @@ (define-vop (%read-cycle-counter) (:policy :fast-safe) (:translate %read-cycle-counter) - (:temporary (:sc unsigned-reg :offset eax-offset :target lo) eax) - (:temporary (:sc unsigned-reg :offset edx-offset :target hi) edx) - (:temporary (:sc unsigned-reg :offset ebx-offset) ebx) - (:temporary (:sc unsigned-reg :offset ecx-offset) ecx) + (:temporary (:sc unsigned-reg :offset rax-offset :target lo) eax) + (:temporary (:sc unsigned-reg :offset rdx-offset :target hi) edx) + (:temporary (:sc unsigned-reg :offset rbx-offset) ebx) + (:temporary (:sc unsigned-reg :offset rcx-offset) ecx) (:ignore ebx ecx) (:results (hi :scs (unsigned-reg)) (lo :scs (unsigned-reg))) @@ -483,13 +522,13 @@ (d :scs (unsigned-reg))) (:result-types unsigned-num unsigned-num unsigned-num unsigned-num) (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0) - :offset eax-offset) eax) + :offset rax-offset) eax) (:temporary (:sc unsigned-reg :from (:argument 1) :to (:result 2) - :offset ecx-offset) ecx) + :offset rcx-offset) ecx) (:temporary (:sc unsigned-reg :from :eval :to (:result 3) - :offset edx-offset) edx) + :offset rdx-offset) edx) (:temporary (:sc unsigned-reg :from :eval :to (:result 1) - :offset ebx-offset) ebx) + :offset rbx-offset) ebx) (:generator 5 (move eax function) (move ecx subfunction) @@ -503,25 +542,20 @@ (:args (fdefn :scs (descriptor-reg))) (:generator 1 ;; atomic because the immobile gen# is in the same byte - (inst or :byte (ea (- 1 other-pointer-lowtag) fdefn) #x80 :lock))) + (inst or :lock :byte (ea (- 1 other-pointer-lowtag) fdefn) #x80))) (define-vop (unset-fdefn-has-static-callers) (:args (fdefn :scs (descriptor-reg))) (:generator 1 ;; atomic because the immobile gen# is in the same byte - (inst and :byte (ea (- 1 other-pointer-lowtag) fdefn) #x7f :lock))) + (inst and :lock :byte (ea (- 1 other-pointer-lowtag) fdefn) #x7f))) (define-vop () - (:translate update-object-layout-or-invalid) + (:translate update-object-layout) (:args (obj :scs (descriptor-reg))) - (:info layout) - (:arg-types * (:constant t)) (:results (res :scs (descriptor-reg))) (:policy :fast-safe) (:vop-var vop) (:generator 1 - (inst push (if (immediate-constant-sc layout) - (make-fixup layout :layout) - (make-constant-tn (sb-c::find-constant layout)))) (inst push obj) (invoke-asm-routine 'call 'invalid-layout-trap vop) (inst pop res))) diff -Nru sbcl-2.0.6/src/compiler/x86-64/type-vops.lisp sbcl-2.1.1/src/compiler/x86-64/type-vops.lisp --- sbcl-2.0.6/src/compiler/x86-64/type-vops.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/type-vops.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -16,8 +16,7 @@ (defun generate-fixnum-test (value) "Set the Z flag if VALUE is fixnum" (inst test :byte - (cond ;; This is hooey. None of the type-vops presently allow - ;; control-stack as a storage class. + (cond ((ea-p value) value) ; merged a memory load + fixnump vop ((sc-is value control-stack) (ea (frame-byte-offset (tn-offset value)) rbp-tn)) (t @@ -88,12 +87,8 @@ (defun %test-immediate (value temp target not-p immediate &optional (drop-through (gen-label))) - ;; Code a single instruction byte test if possible. - (cond ((sc-is value any-reg descriptor-reg) - (inst cmp :byte value immediate)) - (t - (move temp value) ; FIXME - why load? - (inst cmp :byte temp immediate))) + (declare (ignore temp)) + (inst cmp :byte value immediate) (inst jmp (if not-p :ne :e) target) (emit-label drop-through)) @@ -135,6 +130,8 @@ (= (cdar headers) complex-array-widetag))) (ea (- lowtag) value) temp)) + (first (car headers)) + (second (cadr headers)) (untagged)) (multiple-value-bind (equal less-or-equal greater-or-equal when-true @@ -180,45 +177,56 @@ (inst cmp :byte temp widetag) (inst jmp :e when-false)) - ;; FIXME: this backend seems to be missing the special logic for - ;; testing exactly two widetags differing only in a single bit, - ;; which through evolution is almost totally unworkable anyway... + (cond + ((and (fixnump first) + (fixnump second) + (not (cddr headers)) + (= (logcount (logxor first second)) 1)) + ;; Two widetags differing at one bit. Use one cmp and branch. + ;; Start by ORing in the bit that they differ on. + (let ((diff-bit (logxor first second))) + (aver (not (ea-p widetag-tn))) ; can't clobber a header + (inst or :byte widetag-tn diff-bit) + (inst cmp :byte widetag-tn (logior first diff-bit)) + (if not-p (inst jmp :ne target) (inst jmp :eq target)))) + (t ;; Compared to x86 we additionally optimize the cases of a ;; range starting with BIGNUM-WIDETAG (= min widetag) ;; or ending with COMPLEX-ARRAY-WIDETAG (= max widetag) - (do ((remaining headers (cdr remaining))) - ((null remaining)) - (let ((header (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom header) - (inst cmp :byte widetag-tn header) - (if last - (inst jmp equal target) - (inst jmp :e when-true))) - (t - (let ((start (car header)) - (end (cdr header))) - (cond - ((= start bignum-widetag) - (inst cmp :byte widetag-tn end) - (if last - (inst jmp less-or-equal target) - (inst jmp :be when-true))) - ((= end complex-array-widetag) - (inst cmp :byte widetag-tn start) - (if last - (inst jmp greater-or-equal target) - (inst jmp :b when-false))) - ((not last) - (inst cmp :byte temp start) - (inst jmp :b when-false) - (inst cmp :byte temp end) - (inst jmp :be when-true)) - (t - (inst sub :byte temp start) - (inst cmp :byte temp (- end start)) - (inst jmp less-or-equal target)))))))) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst cmp :byte widetag-tn header) + (if last + (inst jmp equal target) + (inst jmp :e when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (cond + ((= start bignum-widetag) + (inst cmp :byte widetag-tn end) + (if last + (inst jmp less-or-equal target) + (inst jmp :be when-true))) + ((= end complex-array-widetag) + (inst cmp :byte widetag-tn start) + (if last + (inst jmp greater-or-equal target) + (inst jmp :b when-false))) + ((not last) + (inst cmp :byte temp start) + (inst jmp :b when-false) + (inst cmp :byte temp end) + (inst jmp :be when-true)) + (t + (inst sub :byte temp start) + (inst cmp :byte temp (- end start)) + (inst jmp less-or-equal target)))))))))) + (emit-label drop-through)))) ;;;; other integer ranges @@ -247,7 +255,7 @@ ;; a <= x <= a + 2^n - 1 ;; is equivalent to unsigned ;; ((x-a) >> n) = 0 - (inst mov temp #.(- sb-xc:most-negative-fixnum)) + (inst mov temp #.(- most-negative-fixnum)) (inst add temp value) (inst shr temp n-fixnum-bits))) @@ -389,16 +397,6 @@ (inst jmp (if not-p :a :be) target) (emit-label skip)))) -;;; The generic code (in src/compiler/generic/{early,late}-type-vops) -;;; would do the wrong thing. UNBOUND-MARKER-WIDETAG looks like a lowtag -;;; to that code and so it would mask off 4 bits before testing, -;;; which matches too many values. -(define-vop (unbound-marker-p simple-type-predicate) - (:translate unbound-marker-p) - (:generator 2 - (inst cmp :byte value unbound-marker-widetag) - (inst jmp (if not-p :ne :e) target))) - (define-vop (pointerp) (:args (value :scs (any-reg descriptor-reg) :target temp)) (:temporary (:sc unsigned-reg :from (:argument 0)) temp) @@ -463,23 +461,63 @@ (make-fixup (tn-value layout) :layout) layout))))) -(defknown layout-inherits-ref-eq (simple-vector index t) boolean (flushable)) -(define-vop (layout-inherits-ref-eq) - (:translate layout-inherits-ref-eq) - (:policy :fast-safe) - (:conditional :e) - (:args (vector :scs (descriptor-reg)) - (index :scs (any-reg descriptor-reg immediate)) - (thing :scs (descriptor-reg immediate))) - (:generator 1 - (inst cmp :dword - (if (sc-is index immediate) - (ea (+ (- other-pointer-lowtag) - (ash (+ vector-data-offset (tn-value index)) word-shift)) - vector) - (ea (+ (- other-pointer-lowtag) - (ash vector-data-offset word-shift)) - vector index (ash 1 (- word-shift n-fixnum-tag-bits)))) - (if (sc-is thing immediate) - (make-fixup (tn-value thing) :layout) - thing)))) +;;; Return the DISP part of an EA based on MEM-OP, which is comprised +;;; of a vop name and its codegen info. +;;; Return NIL if the value can't be encoded in a machine instruction. +(defun valid-memref-byte-disp (mem-op) + (ecase (car mem-op) + ((instance-index-ref-c + raw-instance-ref-c/word + raw-instance-ref-c/signed-word) + (destructuring-bind (index) (cdr mem-op) + (- (ash (+ index instance-slots-offset) word-shift) + instance-pointer-lowtag))) + (slot + (destructuring-bind (name index lowtag) (cdr mem-op) + (declare (ignore name)) + (- (ash index word-shift) lowtag))) + (data-vector-ref-with-offset/simple-vector-c + (destructuring-bind (index offset) (cdr mem-op) + (let ((disp (- (ash (+ vector-data-offset index offset) word-shift) + other-pointer-lowtag))) + (if (typep disp '(signed-byte 32)) disp)))))) + +(define-vop (fixnump simple-type-predicate) + (:translate fixnump) + (:args-var arg-ref) + (:args (value :scs (any-reg descriptor-reg) :load-if (tn-ref-memory-access arg-ref))) + (:generator 3 + (awhen (tn-ref-memory-access arg-ref) + (setq value (ea (cdr it) value))) + (test-type value nil target not-p + (even-fixnum-lowtag odd-fixnum-lowtag pad0-lowtag pad1-lowtag + pad2-lowtag pad3-lowtag pad4-lowtag pad5-lowtag)))) + +;;; Try to absorb a memory load into FIXNUMP. +(defoptimizer (sb-c::vop-optimize fixnump) (vop) + ;; Ensure that the fixnump vop does not try to absorb more than one memref. + ;; That is, if the initial IR2 matches (fixnump (memref (memref))) which is simplified + ;; to (memref+fixnump (memref x)), it would seem to allow matching of the pattern + ;; again if this optimizer is reapplied, because the "new" fixnump vop is superficially + ;; the same, except for the attachment of extra data to its input. + (unless (tn-ref-memory-access (sb-c::vop-args vop)) + (let ((prev (sb-c::previous-vop-is + vop + '(instance-index-ref-c slot + data-vector-ref-with-offset/simple-vector-c)))) + (aver (not (sb-c::vop-results vop))) ; is a :CONDITIONAL vop + (when (and prev (eq (vop-block prev) (vop-block vop))) + (let ((arg (sb-c::vop-args vop))) + (when (and (eq (tn-ref-tn (sb-c::vop-results prev)) (tn-ref-tn arg)) + (sb-c::very-temporary-p (tn-ref-tn arg))) + (binding* ((mem-op (cons (vop-name prev) (vop-codegen-info prev))) + (disp (valid-memref-byte-disp mem-op) :exit-if-null) + (arg-ref + (sb-c::reference-tn (tn-ref-tn (sb-c::vop-args prev)) nil)) + (new (sb-c::emit-and-insert-vop + (sb-c::vop-node vop) (vop-block vop) (sb-c::vop-info vop) + arg-ref nil prev (vop-codegen-info vop)))) + (setf (tn-ref-memory-access arg-ref) `(:read . ,disp)) + (sb-c::delete-vop prev) + (sb-c::delete-vop vop) + new))))))) diff -Nru sbcl-2.0.6/src/compiler/x86-64/vm.lisp sbcl-2.1.1/src/compiler/x86-64/vm.lisp --- sbcl-2.0.6/src/compiler/x86-64/vm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/x86-64/vm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -54,7 +54,7 @@ (define-gprs t *qword-regs* +qword-register-names+ #("RAX" "RCX" "RDX" "RBX" "RSP" "RBP" "RSI" "RDI" "R8" "R9" "R10" "R11" "R12" "R13" "R14" "R15")) - (define-gprs t *dword-regs* +dword-register-names+ + (define-gprs nil *dword-regs* +dword-register-names+ #("EAX" "ECX" "EDX" "EBX" "ESP" "EBP" "ESI" "EDI" "R8D" "R9D" "R10D" "R11D" "R12D" "R13D" "R14D" "R15D")) (define-gprs nil *word-regs* +word-register-names+ @@ -401,7 +401,7 @@ ;;; the appropriate SC number, otherwise return NIL. (defun immediate-constant-sc (value) (typecase value - ((or (integer #.sb-xc:most-negative-fixnum #.sb-xc:most-positive-fixnum) + ((or (integer #.most-negative-fixnum #.most-positive-fixnum) character) immediate-sc-number) (symbol ; Symbols in static and immobile space are immediate diff -Nru sbcl-2.0.6/src/compiler/xref.lisp sbcl-2.1.1/src/compiler/xref.lisp --- sbcl-2.0.6/src/compiler/xref.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/compiler/xref.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -299,7 +299,7 @@ do (dolist (number numbers) (write-var-integer (funcall encoder index number) vector)))) (setf (aref result 0) - (sb-xc:coerce vector '(simple-array (unsigned-byte 8) 1)))) + (coerce vector '(simple-array (unsigned-byte 8) 1)))) ;; RESULT is adjustable. Make it simple. (coerce result 'simple-vector))) diff -Nru sbcl-2.0.6/src/interpreter/sexpr.lisp sbcl-2.1.1/src/interpreter/sexpr.lisp --- sbcl-2.0.6/src/interpreter/sexpr.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/interpreter/sexpr.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1185,7 +1185,13 @@ ;; so the conservative thing is to plug in NILs, not bogus values ;; from whatever file (if any) is currently being loaded. (setf (sb-c::compiled-debug-info-tlf-num+offset cdi) 0) - (setf (symbol-function fname) compiled-fun))))) + ;; Skirt a package lock by avoiding (SETF SYMBOL-FUNCTION) + ;; *technically* this should be a compare-and-swap to ensure that the + ;; original lambda expression is as expected. To do that, we need + ;; to get to the point where fdefns do not store "both" representations + ;; of one function pointer, because we can't assume that multi-word CAS + ;; is a thing. Or use a mutex (horrible). + (setf (fdefn-fun (find-fdefn fname)) compiled-fun))))) (when (fluid-def-p fname) ;; Return a handler that calls FNAME very carefully diff -Nru sbcl-2.0.6/src/pcl/boot.lisp sbcl-2.1.1/src/pcl/boot.lisp --- sbcl-2.0.6/src/pcl/boot.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/boot.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -756,7 +756,7 @@ ;; perhaps because of the way that STRUCTURE-OBJECT inherits ;; both from SLOT-OBJECT and from SB-KERNEL:INSTANCE. In an ;; effort to sweep such problems under the rug, we exclude these - ;; problem cases by blacklisting them here. -- WHN 2001-01-19 + ;; problem cases here. -- WHN 2001-01-19 ((eq specializer 'slot-object) (declare-type nil)) @@ -1335,7 +1335,7 @@ (defstruct (constant-method-call (:copier nil) (:include method-call)) value) -#-sb-fluid (declaim (sb-ext:freeze-type method-call)) +(declaim (sb-ext:freeze-type method-call)) (defmacro invoke-method-call1 (function args cm-args) `(let ((.function. ,function) @@ -1361,7 +1361,7 @@ (:copier nil) (:include fast-method-call)) value) -#-sb-fluid (declaim (sb-ext:freeze-type fast-method-call)) +(declaim (sb-ext:freeze-type fast-method-call)) ;; The two variants of INVOKE-FAST-METHOD-CALL differ in how REST-ARGs ;; are handled. The first one will get REST-ARG as a single list (as @@ -1391,9 +1391,13 @@ ;; a factor of 2 with very little effect on the other ;; cases. Though it'd be nice to have the generic case be equally ;; fast. + ;; This is enough hardwired cases to handle the 0, 1, or 2 optional + ;; arguments to STREAM-WRITE-STRING. If you change anything about this, + ;; make sure to benchmark it. `(case ,more-count (0 ,(generate-call 0)) (1 ,(generate-call 1)) + (2 ,(generate-call 2)) (t (multiple-value-call (fast-method-call-function ,method-call) (values (fast-method-call-pv ,method-call)) (values (fast-method-call-next-method-call ,method-call)) @@ -1403,7 +1407,7 @@ (defstruct (fast-instance-boundp (:copier nil)) (index 0 :type fixnum)) -#-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp)) +(declaim (sb-ext:freeze-type fast-instance-boundp)) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *allow-emf-call-tracing-p* nil) @@ -1570,14 +1574,14 @@ (fixnum (cond ((null args) (%program-error "invalid number of arguments: 0")) - ((null (cdr args)) + ((and (not (minusp emf)) (null (cdr args))) (let* ((slots (get-slots (car args))) (value (clos-slots-ref slots emf))) (if (unbound-marker-p value) (slot-unbound-internal (car args) emf) value))) - ((null (cddr args)) - (setf (clos-slots-ref (get-slots (cadr args)) emf) + ((and (minusp emf) (not (null (cdr args))) (null (cddr args))) + (setf (clos-slots-ref (get-slots (cadr args)) (lognot emf)) (car args))) (t (%program-error "invalid number of arguments")))) (fast-instance-boundp @@ -1649,48 +1653,6 @@ (let ,rebindings ,@body))))) -;;; CMUCL comment (Gerd Moellmann): -;;; -;;; The standard says it's an error if CALL-NEXT-METHOD is called with -;;; arguments, and the set of methods applicable to those arguments is -;;; different from the set of methods applicable to the original -;;; method arguments. (According to Barry Margolin, this rule was -;;; probably added to ensure that before and around methods are always -;;; run before primary methods.) -;;; -;;; This could be optimized for the case that the generic function -;;; doesn't have hairy methods, does have standard method combination, -;;; is a standard generic function, there are no methods defined on it -;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such -;;; preconditions. That looks hairy and is probably not worth it, -;;; because this check will never be fast. -(defun %check-cnm-args (cnm-args orig-args method-cell) - ;; 1. Check for no arguments. - (when cnm-args - (let* ((gf (method-generic-function (car method-cell))) - (nreq (generic-function-nreq gf))) - (declare (fixnum nreq)) - ;; 2. Requirement arguments pairwise: if all are EQL, the applicable - ;; methods must be the same. This takes care of the relatively common - ;; case of twiddling with &KEY arguments without being horribly - ;; expensive. - (unless (do ((orig orig-args (cdr orig)) - (args cnm-args (cdr args)) - (n nreq (1- nreq))) - ((zerop n) t) - (unless (and orig args (eql (car orig) (car args))) - (return nil))) - ;; 3. Only then do the full check. - (let ((omethods (compute-applicable-methods gf orig-args)) - (nmethods (compute-applicable-methods gf cnm-args))) - (unless (equal omethods nmethods) - (error "~@" - nmethods (length cnm-args) cnm-args omethods - (length orig-args) orig-args))))))) - ;; FIXME: replacing this entire mess with DESTRUCTURING-BIND would correct ;; problems similar to those already solved by a correct implementation ;; of DESTRUCTURING-BIND, such as incorrect binding order: @@ -1788,6 +1750,21 @@ ;; modified in the method body. (parameters-setqd nil)) (flet ((walk-function (form context env) + (when (eq context :set) + (let ((var form)) + ;; PCL uses "poor man's constraint propagation" - it starts by assuming + ;; that each specialized parameter has a known type. If any SETQ on it + ;; occurs in a method body, the assumption is dropped for the entire body. + ;; Needless to say, it's horrible and could do much better by initially + ;; binding all specialized parameters thusly: + ;; (let ((arg1 (truly-the specialization1 arg1)) + ;; (arg2 (truly-the specialization2 arg2)) ... + ;; and then having ordinary transforms kick in. + (when (var-declaration '%parameter var env) + ;; If a parameter is shadowed by another binding it won't have a + ;; %PARAMETER declaration. + (pushnew var parameters-setqd :test #'eq))) + (return-from walk-function form)) (unless (and (eq context :eval) (consp form)) (return-from walk-function form)) (case (car form) @@ -1796,27 +1773,6 @@ (unless (eq call-next-method-p t) (setq call-next-method-p (if (cdr form) t :simple))) form) - ((setq multiple-value-setq) - ;; The walker will split (SETQ A 1 B 2) to - ;; separate (SETQ A 1) and (SETQ B 2) forms, so we - ;; only need to handle the simple case of SETQ - ;; here. - (let ((vars (if (eq (car form) 'setq) - (list (second form)) - (second form)))) - (dolist (var vars) - ;; Note that we don't need to check for - ;; %VARIABLE-REBINDING declarations like is - ;; done in CAN-OPTIMIZE-ACCESS1, since the - ;; bindings that will have that declation will - ;; never be SETQd. - (when (var-declaration '%parameter var env) - ;; If a parameter binding is shadowed by - ;; another binding it won't have a - ;; %PARAMETER declaration anymore, and this - ;; won't get executed. - (pushnew var parameters-setqd :test #'eq)))) - form) (function (when (equal (cdr form) '(call-next-method)) (setq call-next-method-p t)) @@ -2016,8 +1972,7 @@ (define-load-time-global *sgf-wrapper* (!boot-make-wrapper (!early-class-size 'standard-generic-function) 'standard-generic-function - nil - #+immobile-code +machine-code-embedding-fsc-instance-bitmap+)) + sb-kernel::standard-gf-primitive-obj-layout-bitmap)) (define-load-time-global *sgf-slots-init* (mapcar (lambda (canonical-slot) @@ -2074,9 +2029,11 @@ gf-info-static-c-a-m-emf (gf-info-c-a-m-emf-std-p t) - gf-info-fast-mf-p) + gf-info-fast-mf-p + + gf-info-cnm-checker) -#-sb-fluid (declaim (sb-ext:freeze-type arg-info)) +(declaim (sb-ext:freeze-type arg-info)) (defun arg-info-valid-p (arg-info) (not (null (arg-info-number-optional arg-info)))) @@ -2404,8 +2361,7 @@ (cond ((eq **boot-state** 'complete) ;; Check that we are under the lock. - #+sb-thread - (aver (eq sb-thread:*current-thread* (sb-thread:mutex-owner (gf-lock gf)))) + #+sb-thread (aver (sb-thread:holding-mutex-p (gf-lock gf))) (setf (safe-gf-dfun-state gf) new-state)) (t (setf (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+) diff -Nru sbcl-2.0.6/src/pcl/braid.lisp sbcl-2.1.1/src/pcl/braid.lisp --- sbcl-2.0.6/src/pcl/braid.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/braid.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -121,8 +121,6 @@ (find-class ',class) ,class))) classes))) -(defun !wrapper-p (x) (and (sb-kernel::layout-p x) (layout-for-pcl-obj-p x))) - (defun !bootstrap-meta-braid () (let* ((*create-classes-from-internal-structure-definitions-p* nil) standard-class-wrapper standard-class @@ -173,6 +171,9 @@ (multiple-value-bind (slots cpl default-initargs direct-subclasses) (!early-collect-inheritance name) (let* ((class (find-class name)) + (bitmap (if (memq name '(standard-generic-function)) + sb-kernel::standard-gf-primitive-obj-layout-bitmap + +layout-all-tagged+)) (wrapper (cond ((eq class slot-class) slot-class-wrapper) ((eq class standard-class) @@ -196,7 +197,7 @@ ((eq class standard-generic-function) standard-generic-function-wrapper) (t - (!boot-make-wrapper (length slots) name)))) + (!boot-make-wrapper (length slots) name bitmap)))) (proto nil)) (let ((symbol (make-class-symbol name))) (when (eq (info :variable :kind symbol) :global) @@ -206,7 +207,7 @@ (error "Slot allocation ~S is not supported in bootstrap." (getf slot :allocation)))) - (when (!wrapper-p wrapper) + (when (layout-for-pcl-obj-p wrapper) (setf (layout-slot-list wrapper) slots)) (setq proto (if (eq meta 'funcallable-standard-class) @@ -223,7 +224,7 @@ standard-effective-slot-definition-wrapper t)) (setf (layout-slot-table wrapper) (make-slot-table class slots t)) - (when (!wrapper-p wrapper) + (when (layout-for-pcl-obj-p wrapper) (setf (layout-slot-list wrapper) slots)) (case meta @@ -356,7 +357,7 @@ (make-slot-table class slots (member metaclass-name '(standard-class funcallable-standard-class)))) - (when (!wrapper-p wrapper) + (when (layout-for-pcl-obj-p wrapper) (setf (layout-slot-list wrapper) slots))) ;; For all direct superclasses SUPER of CLASS, make sure CLASS is @@ -567,7 +568,7 @@ (defun class-of (x) (declare (explicit-check)) - (wrapper-class* (layout-of x))) + (wrapper-class (layout-of x))) (defun eval-form (form) (lambda () (eval form))) @@ -652,6 +653,36 @@ (add-method gf class-method))) gf)) +(define-load-time-global *simple-stream-root-classoid* :unknown) + +(defun assign-layout-bitmap (layout) + ;; We decide only at class finalization time whether it is funcallable. + ;; Picking the right bitmap could probably be done sooner given the metaclass, + ;; but this approach avoids changing how PCL uses MAKE-LAYOUT. + ;; The big comment above MAKE-IMMOBILE-FUNINSTANCE in src/code/x86-64-vm + ;; explains why we differentiate between SGF and everything else. + (let ((inherits (layout-inherits layout))) + (when (find #.(find-layout 'stream) inherits) + (let ((flags 0)) + (dovector (layout inherits) + (when (eq (layout-classoid layout) *simple-stream-root-classoid*) + (setq flags (logior flags +simple-stream-layout-flag+))) + (case layout + (#.(find-layout 'file-stream) + (setq flags (logior flags +file-stream-layout-flag+))) + (#.(find-layout 'string-stream) + (setq flags +string-stream-layout-flag+)))) + (setf (layout-flags layout) + (logior flags +stream-layout-flag+ (layout-flags layout))))) + (when (find #.(find-layout 'function) inherits) + (setf (%raw-instance-ref/signed-word layout (sb-kernel::type-dd-length layout)) + #+immobile-code ; there are two possible bitmaps + (if (or (find *sgf-wrapper* inherits) (eq layout *sgf-wrapper*)) + sb-kernel::standard-gf-primitive-obj-layout-bitmap + +layout-all-tagged+) + ;; there is only one possible bitmap otherwise + #-immobile-code sb-kernel::standard-gf-primitive-obj-layout-bitmap)))) + ;;; Set the inherits from CPL, and register the layout. This actually ;;; installs the class in the Lisp type system. (defun %update-lisp-class-layout (class layout) @@ -661,7 +692,9 @@ (set-layout-inherits layout (order-layout-inherits (map 'simple-vector #'class-wrapper - (reverse (rest (class-precedence-list class)))))) + (reverse (rest (class-precedence-list class))))) + nil 0) + (assign-layout-bitmap layout) (register-layout layout :invalidate t) ;; FIXME: I don't think this should be necessary, but without it diff -Nru sbcl-2.0.6/src/pcl/call-next-method.lisp sbcl-2.1.1/src/pcl/call-next-method.lisp --- sbcl-2.0.6/src/pcl/call-next-method.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/pcl/call-next-method.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,194 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. + +;;;; This software is derived from software originally released by Xerox +;;;; Corporation. Copyright and release statements follow. Later modifications +;;;; to the software are in the public domain and are provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for more +;;;; information. + +;;;; copyright information from original PCL sources: +;;;; +;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;;; All rights reserved. +;;;; +;;;; Use and copying of this software and preparation of derivative works based +;;;; upon this software are permitted. Any distribution of this software or +;;;; derivative works must comply with all applicable United States export +;;;; control laws. +;;;; +;;;; This software is made available AS IS, and Xerox Corporation makes no +;;;; warranty about the software, its performance or its conformity to any +;;;; specification. + +(in-package "SB-PCL") + +;;; CMUCL comment (Gerd Moellmann): +;;; +;;; The standard says it's an error if CALL-NEXT-METHOD is called with +;;; arguments, and the set of methods applicable to those arguments is +;;; different from the set of methods applicable to the original +;;; method arguments. (According to Barry Margolin, this rule was +;;; probably added to ensure that before and around methods are always +;;; run before primary methods.) +;;; +;;; This could be optimized for the case that the generic function +;;; doesn't have hairy methods, does have standard method combination, +;;; is a standard generic function, there are no methods defined on it +;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such +;;; preconditions. That looks hairy and is probably not worth it, +;;; because this check will never be fast. + +;;; Or maybe it will (Jan Moringen): +;;; +;;; The "CALL-NEXT-METHOD argument checker" is a generic function +;;; which has twice as many required parameters as the original +;;; generic function. Consider, for example +;;; +;;; (defgeneric foo (bar baz &key fez)) +;;; +;;; The cnm args checker for this generic function is a generic +;;; function roughly equivalent to +;;; +;;; (defgeneric cnm-args-checker-for-foo (old-bar old-baz new-bar new-baz) +;;; (:generic-function-class cnm-args-checker)) +;;; +;;; The cnm args checker is applied to the concatenation of the +;;; original arguments and the arguments supplied to +;;; CALL-NEXT-METHOD: +;;; +;;; ;; In the expansion of (call-next-method new-bar new-bar ...): +;;; (when (funcall CNM-ARGS-CHECKER-FOR-FOO +;;; old-bar old-baz new-bar new-baz) +;;; (error "This list of applicable methods ... differs.")) +;;; +;;; A cnm args checker initially does not have any methods. When it is +;;; called with a particular sequence of arguments and does not have +;;; an applicable method for these arguments, it computes the +;;; applicable methods /of the original generic function/ for the old +;;; arguments and for the new arguments and adds a method that +;;; immediately returns the computed result when the same (in terms of +;;; CLOS dispatch) combination appears again. +;;; +;;; The cnm args checker must be invalidated when the results cached +;;; in its defined methods become invalid. + +(defun %check-cnm-args (cnm-args orig-args method-cell) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type list cnm-args orig-args)) + ;; 1. Check for no arguments. + (when cnm-args + (let* ((gf (method-generic-function (car method-cell))) + (nreq (generic-function-nreq gf))) + (declare (type (integer 0 #.call-arguments-limit) nreq)) + ;; 2. Consider required arguments pairwise: if the old and new + ;; arguments in all pairs are EQL, the applicable methods must + ;; be the same. This takes care of the relatively common case of + ;; twiddling with &KEY arguments. + (unless (do ((orig orig-args (cdr orig)) + (args cnm-args (cdr args)) + (n nreq (1- n))) + ((zerop n) t) + (declare (type (integer 0 #.call-arguments-limit) n)) + (unless (eql (car orig) (car args)) + (return nil))) + ;; 3. Only then make a cnm args checker and do the full check. + ;; Disabled until problems with EQL specializers and method + ;; "shadowing" are worked out. + #+(or) (let ((result (%use-cnm-checker gf nreq cnm-args orig-args))) + (when result + (destructuring-bind (cnm-methods . orig-methods) result + (error "~@" + cnm-methods (length cnm-args) cnm-args + orig-methods (length orig-args) orig-args)))) + (let ((orig-methods (compute-applicable-methods gf orig-args)) + (cnm-methods (compute-applicable-methods gf cnm-args))) + (unless (equal orig-methods cnm-methods) + (error "~@" + cnm-methods (length cnm-args) cnm-args + orig-methods (length orig-args) orig-args))))))) + +;;; CALL-NEXT-METHOD argument checker application + +(defun %use-cnm-checker (generic-function nreq cnm-args orig-args) + (declare (type (integer 1 #.call-arguments-limit) nreq)) + (let* ((info (gf-arg-info generic-function)) + ;; Setting GF-INFO-CNM-CHECKER is racy but should be OK. + (checker (or (gf-info-cnm-checker info) + (setf (gf-info-cnm-checker info) + (%make-cnm-checker generic-function)))) + (args (make-list (* 2 nreq)))) + (declare (dynamic-extent args)) + ;; Construct the concatenation of the required arguments in + ;; ORIG-ARGS and CNM-ARGS in ARGS. + (loop repeat nreq + for rest1 on args + for arg in orig-args + do (setf (car rest1) arg) + finally (loop for rest2 on (rest rest1) + for arg in cnm-args + do (setf (car rest2) arg))) + (apply checker args))) + +(defun %cnm-checker-lambda-list (nreq) + (append (map-into (make-list (* 2 nreq)) #'gensym) '(&rest rest))) + +(defun %make-cnm-checker (generic-function) + (let ((nreq (generic-function-nreq generic-function))) + (make-instance 'cnm-args-checker + :name nil + :lambda-list (%cnm-checker-lambda-list nreq) + :generic-function generic-function))) + +;;; CALL-NEXT-METHOD argument checker implementation + +(defclass cnm-args-checker (standard-generic-function) + ((%generic-function :initarg :generic-function + :reader cnm-args-checker-generic-function)) + (:metaclass funcallable-standard-class)) + +(defmethod no-applicable-method ((generic-function cnm-args-checker) + &rest args) + ;; Construct a method for GENERIC-FUNCTION that, when applied to + ;; ARGS, returns NIL (which indicates "fno error") if the + ;; CALL-NEXT-METHOD call is fine for the generic function + ;; (cnm-args-checker-generic-function generic-function) and a cons + ;; (ORIG-METHODS . CNM-METHODS) otherwise. + (let* ((original-generic-function (cnm-args-checker-generic-function + generic-function)) + (nreq (generic-function-nreq original-generic-function)) + (orig-args (subseq args 0 nreq)) + (orig-methods (compute-applicable-methods + original-generic-function orig-args)) + (cnm-args (subseq args nreq)) + (cnm-methods (compute-applicable-methods + original-generic-function cnm-args)) + (result (if (equal orig-methods cnm-methods) + nil + (cons orig-methods cnm-methods))) + (lambda-list (%cnm-checker-lambda-list nreq)) + (lambda (make-method-lambda + generic-function + (class-prototype (generic-function-method-class + generic-function)) + `(lambda ,lambda-list + (declare (ignore ,@(remove '&rest lambda-list)) + (optimize (speed 3) (debug 0) (safety 0))) + ',result) + nil)) + (function (compile nil lambda)) + (specializers (append (method-specializers (first orig-methods)) + (method-specializers (first cnm-methods)))) + (method (make-instance 'standard-method + :qualifiers '() + :lambda-list lambda-list + :specializers specializers + :function function))) + (add-method generic-function method) + (apply generic-function args))) diff -Nru sbcl-2.0.6/src/pcl/defclass.lisp sbcl-2.1.1/src/pcl/defclass.lisp --- sbcl-2.0.6/src/pcl/defclass.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/defclass.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -161,7 +161,6 @@ options) (let (metaclass default-initargs - documentation canonized-options) (dolist (option options) (unless (listp option) @@ -191,7 +190,6 @@ (:documentation (unless (stringp (second option)) (error "~S is not a legal :documentation value" (second option))) - (setf documentation t) (push `(:documentation ,(second option)) canonized-options)) (otherwise (push `(',(car option) ',(cdr option)) canonized-options)))) @@ -293,15 +291,15 @@ source-form) (cond ((and (or (eq initform t) (equal initform ''t)) - (neq type t)) + (eq type t)) '(function constantly-t)) ((and (or (eq initform nil) (equal initform ''nil)) - (neq type t)) + (eq type t)) '(function constantly-nil)) ((and (or (eql initform 0) (equal initform ''0)) - (neq type t)) + (eq type t)) '(function constantly-0)) (t (let* ((initform (if (eq type t) diff -Nru sbcl-2.0.6/src/pcl/defcombin.lisp sbcl-2.1.1/src/pcl/defcombin.lisp --- sbcl-2.0.6/src/pcl/defcombin.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/defcombin.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -314,7 +314,8 @@ (setq ,name (nreverse ,name))) (:most-specific-last)))) order-cleanups)))) - `(let (,@(nreverse names) ,@(nreverse specializer-caches)) + `(let (,@(nreverse names) ,@specializer-caches) + (declare (ignorable ,@specializer-caches)) ,@declarations (dolist (.method. .applicable-methods.) (let ((.qualifiers. (method-qualifiers .method.)) diff -Nru sbcl-2.0.6/src/pcl/defs.lisp sbcl-2.1.1/src/pcl/defs.lisp --- sbcl-2.0.6/src/pcl/defs.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/defs.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -38,7 +38,7 @@ has already been partially loaded. This may not work, you may~%~ need to get a fresh lisp (reboot) and then load PCL.")) -#-sb-fluid (declaim (inline gdefinition)) +(declaim (inline gdefinition)) (defun gdefinition (spec) ;; This is null layer right now, but once FDEFINITION stops bypasssing ;; fwrappers/encapsulations we can do that here. diff -Nru sbcl-2.0.6/src/pcl/dfun.lisp sbcl-2.1.1/src/pcl/dfun.lisp --- sbcl-2.0.6/src/pcl/dfun.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/dfun.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -373,7 +373,7 @@ (lambda (new arg) (accessor-miss gf new arg dfun-info))))) -#-sb-fluid (declaim (sb-ext:freeze-type dfun-info)) +(declaim (sb-ext:freeze-type dfun-info)) (defun make-one-class-accessor-dfun (gf type wrapper index) (let ((emit (ecase type @@ -715,16 +715,20 @@ (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*))) (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*))) ,@body)) - ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached - ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is, - ;; does not signal a SLOT-UNBOUND error for a boundp test. - ,@(if type - ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated - ;; slots?) - `((if (and (eq ,type 'boundp) (integerp ,nemf)) - (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args) - (invoke-emf ,nemf ,args))) - `((invoke-emf ,nemf ,args))))) + ,(if type + ;; Munge the EMF so that INVOKE-EMF can do the right thing: + ;; BOUNDP gets a structure, WRITER the logical not of the + ;; index, so that READER can use the raw index. + ;; + ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated + ;; slots?) + `(if (integerp ,nemf) + (case ,type + (boundp (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args)) + (reader (invoke-emf ,nemf ,args)) + (writer (invoke-emf (lognot ,nemf) ,args))) + (invoke-emf ,nemf ,args)) + `(invoke-emf ,nemf ,args)))) ;;; The dynamically adaptive method lookup algorithm is implemented is ;;; implemented as a kind of state machine. The kinds of @@ -1697,6 +1701,15 @@ (defun update-dfun (generic-function &optional dfun cache info) (let ((early-p (early-gf-p generic-function))) (flet ((update () + ;; If GENERIC-FUNCTION has a CALL-NEXT-METHOD argument + ;; checker, the methods of the checker (the checker is a + ;; generic function, each method caches a computation for + ;; a combination of original and C-N-M argument classes) + ;; must be re-computed. + (when (eq **boot-state** 'complete) + (let ((checker (gf-info-cnm-checker (gf-arg-info generic-function)))) + (when checker + (remove-methods checker)))) ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can ;; access it, and so that it's there for eg. future cache updates. (set-dfun generic-function dfun cache info) diff -Nru sbcl-2.0.6/src/pcl/env.lisp sbcl-2.1.1/src/pcl/env.lisp --- sbcl-2.0.6/src/pcl/env.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/env.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -158,7 +158,7 @@ (fmakunbound 'make-load-form) (defgeneric make-load-form (object &optional environment)) -(defun !incorporate-cross-compiled-methods (gf-name &key except) +(defun !install-cross-compiled-methods (gf-name &key except) (assert (generic-function-p (fdefinition gf-name))) ;; Reversing installs less-specific methods first, ;; so that if perchance we crash mid way through the loop, @@ -173,13 +173,15 @@ (source-loc (svref method 5))) (unless (member specializer except) (multiple-value-bind (specializers arg-info) - (ecase gf-name + (case gf-name (print-object (values (list (find-class specializer) (find-class t)) '(:arg-info (2)))) - (make-load-form + ((make-load-form close) (values (list (find-class specializer)) - '(:arg-info (1 . t))))) + '(:arg-info (1 . t)))) + (t + (values (list (find-class specializer)) '(:arg-info (1))))) (load-defmethod 'standard-method gf-name (if qualifier (list qualifier)) specializers lambda-list @@ -190,7 +192,7 @@ mf) plist ,arg-info simple-next-method-call t) source-loc)))))) -(!incorporate-cross-compiled-methods 'make-load-form :except '(layout)) +(!install-cross-compiled-methods 'make-load-form :except '(layout)) (defmethod make-load-form ((class class) &optional env) ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably @@ -223,11 +225,6 @@ (define-default-make-load-form-method standard-object) (define-default-make-load-form-method condition)) -sb-impl:: -(defmethod make-load-form ((host (eql *physical-host*)) &optional env) - (declare (ignore env)) - '*physical-host*) - ;;; I guess if the user defines other kinds of EQL specializers, she would ;;; need to implement this? And how is she supposed to know that? (defmethod eql-specializer-to-ctype ((specializer eql-specializer)) diff -Nru sbcl-2.0.6/src/pcl/fixup.lisp sbcl-2.1.1/src/pcl/fixup.lisp --- sbcl-2.0.6/src/pcl/fixup.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/fixup.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -66,5 +66,54 @@ (setq **boot-state** 'complete) ;;; CLASS-PROTOTYPE for FUNCTION should not use ALLOCATE-INSTANCE. +;;; +;;; FIXME: this causes an error +;;; "A function with declared result type NIL returned: +;;; (SLOT-ACCESSOR :GLOBAL PROTOTYPE WRITER)" +;;; if SB-EXT:*DERIVE-FUNCTION-TYPES* is T. +;;; (let ((class (find-class 'function))) (setf (slot-value class 'prototype) #'identity)) + +(dolist (symbol '(add-method allocate-instance class-name compute-applicable-methods + ensure-generic-function make-instance method-qualifiers + remove-method 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 + 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)) + (sb-impl::deprecate-export *package* symbol :late "2.0.7")) diff -Nru sbcl-2.0.6/src/pcl/fngen.lisp sbcl-2.1.1/src/pcl/fngen.lisp --- sbcl-2.0.6/src/pcl/fngen.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/fngen.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -94,7 +94,7 @@ (defun ensure-fgen (test gensyms generator generator-lambda system) (let ((table *fgens*)) - (sb-thread::with-system-mutex ((hash-table-lock table)) + (with-system-mutex ((hash-table-lock table)) (let ((old (gethash test table))) (cond (old (setf (fgen-generator old) generator) @@ -108,7 +108,7 @@ (defun get-fun-generator (lambda test-converter code-converter) (let* ((test (compute-test lambda test-converter)) (table *fgens*) - (fgen (sb-thread::with-system-mutex ((hash-table-lock table)) + (fgen (with-system-mutex ((hash-table-lock table)) (gethash test table)))) (if fgen (fgen-generator fgen) diff -Nru sbcl-2.0.6/src/pcl/gray-streams.lisp sbcl-2.1.1/src/pcl/gray-streams.lisp --- sbcl-2.0.6/src/pcl/gray-streams.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/gray-streams.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,141 +11,73 @@ (in-package "SB-GRAY") -;;; BUG-OR-ERROR: because we have extensible streams, wherewith the -;;; user is responsible for some of the protocol implementation, it's -;;; not necessarily a bug in SBCL itself if we fall through to one of -;;; these default methods. -;;; -;;; FIXME: there's a lot of similarity in these Gray stream -;;; implementation generic functions. All of them could (maybe -;;; should?) have two default methods: one on STREAM calling -;;; BUG-OR-ERROR, and one on T signalling a TYPE-ERROR. -(declaim (ftype (function * nil) bug-or-error)) -(defun bug-or-error (stream fun) - (declare (optimize allow-non-returning-tail-call)) - (error - "~@).~@:>" - stream fun)) +(defclass stream-function (standard-generic-function) () + (:metaclass sb-mop:funcallable-standard-class)) +(defmacro !def-stream-generic (name ll &rest rest) + `(progn (fmakunbound ',name) + (defgeneric ,name ,ll (:generic-function-class stream-function) ,@rest) + (sb-pcl::!install-cross-compiled-methods ',name))) +(defmethod no-applicable-method ((function stream-function) &rest args) + (let ((stream (car args))) + (if (streamp stream) + (call-next-method) + (error 'type-error :datum stream :expected-type 'stream)))) -(fmakunbound 'stream-element-type) - -(defgeneric stream-element-type (stream) +(!def-stream-generic stream-element-type (stream) (:documentation "Return a type specifier for the kind of object returned by the STREAM. The class FUNDAMENTAL-CHARACTER-STREAM provides a default method which returns CHARACTER.")) -(defmethod stream-element-type ((stream ansi-stream)) - (ansi-stream-element-type stream)) - (defmethod stream-element-type ((stream fundamental-character-stream)) 'character) - -(defmethod stream-element-type ((stream stream)) - (bug-or-error stream 'stream-element-type)) - -(defmethod stream-element-type ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream)) -(fmakunbound 'open-stream-p) - -(defgeneric open-stream-p (stream) +(!def-stream-generic open-stream-p (stream) (:documentation "Return true if STREAM is not closed. A default method is provided by class FUNDAMENTAL-STREAM which returns true if CLOSE has not been called on the stream.")) -(defmethod open-stream-p ((stream ansi-stream)) - (ansi-stream-open-stream-p stream)) - (defmethod open-stream-p ((stream fundamental-stream)) (stream-open-p stream)) - -(defmethod open-stream-p ((stream stream)) - (bug-or-error stream 'open-stream-p)) - -(defmethod open-stream-p ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream)) -(fmakunbound 'close) - -(defgeneric close (stream &key abort) +(!def-stream-generic close (stream &key abort) (:documentation "Close the given STREAM. No more I/O may be performed, but inquiries may still be made. If :ABORT is true, an attempt is made to clean up the side effects of having created the stream.")) -(defmethod close ((stream ansi-stream) &key abort) - (ansi-stream-close stream abort)) - (defmethod close ((stream fundamental-stream) &key abort) (declare (ignore abort)) (setf (stream-open-p stream) nil) t) -(let () - (fmakunbound 'input-stream-p) - - (defgeneric input-stream-p (stream) +(progn + (!def-stream-generic input-stream-p (stream) (:documentation "Can STREAM perform input operations?")) - (defmethod input-stream-p ((stream ansi-stream)) - (ansi-stream-input-stream-p stream)) - (defmethod input-stream-p ((stream fundamental-stream)) nil) (defmethod input-stream-p ((stream fundamental-input-stream)) - t) - - (defmethod input-stream-p ((stream stream)) - (bug-or-error stream 'input-stream-p)) - - (defmethod input-stream-p ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream))) + t)) -(let () - (fmakunbound 'interactive-stream-p) - - (defgeneric interactive-stream-p (stream) +(progn + (!def-stream-generic interactive-stream-p (stream) (:documentation "Is STREAM an interactive stream?")) - (defmethod interactive-stream-p ((stream ansi-stream)) - (funcall (ansi-stream-misc stream) stream :interactive-p)) - (defmethod interactive-stream-p ((stream fundamental-stream)) - nil) - - (defmethod interactive-stream-p ((stream stream)) - (bug-or-error stream 'interactive-stream-p)) - - (defmethod interactive-stream-p ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream))) + nil)) -(let () - (fmakunbound 'output-stream-p) - - (defgeneric output-stream-p (stream) +(progn + (!def-stream-generic output-stream-p (stream) (:documentation "Can STREAM perform output operations?")) - (defmethod output-stream-p ((stream ansi-stream)) - (ansi-stream-output-stream-p stream)) - (defmethod output-stream-p ((stream fundamental-stream)) nil) (defmethod output-stream-p ((stream fundamental-output-stream)) - t) - - (defmethod output-stream-p ((stream stream)) - (bug-or-error stream 'output-stream-p)) - - (defmethod output-stream-p ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream))) + t)) ;;; character input streams ;;; @@ -211,23 +143,19 @@ calls to STREAM-READ-CHAR.")) (defmethod stream-read-line ((stream fundamental-character-input-stream)) - (let ((res (make-string 80)) - (len 80) - (index 0)) - (loop - (let ((ch (stream-read-char stream))) - (cond ((eq ch :eof) - (return (values (%shrink-vector res index) t))) - (t - (when (char= ch #\newline) - (return (values (%shrink-vector res index) nil))) - (when (= index len) - (setq len (* len 2)) - (let ((new (make-string len))) - (replace new res) - (setq res new))) - (setf (schar res index) ch) - (incf index))))))) + (let (eof) + ;; This loop is simpler than the one in ansi-stream-read-line + ;; because here we always return a string for the primary value, + ;; and the caller tests for a 0-length string. + ;; Writing to a string-output-stream adds negligible overhead + ;; versus the method dispatch for each input character. + (values (with-output-to-string (s) + (loop (let ((ch (stream-read-char stream))) + (case ch + (#\newline (return)) + (:eof (return (setq eof t))) + (t (funcall (ansi-stream-out s) s ch)))))) + eof))) (defgeneric stream-clear-input (stream) (:documentation @@ -236,10 +164,6 @@ (defmethod stream-clear-input ((stream fundamental-character-input-stream)) nil) -(defmethod stream-clear-input ((stream stream)) - (bug-or-error stream 'stream-clear-input)) -(defmethod stream-clear-input ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream)) (defgeneric stream-read-sequence (stream seq &optional start end) (:documentation @@ -369,10 +293,6 @@ (defmethod stream-finish-output ((stream fundamental-output-stream)) nil) -(defmethod stream-finish-output ((stream stream)) - (bug-or-error stream 'stream-finish-output)) -(defmethod stream-finish-output ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream)) (defgeneric stream-force-output (stream) (:documentation @@ -381,10 +301,6 @@ (defmethod stream-force-output ((stream fundamental-output-stream)) nil) -(defmethod stream-force-output ((stream stream)) - (bug-or-error stream 'stream-force-output)) -(defmethod stream-force-output ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream)) (defgeneric stream-clear-output (stream) (:documentation @@ -393,10 +309,6 @@ (defmethod stream-clear-output ((stream fundamental-output-stream)) nil) -(defmethod stream-clear-output ((stream stream)) - (bug-or-error stream 'stream-clear-output)) -(defmethod stream-clear-output ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream)) (defgeneric stream-advance-to-column (stream column) (:documentation @@ -452,32 +364,15 @@ "Used by READ-BYTE; returns either an integer, or the symbol :EOF if the stream is at end-of-file.")) -(defmethod stream-read-byte ((stream stream)) - (bug-or-error stream 'stream-read-byte)) -(defmethod stream-read-byte ((non-stream t)) - (error 'type-error :datum non-stream :expected-type 'stream)) - (defgeneric stream-write-byte (stream integer) (:documentation "Implements WRITE-BYTE; writes the integer to the stream and returns the integer as the result.")) -(defmethod stream-write-byte ((stream stream) integer) - (bug-or-error stream 'stream-write-byte)) -(defmethod stream-write-byte ((non-stream t) integer) - (error 'type-error :datum non-stream :expected-type 'stream)) - (defgeneric stream-file-position (stream &optional position-spec) (:documentation "Used by FILE-POSITION. Returns or changes the current position within STREAM.")) - -(defmethod stream-file-position ((stream ansi-stream) &optional position-spec) - (ansi-stream-file-position stream position-spec)) - -(defmethod stream-file-position ((stream t) &optional position-spec) - (declare (ignore stream position-spec)) - nil) - +(sb-pcl::!install-cross-compiled-methods 'stream-file-position) ;;; This is not in the Gray stream proposal, so it is left here ;;; as example code. @@ -555,3 +450,36 @@ (defmethod stream-clear-input ((stream character-input-stream)) (clear-input (character-input-stream-lisp-stream stream))) |# + +#| +A small change to INVOKE-FAST-METHOD-CALL/MORE was able to get an easy 10% speedup + in STREAM-WRITE-STRING as shown below. +---- +(defclass sink-stream (fundamental-character-output-stream) ()) + +(defvar *callcount* 0) +(defmethod sb-gray:stream-write-string ((stream sink-stream) string &optional start end) + (declare (ignore start end)) + (incf *callcount*)) + +(defun time-this (&optional (n-iter 30000000)) + (declare (fixnum n-iter)) + (let ((stream (make-instance 'sink-stream))) + (dotimes (i n-iter) + (write-string "zook" stream :start 0 :end 4))) + (format t "Calls: ~s~%" *callcount*)) +---- + +Taking the best out of 3 runs each for old and new: +perf stat ... --noinform --eval '(setq *evaluator-mode* :compile)' --load foo.lisp --eval '(time-this)' --quit +Old: + 1.272560994 seconds time elapsed +New: + 1.136901160 seconds time elapsed + +Of course a dumb thing about this particular GF is that you probably never +invoke it directly, but only through WRITE-STRING or WRITE-LINE +in which case it always receives 4 args. So the small patch in src/pcl/boot +handles that afficiently, even if it was a little bit ad-hoc. +I don't think it was too ad-hoc though, because it's valid for any GF. +|# diff -Nru sbcl-2.0.6/src/pcl/low.lisp sbcl-2.1.1/src/pcl/low.lisp --- sbcl-2.0.6/src/pcl/low.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/low.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -204,7 +204,8 @@ `(%instance-ref ,x ,sb-vm:instance-data-start)) (defmacro std-instance-slots (x) `(truly-the simple-vector (%std-instance-slots ,x))) -;; %fsc-instance-slots is defined in src/pcl/pre-warm +(defmacro %fsc-instance-slots (fin) + `(%funcallable-instance-info ,fin 0)) (defmacro fsc-instance-slots (x) `(truly-the simple-vector (%fsc-instance-slots ,x))) diff -Nru sbcl-2.0.6/src/pcl/pre-warm.lisp sbcl-2.1.1/src/pcl/pre-warm.lisp --- sbcl-2.0.6/src/pcl/pre-warm.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/pre-warm.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -78,13 +78,6 @@ :dd-type funcallable-structure) ) -;;; Needed to compile the #n# reader because apparently some people think it amusing -;;; to create readable funcallable instances involving circularity and/or sharing. -;;; No constraint on the result type so that the slot implementation strategy -;;; is wholly defined within the warm build. -(defmacro %fsc-instance-slots (fin) - `(%funcallable-instance-info ,fin ,sb-vm:instance-data-start)) - ;;; Set up fake standard-classes. ;;; This is enough to fool the compiler into optimizing TYPEP into ;;; %INSTANCE-TYPEP. @@ -119,11 +112,6 @@ (long-method-combination long-method-combination-p) (short-method-combination short-method-combination-p))) -(defmacro set-layout-valid (layout) - `(let ((layout ,layout)) - (setf (layout-invalid layout) niL) - layout)) - #+sb-xc-host (progn ;;; Create # @@ -135,13 +123,13 @@ (let* ((name 'condition) (classoid (sb-kernel::make-condition-classoid :name name)) (cell (sb-kernel::make-classoid-cell name classoid)) - (layout (set-layout-valid - (make-layout (hash-layout-name name) + (layout (make-layout (hash-layout-name name) classoid - :inherits (vector (find-layout 't)) :depthoid 1 + :inherits (vector (find-layout 't)) :length (+ sb-vm:instance-data-start 1) - :flags +condition-layout-flag+)))) + :flags +condition-layout-flag+ + :invalid nil))) (setf (classoid-layout classoid) layout (info :type :classoid-cell name) cell (info :type :kind name) :instance)) @@ -151,13 +139,13 @@ (let* ((classoid (make-standard-classoid :name name)) (cell (sb-kernel::make-classoid-cell name classoid)) (layout - (set-layout-valid (make-layout (hash-layout-name name) classoid + :depthoid -1 :inherits (map 'vector #'find-layout (cons t (if fun-p '(function)))) :length 0 ; don't care - :depthoid -1)))) + :invalid nil))) (setf (classoid-layout classoid) layout (info :type :classoid-cell name) cell (info :type :kind name) :instance)))) diff -Nru sbcl-2.0.6/src/pcl/print-object.lisp sbcl-2.1.1/src/pcl/print-object.lisp --- sbcl-2.0.6/src/pcl/print-object.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/print-object.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -39,7 +39,7 @@ (let ((*print-pretty* t)) ; use pretty printer dispatch table, not PRINT-OBJECT (fmakunbound 'print-object) (defgeneric print-object (object stream)) - (!incorporate-cross-compiled-methods 'print-object)) + (!install-cross-compiled-methods 'print-object)) (unless (sb-impl::!c-runtime-noinform-p) (write-string " done ")) diff -Nru sbcl-2.0.6/src/pcl/slots.lisp sbcl-2.1.1/src/pcl/slots.lisp --- sbcl-2.0.6/src/pcl/slots.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/slots.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -95,7 +95,7 @@ (return-from slot-value (if cell (funcall (slot-info-reader (cdr cell)) object) - (values (slot-missing (wrapper-class* wrapper) object + (values (slot-missing (wrapper-class wrapper) object slot-name 'slot-value))))) ;; this next test means CONSP, but the transform that weakens ;; CONSP to LISTP isn't working here for some reason. @@ -104,14 +104,14 @@ (t (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) (if (unbound-marker-p value) - (slot-unbound (wrapper-class* wrapper) object slot-name) + (slot-unbound (wrapper-class wrapper) object slot-name) value))) (defun set-slot-value (object slot-name new-value) (let* ((wrapper (valid-wrapper-of object)) (cell (or (find-slot-cell wrapper slot-name) (return-from set-slot-value - (progn (slot-missing (wrapper-class* wrapper) + (progn (slot-missing (wrapper-class wrapper) object slot-name 'setf new-value) new-value)))) (location (car cell)) @@ -143,7 +143,7 @@ (let* ((wrapper (valid-wrapper-of object)) (cell (or (find-slot-cell wrapper slot-name) (return-from slot-value - (values (slot-missing (wrapper-class* wrapper) object slot-name + (values (slot-missing (wrapper-class wrapper) object slot-name 'cas (list old-value new-value)))))) (location (car cell)) (info (cdr cell)) @@ -163,7 +163,7 @@ (t (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell))))) (if (and (unbound-marker-p old) (neq old old-value)) - (slot-unbound (wrapper-class* wrapper) object slot-name) + (slot-unbound (wrapper-class wrapper) object slot-name) old)))) (defun slot-boundp (object slot-name) @@ -179,7 +179,7 @@ (return-from slot-boundp (if cell (funcall (slot-info-boundp (cdr cell)) object) - (and (slot-missing (wrapper-class* wrapper) object + (and (slot-missing (wrapper-class wrapper) object slot-name 'slot-boundp) t)))) ((listp location) ; forcibly transform CONSP to LISTP @@ -199,10 +199,10 @@ +slot-unbound+))) ((not location) (if cell - (let ((class (wrapper-class* wrapper))) + (let ((class (wrapper-class wrapper))) (slot-makunbound-using-class class object (find-slot-definition class slot-name))) - (slot-missing (wrapper-class* wrapper) object slot-name + (slot-missing (wrapper-class wrapper) object slot-name 'slot-makunbound))) ((listp location) ; forcibly transform CONSP to LISTP (setf (cdr location) +slot-unbound+)) diff -Nru sbcl-2.0.6/src/pcl/std-class.lisp sbcl-2.1.1/src/pcl/std-class.lisp --- sbcl-2.0.6/src/pcl/std-class.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/std-class.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -174,7 +174,20 @@ (defmethod add-direct-subclass ((class class) (subclass class)) (with-slots (direct-subclasses) class (with-world-lock () - (pushnew subclass direct-subclasses :test #'eq)) + (pushnew subclass direct-subclasses :test #'eq) + (let ((layout (class-wrapper subclass))) + (when layout + (let* ((classoid (layout-classoid layout))) + (dovector (super-layout (layout-inherits layout)) + (let* ((super (layout-classoid super-layout)) + (subclasses (or (classoid-subclasses super) + (or (classoid-subclasses super) + (setf (classoid-subclasses super) + (make-hash-table :hash-function #'type-hash-value + :test 'eq + :synchronized t)))))) + (when subclasses + (setf (gethash classoid subclasses) layout)))))))) subclass)) (defmethod remove-direct-subclass ((class class) (subclass class)) (with-slots (direct-subclasses) class @@ -300,7 +313,7 @@ (let ((table (specializer-method-table self)) (object (specializer-object self))) (if create - (sb-thread::with-system-mutex ((hash-table-lock table)) + (with-system-mutex ((hash-table-lock table)) (ensure-gethash object table (cons nil nil))) ;; FIXME: in the CREATE case we're locking, because we might be inserting, ;; and must ensure mutual exclusion with other writers. Fine, @@ -548,7 +561,9 @@ (set-layout-inherits layout (order-layout-inherits (map 'simple-vector #'class-wrapper - (reverse (rest cpl)))))) + (reverse (rest cpl)))) + nil 0)) + (assign-layout-bitmap layout) (register-layout layout :invalidate t)))) (mapc #'make-preliminary-layout (class-direct-subclasses class)))))) @@ -761,7 +776,7 @@ ;; (LAMBDA () (SB-PCL::FAST-MAKE-INSTANCE #)) ;; So maybe we can figure out how to bundle two lambdas together? (lambda () - (let* ((dd (layout-info (class-wrapper class))) + (let* ((dd (layout-dd (class-wrapper class))) (f (%make-structure-instance-allocator dd nil))) (if (functionp f) (funcall (setf (slot-value class 'defstruct-constructor) f)) @@ -1554,7 +1569,7 @@ (defun %obsolete-instance-trap (owrapper nwrapper instance) (cond ((layout-for-pcl-obj-p owrapper) - (binding* ((class (wrapper-class* nwrapper)) + (binding* ((class (wrapper-class nwrapper)) (oslots (get-slots instance)) (nwrapper (class-wrapper class)) (nslots (make-array (layout-length nwrapper) @@ -1656,7 +1671,7 @@ (new-slots (make-array (layout-length new-wrapper) :initial-element +slot-unbound+)) (old-wrapper (layout-of instance)) - (old-class (wrapper-class* old-wrapper)) + (old-class (wrapper-class old-wrapper)) (old-slots (get-slots instance)) (safe (safe-p new-class)) (new-wrapper-slots (layout-slot-list new-wrapper))) diff -Nru sbcl-2.0.6/src/pcl/time.lisp sbcl-2.1.1/src/pcl/time.lisp --- sbcl-2.0.6/src/pcl/time.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/time.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,142 +0,0 @@ -;;;; FIXME: This should probably move to some separate tests or benchmarks -;;;; directory. - -(in-package "SB-PCL") - -(declaim (optimize (speed 3) (safety 0) (compilation-speed 0))) - -(defvar *tests*) -(setq *tests* nil) - -(defvar m (car (generic-function-methods #'shared-initialize))) -(defvar gf #'shared-initialize) -(defvar c (find-class 'standard-class)) - -(defclass str () - ((slot :initform nil :reader str-slot)) - (:metaclass structure-class)) - -(defvar str (make-instance 'str)) - -(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" - '(time-slot-value m 'plist 10000)) - *tests*) -(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" - '(time-slot-value m '%generic-function 10000)) - *tests*) -(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (structure)" - '(time-slot-value str 'slot 10000)) - *tests*) -(defun time-slot-value (object slot-name n) - (time (dotimes-fixnum (i n) (slot-value object slot-name)))) - -(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)" - '(time-slot-value-function m 10000)) - *tests*) -(defun time-slot-value-function (object n) - (time (dotimes-fixnum (i n) (slot-value object '%function)))) - -(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)" - '(time-slot-value-slot str 10000)) - *tests*) -(defun time-slot-value-slot (object n) - (time (dotimes-fixnum (i n) (slot-value object 'slot)))) - -(push (cons "Time one-class dfun." - '(time-generic-function-methods gf 10000)) - *tests*) -(defun time-generic-function-methods (object n) - (time (dotimes-fixnum (i n) (generic-function-methods object)))) - -(push (cons "Time one-index dfun." - '(time-class-precedence-list c 10000)) - *tests*) -(defun time-class-precedence-list (object n) - (time (dotimes-fixnum (i n) (class-precedence-list object)))) - -(push (cons "Time n-n dfun." - '(time-method-function m 10000)) - *tests*) -(defun time-method-function (object n) - (time (dotimes-fixnum (i n) (method-function object)))) - -(push (cons "Time caching dfun." - '(time-class-slots c 10000)) - *tests*) -(defun time-class-slots (object n) - (time (dotimes-fixnum (i n) (class-slots object)))) - -(push (cons "Time typep for classes." - '(time-typep-standard-object m 10000)) - *tests*) -(defun time-typep-standard-object (object n) - (time (dotimes-fixnum (i n) (typep object 'standard-object)))) - -(push (cons "Time default-initargs." - '(time-default-initargs (find-class 'plist-mixin) 1000)) - *tests*) -(defun time-default-initargs (n) - (time (dotimes-fixnum (i n) (default-initargs nil nil)))) - -(push (cons "Time make-instance." - '(time-make-instance (find-class 'plist-mixin) 1000)) - *tests*) -(defun time-make-instance (class n) - (time (dotimes-fixnum (i n) (make-instance class)))) - -(push (cons "Time constant-keys make-instance." - '(time-constant-keys-make-instance 1000)) - *tests*) - -(expanding-make-instance-toplevel -(defun constant-keys-make-instance (n) - (dotimes-fixnum (i n) (make-instance 'plist-mixin)))) - -(precompile-random-code-segments) - -(defun time-constant-keys-make-instance (n) - (time (constant-keys-make-instance n))) - -(defun expand-all-macros (form) - (walk-form form nil (lambda (form context env) - (if (eq context :eval) - (values (%macroexpand form env)) - form)))) - -(push (cons "Macroexpand meth-structure-slot-value" - '(pprint (multiple-value-bind (pgf pm) - (prototypes-for-make-method-lambda - 'meth-structure-slot-value) - (expand-defmethod - 'meth-structure-slot-value pgf pm - nil '((object str)) - '((lambda () (slot-value object 'slot))) - nil)))) - *tests*) - -(push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)." - '(disassemble (meth-structure-slot-value str))) - *tests*) -(defmethod meth-structure-slot-value ((object str)) - (lambda () (slot-value object 'slot))) - -#|| ; interesting, but long. (produces 100 lines of output) -(push (cons "Macroexpand meth-standard-slot-value" - '(pprint (expand-all-macros - (expand-defmethod-internal 'meth-standard-slot-value - nil '((object standard-method)) - '((lambda () (slot-value object '%function))) - nil)))) - *tests*) -(push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)." - '(disassemble (meth-standard-slot-value m))) - *tests*) -(defmethod meth-standard-slot-value ((object standard-method)) - (lambda () (slot-value object '%function))) -||# - -(defun run-tests () - (dolist (doc+form (reverse *tests*)) - (format t "~&~%~A~%" (car doc+form)) - (pprint (cdr doc+form)) - (eval (cdr doc+form)))) diff -Nru sbcl-2.0.6/src/pcl/vector.lisp sbcl-2.1.1/src/pcl/vector.lisp --- sbcl-2.0.6/src/pcl/vector.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/vector.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -97,7 +97,7 @@ (when slot-names (let* ((wrapper (pop wrappers)) (std-p (layout-for-pcl-obj-p wrapper)) - (class (wrapper-class* wrapper))) + (class (wrapper-class wrapper))) (dolist (slot-name slot-names) (destructuring-bind (location . info) (or (find-slot-cell wrapper slot-name) @@ -312,8 +312,6 @@ (define-walker-template pv-offset) ; These forms get munged by mutate slots. (defmacro pv-offset (arg) arg) -(define-walker-template instance-accessor-parameter) -(defmacro instance-accessor-parameter (x) x) ;;; It is safe for these two functions to be wrong. They just try to ;;; guess what the most likely case will be. diff -Nru sbcl-2.0.6/src/pcl/walk.lisp sbcl-2.1.1/src/pcl/walk.lisp --- sbcl-2.0.6/src/pcl/walk.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/walk.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -449,8 +449,6 @@ (define-walker-template macrolet walk-macrolet) (define-walker-template multiple-value-call (nil eval repeat (eval))) (define-walker-template multiple-value-prog1 (nil return repeat (eval))) -(define-walker-template multiple-value-setq walk-multiple-value-setq) -(define-walker-template multiple-value-bind walk-multiple-value-bind) (define-walker-template progn (nil repeat (eval))) (define-walker-template progv (nil eval eval repeat (eval))) (define-walker-template quote (nil quote)) @@ -469,6 +467,14 @@ ;;; FIXME: maybe we don't need this one any more, given that ;;; NAMED-LAMBDA now expands into (FUNCTION (NAMED-LAMBDA ...))? (define-walker-template named-lambda walk-named-lambda) +#| +;;; To find templateized symbols that aren't special operators: +(do-all-symbols (s) + (let ((template + (sb-int:info :function :walker-template s))) + (when (and template (not (special-operator-p s))) + (format t "Why? ~S~%" s)))) +|# (defvar *walk-form-expand-macros-p* nil) (defvar *walk-form-preserve-source* nil) @@ -759,23 +765,15 @@ new-env))) (relist* form let walked-bindings walked-body)))) -(defun let*-binding-name (binding) - (if (symbolp binding) - binding - (car binding))) - -(defun let*-binding-init (binding) - (if (or (symbolp binding) - (null (cdr binding))) - 'no-init - (cadr binding))) - -(defun let*-bindings (bindings &aux names inits (seen (make-hash-table :test #'eq))) +(defun let*-bindings (bindings &aux names inits (seen (alloc-xset))) (dolist (binding (reverse bindings) (values names inits)) - (let ((name (let*-binding-name binding))) - (push (cons name (gethash name seen)) names) - (setf (gethash name seen) t) - (push (let*-binding-init binding) inits)))) + (multiple-value-bind (name init) + (cond ((atom binding) (values binding 'no-init)) + ((not (cdr binding)) (values (car binding) 'no-init)) + (t (values (car binding) (cadr binding)))) + (push (cons name (xset-member-p name seen)) names) + (add-to-xset name seen) + (push init inits)))) (defun walk-let* (form context env) (walker-environment-bind (new-env env) @@ -852,55 +850,24 @@ (relist* form locally walked-body)))) -(defun walk-multiple-value-setq (form context env) - (let ((vars (cadr form))) - (if (some (lambda (var) - (and (symbolp var) (variable-symbol-macro-p var env))) - vars) - (let* ((temps (mapcar (lambda (var) - (declare (ignore var)) - (gensym)) - vars)) - (sets (mapcar (lambda (var temp) `(setq ,var ,temp)) - vars - temps)) - (expanded `(multiple-value-bind ,temps ,(caddr form) - ,@sets)) - (walked (walk-form-internal expanded context env))) - (if (eq walked expanded) - form - walked)) - (walk-template form '(nil (repeat (set)) eval) context env)))) - -(defun walk-multiple-value-bind (form context old-env) - (walker-environment-bind (new-env old-env) - (let* ((mvb (car form)) - (bindings (cadr form)) - (mv-form (walk-template (caddr form) 'eval context old-env)) - (body (cdddr form)) - walked-bindings - (walked-body - (walk-declarations - body - (lambda (real-body real-env) - (setq walked-bindings - (walk-bindings-1 bindings old-env new-env context)) - (walk-repeat-eval real-body real-env)) - new-env))) - (relist* form mvb walked-bindings mv-form walked-body)))) - (defun walk-bindings-1 (bindings old-env new-env context) (and bindings (let ((binding (car bindings))) (recons bindings - (if (symbolp binding) + (typecase binding + (symbol (prog1 binding - (note-var-binding binding new-env)) - (prog1 (relist binding - (car binding) - (walk-form-internal - (cadr binding) context old-env)) + (note-var-binding binding new-env))) + ((cons symbol list) + (prog1 (relist* binding + (car binding) + (walk-form-internal + (cadr binding) context old-env) + ;; Preserve "trailing junk" + (cddr binding)) (note-var-binding (car binding) new-env))) + (t ; illegal syntax, (let (#(foo))) or (let (a . #*1)) etc + binding)) (walk-bindings-1 (cdr bindings) old-env new-env context))))) (defun walk-lambda (form context old-env) diff -Nru sbcl-2.0.6/src/pcl/wrapper.lisp sbcl-2.1.1/src/pcl/wrapper.lisp --- sbcl-2.0.6/src/pcl/wrapper.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/pcl/wrapper.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -31,24 +31,21 @@ ;;; This is called in BRAID when we are making wrappers for classes ;;; whose slots are not initialized yet, and which may be built-in -;;; classes. We pass in the class name in addition to the class. -(defun !boot-make-wrapper (length name &optional class (bitmap -1)) +;;; classes. +(defun !boot-make-wrapper (length name &optional (bitmap +layout-all-tagged+)) (let ((found (find-classoid name nil))) (cond (found - (unless (classoid-pcl-class found) - (setf (classoid-pcl-class found) class)) - (aver (eq (classoid-pcl-class found) class)) (let ((layout (classoid-layout found))) (aver layout) layout)) (t - (set-layout-valid (make-layout (hash-layout-name name) - (make-standard-classoid :name name :pcl-class class) + (make-standard-classoid :name name) :length length :flags +pcl-object-layout-flag+ - :bitmap bitmap)))))) + :bitmap bitmap + :invalid nil))))) ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in ;;; and structure classes already exist when PCL is initialized, so we @@ -74,9 +71,9 @@ :name (and (symbolp name) name))) (t (bug "Got to T branch in ~S" 'make-wrapper)))))) - (set-layout-valid - (make-layout (hash-layout-name name) - classoid :length length :flags +pcl-object-layout-flag+)))) + (make-layout (hash-layout-name name) classoid + :bitmap +layout-all-tagged+ + :invalid nil :length length :flags +pcl-object-layout-flag+))) (t (let* ((found (find-classoid (slot-value class 'name))) (layout (classoid-layout found))) @@ -86,23 +83,6 @@ (aver layout) layout)))) -(declaim (inline wrapper-class*)) -(defun wrapper-class* (wrapper) - (or (wrapper-class wrapper) - ;; FIXME: this branch seems unreachable. - ;; It would be nice to eliminate WRAPPER-CLASS* if we can show that it - ;; is only a holdover from an earlier way of bootstrapping that resulted - ;; in the temporary absence of a PCL-CLASS for some non-standard-class. - ;; Certainly no test gets here [changing it to (BUG "got here") worked]. - ;; Note however that - ;; (CLASSOID-PCL-CLASS (FIND-CLASSOID 'STANDARD-INSTANCE)) => NIL - ;; which can be resolved by just ensuring one time that it has a CLASS. - ;; And nothing else seems to be problematic. - (let ((classoid (layout-classoid wrapper))) - (ensure-non-standard-class - (classoid-name classoid) - classoid)))) - ;;; The wrapper cache machinery provides general mechanism for ;;; trapping on the next access to any instance of a given class. This ;;; mechanism is used to implement the updating of instances when the @@ -176,8 +156,7 @@ ;;; but also pretty much not correct. (defun %invalidate-wrapper (owrapper state nwrapper) (aver (member state '(:flush :obsolete))) - #+sb-thread (aver (eq (sb-thread:mutex-owner sb-c::**world-lock**) - sb-thread:*current-thread*)) + #+sb-thread (aver (sb-thread:holding-mutex-p sb-c::**world-lock**)) (let ((classoid (layout-classoid nwrapper)) (new-previous ()) (new-state (cons state nwrapper))) @@ -242,7 +221,7 @@ ;; previous call to REGISTER-LAYOUT for a superclass of ;; INSTANCE's class. See also the comment above ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this. - (let ((class (wrapper-class* owrapper))) + (let ((class (wrapper-class owrapper))) (%force-cache-flushes class) ;; KLUDGE: avoid an infinite recursion, it's still better to ;; bail out with an error for server softwares. see FIXME above. @@ -388,7 +367,7 @@ (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail) (setf dfun-wrappers-tail new-dfun-wrappers-tail)))) ,@(when wrappers - `((setq class (wrapper-class* wrapper)) + `((setq class (wrapper-class wrapper)) (setq type `(class-eq ,class))))) ,@(when wrappers `((push wrapper wrappers-rev) diff -Nru sbcl-2.0.6/src/runtime/alloc.c sbcl-2.1.1/src/runtime/alloc.c --- sbcl-2.0.6/src/runtime/alloc.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/alloc.c 2021-01-30 11:22:38.000000000 +0000 @@ -30,9 +30,13 @@ #ifdef LISP_FEATURE_GENCGC #ifdef LISP_FEATURE_SB_THREAD /* This lock is used to protect non-thread-local allocation. */ -static pthread_mutex_t allocation_lock = PTHREAD_MUTEX_INITIALIZER; +#ifdef LISP_FEATURE_WIN32 +CRITICAL_SECTION code_allocator_lock, alloc_profiler_lock; +#else +static pthread_mutex_t code_allocator_lock = PTHREAD_MUTEX_INITIALIZER; pthread_mutex_t alloc_profiler_lock = PTHREAD_MUTEX_INITIALIZER; #endif +#endif lispobj alloc_code_object (unsigned total_words) { struct thread *th = arch_os_get_current_thread(); @@ -51,12 +55,12 @@ /* Allocations of code are all serialized. We might also acquire * free_pages_lock depending on availability of space in the region */ - int result = thread_mutex_lock(&allocation_lock); + int result = thread_mutex_lock(&code_allocator_lock); gc_assert(!result); struct code *code = (struct code *) lisp_alloc(&gc_alloc_region[CODE_PAGE_TYPE-1], total_words*N_WORD_BYTES, CODE_PAGE_TYPE, th); - result = thread_mutex_unlock(&allocation_lock); + result = thread_mutex_unlock(&code_allocator_lock); gc_assert(!result); code->header = ((uword_t)total_words << CODE_HEADER_SIZE_SHIFT) | CODE_HEADER_WIDETAG; diff -Nru sbcl-2.0.6/src/runtime/alpha-arch.c sbcl-2.1.1/src/runtime/alpha-arch.c --- sbcl-2.0.6/src/runtime/alpha-arch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/alpha-arch.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,369 +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. - */ - -/* Note that although superficially it appears that we use - * os_context_t like we ought to, we actually just assume its a - * ucontext in places. Naughty */ - -#include -#include - -#include "sbcl.h" -#include "runtime.h" -#include "globals.h" -#include "validate.h" -#include "os.h" -#include "arch.h" -#include "lispregs.h" -#include "signal.h" -#include "alloc.h" -#include "interrupt.h" -#include "interr.h" -#include "breakpoint.h" - -extern char call_into_lisp_LRA[], call_into_lisp_end[]; - -#define BREAKPOINT_INST 0x80 - - -void -arch_init(void) -{ - /* This must be called _after_ os_init(), so that we know what the - * page size is. */ - - if (mmap((os_vm_address_t) call_into_lisp_LRA_page,os_vm_page_size, - OS_VM_PROT_ALL,MAP_PRIVATE|MAP_ANONYMOUS|MAP_FIXED,-1,0) - == (os_vm_address_t) -1) - perror("mmap"); - - /* call_into_lisp_LRA is a collection of trampolines written in asm - - * see alpha-assem.S. We copy it to call_into_lisp_LRA_page where - * VOPs and things can find it. (I don't know why they can't find it - * where it was to start with.) */ - bcopy(call_into_lisp_LRA,(void *)call_into_lisp_LRA_page,os_vm_page_size); - - os_flush_icache((os_vm_address_t)call_into_lisp_LRA_page, - os_vm_page_size); - return; -} - -os_vm_address_t -arch_get_bad_addr (int sig, siginfo_t *code, os_context_t *context) -{ - unsigned int badinst; - - /* Instructions are 32 bit quantities. */ - unsigned int *pc ; - /* fprintf(stderr,"arch_get_bad_addr %d %p %p\n", - sig, code, context); */ - pc= (unsigned int *)(*os_context_pc_addr(context)); - - if (((unsigned long)pc) & 3) { - return NULL; /* In what case would pc be unaligned?? */ - } - - if ( (pc < READ_ONLY_SPACE_START || - pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) && - (pc < current_dynamic_space || - pc >= current_dynamic_space + dynamic_space_size)) - return NULL; - - return context->uc_mcontext.sc_traparg_a0; -} - -void -arch_skip_instruction(os_context_t *context) -{ - /* This may be complete rubbish, as (at least for traps) pc points - * _after_ the instruction that caused us to be here anyway. - */ - char **pcptr; - pcptr = (char **) os_context_pc_addr(context); - *pcptr += 4; -} - -unsigned char * -arch_internal_error_arguments(os_context_t *context) -{ - return (unsigned char *)(*os_context_pc_addr(context)+4); -} - -boolean -arch_pseudo_atomic_atomic(os_context_t *context) -{ - /* FIXME: this foreign_function_call_active test is dubious at - * best. If a foreign call is made in a pseudo atomic section - * (?) or more likely a pseudo atomic section is in a foreign - * call then an interrupt is executed immediately. Maybe it - * has to do with C code not maintaining pseudo atomic - * properly. MG - 2005-08-10 - * - * The foreign_function_call_active used to live at each call-site - * to arch_pseudo_atomic_atomic, but this seems clearer. - * --NS 2007-05-15 */ - return (!foreign_function_call_active) - && ((*os_context_register_addr(context,reg_ALLOC)) & 1); -} - -void arch_set_pseudo_atomic_interrupted(os_context_t *context) -{ - /* On coming out of an atomic section, we subtract 1 from - * reg_Alloc, then try to store something at that address. So, - * to signal that it was interrupted and a signal should be handled, - * we set bit 63 of reg_ALLOC here so that the end-of-atomic code - * will raise SIGSEGV (no ram mapped there). We catch the signal - * (see the appropriate *-os.c) and call interrupt_handle_pending() - * for the saved signal instead */ - - *os_context_register_addr(context,reg_ALLOC) |= (1L<<63); -} - -void arch_clear_pseudo_atomic_interrupted(os_context_t *context) -{ - *os_context_register_addr(context, reg_ALLOC) &= ~(1L<<63); -} - -unsigned int arch_install_breakpoint(void *pc) -{ - unsigned int *ptr = (unsigned int *)pc; - unsigned int result = *ptr; - *ptr = BREAKPOINT_INST; - - os_flush_icache((os_vm_address_t)ptr, sizeof(unsigned int)); - - return result; -} - -void arch_remove_breakpoint(void *pc, unsigned int orig_inst) -{ - unsigned int *ptr = (unsigned int *)pc; - *ptr = orig_inst; - os_flush_icache((os_vm_address_t)pc, sizeof(unsigned int)); -} - -static unsigned int *skipped_break_addr, displaced_after_inst, - after_breakpoint; - - -/* This returns a PC value. Lisp code is all in the 32-bit-addressable - * space, so we should be ok with an unsigned int. */ -unsigned int -emulate_branch(os_context_t *context, unsigned int orig_inst) -{ - int op = orig_inst >> 26; - int reg_a = (orig_inst >> 21) & 0x1f; - int reg_b = (orig_inst >> 16) & 0x1f; - int disp = - (orig_inst&(1<<20)) ? - orig_inst | (-1 << 21) : - orig_inst&0x1fffff; - int next_pc = *os_context_pc_addr(context); - int branch = 0; /* was NULL; */ - - switch(op) { - case 0x1a: /* jmp, jsr, jsr_coroutine, ret */ - *os_context_register_addr(context,reg_a) = - *os_context_pc_addr(context); - *os_context_pc_addr(context) = - *os_context_register_addr(context,reg_b)& ~3; - break; - case 0x30: /* br */ - *os_context_register_addr(context,reg_a)=*os_context_pc_addr(context); - branch = 1; - break; - case 0x31: /* fbeq */ - if (*(os_context_float_register_addr(context,reg_a))==0) branch = 1; - break; - case 0x32: /* fblt */ - if (*os_context_float_register_addr(context,reg_a)<0) branch = 1; - break; - case 0x33: /* fble */ - if (*os_context_float_register_addr(context,reg_a)<=0) branch = 1; - break; - case 0x34: /* bsr */ - *os_context_register_addr(context,reg_a)=*os_context_pc_addr(context); - branch = 1; - break; - case 0x35: /* fbne */ - if (*os_context_register_addr(context,reg_a)!=0) branch = 1; - break; - case 0x36: /* fbge */ - if (*os_context_float_register_addr(context,reg_a)>=0) branch = 1; - break; - case 0x37: /* fbgt */ - if (*os_context_float_register_addr(context,reg_a)>0) branch = 1; - break; - case 0x38: /* blbc */ - if ((*os_context_register_addr(context,reg_a)&1) == 0) branch = 1; - break; - case 0x39: /* beq */ - if (*os_context_register_addr(context,reg_a)==0) branch = 1; - break; - case 0x3a: /* blt */ - if (*os_context_register_addr(context,reg_a)<0) branch = 1; - break; - case 0x3b: /* ble */ - if (*os_context_register_addr(context,reg_a)<=0) branch = 1; - break; - case 0x3c: /* blbs */ - if ((*os_context_register_addr(context,reg_a)&1)!=0) branch = 1; - break; - case 0x3d: /* bne */ - if (*os_context_register_addr(context,reg_a)!=0) branch = 1; - break; - case 0x3e: /* bge */ - if (*os_context_register_addr(context,reg_a)>=0) branch = 1; - break; - case 0x3f: /* bgt */ - if (*os_context_register_addr(context,reg_a)>0) branch = 1; - break; - } - if (branch) - next_pc += disp*4; - return next_pc; -} - -static sigset_t orig_sigmask; - -/* Perform the instruction that we overwrote with a breakpoint. As we - * don't have a single-step facility, this means we have to: - * - put the instruction back - * - put a second breakpoint at the following instruction, - * set after_breakpoint and continue execution. - * - * When the second breakpoint is hit (very shortly thereafter, we hope) - * sigtrap_handler gets called again, but follows the AfterBreakpoint - * arm, which - * - puts a bpt back in the first breakpoint place (running across a - * breakpoint shouldn't cause it to be uninstalled) - * - replaces the second bpt with the instruction it was meant to be - * - carries on - * - * Clear? - */ - -void arch_do_displaced_inst(os_context_t *context,unsigned int orig_inst) -{ - /* Apparent off-by-one errors ahoy. If you consult the Alpha ARM, - * it will tell you that after a BPT, the saved PC is the address - * of the instruction _after_ the instruction that caused the trap. - * - * However, we decremented PC by 4 before calling the Lisp-level - * handler that calls this routine (see alpha-arch.c line 322 and - * friends) so when we get to this point PC is actually pointing - * at the BPT instruction itself. This is good, because this is - * where we want to restart execution when we do that */ - - unsigned int *pc=(unsigned int *)(*os_context_pc_addr(context)); - unsigned int *next_pc; - int op = orig_inst >> 26;; - - orig_sigmask = *os_context_sigmask_addr(context); - sigaddset_blockable(os_context_sigmask_addr(context)); - - /* Put the original instruction back. */ - *pc = orig_inst; - os_flush_icache((os_vm_address_t)pc, sizeof(unsigned int)); - skipped_break_addr = pc; - - /* Figure out where we will end up after running the displaced - * instruction */ - if (op == 0x1a || (op&0xf) == 0x30) /* a branch */ - /* The cast to long is just to shut gcc up. */ - next_pc = (unsigned int *)((long)emulate_branch(context,orig_inst)); - else - next_pc = pc+1; - - /* Set the after breakpoint. */ - displaced_after_inst = *next_pc; - *next_pc = BREAKPOINT_INST; - after_breakpoint=1; - os_flush_icache((os_vm_address_t)next_pc, sizeof(unsigned int)); -} - -void -arch_handle_breakpoint(os_context_t *context) -{ - *os_context_pc_addr(context) -=4; - handle_breakpoint(context); -} - -void -arch_handle_fun_end_breakpoint(os_context_t *context) -{ - *os_context_pc_addr(context) -=4; - *os_context_pc_addr(context) = - (int)handle_fun_end_breakpoint(context); -} - -void -arch_handle_single_step_trap(os_context_t *context, int trap) -{ - unsigned int code = *((u32 *) (*os_context_pc_addr(context))); - int register_offset = code >> 8 & 0x1f; - handle_single_step_trap(context, trap, register_offset); - arch_skip_instruction(context); -} - -static void -sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) -{ - unsigned int code; - - /* this is different from how CMUCL does it. CMUCL used "call_pal - * PAL_gentrap", which doesn't do anything on Linux (unless NL0 - * contains certain specific values). We use "bugchk" instead. - * It's (for our purposes) just the same as bpt but has a - * different opcode so we can test whether we're dealing with a - * breakpoint or a "system service" */ - - if ((*(unsigned int*)(*os_context_pc_addr(context)-4))==BREAKPOINT_INST) { - if (after_breakpoint) { - /* see comments above arch_do_displaced_inst. This is where - * we reinsert the breakpoint that we removed earlier */ - - *os_context_pc_addr(context) -=4; - *skipped_break_addr = BREAKPOINT_INST; - os_flush_icache((os_vm_address_t)skipped_break_addr, - sizeof(unsigned int)); - skipped_break_addr = NULL; - *(unsigned int *)*os_context_pc_addr(context) = - displaced_after_inst; - os_flush_icache((os_vm_address_t)*os_context_pc_addr(context), sizeof(unsigned int)); - *os_context_sigmask_addr(context)= orig_sigmask; - after_breakpoint=0; /* false */ - return; - } else - code = trap_Breakpoint; - } else - /* a "system service" */ - code=*((u32 *)(*os_context_pc_addr(context))); - handle_trap(context, code); -} - -unsigned long -arch_get_fp_control() -{ - return ieee_get_fp_control(); -} - -void -arch_set_fp_control(unsigned long fp) -{ - ieee_set_fp_control(fp); -} - - -void arch_install_interrupt_handlers() -{ - undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); -} diff -Nru sbcl-2.0.6/src/runtime/alpha-arch.h sbcl-2.1.1/src/runtime/alpha-arch.h --- sbcl-2.0.6/src/runtime/alpha-arch.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/alpha-arch.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -#ifndef _ALPHA_ARCH_H -#define _ALPHA_ARCH_H - -#define ALIEN_STACK_GROWS_DOWNWARD - -#endif /* _ALPHA_ARCH_H */ diff -Nru sbcl-2.0.6/src/runtime/alpha-assem.S sbcl-2.1.1/src/runtime/alpha-assem.S --- sbcl-2.0.6/src/runtime/alpha-assem.S 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/alpha-assem.S 1970-01-01 00:00:00.000000000 +0000 @@ -1,300 +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. - */ - -#ifdef __ELF__ -// Mark the object as not requiring an executable stack. -.section .note.GNU-stack,"",%progbits -#endif - -#include "validate.h" -#include -#ifdef linux -#include -#else -#include -#endif -#include "sbcl.h" -#include "lispregs.h" -#include "genesis/fdefn.h" -#include "genesis/closure.h" -#include "genesis/code.h" -#include "genesis/funcallable-instance.h" -#include "genesis/simple-fun.h" -#include "genesis/static-symbols.h" - -/* #include "globals.h" */ - -/* - * Function to transfer control into lisp. - */ - .text - .align 4 - .globl call_into_lisp - .ent call_into_lisp -call_into_lisp: -#define framesize 8*8 - ldgp gp, 0($27) - /* Save all the C regs. */ - lda sp,-framesize(sp) - stq ra, framesize-8*8(sp) - stq s0, framesize-8*7(sp) - stq s1, framesize-8*6(sp) - stq s2, framesize-8*5(sp) - stq s3, framesize-8*4(sp) - stq s4, framesize-8*3(sp) - stq s5, framesize-8*2(sp) - stq s6, framesize-8*1(sp) - .mask 0x0fc001fe, -framesize - .frame sp,framesize,ra - - /* Clear descriptor regs */ - ldil reg_CODE,0 - ldil reg_FDEFN,0 - mov a0,reg_LEXENV - sll a2,2,reg_NARGS - ldil reg_OCFP,0 - ldil reg_LRA,0 - ldil reg_L0,0 - ldil reg_L1,0 - - - /* Establish NIL. */ - ldil reg_NULL,NIL - - /* The CMUCL comment here is "Start pseudo-atomic.", but */ - /* there's no obvious code that would have that effect */ - - /* No longer in foreign call. */ - stl zero,foreign_function_call_active - - /* Load lisp state. */ - ldq reg_ALLOC,dynamic_space_free_pointer - ldq reg_BSP,current_binding_stack_pointer - ldq reg_CSP,current_control_stack_pointer - ldq reg_OCFP,current_control_frame_pointer - mov a1,reg_CFP - - .set noat - ldil reg_L2,0 - .set at - - /* End of pseudo-atomic. */ - - /* Establish lisp arguments. */ - ldl reg_A0,0(reg_CFP) - ldl reg_A1,4(reg_CFP) - ldl reg_A2,8(reg_CFP) - ldl reg_A3,12(reg_CFP) - ldl reg_A4,16(reg_CFP) - ldl reg_A5,20(reg_CFP) - - /* This call will 'return' into the LRA page below */ - lda reg_LRA,call_into_lisp_LRA_page+OTHER_POINTER_LOWTAG - - /* Indirect the closure */ - ldl reg_CODE, CLOSURE_FUN_OFFSET(reg_LEXENV) - addl reg_CODE, SIMPLE_FUN_INSTS_OFFSET, reg_LIP - - /* And into lisp we go. */ - jsr reg_ZERO,(reg_LIP) - - - /* a page of the following code (from call_into_lisp_LRA - onwards) is copied into the LRA page at arch_init() time. */ - - .set noreorder - .align 3 - .globl call_into_lisp_LRA -call_into_lisp_LRA: - - .long RETURN_PC_WIDETAG - - /* execution resumes here*/ - mov reg_OCFP,reg_CSP - nop - - /* return value already there */ - mov reg_A0,v0 - - /* Turn on pseudo-atomic. */ - - /* Save LISP registers */ - stq reg_ALLOC, dynamic_space_free_pointer - stq reg_BSP,current_binding_stack_pointer - stq reg_CSP,current_control_stack_pointer - stq reg_CFP,current_control_frame_pointer - - /* Back in C land. [CSP is just a handy non-zero value.] */ - stl reg_CSP,foreign_function_call_active - - /* Turn off pseudo-atomic and check for traps. */ - - /* Restore C regs */ - ldq ra, framesize-8*8(sp) - ldq s0, framesize-8*7(sp) - ldq s1, framesize-8*6(sp) - ldq s2, framesize-8*5(sp) - ldq s3, framesize-8*4(sp) - ldq s4, framesize-8*3(sp) - ldq s5, framesize-8*2(sp) - ldq s6, framesize-8*1(sp) - - /* Restore the C stack! */ - lda sp, framesize(sp) - - ret zero,(ra),1 - .globl call_into_lisp_end -call_into_lisp_end: - .end call_into_lisp - -/* - * Transfering control from Lisp into C. reg_CFUNC (t10, 24) contains - * the address of the C function to call - */ - .set noreorder - .text - .align 4 - .globl call_into_c - .ent call_into_c -call_into_c: - .mask 0x0fc001fe, -12 - .frame sp,12,ra - mov reg_CFP, reg_OCFP - mov reg_CSP, reg_CFP - addq reg_CFP, 32, reg_CSP - stl reg_OCFP, 0(reg_CFP) - subl reg_LIP, reg_CODE, reg_L1 - addl reg_L1, OTHER_POINTER_LOWTAG, reg_L1 - stl reg_L1, 4(reg_CFP) - stl reg_CODE, 8(reg_CFP) - stl reg_NULL, 12(reg_CFP) - - /* Set the pseudo-atomic flag. */ - addq reg_ALLOC,1,reg_ALLOC - - /* Get the top two register args and fix the NSP to point to arg 7 */ - ldq reg_NL4,0(reg_NSP) - ldq reg_NL5,8(reg_NSP) - addq reg_NSP,16,reg_NSP - - /* Save lisp state. */ - subq reg_ALLOC,1,reg_L1 - stq reg_L1, dynamic_space_free_pointer - - stq reg_BSP, current_binding_stack_pointer - stq reg_CSP, current_control_stack_pointer - stq reg_CFP, current_control_frame_pointer - - /* Mark us as in C land. */ - stl reg_CSP, foreign_function_call_active - - /* Were we interrupted? */ - subq reg_ALLOC,1,reg_ALLOC - stl reg_ZERO,0(reg_ALLOC) - - /* Into C land we go. */ - - mov reg_CFUNC, reg_L1 /* L1=pv: this is a hint to the cache */ - - jsr ra, (reg_CFUNC) - ldgp $29,0(ra) - - /* restore NSP */ - subq reg_NSP,16,reg_NSP - - /* Clear unsaved descriptor regs */ - mov reg_ZERO, reg_NARGS - mov reg_ZERO, reg_A0 - mov reg_ZERO, reg_A1 - mov reg_ZERO, reg_A2 - mov reg_ZERO, reg_A3 - mov reg_ZERO, reg_A4 - mov reg_ZERO, reg_A5 - mov reg_ZERO, reg_L0 - .set noat - mov reg_ZERO, reg_L2 - .set at - - /* Turn on pseudo-atomic. */ - lda reg_ALLOC,1(reg_ZERO) - - /* Mark us at in Lisp land. */ - stl reg_ZERO, foreign_function_call_active - - /* Restore ALLOC, preserving pseudo-atomic-atomic */ - ldq reg_NL0,dynamic_space_free_pointer - addq reg_ALLOC,reg_NL0,reg_ALLOC - - /* Check for interrupt */ - subq reg_ALLOC,1,reg_ALLOC - stl reg_ZERO,0(reg_ALLOC) - - ldl reg_NULL, 12(reg_CFP) - - /* Restore LRA & CODE (they may have been GC'ed) */ - /* can you see anything here which touches LRA? I can't ...*/ - ldl reg_CODE, 8(reg_CFP) - ldl reg_NL0, 4(reg_CFP) - subq reg_NL0, OTHER_POINTER_LOWTAG, reg_NL0 - addq reg_CODE, reg_NL0, reg_NL0 - - mov reg_CFP, reg_CSP - mov reg_OCFP, reg_CFP - - ret zero, (reg_NL0), 1 - - .end call_into_c - - .text - .globl start_of_tramps -start_of_tramps: - - .text - .globl end_of_tramps -end_of_tramps: - - -/* - * fun-end breakpoint magic. - */ - -/* - * For an explanation of the magic involved in function-end - * breakpoints, see the implementation in ppc-assem.S. - */ - - .text - .align 2 - .set noreorder - .globl fun_end_breakpoint_guts -fun_end_breakpoint_guts: - .long (((CODE_SIZE+1)&~1)< -#include -#include -#include "sbcl.h" -#include "./signal.h" -#include "os.h" -#include "arch.h" -#include "globals.h" -#include "interrupt.h" -#include "interr.h" -#include "lispregs.h" -#include -#include - -#include -#include -#include -#include -#include -#include - -#include "validate.h" - -#ifdef LISP_FEATURE_SB_THREAD -#error "Define threading support functions" -#else -int arch_os_thread_init(struct thread *thread) { - return 1; /* success */ -} -int arch_os_thread_cleanup(struct thread *thread) { - return 1; /* success */ -} -#endif - - -os_context_register_t * -os_context_register_addr(os_context_t *context, int offset) -{ - return &context->uc_mcontext.sc_regs[offset]; -} - -os_context_register_t * -os_context_float_register_addr(os_context_t *context, int offset) -{ - return &context->uc_mcontext.sc_fpregs[offset]; -} - -os_context_register_t * -os_context_pc_addr(os_context_t *context) -{ - return &((context->uc_mcontext).sc_pc); -} - -sigset_t * -os_context_sigmask_addr(os_context_t *context) -{ - return &context->uc_sigmask; -} - -unsigned long -os_context_fp_control(os_context_t *context) -{ - return ieee_fpcr_to_swcr((context->uc_mcontext).sc_fpcr); -} - -void -os_restore_fp_control(os_context_t *context) -{ - /* FIXME: 0x7E0000 is defined as something useful in constants.h, - but without the UL, which would probably lead to 32/64-bit - errors if we simply used it here. Ugh. CSR, 2003-09-15 */ - arch_set_fp_control(os_context_fp_control(context) & ~(0x7e0000UL) & - /* KLUDGE: for some reason that I don't - understand, by the time we get here the - "enable denormalized traps" bit in the fp - control word is set. Since we really don't - want to tra every time someone types - LEAST-POSITIVE-SINGLE-FLOAT into the repl, - mask that bit out. -- CSR, 2003-09-15 */ - ~(0x1UL<<6)); -} - -void os_flush_icache(os_vm_address_t address, os_vm_size_t length) -{ - asm volatile ("imb" : : : "memory" ); -} diff -Nru sbcl-2.0.6/src/runtime/alpha-linux-os.h sbcl-2.1.1/src/runtime/alpha-linux-os.h --- sbcl-2.0.6/src/runtime/alpha-linux-os.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/alpha-linux-os.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -#ifndef _ALPHA_LINUX_OS_H -#define _ALPHA_LINUX_OS_H - -typedef ucontext_t os_context_t; -typedef long os_context_register_t; - -#include "arch-os-generic.inc" - -unsigned long os_context_fp_control(os_context_t *context); - -#endif /* _ALPHA_LINUX_OS_H */ diff -Nru sbcl-2.0.6/src/runtime/alpha-lispregs.h sbcl-2.1.1/src/runtime/alpha-lispregs.h --- sbcl-2.0.6/src/runtime/alpha-lispregs.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/alpha-lispregs.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +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. - */ - -#define NREGS (32) - -#ifdef __ASSEMBLER__ -#ifdef linux -#define REG(num) $##num -#else -#define REG(num) $/**/num -#endif /* linux */ -#else -#define REG(num) num -#endif - /* "traditional" register name and use */ - /* courtesy of */ -#define reg_LIP REG(0) /* v0 */ -#define reg_A0 REG(1) /* t0 - temporary (caller-saved) */ -#define reg_A1 REG(2) /* t1 */ -#define reg_A2 REG(3) /* t2 */ -#define reg_A3 REG(4) /* t3 */ -#define reg_A4 REG(5) /* t4 */ -#define reg_A5 REG(6) /* t5 */ -#define reg_L0 REG(7) /* t6 */ -#define reg_NARGS REG(8) /* t7 */ -#define reg_CSP REG(9) /* s0 - saved (callee-saved) */ -#define reg_CFP REG(10) /* s1 */ -#define reg_OCFP REG(11) /* s2 */ -#define reg_BSP REG(12) /* s3 */ -#define reg_LEXENV REG(13) /* s4 */ -#define reg_CODE REG(14) /* s5 */ -#define reg_NULL REG(15) /* s6 = fp (frame pointer) */ -#define reg_NL0 REG(16) /* a0 - argument (caller-saved) */ -#define reg_NL1 REG(17) /* a1 */ -#define reg_NL2 REG(18) /* a2 */ -#define reg_NL3 REG(19) /* a3 */ -#define reg_NL4 REG(20) /* a4 */ -#define reg_NL5 REG(21) /* a5 */ -#define reg_ALLOC REG(22) /* t8 - more temps (caller-saved) */ -#define reg_FDEFN REG(23) /* t9 */ -#define reg_CFUNC REG(24) /* t10 */ -#define reg_NFP REG(25) /* t11 */ -#define reg_LRA REG(26) /* ra - return address */ -#define reg_L1 REG(27) /* t12, or pv - procedure variable */ -#define reg_L2 REG(28) /* at - assembler temporary */ -#define reg_GP REG(29) /* global pointer */ -#define reg_NSP REG(30) /* sp - stack pointer */ -#define reg_ZERO REG(31) /* reads as zero, writes are noops */ - -#define call_into_lisp_LRA_page 0x10000 diff -Nru sbcl-2.0.6/src/runtime/arm64-arch.c sbcl-2.1.1/src/runtime/arm64-arch.c --- sbcl-2.0.6/src/runtime/arm64-arch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/arm64-arch.c 2021-01-30 11:22:38.000000000 +0000 @@ -32,7 +32,7 @@ void arch_skip_instruction(os_context_t *context) { - u32 trap_instruction = *((u32 *)*os_context_pc_addr(context)); + uint32_t trap_instruction = *((uint32_t *)*os_context_pc_addr(context)); unsigned code = trap_instruction >> 5 & 0xFF; *os_context_pc_addr(context) += 4; switch (code) @@ -119,7 +119,7 @@ static void sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) { - u32 trap_instruction = *((u32 *)*os_context_pc_addr(context)); + uint32_t trap_instruction = *((uint32_t *)*os_context_pc_addr(context)); unsigned code = trap_instruction >> 5 & 0xFF; if ((trap_instruction >> 21) != 0x6A1) { lose("Unrecognized trap instruction %08lx in sigtrap_handler() (PC: %p)", @@ -136,8 +136,8 @@ void arch_install_interrupt_handlers() { - undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); - undoably_install_low_level_interrupt_handler(SIGILL, sigill_handler); + ll_install_handler(SIGTRAP, sigtrap_handler); + ll_install_handler(SIGILL, sigill_handler); } diff -Nru sbcl-2.0.6/src/runtime/arm64-assem.S sbcl-2.1.1/src/runtime/arm64-assem.S --- sbcl-2.0.6/src/runtime/arm64-assem.S 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/arm64-assem.S 2021-01-30 11:22:38.000000000 +0000 @@ -52,7 +52,7 @@ #endif -#ifdef OS_THREAD_STACK +#ifdef LISP_FEATURE_OS_THREAD_STACK .align 2 .global funcall1_switching_stack .type funcall1_switching_stack, %function diff -Nru sbcl-2.0.6/src/runtime/arm64-bsd-os.c sbcl-2.1.1/src/runtime/arm64-bsd-os.c --- sbcl-2.0.6/src/runtime/arm64-bsd-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/arm64-bsd-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -25,8 +25,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include @@ -39,16 +37,10 @@ #include "validate.h" size_t os_vm_page_size; +#if defined(LISP_FEATURE_OPENBSD) int arch_os_thread_init(struct thread *thread) { stack_t sigstack; -#ifdef LISP_FEATURE_SB_THREAD -#ifdef LISP_FEATURE_GCC_TLS - current_thread = thread; -#else - pthread_setspecific(specials,thread); -#endif -#endif /* Signal handlers are normally run on the main stack, but we've * swapped stacks, require that the control stack contain only * boxed data, and expands upwards while the C stack expands @@ -65,7 +57,6 @@ return 1; /* success */ } -#if defined(LISP_FEATURE_OPENBSD) os_context_register_t * os_context_register_addr(os_context_t *context, int regno) @@ -94,8 +85,6 @@ { } -#endif - os_context_register_t * os_context_lr_addr(os_context_t *context) { @@ -109,3 +98,69 @@ = (os_vm_address_t)(((uintptr_t) address) + length); __clear_cache(address, end_address); } + +#elif defined(LISP_FEATURE_NETBSD) + +int arch_os_thread_init(struct thread *thread) { + stack_t sigstack; +#ifdef LISP_FEATURE_SB_THREAD +#ifdef LISP_FEATURE_GCC_TLS + current_thread = thread; +#else + pthread_setspecific(specials,thread); +#endif +#endif + /* Signal handlers are normally run on the main stack, but we've + * swapped stacks, require that the control stack contain only + * boxed data, and expands upwards while the C stack expands + * downwards. */ + sigstack.ss_sp = calc_altstack_base(thread); + sigstack.ss_flags = 0; + sigstack.ss_size = calc_altstack_size(thread); + if(sigaltstack(&sigstack,0)<0) + lose("Cannot sigaltstack: %s\n",strerror(errno)); + + return 1; /* success */ +} +int arch_os_thread_cleanup(struct thread *thread) { + return 1; /* success */ +} + +os_context_register_t * +os_context_register_addr(os_context_t *context, int offset) +{ + return (os_context_register_t *)&(context->uc_mcontext.__gregs[offset]); +} + +os_context_register_t * +os_context_pc_addr(os_context_t *context) +{ + return os_context_register_addr(context, 32); +} + +os_context_register_t * +os_context_lr_addr(os_context_t *context) +{ + return os_context_register_addr(context, reg_LR); +} + +void +os_restore_fp_control(os_context_t *context) +{ + /* FIXME: Implement. */ +} + +os_context_register_t * +os_context_float_register_addr(os_context_t *context, int offset) +{ + return (os_context_register_t*) + &context->uc_mcontext.__fregs.__qregs[offset]; +} + +void +os_flush_icache(os_vm_address_t address, os_vm_size_t length) +{ + __builtin___clear_cache(address, address + length); +} + +#endif diff -Nru sbcl-2.0.6/src/runtime/arm64-linux-os.c sbcl-2.1.1/src/runtime/arm64-linux-os.c --- sbcl-2.0.6/src/runtime/arm64-linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/arm64-linux-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -25,8 +25,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include @@ -39,13 +37,6 @@ int arch_os_thread_init(struct thread *thread) { stack_t sigstack; -#ifdef LISP_FEATURE_SB_THREAD -#ifdef LISP_FEATURE_GCC_TLS - current_thread = thread; -#else - pthread_setspecific(specials,thread); -#endif -#endif /* Signal handlers are normally run on the main stack, but we've * swapped stacks, require that the control stack contain only * boxed data, and expands upwards while the C stack expands diff -Nru sbcl-2.0.6/src/runtime/arm-bsd-os.c sbcl-2.1.1/src/runtime/arm-bsd-os.c --- sbcl-2.0.6/src/runtime/arm-bsd-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/arm-bsd-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -25,9 +25,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include -#include #include #include @@ -141,7 +138,7 @@ sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) { unsigned int code = *((unsigned char *)(4+*os_context_pc_addr(context))); - u32 trap_instruction = *((u32 *)*os_context_pc_addr(context)); + uint32_t trap_instruction = *((uint32_t *)*os_context_pc_addr(context)); if (trap_instruction != 0xe7ffdefe) { lose("Unrecognized trap instruction %08lx in sigtrap_handler()", @@ -157,5 +154,5 @@ void arch_install_interrupt_handlers() { - undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); + ll_install_handler(SIGTRAP, sigtrap_handler); } diff -Nru sbcl-2.0.6/src/runtime/arm-linux-os.c sbcl-2.1.1/src/runtime/arm-linux-os.c --- sbcl-2.0.6/src/runtime/arm-linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/arm-linux-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -25,8 +25,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include @@ -106,7 +104,7 @@ sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) { unsigned int code = *((unsigned char *)(4+*os_context_pc_addr(context))); - u32 trap_instruction = *((u32 *)*os_context_pc_addr(context)); + uint32_t trap_instruction = *((uint32_t *)*os_context_pc_addr(context)); if (trap_instruction != 0xe7f001f0) { lose("Unrecognized trap instruction %08lx in sigtrap_handler()", @@ -122,5 +120,5 @@ void arch_install_interrupt_handlers() { - undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); + ll_install_handler(SIGTRAP, sigtrap_handler); } diff -Nru sbcl-2.0.6/src/runtime/atomiclog.inc sbcl-2.1.1/src/runtime/atomiclog.inc --- sbcl-2.0.6/src/runtime/atomiclog.inc 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/runtime/atomiclog.inc 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,49 @@ +#define EVENTBUFMAX 10000 +extern uword_t *eventdata; +extern int n_logevents; + +/// eventN = record event with N parameters +#define event0(fmt) \ + { int i_ = __sync_fetch_and_add(&n_logevents, 2); if (i_ < EVENTBUFMAX) { \ + eventdata[i_ ] = 2; \ + eventdata[i_+1] = (uword_t)fmt; } } + +#define event1(fmt, arg1) \ + { int i_ = __sync_fetch_and_add(&n_logevents, 3); if (i_ < EVENTBUFMAX) { \ + eventdata[i_ ] = 3; \ + eventdata[i_+1] = (uword_t)fmt; \ + eventdata[i_+2] = (uword_t)arg1; } } + +#define event2(fmt, arg1, arg2) \ + { int i_ = __sync_fetch_and_add(&n_logevents, 4); if (i_ < EVENTBUFMAX) { \ + eventdata[i_ ] = 4; \ + eventdata[i_+1] = (uword_t)fmt; \ + eventdata[i_+2] = (uword_t)arg1; \ + eventdata[i_+3] = (uword_t)arg2; } } + +#define event3(fmt, arg1, arg2, arg3) \ + { int i_ = __sync_fetch_and_add(&n_logevents, 5); if (i_ < EVENTBUFMAX) { \ + eventdata[i_ ] = 5; \ + eventdata[i_+1] = (uword_t)fmt; \ + eventdata[i_+2] = (uword_t)arg1; \ + eventdata[i_+3] = (uword_t)arg2; \ + eventdata[i_+4] = (uword_t)arg3; } } + +#define event4(fmt, arg1, arg2, arg3, arg4) \ + { int i_ = __sync_fetch_and_add(&n_logevents, 6); if (i_ < EVENTBUFMAX) { \ + eventdata[i_ ] = 6; \ + eventdata[i_+1] = (uword_t)fmt; \ + eventdata[i_+2] = (uword_t)arg1; \ + eventdata[i_+3] = (uword_t)arg2; \ + eventdata[i_+4] = (uword_t)arg3; \ + eventdata[i_+5] = (uword_t)arg4; } } + +#define event5(fmt, arg1, arg2, arg3, arg4, arg5) \ + { int i_ = __sync_fetch_and_add(&n_logevents, 7); if (i_ < EVENTBUFMAX) { \ + eventdata[i_ ] = 7; \ + eventdata[i_+1] = (uword_t)fmt; \ + eventdata[i_+2] = (uword_t)arg1; \ + eventdata[i_+3] = (uword_t)arg2; \ + eventdata[i_+4] = (uword_t)arg3; \ + eventdata[i_+5] = (uword_t)arg4; \ + eventdata[i_+6] = (uword_t)arg5; } } diff -Nru sbcl-2.0.6/src/runtime/backtrace.c sbcl-2.1.1/src/runtime/backtrace.c --- sbcl-2.0.6/src/runtime/backtrace.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/backtrace.c 2021-01-30 11:22:38.000000000 +0000 @@ -35,25 +35,14 @@ #include "gc.h" #include "code.h" #include "var-io.h" +#include "gc-internal.h" +#include "forwarding-ptr.h" +#include "lispstring.h" #ifdef LISP_FEATURE_OS_PROVIDES_DLADDR # include #endif -static void -sbcl_putwc(wchar_t c, FILE *file) -{ -#ifdef LISP_FEATURE_OS_PROVIDES_PUTWC - putwc(c, file); -#else - if (c < 256) { - fputc(c, file); - } else { - fputc('?', file); - } -#endif -} - static int decode_locs(lispobj packed_integer, int *offset, int *elsewhere) { struct varint_unpacker unpacker; @@ -105,34 +94,31 @@ static void print_string (struct vector *vector, FILE *f) { - int tag = widetag_of(&vector->header); + if (!string_widetag_p(widetag_of(&vector->header))) { + fprintf(f, "", widetag_of(&vector->header)); + return; + } + int i; + int n = fixnum_value(vector->length); + for (i = 0; i < n; i++) { + unsigned int c = schar(vector, i); + if (c > 0xFFFF) fprintf(f,"\\U%08x", c); + // without knowing whether the terminal can accept + // character codes 128 through 255, it's conservative + // to just output unicode escapes. + else if (c > 0x7F) fprintf(f,"\\u%04x", c); + else { + if (c == '\\' || c == '"') putc('\\', f); + putc(c, f); + } + } +} -#define doit(TYPE) \ - do { \ - int i; \ - int n = fixnum_value(vector->length); \ - TYPE *data = (TYPE *) vector->data; \ - for (i = 0; i < n; i++) { \ - wchar_t c = (wchar_t) data[i]; \ - if (c == '\\' || c == '"') \ - putc('\\', f); \ - sbcl_putwc(c, f); \ - } \ - } while (0) - - switch (tag) { - case SIMPLE_BASE_STRING_WIDETAG: - doit(unsigned char); - break; -#ifdef SIMPLE_CHARACTER_STRING_WIDETAG - case SIMPLE_CHARACTER_STRING_WIDETAG: - doit(unsigned int); - break; -#endif - default: - fprintf(f, "", tag); - } -#undef doit +lispobj debug_print(lispobj string) +{ + print_string(VECTOR(string), stderr); + putc('\n', stderr); + return 0; } static int string_equal (struct vector *vector, char *string) @@ -145,6 +131,7 @@ static void print_entry_name (lispobj name, FILE *f) { + name = follow_maybe_fp(name); if (listp(name)) { putc('(', f); while (name != NIL) { @@ -154,19 +141,20 @@ return; } print_entry_name(CONS(name)->car, f); - name = CONS(name)->cdr; + name = follow_maybe_fp(CONS(name)->cdr); if (name != NIL) putc(' ', f); } putc(')', f); } else if (lowtag_of(name) == OTHER_POINTER_LOWTAG) { - lispobj *object = native_pointer(name); - if (widetag_of(object) == SYMBOL_WIDETAG) { - struct symbol *symbol = (struct symbol *) object; + struct symbol *symbol = SYMBOL(name); + int widetag = header_widetag(symbol->header); + switch (widetag) { + case SYMBOL_WIDETAG: if (symbol->package != NIL) { struct package *pkg - = (struct package *) native_pointer(symbol->package); - struct vector *pkg_name = VECTOR(pkg->_name); + = (struct package *) native_pointer(follow_maybe_fp(symbol->package)); + struct vector *pkg_name = VECTOR(follow_maybe_fp(pkg->_name)); if (string_equal(pkg_name, "COMMON-LISP")) ; else if (string_equal(pkg_name, "COMMON-LISP-USER")) { @@ -179,17 +167,18 @@ fputs("::", f); } } - print_string(VECTOR(symbol->name), f); - } else if (widetag_of(object) == SIMPLE_BASE_STRING_WIDETAG + print_string(VECTOR(follow_maybe_fp(symbol->name)), f); + break; + case SIMPLE_BASE_STRING_WIDETAG: #ifdef SIMPLE_CHARACTER_STRING_WIDETAG - || widetag_of(object) == SIMPLE_CHARACTER_STRING_WIDETAG + case SIMPLE_CHARACTER_STRING_WIDETAG: #endif - ) { putc('"', f); - print_string((struct vector*)object, f); + print_string((struct vector*)symbol, f); putc('"', f); - } else { - fprintf(f, "", widetag_of(object)); + break; + default: + fprintf(f, "", widetag); } } else if (fixnump(name)) { fprintf(f, "%d", (int)fixnum_value(name)); @@ -219,28 +208,16 @@ * better not change. */ struct call_frame { -#ifndef LISP_FEATURE_ALPHA struct call_frame *old_cont; -#else - u32 old_cont; -#endif lispobj saved_lra; lispobj code; lispobj other_state[5]; }; struct call_info { -#ifndef LISP_FEATURE_ALPHA struct call_frame *frame; -#else - u32 frame; -#endif int interrupted; -#ifndef LISP_FEATURE_ALPHA struct code *code; -#else - u32 code; -#endif lispobj lra; int pc; /* Note: this is the trace file offset, not the actual pc. */ }; @@ -323,11 +300,7 @@ } if (info->code != NULL) info->pc = pc - (uword_t) info->code - -#ifndef LISP_FEATURE_ALPHA (HEADER_LENGTH(info->code->header) * sizeof(lispobj)); -#else - (HEADER_LENGTH(((struct code *)info->code)->header) * sizeof(lispobj)); -#endif else info->pc = 0; } @@ -497,17 +470,13 @@ describe_thread_state(void) { struct thread *thread = arch_os_get_current_thread(); - struct interrupt_data *data = thread->interrupt_data; + struct interrupt_data *data = &thread_interrupt_data(thread); #ifndef LISP_FEATURE_WIN32 sigset_t mask; - get_current_sigmask(&mask); - printf("Signal mask:\n"); - printf(" SIGALRM = %d\n", sigismember(&mask, SIGALRM)); - printf(" SIGINT = %d\n", sigismember(&mask, SIGINT)); - printf(" SIGPROF = %d\n", sigismember(&mask, SIGPROF)); -#ifdef SIG_STOP_FOR_GC - printf(" SIG_STOP_FOR_GC = %d\n", sigismember(&mask, SIG_STOP_FOR_GC)); -#endif + char string[180]; + thread_sigmask(SIG_BLOCK, 0, &mask); + sigset_tostring(&mask, string, sizeof string); + if (string[0]) printf("Signal mask: %s\n", string); #endif printf("Specials:\n"); printf(" *GC-INHIBIT* = %s\n", (read_TLS(GC_INHIBIT, thread) == T) ? "T" : "NIL"); @@ -600,3 +569,174 @@ } } #endif + +// Find the simple_fun that contains 'pc' in 'code' +int simple_fun_index_from_pc(struct code* code, char *pc) +{ + char *instruction_area = code_text_start(code); + unsigned int* offsets = code_fun_table(code) - 1; + int index; + for (index = code_n_funs(code) - 1; index >= 0; --index) { + char *base = instruction_area + offsets[-index]; + if (pc >= base) return index; + } + return -1; +} + +static boolean __attribute__((unused)) print_lisp_fun_name(char* pc) +{ + struct code* code; + if (gc_managed_addr_p((uword_t)pc) && + (code = (void*)component_ptr_from_pc(pc)) != 0) { + struct compiled_debug_fun* df = debug_function_from_pc(code, pc); + if (df) { + fprintf(stderr, " %p [", pc); + print_entry_name(df->name, stderr); + fprintf(stderr, "]\n"); + return 1; + } + } + return 0; +} + +#ifdef LISP_FEATURE_BACKTRACE_ON_SIGNAL +#define UNW_LOCAL_ONLY +#ifdef HAVE_LIBUNWIND +#include +#endif +#include "genesis/thread-instance.h" +#include "genesis/mutex.h" +static __attribute__((unused))int backtrace_completion_pipe[2] = {-1,-1}; +void libunwind_backtrace(struct thread *th, os_context_t *context) +{ + fprintf(stderr, "Lisp thread @ %p, tid %d", th, (int)th->os_kernel_tid); +#ifdef LISP_FEATURE_SB_THREAD + // the TLS area is not used if #-sb-thread. And if so, it must be "main thred" + struct thread_instance* lispthread = (void*)native_pointer(th->lisp_thread); + if (lispthread->name != NIL) { + fprintf(stderr, " (\""); + print_string(VECTOR(lispthread->name), stderr); + fprintf(stderr, "\")"); + } + putc('\n', stderr); + if (lispthread->waiting_for != NIL) { + fprintf(stderr, "waiting for %p", (void*)lispthread->waiting_for); + if (instancep(lispthread->waiting_for)) { + // THREAD-WAITING-FOR can be a mutex or a waitqueue (if not a cons). + // Accessing it as if it's a mutex works because both a waitqueue + // and a mutex have a name at the same slot offset (if #+sb-futex). + // So to reiterate the comment from linux-os.c - + // "Use this only if you know what you're doing" + struct mutex* lispmutex = (void*)native_pointer(lispthread->waiting_for); + if (lispmutex->name != NIL) { + fprintf(stderr, " (MUTEX:\""); + print_string(VECTOR(lispmutex->name), stderr); + fprintf(stderr, "\")"); + } + } + putc('\n', stderr); + } +#endif +#ifdef HAVE_LIBUNWIND + char procname[100]; + unw_cursor_t cursor; + // "unw_init_local() is thread-safe as well as safe to use from a signal handler." + // "unw_get_proc_name() is thread-safe. If cursor cp is in the local address-space, + // this routine is also safe to use from a signal handler." + if (context) { + unw_init_local(&cursor, context); + } else { + unw_context_t here; + unw_getcontext(&here); + unw_init_local(&cursor, &here); + } + do { + uword_t offset; + char *pc; + unw_get_reg(&cursor, UNW_TDEP_IP, (uword_t*)&pc); + if (print_lisp_fun_name(pc)) { + // printed + } else if (!unw_get_proc_name(&cursor, procname, sizeof procname, &offset)) { + fprintf(stderr, " %p [%s]\n", pc, procname); + } else { + fprintf(stderr, " %p ?\n", pc); + } + } while (unw_step(&cursor)); +#else + // If you don't have libunwind, this will almost surely not work, + // because we can't figure out how to get backwards past a signal frame. + log_backtrace_from_fp((void*)*os_context_fp_addr(context), 100, 0, stderr); +#endif +} +void backtrace_lisp_threads(int __attribute__((unused)) signal, + siginfo_t __attribute__((unused)) *info, + os_context_t *context) +{ +#ifdef LISP_FEATURE_SB_THREAD + if (backtrace_completion_pipe[1] >= 0) { + libunwind_backtrace(current_thread, context); + write(backtrace_completion_pipe[1], context /* any random byte */, 1); + return; + } + struct thread *th; + int nthreads = 0; + for_each_thread(th) { ++nthreads; } + if (signal) + fprintf(stderr, "Caught backtrace-all signal in tid %d, %d threads\n", + (int)arch_os_get_current_thread()->os_kernel_tid, nthreads); + // Would be nice if we could forcibly stop all the other threads, + // but pthread_mutex_trylock is not safe to use in a signal handler. + if (nthreads > 1) { + pipe(backtrace_completion_pipe); + } + for_each_thread(th) { + if (th == arch_os_get_current_thread()) + libunwind_backtrace(th, context); + else { + char junk; + pthread_kill(th->os_thread, SIGXCPU); + read(backtrace_completion_pipe[0], &junk, 1); + } + } + if (nthreads > 1) { + close(backtrace_completion_pipe[1]); + close(backtrace_completion_pipe[0]); + backtrace_completion_pipe[0] = backtrace_completion_pipe[1] = -1; + } +#else + libunwind_backtrace(arch_os_get_current_thread(), context); +#endif +} +static int watchdog_pipe[2] = {-1,-1}; +static pthread_t watchdog_tid; +static void* watchdog_thread(void* arg) { + struct timeval timeout; + fd_set fds; + FD_ZERO(&fds); + FD_SET(watchdog_pipe[0], &fds); + timeout.tv_sec = (long)arg; + timeout.tv_usec = 0; + int nfds = select(watchdog_pipe[0]+1, &fds, 0, 0, &timeout); + if (nfds == 0) { + // Ensure this message comes out in one piece even if nothing following it does. + char msg[] = "Watchdog timer expired\n"; write(2, msg, sizeof msg-1); + backtrace_lisp_threads(0, 0, 0); + _exit(1); // cause the test suite to exit with failure + } + return 0; +} +void start_watchdog(int sec) { + if (pipe(watchdog_pipe)) lose("Can't make watchdog pipe"); + pthread_create(&watchdog_tid, 0, watchdog_thread, (void*)(long)sec); + char msg[] = "Started watchdog thread\n"; write(2, msg, sizeof msg-1); +} +void stop_watchdog() { + char c[1] = {0}; + write(watchdog_pipe[1], c, 1); + close(watchdog_pipe[1]); + void* result; + pthread_join(watchdog_tid, &result); + close(watchdog_pipe[0]); + watchdog_pipe[0] = watchdog_pipe[1] = -1; +} +#endif diff -Nru sbcl-2.0.6/src/runtime/breakpoint.c sbcl-2.1.1/src/runtime/breakpoint.c --- sbcl-2.0.6/src/runtime/breakpoint.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/breakpoint.c 2021-01-30 11:22:38.000000000 +0000 @@ -94,11 +94,7 @@ static long compute_offset(os_context_t *context, lispobj code) { if (code != NIL) { -#ifdef LISP_FEATURE_HPPA - uword_t pc = *os_context_pc_addr(context) & ~3; -#else uword_t pc = *os_context_pc_addr(context); -#endif struct code *codeptr = (struct code *)native_pointer(code); uword_t code_start = (uword_t)code_text_start(codeptr); int offset; @@ -117,7 +113,7 @@ fake_foreign_function_call(context); #ifndef LISP_FEATURE_SB_SAFEPOINT - unblock_gc_signals(0, 0); + unblock_gc_signals(); #endif code = find_code(context); @@ -144,7 +140,7 @@ fake_foreign_function_call(context); #ifndef LISP_FEATURE_SB_SAFEPOINT - unblock_gc_signals(0, 0); + unblock_gc_signals(); #endif code = find_code(context); diff -Nru sbcl-2.0.6/src/runtime/bsd-os.c sbcl-2.1.1/src/runtime/bsd-os.c --- sbcl-2.0.6/src/runtime/bsd-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/bsd-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -63,7 +63,7 @@ #if defined LISP_FEATURE_FREEBSD #include -#if defined(LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_SB_PTHREAD_FUTEX) +#ifdef LISP_FEATURE_SB_FUTEX #include #endif @@ -201,7 +201,12 @@ } else #endif { + os_vm_address_t requested = addr; addr = mmap(addr, len, protection, flags, -1, 0); + if (requested && requested != addr && !(attributes & MOVABLE)) { + return 0; + } + } if (addr == MAP_FAILED) { @@ -280,10 +285,9 @@ SHOW("os_install_interrupt_handlers()/bsd-os/defined(GENCGC)"); if (INSTALL_SIG_MEMORY_FAULT_HANDLER) { #if defined(LISP_FEATURE_MACH_EXCEPTION_HANDLER) - undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT, - mach_error_memory_fault_handler); + ll_install_handler(SIG_MEMORY_FAULT, mach_error_memory_fault_handler); #else - undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT, + ll_install_handler(SIG_MEMORY_FAULT, #if defined(LISP_FEATURE_FREEBSD) && !defined(__GLIBC__) (__siginfohandler_t *) #endif @@ -294,13 +298,13 @@ #ifdef LISP_FEATURE_SB_THREAD # ifdef LISP_FEATURE_SB_SAFEPOINT # ifdef LISP_FEATURE_SB_THRUPTION - undoably_install_low_level_interrupt_handler(SIGPIPE, thruption_handler); + ll_install_handler(SIGURG, thruption_handler); # endif # else - undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC, - sig_stop_for_gc_handler); + ll_install_handler(SIG_STOP_FOR_GC, sig_stop_for_gc_handler); # endif #endif + SHOW("leaving os_install_interrupt_handlers()"); } @@ -321,8 +325,7 @@ os_install_interrupt_handlers(void) { SHOW("os_install_interrupt_handlers()/bsd-os/!defined(GENCGC)"); - undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT, - sigsegv_handler); + ll_install_handler(SIG_MEMORY_FAULT, sigsegv_handler); } #endif /* defined GENCGC */ @@ -450,8 +453,7 @@ #endif /* LISP_FEATURE_X86 */ } -#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_FUTEX) \ - && !defined(LISP_FEATURE_SB_PTHREAD_FUTEX) +#ifdef LISP_FEATURE_SB_FUTEX int futex_wait(int *lock_word, long oldval, long sec, unsigned long usec) { @@ -459,30 +461,24 @@ int ret; if (sec < 0) - ret = umtx_wait((void *)lock_word, oldval, NULL); + ret = _umtx_op((void *)lock_word, UMTX_OP_WAIT, oldval, 0, 0); else { timeout.tv_sec = sec; timeout.tv_nsec = usec * 1000; - ret = umtx_wait((void *)lock_word, oldval, &timeout); - } - - switch (ret) { - case 0: - return 0; - case ETIMEDOUT: - return 1; - case EINTR: - return 2; - default: - /* EWOULDBLOCK and others, need to check the lock */ - return -1; + ret = _umtx_op((void *)lock_word, UMTX_OP_WAIT, oldval, (void*)sizeof timeout, &timeout); } + if (ret == 0) return 0; + // technically we would not need to check any of the error codes if the lisp side + // could just avoid looping if there is no time remaining. + if (errno == ETIMEDOUT) return 1; + if (errno == EINTR) return 2; + return -1; } int futex_wake(int *lock_word, int n) { - return umtx_wake((void *)lock_word, n); + return _umtx_op((void *)lock_word, UMTX_OP_WAKE, n, 0, 0); } #endif #endif /* __FreeBSD__ */ @@ -504,8 +500,7 @@ } -#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_FUTEX) \ - && !defined(LISP_FEATURE_SB_PTHREAD_FUTEX) +#ifdef LISP_FEATURE_SB_FUTEX int futex_wait(int *lock_word, long oldval, long sec, unsigned long usec) { diff -Nru sbcl-2.0.6/src/runtime/cheneygc.c sbcl-2.1.1/src/runtime/cheneygc.c --- sbcl-2.0.6/src/runtime/cheneygc.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/cheneygc.c 2021-01-30 11:22:38.000000000 +0000 @@ -153,8 +153,7 @@ printf("Scavenging interrupt handlers (%d bytes) ...\n", (int)sizeof(interrupt_handlers)); #endif - scavenge((lispobj *) interrupt_handlers, - sizeof(interrupt_handlers) / sizeof(lispobj)); + scavenge(lisp_sig_handlers, NSIG); #ifdef PRINTNOISE printf("Scavenging the control stack ...\n"); @@ -201,10 +200,6 @@ /* Maybe FIXME: it's possible that we could significantly reduce * RSS by zeroing the from_space or madvise(MADV_DONTNEED) or * similar os-dependent tricks here */ -#ifdef LISP_FEATURE_HPUX - /* hpux cant handle unmapping areas that are not 100% mapped */ - clear_auto_gc_trigger(); -#endif os_zero((os_vm_address_t) from_space, (os_vm_size_t) dynamic_space_size); @@ -362,7 +357,7 @@ void gc_init(void) { - weakobj_init(); + gc_common_init(); } /* noise to manipulate the gc trigger stuff */ @@ -394,7 +389,7 @@ uword_t end = (uword_t)addr + length - 1; if (((uword_t)addr >= DYNAMIC_0_SPACE_START && end < semispace_0_end) || ((uword_t)addr >= DYNAMIC_1_SPACE_START && end < semispace_1_end)) { -#if defined(SUNOS) || defined(SOLARIS) || defined(LISP_FEATURE_HPUX) +#if defined(SUNOS) || defined(SOLARIS) os_invalidate(addr, length); #else os_protect(addr, length, 0); @@ -417,7 +412,7 @@ addr = (os_vm_address_t)current_auto_gc_trigger; length = dynamic_space_size + (os_vm_address_t)current_dynamic_space - addr; -#if defined(SUNOS) || defined(SOLARIS) || defined(LISP_FEATURE_HPUX) +#if defined(SUNOS) || defined(SOLARIS) /* don't want to force whole space into swapping mode... */ os_validate(NOT_MOVABLE, addr, length); #else diff -Nru sbcl-2.0.6/src/runtime/coalesce.c sbcl-2.1.1/src/runtime/coalesce.c --- sbcl-2.0.6/src/runtime/coalesce.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/coalesce.c 2021-01-30 11:22:38.000000000 +0000 @@ -153,7 +153,7 @@ static uword_t coalesce_range(lispobj* where, lispobj* limit, uword_t arg) { struct hopscotch_table* ht = (struct hopscotch_table*)arg; - lispobj layout, bitmap, *next; + lispobj layout, *next; sword_t nwords, i; for ( ; where < limit ; where = next ) { @@ -164,14 +164,11 @@ next = where + nwords; switch (widetag) { case INSTANCE_WIDETAG: // mixed boxed/unboxed objects -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER case FUNCALLABLE_INSTANCE_WIDETAG: -#endif - layout = instance_layout(where); - bitmap = LAYOUT(layout)->bitmap; - for(i=1; i> 14 : 0; +#ifdef LISP_FEATURE_64_BIT + return table ? *table >> 32 : 0; // high 4 bits are the serialno +#else + return table ? *table >> 14 : 0; // else it only gets 18 (= 32 - 14) bits +#endif } static inline unsigned int code_n_named_calls(struct code* code) { diff -Nru sbcl-2.0.6/src/runtime/Config.alpha-linux sbcl-2.1.1/src/runtime/Config.alpha-linux --- sbcl-2.0.6/src/runtime/Config.alpha-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.alpha-linux 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -# -*- makefile -*- for the C-level run-time support for SBCL - -# 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. - -#LD = ld -taso ;; $LD is no longer used anywhere, should that be moved below? -LINKFLAGS += -dynamic -v -Wl,-T -Wl,ld-script.alpha-linux -rdynamic -NM = ./linux-nm - -ASSEM_SRC = alpha-assem.S ldso-stubs.S -ARCH_SRC = alpha-arch.c - -OS_SRC = linux-os.c linux-mman.c alpha-linux-os.c -OS_LIBS = -ldl - -ifdef LISP_FEATURE_SB_CORE_COMPRESSION - OS_LIBS += -lz -endif - -GC_SRC = cheneygc.c - -# Nothing to do for after-grovel-headers. -.PHONY: after-grovel-headers -after-grovel-headers: diff -Nru sbcl-2.0.6/src/runtime/Config.arm64-linux sbcl-2.1.1/src/runtime/Config.arm64-linux --- sbcl-2.0.6/src/runtime/Config.arm64-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.arm64-linux 2021-01-30 11:22:38.000000000 +0000 @@ -9,8 +9,6 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -NM = ./linux-nm - ASSEM_SRC = arm64-assem.S ARCH_SRC = arm64-arch.c diff -Nru sbcl-2.0.6/src/runtime/Config.arm64-netbsd sbcl-2.1.1/src/runtime/Config.arm64-netbsd --- sbcl-2.0.6/src/runtime/Config.arm64-netbsd 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.arm64-netbsd 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,21 @@ +# -*- makefile -*- for the C-level run-time support for SBCL + +# 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. + +include Config.arm64-bsd + +OS_LIBS = -lutil + +ifdef LISP_FEATURE_SB_THREAD + OS_LIBS += -lpthread -lrt +endif + +LINKFLAGS += -export-dynamic +LDFLAGS += -export-dynamic diff -Nru sbcl-2.0.6/src/runtime/Config.arm-android sbcl-2.1.1/src/runtime/Config.arm-android --- sbcl-2.0.6/src/runtime/Config.arm-android 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.arm-android 2021-01-30 11:22:38.000000000 +0000 @@ -12,7 +12,6 @@ CC=${NDK_PATH}/toolchains/arm-linux-androideabi-4.8/prebuilt/linux-x86_64/arm-linux-androideabi/bin/gcc CFLAGS += -marm -march=armv5 --sysroot=${NDK_PATH}/platforms/android-15/arch-arm/ LINKFLAGS += --sysroot=${NDK_PATH}/platforms/android-15/arch-arm/ -NM = ${NDK_PATH}/toolchains/arm-linux-androideabi-4.8/prebuilt/linux-x86_64/arm-linux-androideabi/bin/nm ASSEM_SRC = arm-assem.S ARCH_SRC = arm-arch.c diff -Nru sbcl-2.0.6/src/runtime/Config.arm-linux sbcl-2.1.1/src/runtime/Config.arm-linux --- sbcl-2.0.6/src/runtime/Config.arm-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.arm-linux 2021-01-30 11:22:38.000000000 +0000 @@ -10,7 +10,6 @@ # files for more information. CFLAGS += -marm -march=armv5 -NM = ./linux-nm ASSEM_SRC = arm-assem.S ARCH_SRC = arm-arch.c diff -Nru sbcl-2.0.6/src/runtime/Config.generic-openbsd sbcl-2.1.1/src/runtime/Config.generic-openbsd --- sbcl-2.0.6/src/runtime/Config.generic-openbsd 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.generic-openbsd 2021-01-30 11:22:38.000000000 +0000 @@ -13,7 +13,7 @@ OS_LIBS += -lutil ifdef LISP_FEATURE_SB_THREAD -CFLAGS += -pthread -DOS_THREAD_STACK +CFLAGS += -pthread OS_LIBS += -pthread endif diff -Nru sbcl-2.0.6/src/runtime/Config.hppa-hpux sbcl-2.1.1/src/runtime/Config.hppa-hpux --- sbcl-2.0.6/src/runtime/Config.hppa-hpux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.hppa-hpux 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -# -*- makefile -*- for the C-level run-time support for SBCL - -# 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. - -LINKFLAGS += -v -# avoid native tools -NM = /usr/local/bin/nm -CC = /usr/local/bin/gcc - -ASSEM_SRC = hppa-assem.S ldso-stubs.S -ARCH_SRC = hppa-arch.c -OS_SRC = hpux-os.c hppa-hpux-os.c - -OS_LIBS = - -CFLAGS += -D_POSIX_SOURCE -D_HPUX_SOURCE - -ifdef LISP_FEATURE_LARGEFILE - CFLAGS += -D_LARGEFILE_SOURCE -D_LARGEFILE64_SOURCE -D_FILE_OFFSET_BITS=64 -endif - -ifdef LISP_FEATURE_SB_THREAD - OS_LIBS += -lpthread -endif -ifdef LISP_FEATURE_SB_CORE_COMPRESSION - OS_LIBS += -lz -endif - -GC_SRC = cheneygc.c - -# Nothing to do for after-grovel-headers. -.PHONY: after-grovel-headers -after-grovel-headers: diff -Nru sbcl-2.0.6/src/runtime/Config.hppa-linux sbcl-2.1.1/src/runtime/Config.hppa-linux --- sbcl-2.0.6/src/runtime/Config.hppa-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.hppa-linux 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -# -*- makefile -*- for the C-level run-time support for SBCL - -# 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. - -LINKFLAGS += -v -NM = ./linux-nm - -ASSEM_SRC = hppa-assem.S ldso-stubs.S -ARCH_SRC = hppa-arch.c - -OS_SRC = linux-os.c linux-mman.c hppa-linux-os.c -OS_LIBS = -ldl -ifdef LISP_FEATURE_SB_CORE_COMPRESSION - OS_LIBS += -lz -endif - -GC_SRC = cheneygc.c - -# Nothing to do for after-grovel-headers. -.PHONY: after-grovel-headers -after-grovel-headers: diff -Nru sbcl-2.0.6/src/runtime/Config.mips-linux sbcl-2.1.1/src/runtime/Config.mips-linux --- sbcl-2.0.6/src/runtime/Config.mips-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.mips-linux 2021-01-30 11:22:38.000000000 +0000 @@ -10,7 +10,6 @@ # files for more information. LINKFLAGS += -O2 -Wl,--export-dynamic -NM = ./linux-nm ASSEM_SRC = mips-assem.S ARCH_SRC = mips-arch.c diff -Nru sbcl-2.0.6/src/runtime/Config.ppc64-linux sbcl-2.1.1/src/runtime/Config.ppc64-linux --- sbcl-2.0.6/src/runtime/Config.ppc64-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.ppc64-linux 2021-01-30 11:22:38.000000000 +0000 @@ -9,9 +9,8 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -CFLAGS += -m64 +CFLAGS += -m64 -std=gnu99 LINKFLAGS += -m64 -Wl,--export-dynamic -NM = ./linux-nm ASSEM_SRC = ppc64-assem.S ARCH_SRC = ppc-arch.c diff -Nru sbcl-2.0.6/src/runtime/Config.ppc-linux sbcl-2.1.1/src/runtime/Config.ppc-linux --- sbcl-2.0.6/src/runtime/Config.ppc-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.ppc-linux 2021-01-30 11:22:38.000000000 +0000 @@ -9,9 +9,8 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -CFLAGS += -m32 +CFLAGS += -m32 -std=gnu99 LINKFLAGS += -m32 -Wl,--export-dynamic -NM = ./linux-nm ASSEM_SRC = ppc-assem.S ARCH_SRC = ppc-arch.c diff -Nru sbcl-2.0.6/src/runtime/Config.riscv-linux sbcl-2.1.1/src/runtime/Config.riscv-linux --- sbcl-2.0.6/src/runtime/Config.riscv-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.riscv-linux 2021-01-30 11:22:38.000000000 +0000 @@ -9,8 +9,6 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -NM = ./linux-nm - ARCH_SRC = riscv-arch.c OS_SRC = linux-os.c linux-mman.c riscv-linux-os.c diff -Nru sbcl-2.0.6/src/runtime/Config.sparc-linux sbcl-2.1.1/src/runtime/Config.sparc-linux --- sbcl-2.0.6/src/runtime/Config.sparc-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.sparc-linux 2021-01-30 11:22:38.000000000 +0000 @@ -12,7 +12,6 @@ CFLAGS += -m32 -fno-PIC ASFLAGS = -m32 -fno-PIC -g -Wall -Wa,-xarch=v8plus LINKFLAGS += -rdynamic -m32 -NM = ./linux-nm ASSEM_SRC = sparc-assem.S ARCH_SRC = sparc-arch.c diff -Nru sbcl-2.0.6/src/runtime/Config.x86-64-bsd sbcl-2.1.1/src/runtime/Config.x86-64-bsd --- sbcl-2.0.6/src/runtime/Config.x86-64-bsd 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-64-bsd 2021-01-30 11:22:38.000000000 +0000 @@ -18,6 +18,9 @@ ifdef LISP_FEATURE_SB_CORE_COMPRESSION OS_LIBS += -lz endif +ifdef HAVE_LIBUNWIND + OS_LIBS += -lunwind +endif CFLAGS += -fno-omit-frame-pointer LINKFLAGS += -Wl,--export-dynamic diff -Nru sbcl-2.0.6/src/runtime/Config.x86-64-darwin sbcl-2.1.1/src/runtime/Config.x86-64-darwin --- sbcl-2.0.6/src/runtime/Config.x86-64-darwin 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-64-darwin 2021-01-30 11:22:38.000000000 +0000 @@ -9,7 +9,7 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -CFLAGS += -g -Wall -O2 -fdollars-in-identifiers -DOS_THREAD_STACK +CFLAGS += -g -Wall -O2 -fdollars-in-identifiers ifdef SBCL_MACOSX_VERSION_MIN CFLAGS += -mmacosx-version-min=$(SBCL_MACOSX_VERSION_MIN) diff -Nru sbcl-2.0.6/src/runtime/Config.x86-64-linux sbcl-2.1.1/src/runtime/Config.x86-64-linux --- sbcl-2.0.6/src/runtime/Config.x86-64-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-64-linux 2021-01-30 11:22:38.000000000 +0000 @@ -9,8 +9,6 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -NM = ./linux-nm - ASSEM_SRC = x86-64-assem.S ARCH_SRC = x86-64-arch.c OS_SRC = linux-os.c linux-mman.c x86-64-linux-os.c @@ -42,6 +40,10 @@ OS_LIBS += -lz endif +ifdef HAVE_LIBUNWIND + OS_LIBS += -lunwind +endif + CFLAGS += -Wunused-parameter -fno-omit-frame-pointer -momit-leaf-frame-pointer DISABLE_PIE=no diff -Nru sbcl-2.0.6/src/runtime/Config.x86-64-sunos sbcl-2.1.1/src/runtime/Config.x86-64-sunos --- sbcl-2.0.6/src/runtime/Config.x86-64-sunos 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-64-sunos 2021-01-30 11:22:38.000000000 +0000 @@ -1,8 +1,7 @@ CC=gcc -CFLAGS = -m64 -g -O2 -Wall -D__EXTENSIONS__ -D_POSIX_C_SOURCE=199506L -DSVR4 -D_REENTRANT -fno-omit-frame-pointer +CFLAGS = -m64 -g -O2 -Wall -std=gnu89 -D__EXTENSIONS__ -D_POSIX_C_SOURCE=199506L -DSVR4 -D_REENTRANT -fno-omit-frame-pointer LINKFLAGS = -m64 -g ASFLAGS = -m64 -Wall -NM = nm -xgp GREP = ggrep #CC=/opt/SunStudioExpress/bin/cc diff -Nru sbcl-2.0.6/src/runtime/Config.x86-64-win32 sbcl-2.1.1/src/runtime/Config.x86-64-win32 --- sbcl-2.0.6/src/runtime/Config.x86-64-win32 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-64-win32 2021-01-30 11:22:38.000000000 +0000 @@ -14,10 +14,6 @@ OS_SRC = win32-os.c x86-64-win32-os.c -ifdef LISP_FEATURE_SB_THREAD - OS_SRC += pthreads_win32.c -endif - ifdef LISP_FEATURE_SB_LINKABLE_RUNTIME LIBSBCL = libsbcl.a USE_LIBSBCL = -Wl,--whole-archive libsbcl.a -Wl,--no-whole-archive @@ -44,6 +40,9 @@ ifdef LISP_FEATURE_SB_CORE_COMPRESSION OS_LIBS += -lz endif +ifdef LISP_FEATURE_SB_FUTEX + OS_LIBS += -lSynchronization +endif ifdef LISP_FEATURE_IMMOBILE_SPACE GC_SRC = fullcgc.c gencgc.c traceroot.c immobile-space.c @@ -52,7 +51,7 @@ endif CFLAGS = -g -W -Wall \ - -Wno-unused-function \ + -Wno-unused-function -Wno-unused-parameter -Wno-cast-function-type \ -fno-omit-frame-pointer \ -O5 -m64 -DWINVER=0x0501 \ -D__W32API_USE_DLLIMPORT__ diff -Nru sbcl-2.0.6/src/runtime/Config.x86-darwin sbcl-2.1.1/src/runtime/Config.x86-darwin --- sbcl-2.0.6/src/runtime/Config.x86-darwin 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-darwin 2021-01-30 11:22:38.000000000 +0000 @@ -9,7 +9,7 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -CFLAGS += -arch i386 -g -Wall -O2 -fdollars-in-identifiers -fno-omit-frame-pointer -DOS_THREAD_STACK +CFLAGS += -arch i386 -g -Wall -O2 -fdollars-in-identifiers -fno-omit-frame-pointer LINKFLAGS += -arch i386 ifdef SBCL_MACOSX_VERSION_MIN diff -Nru sbcl-2.0.6/src/runtime/Config.x86-linux sbcl-2.1.1/src/runtime/Config.x86-linux --- sbcl-2.0.6/src/runtime/Config.x86-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-linux 2021-01-30 11:22:38.000000000 +0000 @@ -9,8 +9,6 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -NM = ./linux-nm - ASSEM_SRC = x86-assem.S ARCH_SRC = x86-arch.c OS_SRC = linux-os.c linux-mman.c x86-linux-os.c @@ -43,6 +41,9 @@ ifdef LISP_FEATURE_SB_CORE_COMPRESSION OS_LIBS += -lz endif +ifdef HAVE_LIBUNWIND + OS_LIBS += -lunwind +endif ifdef LISP_FEATURE_SB_LINKABLE_RUNTIME LIBSBCL = sbcl.o USE_LIBSBCL = sbcl.o diff -Nru sbcl-2.0.6/src/runtime/Config.x86-sunos sbcl-2.1.1/src/runtime/Config.x86-sunos --- sbcl-2.0.6/src/runtime/Config.x86-sunos 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-sunos 2021-01-30 11:22:38.000000000 +0000 @@ -11,7 +11,6 @@ CC=gcc CFLAGS = -g -O2 -Wall -D__EXTENSIONS__ -D_POSIX_C_SOURCE=199506L -DSVR4 -D_REENTRANT -fno-omit-frame-pointer -NM = nm -xgp GREP = ggrep ASSEM_SRC = x86-assem.S diff -Nru sbcl-2.0.6/src/runtime/Config.x86-win32 sbcl-2.1.1/src/runtime/Config.x86-win32 --- sbcl-2.0.6/src/runtime/Config.x86-win32 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/Config.x86-win32 2021-01-30 11:22:38.000000000 +0000 @@ -14,7 +14,7 @@ ASSEM_SRC = x86-assem.S ARCH_SRC = x86-arch.c -OS_SRC = win32-os.c x86-win32-os.c pthreads_win32.c +OS_SRC = win32-os.c x86-win32-os.c ifdef LISP_FEATURE_SB_LINKABLE_RUNTIME LIBSBCL = libsbcl.a @@ -42,11 +42,14 @@ ifdef LISP_FEATURE_SB_CORE_COMPRESSION OS_LIBS += -lz endif +ifdef LISP_FEATURE_SB_FUTEX + OS_LIBS += -lSynchronization +endif GC_SRC = fullcgc.c gencgc.c traceroot.c CFLAGS = -g -Wall -O3 \ - -fno-omit-frame-pointer -march=i686 -DWINVER=0x0501 \ + -fno-omit-frame-pointer -march=i686 -DWINVER=0x600 -D_WIN32_WINNT=0x600 \ -D__W32API_USE_DLLIMPORT__ \ -mpreferred-stack-boundary=2 # We assume Windows ABI 4-byte alignment, but GCC decided to change to diff -Nru sbcl-2.0.6/src/runtime/core.h sbcl-2.1.1/src/runtime/core.h --- sbcl-2.0.6/src/runtime/core.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/core.h 2021-01-30 11:22:38.000000000 +0000 @@ -15,11 +15,7 @@ #include "sbcl.h" #include "runtime.h" -#ifdef LISP_FEATURE_ALPHA -typedef u32 core_entry_elt_t; -#else typedef sword_t core_entry_elt_t; -#endif struct ndir_entry { core_entry_elt_t identifier; diff -Nru sbcl-2.0.6/src/runtime/coreparse.c sbcl-2.1.1/src/runtime/coreparse.c --- sbcl-2.0.6/src/runtime/coreparse.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/coreparse.c 2021-01-30 11:22:38.000000000 +0000 @@ -183,7 +183,7 @@ # ifdef LISP_FEATURE_WIN32 /* Ensure the memory is committed so zlib doesn't segfault trying to inflate. */ - os_validate_recommit(addr, len); + os_commit_memory(addr, len); # endif if (-1 == lseek(fd, offset, SEEK_SET)) { @@ -383,10 +383,9 @@ struct heap_adjust __attribute__((unused)) *adj) { #if defined(LISP_FEATURE_COMPACT_INSTANCE_HEADER) && defined(LISP_FEATURE_64_BIT) - lispobj ptr = function_layout(fun); + lispobj ptr = funinstance_layout(fun); lispobj adjusted = adjust_word(adj, ptr); - if (adjusted != ptr) - FIXUP(set_function_layout(fun, adjusted), fun); + if (adjusted != ptr) FIXUP(funinstance_layout(fun)=adjusted, fun); #endif } @@ -395,9 +394,10 @@ lispobj *where = (lispobj*)start; int widetag; long nwords; - lispobj layout, adjusted_layout, bitmap; + lispobj layout, adjusted_layout; struct code* code; sword_t delta; + int i; adj->n_relocs_abs = adj->n_relocs_rel = 0; for ( ; where < end ; where += nwords ) { @@ -417,32 +417,17 @@ // - Otherwise, the word might point to a relocated range, // either the instance itself, or a trampoline in immobile space. adjust_word_at(where+1, adj); + /* FALLTHROUGH */ case INSTANCE_WIDETAG: - layout = (widetag == FUNCALLABLE_INSTANCE_WIDETAG) ? - funinstance_layout(where) : instance_layout(where); + layout = layout_of(where); adjusted_layout = adjust_word(adj, layout); - // Do not alter the layout as stored in the instance if non-compact - // header. instance_scan() will do it if necessary. -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER - if (adjusted_layout != layout) - instance_layout(where) = adjusted_layout; -#endif - bitmap = LAYOUT(adjusted_layout)->bitmap; - gc_assert(fixnump(bitmap) - || widetag_of(native_pointer(bitmap))==BIGNUM_WIDETAG); - // If the post-adjustment address of 'layout' is higher than 'where', - // then the layout's pointer slots need adjusting. - // This is true regardless of whether the core was mapped at a higher - // or lower address than desired. - if (is_lisp_pointer(bitmap) && adjusted_layout > (lispobj)where) { - // Do not write back the adjusted bitmap pointer. Each heap word - // must be touched at most once. When the layout itself gets scanned, - // the bitmap slot will be rewritten if needed. - bitmap = adjust_word(adj, bitmap); - } - - instance_scan((void(*)(lispobj*,sword_t,uword_t))adjust_pointers, - where+1, nwords-1, bitmap, (uintptr_t)adj); + // writeback the layout if it changed. The layout is not a tagged slot + // so it would not be fixed up otherwise. + if (adjusted_layout != layout) layout_of(where) = adjusted_layout; + struct bitmap bitmap = get_layout_bitmap(LAYOUT(adjusted_layout)); + lispobj* slots = where+1; + for (i=0; i<(nwords-1); ++i) + if (bitmap_logbitp(i, bitmap)) adjust_pointers(slots+i, 1, adj); continue; case FDEFN_WIDETAG: adjust_pointers(where+1, 2, adj); @@ -464,7 +449,6 @@ // Fixup absolute jump table lispobj* jump_table = code_jumptable_start(code); int count = jumptable_count(jump_table); - int i; for (i = 1; i < count; ++i) adjust_word_at(jump_table+i, adj); #endif // Fixup all embedded simple-funs @@ -499,7 +483,7 @@ break; // Vectors require extra care because of address-based hashing. case SIMPLE_VECTOR_WIDETAG: - if (is_vector_subtype(*where, VectorAddrHashing)) { + if (vector_flagp(*where, VectorAddrHashing)) { struct vector* v = (struct vector*)where; // If you could make a hash-table vector with space for exactly 1 k/v pair, // it would have length 5. @@ -534,7 +518,6 @@ case COMPLEX_CHARACTER_STRING_WIDETAG: #endif case COMPLEX_BASE_STRING_WIDETAG: - case COMPLEX_VECTOR_NIL_WIDETAG: case COMPLEX_BIT_VECTOR_WIDETAG: case COMPLEX_VECTOR_WIDETAG: case COMPLEX_ARRAY_WIDETAG: @@ -835,8 +818,17 @@ else #endif if (request) { - addr = (uword_t)os_validate(sub_2gb_flag ? MOVABLE_LOW : MOVABLE, - (os_vm_address_t)addr, request); +#ifdef LISP_FEATURE_WIN32 + if (id == DYNAMIC_CORE_SPACE_ID) { + addr = (uword_t)os_validate_nocommit(sub_2gb_flag ? MOVABLE_LOW : MOVABLE, + (os_vm_address_t)addr, request); + } + else +#endif + { + addr = (uword_t)os_validate(sub_2gb_flag ? MOVABLE_LOW : MOVABLE, + (os_vm_address_t)addr, request); + } if (!addr) { lose("Can't allocate %#"OBJ_FMTX" bytes for space %ld", (lispobj)request, id); @@ -863,13 +855,7 @@ DYNAMIC_0_SPACE_START = addr = semispace_0_start; current_dynamic_space = (lispobj*)addr; // Request that much again now -#ifdef LISP_FEATURE_ALPHA /* meaning: is this a 32-on-64 SBCL implementation */ - uword_t addr1 = (uword_t)os_validate(MOVABLE_LOW, 0, request); - extern os_set_cheneygc_spaces(uword_t,uword_t); - os_set_cheneygc_spaces(addr, addr1); -#else uword_t addr1 = (uword_t)os_allocate(request); -#endif uword_t semispace_1_start = ALIGN_UP(addr1, BACKEND_PAGE_BYTES); uword_t semispace_1_end = ALIGN_DOWN(addr1 + request, BACKEND_PAGE_BYTES); @@ -1131,7 +1117,7 @@ if (hopscotch_get(seen, ptr, 0)) return; hopscotch_insert(seen, ptr, 1); - lispobj layout, bitmap, *obj; + lispobj layout, *obj; int nwords, i; if (lowtag_of(ptr) == LIST_POINTER_LOWTAG) { RECURSE(CONS(ptr)->car); @@ -1141,28 +1127,23 @@ nwords = fixnum_value(obj[1]); // vector length for(i=0; ibitmap; - for(i=1; i<=nwords; ++i) - if (layout_bitmap_logbitp(i-1, bitmap)) RECURSE(obj[i]); - break; case FUNCALLABLE_INSTANCE_WIDETAG: - layout = funinstance_layout(obj); + layout = layout_of(obj); graph_visit(ptr, layout, seen); - bitmap = LAYOUT(layout)->bitmap; - nwords = SHORT_BOXED_NWORDS(*obj); - // We don't need to scan the word at index 1 (the trampoline pointer) - // because it either points to the FIN itself or to readonly space. - for(i=2; i<=nwords; ++i) - if (layout_bitmap_logbitp(i-1, bitmap)) RECURSE(obj[i]); + nwords = sizetab[widetag_of(obj)](obj); + struct bitmap bitmap = get_layout_bitmap(LAYOUT(layout)); + for (i=0; i<(nwords-1); ++i) + if (bitmap_logbitp(i, bitmap)) RECURSE(obj[1+i]); + break; + case CODE_HEADER_WIDETAG: + nwords = code_header_words((struct code*)obj); + for(i=2; iheaders[0].count; else { lispobj* obj = native_pointer(ptr); - int widetag = widetag_of(obj); + lispobj header = *obj; + int widetag = header_widetag(header); int header_index = widetag>>2; - int words = OBJECT_SIZE(*obj, obj); + int words = OBJECT_SIZE(header, obj); ++v->headers[header_index].count; v->headers[header_index].words += words; if (widetag == SIMPLE_VECTOR_WIDETAG) { - int subtype = (*obj >> N_WIDETAG_BITS) & 7; - if (subtype == subtype_VectorWeak) - subtype = 1; - else if (subtype & subtype_VectorHashing) + int subtype = 0; + if (vector_flagp(header, VectorHashing)) subtype = 2; - else // The above test should account for everything - gc_assert(subtype == 0); + else if (vector_flagp(header, VectorWeak)) + subtype = 1; ++v->sv_subtypes[subtype].count; v->sv_subtypes[subtype].words += words; } diff -Nru sbcl-2.0.6/src/runtime/forwarding-ptr.h sbcl-2.1.1/src/runtime/forwarding-ptr.h --- sbcl-2.0.6/src/runtime/forwarding-ptr.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/forwarding-ptr.h 2021-01-30 11:22:38.000000000 +0000 @@ -59,4 +59,17 @@ return newspace_copy; } +/// Chase the pointer in 'word' if it points to a forwarded object. +static inline lispobj follow_maybe_fp(lispobj word) +{ + return (is_lisp_pointer(word) && forwarding_pointer_p(native_pointer(word))) + ? forwarding_pointer_value(native_pointer(word)) : word; +} +/// As above, but 'ptr' MUST be a pointer. +static inline lispobj follow_fp(lispobj ptr) +{ + return forwarding_pointer_p(native_pointer(ptr)) + ? forwarding_pointer_value(native_pointer(ptr)) : ptr; +} + #endif diff -Nru sbcl-2.0.6/src/runtime/fullcgc.c sbcl-2.1.1/src/runtime/fullcgc.c --- sbcl-2.0.6/src/runtime/fullcgc.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/fullcgc.c 2021-01-30 11:22:38.000000000 +0000 @@ -244,54 +244,55 @@ #define HT_ENTRY_LIVENESS_FUN_ARRAY_NAME alivep_funs #include "weak-hash-pred.inc" +static void trace_using_layout(lispobj layout, lispobj* where, int nslots) +{ + // Apart from the allowance for untagged pointers in lockfree list nodes, + // this contains almost none of the special cases that gencgc does. + if (!layout) return; + gc_mark_obj(layout); + if (lockfree_list_node_layout_p(LAYOUT(layout))) { // allow untagged 'next' + struct instance* node = (struct instance*)where; + lispobj next = node->slots[INSTANCE_DATA_START]; + // ignore if 0 + if (fixnump(next) && next) __mark_obj(next|INSTANCE_POINTER_LOWTAG); + } + struct bitmap bitmap = get_layout_bitmap(LAYOUT(layout)); + int i; + lispobj* slots = where+1; + for (i=0; ibitmap; - // If no raw slots, just scan without use of the bitmap. - // A bitmap of -1 implies that not only are all slots tagged, - // there is no special GC method for any slot. - if (bitmap == make_fixnum(-1)) break; - // Otherwise, the first slot might merit special treatment. - if (lockfree_list_node_layout_p(LAYOUT(layout))) { - struct instance* node = (struct instance*)where; - lispobj next = node->slots[INSTANCE_DATA_START]; - if (fixnump(next) && next) // ignore initially 0 heap words - __mark_obj(next|INSTANCE_POINTER_LOWTAG); - } - for(i=1; idata[fixnum_value(v->length)-1]; gc_dcheck(instancep(lhash_table)); @@ -313,10 +314,6 @@ } return; } - if (is_vector_subtype(header, VectorWeak)) { - add_to_weak_vector_list(where, header); - return; - } break; #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) /* on x86[-64], closure->fun is a fixnum-qua-pointer. Convert it to a lisp @@ -485,7 +482,7 @@ int obj_spacing = fixedobj_page_obj_align(page); if (!obj_spacing) continue; - int nwords = fixedobj_page_obj_size(page); + int nwords = obj_spacing >> WORD_SHIFT; lispobj *limit = (lispobj*)((char*)obj + IMMOBILE_CARD_BYTES - obj_spacing); for ( ; obj <= limit ; obj = (lispobj*)((char*)obj + obj_spacing) ) { lispobj header = *obj; diff -Nru sbcl-2.0.6/src/runtime/gc-common.c sbcl-2.1.1/src/runtime/gc-common.c --- sbcl-2.0.6/src/runtime/gc-common.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/gc-common.c 2021-01-30 11:22:38.000000000 +0000 @@ -129,7 +129,7 @@ #define FIX_POINTER() { \ lispobj *ptr = native_pointer(object); \ if (forwarding_pointer_p(ptr)) \ - *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); \ + *object_ptr = forwarding_pointer_value(ptr); \ else /* Scavenge that pointer. */ \ scav_ptr[PTR_SCAVTAB_INDEX(object)](object_ptr, object); \ } @@ -288,10 +288,13 @@ return 1; } - +extern int pin_all_dynamic_space_code; static struct code * trans_code(struct code *code) { +#ifdef LISP_FEATURE_GENCGC + gc_dcheck(!pin_all_dynamic_space_code); +#endif /* if object has already been transported, just return pointer */ if (forwarding_pointer_p((lispobj *)code)) { return (struct code *)native_pointer(forwarding_pointer_value((lispobj*)code)); @@ -300,7 +303,7 @@ gc_dcheck(widetag_of(&code->header) == CODE_HEADER_WIDETAG); /* prepare to transport the code vector */ - lispobj l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG; + lispobj l_code = make_lispobj(code, OTHER_POINTER_LOWTAG); lispobj l_new_code = copy_large_object(l_code, code_total_nwords(code), CODE_PAGE_TYPE); @@ -313,7 +316,7 @@ set_forwarding_pointer((lispobj *)code, l_new_code); struct code *new_code = (struct code *) native_pointer(l_new_code); - uword_t displacement = l_new_code - l_code; + sword_t displacement = l_new_code - l_code; #if defined LISP_FEATURE_PPC || defined LISP_FEATURE_PPC64 || \ defined LISP_FEATURE_X86 || defined LISP_FEATURE_X86_64 @@ -351,7 +354,7 @@ trans_code_header(lispobj object) { struct code *ncode = trans_code((struct code *) native_pointer(object)); - return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG; + return make_lispobj(ncode, OTHER_POINTER_LOWTAG); } static sword_t @@ -376,10 +379,9 @@ uword_t offset = HeaderValue(return_pc->header) * N_WORD_BYTES; /* Transport the whole code object */ - struct code *code = (struct code *) ((uword_t) return_pc - offset); - struct code *ncode = trans_code(code); + struct code *code = trans_code((struct code *) ((uword_t) return_pc - offset)); - return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG; + return make_lispobj((char*)code + offset, OTHER_POINTER_LOWTAG); } #endif /* RETURN_PC_WIDETAG */ @@ -422,10 +424,9 @@ (HeaderValue(fheader->header) & FUN_HEADER_NWORDS_MASK) * N_WORD_BYTES; /* Transport the whole code object */ - struct code *code = (struct code *) ((uword_t) fheader - offset); - struct code *ncode = trans_code(code); + struct code *code = trans_code((struct code *) ((uword_t) fheader - offset)); - return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG; + return make_lispobj((char*)code + offset, FUN_POINTER_LOWTAG); } @@ -642,87 +643,75 @@ return 1; } -static inline boolean bignum_logbitp_inline(int index, struct bignum* bignum) -{ - int len = HeaderValue(bignum->header); - int word_index = index / N_WORD_BITS; - int bit_index = index % N_WORD_BITS; - return word_index < len ? (bignum->digits[word_index] >> bit_index) & 1 : 0; -} -boolean positive_bignum_logbitp(int index, struct bignum* bignum) -{ - /* If the bignum in the layout has another pointer to it (besides the layout) - acting as a root, and which is scavenged first, then transporting the - bignum causes the layout to see a FP, as would copying an instance whose - layout that is. This is a nearly impossible scenario to create organically - in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum - except for a few things that would cause it to be pinned anyway, - such as it being kept in a local variable during structure manipulation. - See 'interleaved-raw.impure.lisp' for a way to trigger this */ - if (forwarding_pointer_p((lispobj*)bignum)) { - lispobj forwarded = forwarding_pointer_value((lispobj*)bignum); -#if 0 - fprintf(stderr, "GC bignum_logbitp(): fwd from %p to %p\n", - (void*)bignum, (void*)forwarded); -#endif - bignum = (struct bignum*)native_pointer(forwarded); - } - return bignum_logbitp_inline(index, bignum); -} +//// General boxed object scav/trans/size functions -// Helper function for stepping through the tagged slots of an instance in -// scav_instance and verify_space. -void -instance_scan(void (*proc)(lispobj*, sword_t, uword_t), - lispobj *instance_slots, - sword_t nslots, /* number of payload words */ - lispobj layout_bitmap, - uword_t arg) -{ - sword_t index; - - if (fixnump(layout_bitmap)) { - if (layout_bitmap == make_fixnum(-1)) - proc(instance_slots, nslots, arg); - else { - sword_t bitmap = fixnum_value(layout_bitmap); // signed integer! - for (index = 0; index < nslots ; index++, bitmap >>= 1) - if (bitmap & 1) - proc(instance_slots + index, 1, arg); - } - } else { /* huge bitmap */ - struct bignum * bitmap; - bitmap = (struct bignum*)native_pointer(layout_bitmap); - for (index = 0; index < nslots ; index++) - if (bignum_logbitp_inline(index, bitmap)) - proc(instance_slots + index, 1, arg); - } +#define DEF_SCAV_BOXED(suffix, sizer) \ + static sword_t __attribute__((unused)) \ + scav_##suffix(lispobj *where, lispobj header) { \ + return 1 + scavenge(where+1, sizer(header)); \ + } \ + static lispobj trans_##suffix(lispobj object) { \ + return copy_object(object, 1 + sizer(*native_pointer(object))); \ + } \ + static sword_t size_##suffix(lispobj *where) { return 1 + sizer(*where); } + +DEF_SCAV_BOXED(boxed, BOXED_NWORDS) +DEF_SCAV_BOXED(short_boxed, SHORT_BOXED_NWORDS) +DEF_SCAV_BOXED(tiny_boxed, TINY_BOXED_NWORDS) + +static inline int array_header_nwords(lispobj header) { + unsigned char rank = (header >> 16); + ++rank; // wraparound from 255 to 0 + int nwords = sizeof (struct array)/N_WORD_BYTES + (rank-1); + return ALIGN_UP(nwords, 2); +} +static sword_t scav_array(lispobj *where, lispobj header) { + struct array* a = (void*)where; + scav1(&a->data, a->data); + // displaced_p sounds like it would be T or NIL, but it is overloaded + // to hold information for situations where array A is displaced to an + // expressly adjustable array B which gets adjusted to become too small + // to contain all the elements of A. + scav1(&a->displaced_p, a->displaced_p); + scav1(&a->displaced_from, a->displaced_from); + return array_header_nwords(header); +} +static lispobj trans_array(lispobj object) { + // VECTOR is a lie but I'm using it only to subtract the lowtag + return copy_object(object, array_header_nwords(VECTOR(object)->header)); } +static sword_t size_array(lispobj *where) { return array_header_nwords(*where); } static sword_t scav_instance(lispobj *where, lispobj header) { - int nslots = instance_length(header) | 1; - if (!instance_layout(where)) return 1 + nslots; + int nslots = instance_length(header); // un-padded length + int total_nwords = 1 + (nslots | 1); - lispobj *layout = native_pointer(instance_layout(where)); -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER - if (immobile_obj_gen_bits(layout) == from_space) - enliven_immobile_obj(layout, 1); -#else - if (forwarding_pointer_p(layout)) - layout = native_pointer(forwarding_pointer_value(layout)); -#endif - lispobj lbitmap = ((struct layout*)layout)->bitmap; - if (lbitmap == make_fixnum(-1)) { - scavenge(where+1, nslots); - return 1 + nslots; + // First things first: fix or enliven the layout pointer as necessary, + // writing it back if and only if it changed. + lispobj layoutptr = instance_layout(where), old = layoutptr; + if (!layoutptr) return total_nwords; // instance can't point to any data yet + scav1(&layoutptr, layoutptr); + if (layoutptr != old) instance_layout(where) = layoutptr; + struct layout *layout = (void*)(layoutptr - INSTANCE_POINTER_LOWTAG); + struct bitmap bitmap = get_layout_bitmap(layout); + sword_t mask = bitmap.bits[0]; // there's always at least 1 bitmap word + + if (bitmap.nwords == 1) { + if ((uword_t)mask == (uword_t)-1 << INSTANCE_DATA_START) { + // Easy case: all slots are tagged words + scavenge(where+1+INSTANCE_DATA_START, nslots-INSTANCE_DATA_START); + return total_nwords; + } + if (mask == 0) return total_nwords; // trivial case: no tagged words } + // Specially scavenge the 'next' slot of a lockfree list node. If the node is // pending deletion, 'next' will satisfy fixnump() but is in fact a pointer. // GC doesn't care too much about the deletion algorithm, but does have to // ensure liveness of the pointee, which may move unless pinned. - if (lockfree_list_node_layout_p((struct layout*)layout)) { + if (lockfree_list_node_layout_p(layout)) { struct instance* node = (struct instance*)where; lispobj next = node->slots[INSTANCE_DATA_START]; if (fixnump(next) && next) { // ignore initially 0 heap words @@ -733,74 +722,66 @@ node->slots[INSTANCE_DATA_START] = descriptor & ~LOWTAG_MASK; } } - if (!fixnump(lbitmap)) { - /* It is conceivable that 'lbitmap' points to from_space, AND that it - * is stored in one of the slots of the instance about to be scanned. - * If so, then forwarding it will deposit new bits into its first - * one or two words, rendering it bogus for use as the instance's bitmap. - * So scavenge it up front to fix its address */ - scav1(&lbitmap, lbitmap); - instance_scan((void(*)(lispobj*,sword_t,uword_t))scavenge, - where+1, nslots, lbitmap, 0); - } else { - sword_t bitmap = fixnum_value(lbitmap); // signed integer! - int n = nslots; - lispobj obj; - for ( ; n-- ; bitmap >>= 1) { - ++where; - if ((bitmap & 1) && is_lisp_pointer(obj = *where)) - scav1(where, obj); - } - } - return 1 + nslots; + + ++where; // skip over the header + lispobj obj; + unsigned int end_word_index = bitmap.nwords - 1; + if (end_word_index) { // > 1 word + unsigned int bitmap_word_index = 0; + // 'mask' was preloaded with the bitmap.bits[0] + do { + // I suspect that mutating a structure layout with raw slots + // could cause this assertion to fail, but at least we'll catch + // that the user did something dangerous, exiting with an error + // rather than causing heap corruption. + if (nslots < N_WORD_BITS) lose("Mutated structure layout %p", (void*)layout); + nslots -= N_WORD_BITS; + lispobj* limit = where + N_WORD_BITS; + do { + if ((mask & 1) && is_lisp_pointer(obj = *where)) scav1(where, obj); + mask >>= 1; + } while (++where < limit); + mask = bitmap.bits[++bitmap_word_index]; + } while (bitmap_word_index != end_word_index); + } + // Scan at most N_WORD_BITS more using the final word of the mask. + // But there may be 0 slots remaining, or more than N_WORD_BITS slots remaining. + int count = nslots <= N_WORD_BITS ? nslots : N_WORD_BITS; + lispobj* limit = where + count; + for ( ; where < limit ; mask >>= 1, ++where ) + if ((mask & 1) && is_lisp_pointer(obj = *where)) scav1(where, obj); + nslots -= count; + + // Finally, see if the mask has its top bit on and there are more slots + if (mask < 0 && nslots != 0) scavenge(where, nslots); + return total_nwords; } static sword_t size_instance(lispobj *where) { return 1 + (instance_length(*where) | 1); } -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER static sword_t scav_funinstance(lispobj *where, lispobj header) { - // Do a similar thing as scav_instance but do not split into 3 cases - // based on whether the bitmap is a fixnum or a bignum or the special - // case of all tagged; it's always a fixnum, with at least 1 raw slot. - int nslots = SHORT_BOXED_NWORDS(header); - if (!instance_layout(where)) return 1 + nslots; - - lispobj *layout = native_pointer(instance_layout(where)); - if (immobile_obj_gen_bits(layout) == from_space) - enliven_immobile_obj(layout, 1); - lispobj lbitmap = ((struct layout*)layout)->bitmap; - gc_assert(fixnump(lbitmap)); - sword_t bitmap = fixnum_value(lbitmap); - int n = nslots; + int nslots = HeaderValue(header) & SHORT_HEADER_MAX_WORDS; + // First things first: fix or enliven the layout pointer as necessary, + // writing it back if and only if it changed. + lispobj layoutptr = funinstance_layout(where), old = layoutptr; + if (!layoutptr) return 1 + (nslots | 1); // skip, instance can't point to data + scav1(&layoutptr, layoutptr); + if (layoutptr != old) funinstance_layout(where) = layoutptr; + // Do a similar thing as scav_instance but without any special cases. + struct bitmap bitmap = get_layout_bitmap(LAYOUT(layoutptr)); + gc_assert(bitmap.nwords == 1); + sword_t mask = bitmap.bits[0]; + ++where; + lispobj* limit = where + nslots; lispobj obj; - for ( ; n-- ; bitmap >>= 1) { - ++where; - if ((bitmap & 1) && is_lisp_pointer(obj = *where)) - scav1(where, obj); - } - return 1 + nslots; + for ( ; where < limit ; mask >>= 1, ++where ) + if ((mask & 1) && is_lisp_pointer(obj = *where)) scav1(where, obj); + return 1 + (nslots | 1); } -#endif - -//// Boxed object scav/trans/size functions - -#define DEF_SCAV_BOXED(suffix, sizer) \ - static sword_t __attribute__((unused)) \ - scav_##suffix(lispobj *where, lispobj header) { \ - return 1 + scavenge(where+1, sizer(header)); \ - } \ - static lispobj trans_##suffix(lispobj object) { \ - return copy_object(object, 1 + sizer(*native_pointer(object))); \ - } \ - static sword_t size_##suffix(lispobj *where) { return 1 + sizer(*where); } - -DEF_SCAV_BOXED(boxed, BOXED_NWORDS) -DEF_SCAV_BOXED(short_boxed, SHORT_BOXED_NWORDS) -DEF_SCAV_BOXED(tiny_boxed, TINY_BOXED_NWORDS) /* Bignums use the high bit as the mark, and all remaining bits * excluding the 8 widetag bits to convey the size. @@ -836,7 +817,7 @@ lispobj obj = fdefn_callee_lispobj(fdefn); lispobj new = obj; scavenge(&new, 1); - if (new != obj) fdefn->raw_addr += (new - obj); + if (new != obj) fdefn->raw_addr += (sword_t)(new - obj); // Payload length is not computed from the header return FDEFN_SIZE; } @@ -983,8 +964,7 @@ #define TEST_WEAK_CELL(cell, pointee, broken) \ lispobj *native = native_pointer(pointee); \ if (from_space_p(pointee)) \ - cell = forwarding_pointer_p(native) ? \ - LOW_WORD(forwarding_pointer_value(native)) : broken; \ + cell = forwarding_pointer_p(native) ? forwarding_pointer_value(native) : broken; \ else if (immobile_space_p(pointee)) { \ if (immobile_obj_gen_bits(base_pointer(pointee)) == from_space) cell = broken; \ } @@ -1103,10 +1083,10 @@ void add_to_weak_vector_list(lispobj* vector, lispobj header) { - if (!is_vector_subtype(header, VectorWeakVisited)) { + if (!vector_flagp(header, VectorWeakVisited)) { weak_vectors = (struct cons*)gc_private_cons((uword_t)vector, (uword_t)weak_vectors); - *vector |= subtype_VectorWeakVisited << N_WIDETAG_BITS; + *vector |= flag_VectorWeakVisited << N_WIDETAG_BITS; } } @@ -1212,8 +1192,53 @@ return weak_objects.count != old_count; } -void weakobj_init() +int finalizer_thread_runflag = 1; +#ifdef LISP_FEATURE_SB_THREAD +#ifdef LISP_FEATURE_WIN32 +CRITICAL_SECTION finalizer_mutex; +CONDITION_VARIABLE finalizer_condvar; +void finalizer_thread_wait () { + EnterCriticalSection(&finalizer_mutex); + if (finalizer_thread_runflag) + SleepConditionVariableCS(&finalizer_condvar, &finalizer_mutex, INFINITE); + LeaveCriticalSection(&finalizer_mutex); +} +void finalizer_thread_wake () { + WakeAllConditionVariable(&finalizer_condvar); +} +void finalizer_thread_stop () { + EnterCriticalSection(&finalizer_mutex); + finalizer_thread_runflag = 0; + WakeAllConditionVariable(&finalizer_condvar); + LeaveCriticalSection(&finalizer_mutex); +} +#else +pthread_mutex_t finalizer_mutex = PTHREAD_MUTEX_INITIALIZER; +pthread_cond_t finalizer_condvar = PTHREAD_COND_INITIALIZER; +void finalizer_thread_wait () { + thread_mutex_lock(&finalizer_mutex); + if (finalizer_thread_runflag) + pthread_cond_wait(&finalizer_condvar, &finalizer_mutex); + thread_mutex_unlock(&finalizer_mutex); +} +void finalizer_thread_wake() { + pthread_cond_broadcast(&finalizer_condvar); +} +void finalizer_thread_stop() { + thread_mutex_lock(&finalizer_mutex); + finalizer_thread_runflag = 0; + pthread_cond_broadcast(&finalizer_condvar); + thread_mutex_unlock(&finalizer_mutex); +} +#endif +#endif + +void gc_common_init() { +#ifdef LISP_FEATURE_WIN32 + InitializeCriticalSection(&finalizer_mutex); + InitializeConditionVariable(&finalizer_condvar); +#endif hopscotch_init(); hopscotch_create(&weak_objects, HOPSCOTCH_HASH_FUN_DEFAULT, N_WORD_BYTES, 32 /* logical bin count */, 0 /* default range */); @@ -1270,7 +1295,7 @@ { lispobj* data = kv_vector->data; - if (!is_vector_subtype(kv_vector->header, VectorAddrHashing)) { + if (!vector_flagp(kv_vector->header, VectorAddrHashing)) { // All keys were hashed address-insensitively return (void)scavenge(data + 2, KV_PAIRS_HIGH_WATER_MARK(data) * 2); } @@ -1340,19 +1365,19 @@ { sword_t length = fixnum_value(where[1]); - /* SB-VM:VECTOR-HASHING-SUBTYPE is set for all hash tables in the + /* SB-VM:VECTOR-HASHING-FLAG is set for all hash tables in the * Lisp HASH-TABLE code to indicate need for special GC support. * But note that if the vector is a hashing vector that is neither * weak nor contains any key hashed by its address, then it is basically * a regular vector, except that GC needs only to look at cells below * the high-water-mark, plus the SUPPLEMENT slot at the end */ - if (vector_subtype(header) == 0) { // no special indicator bits set + if (vector_flags_zerop(header)) { // ordinary simple-vector normal: scavenge(where + 2, length); goto done; } - if (vector_subtype(header) == subtype_VectorWeak) { // specifically not weak + hashing + if (vector_is_weak_not_hashing_p(header)) { add_to_weak_vector_list(where, header); goto done; } @@ -1363,7 +1388,7 @@ /* Scavenge element (length-1), which may be a hash-table structure. */ scavenge(&data[length-1], 1); - if (!is_vector_subtype(header, VectorWeak)) { + if (!vector_flagp(header, VectorWeak)) { scan_nonweak_kv_vector((struct vector*)where, gc_scav_pair); goto done; } @@ -1535,7 +1560,7 @@ SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG); boolean rehash = 0; - boolean save_culled_values = (hash_table->flags & MAKE_FIXNUM(4)) != 0; + boolean save_culled_values = (hash_table->flags & make_fixnum(4)) != 0; // I'm slightly confused as to why we can't (or don't) compute the // 'should rehash' flag while scavenging the weak k/v vector. // I believe the explanation is this: for weak-key-AND-value tables, the vector @@ -1649,6 +1674,30 @@ return NULL; } +/// Return the name of the simple-fun containing 'pc', +/// and if 'pfun' is non-null then store the base pointer +/// to the function in *pfun. This is an easier-to-use interface than +/// just returning the function, because accessing the name requires +/// knowing the function's index into the entry-point vector. +lispobj simple_fun_name_from_pc(char *pc, lispobj** pfun) +{ + struct code* code = (void*)component_ptr_from_pc(pc); + if (!code) return 0; // not in lisp heap + char *insts = code_text_start(code); + unsigned int* offsets = code_fun_table(code) - 1; + int i; + // Scanning backwards makes the stopping condition easy: + // the first function lower than 'pc' is the right answer. + for (i=code_n_funs(code)-1; i>=0; --i) { + struct simple_fun* fun = (void*)(insts + offsets[-i]); + if ((char*)fun < pc) { + if (pfun) *pfun = (lispobj*)fun; + return code->constants[i*CODE_SLOTS_PER_SIMPLE_FUN]; + } + } + return 0; // oops, how did this happen? +} + /* Scan an area looking for an object which encloses the given pointer. * Return the object start on success, or NULL on failure. */ lispobj * @@ -1792,6 +1841,33 @@ return 0; } +static boolean can_invoke_post_gc(struct thread* th, + sigset_t *context_sigmask) +{ +#ifdef LISP_FEATURE_SB_THREAD + lispobj obj = th->lisp_thread; + /* Ok, I seriously doubt that this can happen now. Don't we create + * the 'struct thread' with a pointer to its SB-THREAD:THREAD right away? + * I thought so. But if I'm mistaken, give up. */ + if (!obj) return 0; + struct thread_instance* lispthread = (void*)(obj - INSTANCE_POINTER_LOWTAG); + + /* If the SB-THREAD:THREAD has a 0 for its 'struct thread', give up. + * This is the same as the THREAD-ALIVE-P test. Maybe a thread that is + * in the process of un-setting that slot performed this GC. */ + if (!lispthread->primitive_thread) return 0; + + /* I don't know why we aren't in general willing to run post-GC with some or all + * deferrable signals blocked. "Obviously" the idea is to run post-GC code only in + * a thread that is in a nominally pristine state, as opposed to one that is doing + * any manner of monkey business. But was there some specific issue related to + * running post-GC with signals blocked? Nontrivial post-GC code is bad anyway, + * so how could trivial code be adversely affected? i.e. if your post-GC code + * can't run with some signals blocked, then it shouldn't be your post-GC code. */ +#endif + return !deferrables_blocked_p(context_sigmask); +} + boolean maybe_gc(os_context_t *context) { @@ -1827,7 +1903,7 @@ */ #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT)) check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context)); - unblock_gc_signals(0, 0); + unblock_gc_signals(); #endif FSHOW((stderr, "/maybe_gc: calling SUB_GC\n")); /* FIXME: Nothing must go wrong during GC else we end up running @@ -1864,7 +1940,11 @@ (read_TLS(ALLOW_WITH_INTERRUPTS,thread) != NIL))) { #ifndef LISP_FEATURE_WIN32 sigset_t *context_sigmask = os_context_sigmask_addr(context); - if (!deferrables_blocked_p(context_sigmask)) { + if (can_invoke_post_gc(thread, context_sigmask)) { + /* The gist of this is that we make it appear that return-from-signal + * happened, and the calling code decided to take a detour through the + * post-GC code. Except that we do it while the interrupt context + * is still on the stack */ thread_sigmask(SIG_SETMASK, context_sigmask, 0); #ifndef LISP_FEATURE_SB_SAFEPOINT check_gc_signals_unblocked_or_lose(0); @@ -1951,7 +2031,7 @@ ((os_vm_address_t)sp >= hard_guard_page_address)) || (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) && ((os_vm_address_t)sp >= guard_page_address) && - (th->control_stack_guard_page_protected != NIL))) + th->state_word.control_stack_guard_page_protected)) return; #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD do { @@ -2019,7 +2099,7 @@ lispobj *ptr = native_pointer(object); if (forwarding_pointer_p(ptr)) { /* Yes, there's a forwarding pointer. */ - *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); + *object_ptr = forwarding_pointer_value(ptr); } else { /* Scavenge that pointer. */ long n_words_scavenged = @@ -2357,3 +2437,15 @@ sift_down(array, 0, end); } } + +/// External function for calling from Lisp. +page_index_t ext_lispobj_size(lispobj *addr) { + return OBJECT_SIZE(*addr,addr) * N_WORD_BYTES; +} +/// External function for calling from Lisp. +/// This would be better build into a '.so' from a test +/// because it really serves no other purpose. +int test_bitmap_logbitp(int i, struct layout* l) { + struct bitmap bitmap = get_layout_bitmap(l); + return bitmap_logbitp(i, bitmap); +} diff -Nru sbcl-2.0.6/src/runtime/gc-internal.h sbcl-2.1.1/src/runtime/gc-internal.h --- sbcl-2.0.6/src/runtime/gc-internal.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/gc-internal.h 2021-01-30 11:22:38.000000000 +0000 @@ -59,18 +59,46 @@ #define FUN_SELF_FIXNUM_TAGGED 0 #endif -// Return only the lisp-visible vector header flag bits bits, -// masking out subtype_VectorWeakVisited. -#define vector_subtype(header) (HeaderValue(header) & 7) -// Test for presence of a bit in vector's header. -#define is_vector_subtype(header, val) (HeaderValue(header) & subtype_##val) +/* + * Predicates rather than bit extractors should be used to test the flags + * in a vector header, because: + * + * - while trying to place the flags into a different header byte, I found it + * unobvious whether to treat flags as part of the "Header data" (which is a + * 3-byte or 7-byte wide field starting at bit 8) versus the entire "Header word". + * So e.g. if the Lisp VECTOR-WEAK value were redefined to #x0100, which would + * place a 1 bit into byte index 3 (using SET-HEADER-DATA), it isn't clear that + * "vector_flags(vector) == vectorWeak" is the proper test, because vector_flags() + * could reasonably be defined to right-shift by 0, 8, or 16 bits. + * (i.e. leave the bits where they are, but mask out the widetag; or make them + * act like "Header data"; or right-align as if we had Lisp bitfield extractors) + * Looked at differently, the natural values for the first 3 flag bits should be + * 1, 2, and 4 but this would force you to write expressions such as: + * (SET-HEADER-DATA V (ASH SB-VM:VECTOR-HASHING-FLAG SB-VM:VECTOR-FLAG-BITS-SHIFT)) + * which looks to be terribly inconvenient for Lisp. + * Alternatively, the constants can be defined as their "natural" values for C + * which would have flag_VectorWeak = 0x010000, but then you need the inverse + * shift in Lisp which expects SET-HEADER-DATA to get #x0100 as the argument. + * Hypothetically, that is. + * + * - With smarter macros it ought to be possible to avoid 8-byte loads and shifts. + * They would need to be endian-aware, which I didn't want to do just yet. + */ +#define vector_flagp(header, val) ((int)header & (flag_##val << N_WIDETAG_BITS)) +#define vector_flags_zerop(header) ((int)(header) & 0x0700) == 0 +// True if flags are zero, also testing the widetag at the same time. +#define ordinary_simple_vector_p(header) ((int)(header) & 0x07ff) == SIMPLE_VECTOR_WIDETAG +// Return true if vector is a weak vector that is not a hash-table vector. +#define vector_is_weak_not_hashing_p(header) \ + ((int)(header) & ((flag_VectorWeak|flag_VectorHashing) << N_WIDETAG_BITS)) == \ + (flag_VectorWeak << N_WIDETAG_BITS) // Mask out the fullcgc mark bit when asserting header validity #define UNSET_WEAK_VECTOR_VISITED(v) \ gc_assert((v->header & 0xffff) == \ - (((subtype_VectorWeakVisited|subtype_VectorWeak) << N_WIDETAG_BITS) \ + (((flag_VectorWeakVisited|flag_VectorWeak) << N_WIDETAG_BITS) \ | SIMPLE_VECTOR_WIDETAG)); \ - v->header ^= subtype_VectorWeakVisited << N_WIDETAG_BITS + v->header ^= flag_VectorWeakVisited << N_WIDETAG_BITS /* values for the *_alloc_* parameters, also see the commentary for * struct page in gencgc-internal.h. These constants are used in gc-common, @@ -131,35 +159,6 @@ extern int simple_fun_index(struct code*, struct simple_fun*); -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER -static inline lispobj funinstance_layout(lispobj* funinstance_ptr) { // native ptr - return instance_layout(funinstance_ptr); -} -static inline lispobj function_layout(lispobj* fun_ptr) { // native ptr - return instance_layout(fun_ptr); -} -static inline void set_function_layout(lispobj* fun_ptr, lispobj layout) { - instance_layout(fun_ptr) = layout; -} -#else -static inline lispobj funinstance_layout(lispobj* instance_ptr) { // native ptr - // first 4 words are: header, trampoline, fin-fun, layout - return instance_ptr[3]; -} -// No layout in simple-fun or closure, because there are no free bits -static inline lispobj -function_layout(lispobj __attribute__((unused)) *fun_ptr) { // native ptr - return 0; -} -static inline void set_function_layout(lispobj __attribute__((unused)) *fun_ptr, - lispobj __attribute__((unused)) layout) { - lose("Can't assign layout"); -} -#endif - -#include "genesis/bignum.h" -extern boolean positive_bignum_logbitp(int,struct bignum*); - extern lispobj fdefn_callee_lispobj(struct fdefn *fdefn); boolean valid_widetag_p(unsigned char widetag); diff -Nru sbcl-2.0.6/src/runtime/gc-private.h sbcl-2.1.1/src/runtime/gc-private.h --- sbcl-2.0.6/src/runtime/gc-private.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/gc-private.h 2021-01-30 11:22:38.000000000 +0000 @@ -97,7 +97,7 @@ void (*)(lispobj*)); extern int (*weak_ht_alivep_funs[4])(lispobj,lispobj); extern void gc_scav_pair(lispobj where[2]); -extern void weakobj_init(); +extern void gc_common_init(); extern boolean test_weak_triggers(int (*)(lispobj), void (*)(lispobj)); lispobj copy_unboxed_object(lispobj object, sword_t nwords); @@ -234,18 +234,48 @@ * In cheneygc, chaining is performed in 'trans_weak_pointer' * which works just as well, since an object is transported * at most once per GC cycle */ - wp->next = (struct weak_pointer *)LOW_WORD(weak_pointer_chain); + wp->next = weak_pointer_chain; weak_pointer_chain = wp; } -/// Same as Lisp LOGBITP, except no negative bignums allowed. -static inline boolean layout_bitmap_logbitp(int index, lispobj bitmap) +#include "genesis/layout.h" +struct bitmap { sword_t *bits; unsigned int nwords; }; +static inline struct bitmap get_layout_bitmap(struct layout* layout) { - if (fixnump(bitmap)) - return (index < (N_WORD_BITS - N_FIXNUM_TAG_BITS)) - ? (bitmap >> (index+N_FIXNUM_TAG_BITS)) & 1 - : (sword_t)bitmap < 0; - return positive_bignum_logbitp(index, (struct bignum*)native_pointer(bitmap)); + struct bitmap bitmap; + const int layout_id_vector_fixed_capacity = 7; +#ifdef LISP_FEATURE_64_BIT + sword_t depthoid = layout->flags; + // Depthoid is stored in the upper 4 bytes of the header, as a fixnum. + depthoid >>= (32 + N_FIXNUM_TAG_BITS); + int extra_id_words = + (depthoid > layout_id_vector_fixed_capacity) ? + ALIGN_UP(depthoid - layout_id_vector_fixed_capacity, 2) / 2 : 0; +#else + sword_t depthoid = layout->depthoid; + depthoid >>= N_FIXNUM_TAG_BITS; + int extra_id_words = (depthoid > layout_id_vector_fixed_capacity) ? + depthoid - layout_id_vector_fixed_capacity : 0; +#endif + // The 2 bits for stable address-based hashing can't ever bet set. + const int baseline_payload_words = (sizeof (struct layout) / N_WORD_BYTES) - 1; + int payload_words = ((unsigned int)layout->header >> INSTANCE_LENGTH_SHIFT) & 0x3FFF; + bitmap.bits = (sword_t*)((char*)layout + sizeof (struct layout)) + extra_id_words; + bitmap.nwords = payload_words - baseline_payload_words - extra_id_words; + return bitmap; +} + +/* Return true if the INDEXth bit is set in BITMAP. + * Index 0 corresponds to the word just after the instance header. + * So index 0 may be the layout pointer if #-compact-instance-header, + * or a user data slot if #+compact-instance-header + */ +static inline boolean bitmap_logbitp(unsigned int index, struct bitmap bitmap) +{ + unsigned int word_index = index / N_WORD_BITS; + unsigned int bit_index = index % N_WORD_BITS; + if (word_index >= bitmap.nwords) return bitmap.bits[bitmap.nwords-1] < 0; + return (bitmap.bits[word_index] >> bit_index) & 1; } /* Keep in sync with 'target-hash-table.lisp' */ @@ -334,27 +364,70 @@ #define KV_PAIRS_HIGH_WATER_MARK(kvv) fixnum_value(kvv[0]) #define KV_PAIRS_REHASH(kvv) kvv[1] -#include "genesis/layout.h" -// Generalize over INSTANCEish things. (Not general like SB-KERNEL:LAYOUT-OF) -static inline lispobj layout_of(lispobj* instance) { // native ptr - // Smart C compilers eliminate the ternary operator if exprs are the same - return widetag_of(instance) == FUNCALLABLE_INSTANCE_WIDETAG - ? funinstance_layout(instance) : instance_layout(instance); -} +/* This is NOT the same value that lisp's %INSTANCE-LENGTH returns. + * Lisp always uses the logical length (as originally allocated), + * except when heap-walking which requires exact physical sizes */ +static inline int instance_length(lispobj header) +{ + // * Byte 3 of an instance header word holds the immobile gen# and visited bit, + // so those have to be masked off. + // * fullcgc uses bit index 31 as a mark bit, so that has to + // be cleared. Lisp does not have to clear bit 31 because fullcgc does not + // operate concurrently. + // * If the object is in hashed-and-moved state and the original instance payload + // length was odd (total object length was even), then add 1. + // This can be detected by ANDing some bits, bit 10 being the least-significant + // bit of the original size, and bit 9 being the 'hashed+moved' bit. + // * 64-bit machines do not need 'long' right-shifts, so truncate to int. + + int extra = ((unsigned int)header >> 10) & ((unsigned int)header >> 9) & 1; + return (((unsigned int)header >> INSTANCE_LENGTH_SHIFT) & 0x3FFF) + extra; +} + +/// instance_layout() and layout_of() macros takes a lispobj* and are lvalues +#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER + +# ifdef LISP_FEATURE_LITTLE_ENDIAN +# define instance_layout(native_ptr) ((uint32_t*)(native_ptr))[1] +# else +# error "No instance_layout() defined" +# endif +# define funinstance_layout(native_ptr) instance_layout(native_ptr) +// generalize over either metatype, but not as general as SB-KERNEL:LAYOUT-OF +# define layout_of(native_ptr) instance_layout(native_ptr) + +#else + +// first 2 words of ordinary instance are: header, layout +# define instance_layout(native_ptr) ((lispobj*)native_ptr)[1] +// first 4 words of funcallable instance are: header, trampoline, layout, fin-fun +# define funinstance_layout(native_ptr) ((lispobj*)native_ptr)[2] +# define layout_of(native_ptr) \ + ((lispobj*)native_ptr)[1+((widetag_of(native_ptr)>>LAYOUT_SELECTOR_BIT)&1)] + +#endif + +static inline int layout_depth2_id(struct layout* layout) { + int32_t* vector = (int32_t*)&layout->id_word0; + return vector[0]; +} +// Keep in sync with hardwired IDs in src/compiler/generic/genesis.lisp +#define LAYOUT_LAYOUT_ID 3 +#define LFLIST_NODE_LAYOUT_ID 4 -extern lispobj layout_of_layout; /// Return true if 'thing' is a layout. +/// This predicate is careful, as is it used to verify heap invariants. static inline boolean layoutp(lispobj thing) { lispobj base_ptr = thing - INSTANCE_POINTER_LOWTAG; lispobj layout; if ((base_ptr & LOWTAG_MASK) || !(layout = layout_of((lispobj*)base_ptr))) return 0; - return layout == layout_of_layout; + return layout_depth2_id(LAYOUT(layout)) == LAYOUT_LAYOUT_ID; } - -static inline int lockfree_list_node_layout_p(struct layout* layout) { - return layout->flags & flag_LockfreeListNode; +/// Return true if 'thing' is the layout of any subtype of sb-lockless::list-node. +static inline boolean lockfree_list_node_layout_p(struct layout* layout) { + return layout_depth2_id(layout) == LFLIST_NODE_LAYOUT_ID; } #endif /* _GC_PRIVATE_H_ */ diff -Nru sbcl-2.0.6/src/runtime/gencgc.c sbcl-2.1.1/src/runtime/gencgc.c --- sbcl-2.0.6/src/runtime/gencgc.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/gencgc.c 2021-01-30 11:22:38.000000000 +0000 @@ -29,7 +29,7 @@ #include #include "sbcl.h" #if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD) -#include "pthreads_win32.h" +// #else #include #endif @@ -231,6 +231,21 @@ page_ends_contiguous_block_p(page_index_t page_index, generation_index_t __attribute__((unused)) gen) { + /* Re. this next test: git rev c769dd53 said that there was a bug when we don't + * test page_bytes_used, but I fail to see how 'page_starts_contiguous_block_p' + * on the next page is not a STRONGER condition, i.e. it should imply that + * 'page_index' ends a block without regard for the number of bytes used. + * Apparently at some point I understood this and now I don't again. + * That's what comments are for, damnit. + * Anyway, I *think* the issue was, at some point, as follows: + * | page | page | + * pinned-obj + * <------------------- scan-start + * where the first of the two pages had a small object pinned. This used to + * adjust the bytes used to account _only_ for the pins. That was wrong - + * the page has to be counted as if it is completely full. + * So _maybe_ both these conditions do not need to be present now ? + */ // There is *always* a next page in the page table. boolean answer = page_bytes_used(page_index) < GENCGC_CARD_BYTES || page_starts_contiguous_block_p(page_index+1); @@ -350,8 +365,12 @@ * >1 thread at a time and must be thread-safe. This lock must be * seized before all accesses to generations[] or to parts of * page_table[] that other threads may want to see */ +#ifdef LISP_FEATURE_WIN32 +static CRITICAL_SECTION free_pages_lock; +#else static pthread_mutex_t free_pages_lock = PTHREAD_MUTEX_INITIALIZER; #endif +#endif extern os_vm_size_t gencgc_release_granularity; os_vm_size_t gencgc_release_granularity = GENCGC_RELEASE_GRANULARITY; @@ -573,7 +592,7 @@ } -#if defined(LISP_FEATURE_X86) +#if defined LISP_FEATURE_X86 && !defined LISP_FEATURE_LINUX void fast_bzero(void*, size_t); /* in -assem.S */ #else #define fast_bzero(addr, count) memset(addr, 0, count) @@ -601,6 +620,9 @@ lose("madvise failed"); } else #endif +#ifdef LISP_FEATURE_WIN32 + os_revalidate_bzero(addr, length); +#else { void *new_addr; os_invalidate(addr, length); @@ -610,6 +632,7 @@ addr, new_addr); } } +#endif } /* @@ -844,12 +867,12 @@ #include "private-cons.inc" static inline boolean region_closed_p(struct alloc_region* region) { - return !region->end_addr; + return !region->start_addr; } #define ASSERT_REGIONS_CLOSED() \ - gc_assert(!((uintptr_t)boxed_region.end_addr \ - |(uintptr_t)unboxed_region.end_addr \ - |(uintptr_t)code_region.end_addr)) + gc_assert(!((uintptr_t)boxed_region.start_addr \ + |(uintptr_t)unboxed_region.start_addr \ + |(uintptr_t)code_region.start_addr)) /* Find a new region with room for at least the given number of bytes. * @@ -1676,6 +1699,31 @@ && lowtag_of(addr) == LOWTAG_FOR_WIDETAG(widetag); } +#define is_code(type) ((type & PAGE_TYPE_MASK) == CODE_PAGE_TYPE) + +/* Return true if and only if everything on the specified page is NOT subject + * to evacuation, i.e. either the page is not in 'from_space', or is entirely + * pinned. "Entirely pinned" is predicated on being marked as pinned, + * and satisfying one of two additional criteria: + * 1. the page is a single-object page + * 2. the page contains only code, and all code objects are pinned. + * + * A non-large-object page that is marked "pinned" does not suffice + * to be considered entirely pinned if it contains other than code. + * + * (I would have named this "wholly_pinned_p" were it not for the additional + * check about from_space, because that's kind of a misnomer in as much as + * pinning pertains only to fromspace.) + */ +int pin_all_dynamic_space_code; +static inline int not_condemned_p(page_index_t page) +{ + return (page_table[page].gen != from_space) + || (page_table[page].pinned && + (page_single_obj_p(page) || + (is_code(page_table[page].type) && pin_all_dynamic_space_code))); +} + #if !GENCGC_IS_PRECISE // Return the starting address of the object containing 'addr' // if and only if the object is one which would be evacuated from 'from_space' @@ -1688,12 +1736,11 @@ { /* quick check 1: Address is quite likely to have been invalid. */ struct page* page = &page_table[addr_page_index]; - boolean enforce_lowtag = (page->type & PAGE_TYPE_MASK) != CODE_PAGE_TYPE; + boolean enforce_lowtag = !is_code(page->type); if ((addr & (GENCGC_CARD_BYTES - 1)) >= page_bytes_used(addr_page_index) || (!is_lisp_pointer(addr) && enforce_lowtag) || - (compacting_p() && (page->gen != from_space || - (page->pinned && (page->type & SINGLE_OBJECT_FLAG))))) + (compacting_p() && not_condemned_p(addr_page_index))) return 0; gc_assert(!(page->type & OPEN_REGION_PAGE_FLAG)); @@ -1766,8 +1813,7 @@ // quick check 1: within from_space and within page usage if ((addr & (GENCGC_CARD_BYTES - 1)) >= page_bytes_used(addr_page_index) || - (compacting_p() && (page->gen != from_space || - (page->pinned && (page->type & SINGLE_OBJECT_FLAG))))) + (compacting_p() && not_condemned_p(addr_page_index))) return 0; gc_assert(!(page->type & OPEN_REGION_PAGE_FLAG)); @@ -2048,7 +2094,14 @@ /* Add 'object' to the hashtable, and if the object is a code component, * then also add all of the embedded simple-funs. - * The rationale for the extra work on code components is that without it, + * It is OK to call this function on an object which is already pinned- + * it will do nothing. + * But it is not OK to call this if the object is not one which merits + * pinning in the first place. i.e. It MUST be an object in from_space + * and moreover must be in the condemned set, which means that it can't + * be a code object if pin_all_dynamic_space_code is 1. + * + * The rationale for doing some extra work on code components is that without it, * every test of pinned_p() on an object would have to check if the pointer * is to a simple-fun - entailing an extra read of the header - and mapping * to its code component if so. Since more calls to pinned_p occur than to @@ -2158,21 +2211,29 @@ #endif /* Pin an unambiguous descriptor object which may or may not be a pointer. - * Ignore objects with immediate lowtags */ + * Ignore immediate objects, and heuristically skip some objects that are + * known to be pinned without looking in pinned_objects. + * pin_object() will always do the right thing and ignore multiple + * calls with the same object in the same collection pass. + */ static void __attribute__((unused)) pin_exact_root(lispobj obj) { + // These tests are performed in approximate order of quickness to check. + + // 1. pointerness if (!is_lisp_pointer(obj)) return; + // 2. If not moving, then pinning is irrelevant. 'obj' is a-priori live given + // the reference from *PINNED-OBJECTS*, and obviously it won't move. + if (!compacting_p()) return; + // 3. If pointing off-heap, why are you pinning? Just ignore it. + // Would this need to do anything if immobile-space were ported + // to the precise GC platforms. FIXME? page_index_t page = find_page_index((void*)obj); if (page < 0) return; + // 4. Ignore if not in the condemned set. + if (not_condemned_p(page)) return; - /* If we're in precise gencgc (non-x86oid as of this writing) then - * we are only called on valid object pointers in the first place, - * so we just have to do a bounds-check against the heap, a - * generation check, and the already-pinned check. */ - if (compacting_p() && (page_table[page].gen != from_space || - (page_single_obj_p(page) && - page_table[page].pinned))) - return; + // Never try to pin an interior pointer - always use base pointers. lispobj *object_start = native_pointer(obj); switch (widetag_of(object_start)) { case SIMPLE_FUN_WIDETAG: @@ -2341,7 +2402,7 @@ // high-water mark which is in general a good thing. Perhaps if the // ratio of HWM to total size warrants it, we should prefer to use the // large_simple_vector optimization instead. - return header_widetag(header) == SIMPLE_VECTOR_WIDETAG && vector_subtype(header) == 0; + return ordinary_simple_vector_p(header); } /* Attempt to re-protect code from first_page to last_page inclusive. @@ -2356,7 +2417,7 @@ if (!ENABLE_PAGE_PROTECTION) return; page_index_t i; for (i=first_page+1; i <= last_page; ++i) // last_page is inclusive - gc_assert((page_table[i].type & PAGE_TYPE_MASK) == CODE_PAGE_TYPE); + gc_assert(is_code(page_table[i].type)); lispobj* where = start; for (; where < limit; where += sizetab[widetag_of(where)](where)) { @@ -2451,8 +2512,7 @@ heap_scavenge(start, limit); /* Now scan the pages and write protect those that * don't have pointers to younger generations. */ - if (CODE_PAGES_USE_SOFT_PROTECTION && - (page_table[i].type & PAGE_TYPE_MASK) == CODE_PAGE_TYPE) { + if (CODE_PAGES_USE_SOFT_PROTECTION && is_code(page_table[i].type)) { update_code_writeprotection(i, last_page, start, limit); } else { page_index_t j; @@ -2949,9 +3009,6 @@ } else switch(widetag) { /* boxed or partially boxed objects */ lispobj layout_word; - // Two reasons for including funcallable instance here: - // (1) the layout may be in the header, and we need to verify it - // (2) there may be unboxed words in the object case FUNCALLABLE_INSTANCE_WIDETAG: case INSTANCE_WIDETAG: layout_word = layout_of(where); @@ -2961,10 +3018,14 @@ state->vaddr = 0; gc_assert(layoutp(layout_word)); struct layout *layout = LAYOUT(layout_word); - sword_t nslots = instance_length(thing) | 1; - lispobj bitmap = layout->bitmap; - gc_assert(fixnump(bitmap) - || widetag_of(native_pointer(bitmap))==BIGNUM_WIDETAG); + struct bitmap bitmap = get_layout_bitmap(layout); + if (widetag_of(where) == FUNCALLABLE_INSTANCE_WIDETAG) { +#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER + gc_assert(bitmap.bits[0] == (sword_t)-1 || bitmap.bits[0] == (sword_t)6); +#else + gc_assert(bitmap.bits[0] == (sword_t)-4); +#endif + } if (lockfree_list_node_layout_p(layout)) { struct instance* node = (struct instance*)where; lispobj next = node->slots[INSTANCE_DATA_START]; @@ -2975,9 +3036,12 @@ state->vaddr = 0; } } - instance_scan((void (*)(lispobj*, sword_t, uword_t))verify_range, - where+1, nslots, bitmap, (uintptr_t)state); - count = 1 + nslots; + int i; + int nwords = sizetab[widetag](where); + lispobj* slots = where+1; + for (i=0; i<(nwords-1); ++i) + if (bitmap_logbitp(i, bitmap)) verify_range(slots+i, 1, state); + count = nwords; } break; case CODE_HEADER_WIDETAG: @@ -3001,7 +3065,7 @@ for_each_simple_fun(i, fheaderp, code, 1, { #if defined(LISP_FEATURE_COMPACT_INSTANCE_HEADER) lispobj __attribute__((unused)) layout = - function_layout((lispobj*)fheaderp); + funinstance_layout((lispobj*)fheaderp); gc_assert(!layout || layout == LAYOUT_OF_FUNCTION); #endif }); @@ -3096,7 +3160,7 @@ (lispobj*)get_binding_stack_pointer(th), flags ^ VERIFYING_HEAP_OBJECTS); #ifdef LISP_FEATURE_SB_THREAD - verify_space((lispobj)(th+1), + verify_space((lispobj)&th->lisp_thread, (lispobj*)(SymbolValue(FREE_TLS_INDEX,0) + (char*)th), flags ^ VERIFYING_HEAP_OBJECTS); #endif @@ -3213,7 +3277,6 @@ os_context_t __attribute__((unused)) *c) { #ifdef LISP_FEATURE_SB_THREAD - void **ptr; /* On Darwin the signal context isn't a contiguous block of memory, * so just preserve_pointering its contents won't be sufficient. */ @@ -3247,6 +3310,7 @@ #endif #endif #if !defined(LISP_FEATURE_WIN32) + void **ptr; for(ptr = ((void **)(c+1))-1; ptr>=(void **)c; ptr--) { proc((os_context_register_t)*ptr); } @@ -3266,8 +3330,9 @@ for (i = 0; i < next_free_page; i++) { /* 'pinned' is cleared lazily, so test the 'gen' field as well. */ - if (page_table[i].gen == from_space - && page_table[i].pinned && page_single_obj_p(i)) { + if (page_table[i].gen == from_space && page_table[i].pinned && + (page_single_obj_p(i) || (is_code(page_table[i].type) + && pin_all_dynamic_space_code))) { page_table[i].gen = new_space; /* And since we're moving the pages wholesale, also adjust * the generation allocation counters. */ @@ -3278,19 +3343,6 @@ } } -lispobj layout_of_layout; -void compute_layout_of_layout() -{ - // Compute layout_of_layout from some structure instance by taking the layout - // of its layout. T's package serves as an exemplar structure. - // If you use NIL, then you can't use the convenient casting macro SYMBOL - // which subtracts the wrong lowtag for ppc64 since NIL is primarily a list - // and only coincidentally a symbol if the lowtags work out right. - lispobj* package = (lispobj*)(SYMBOL(T)->package - INSTANCE_POINTER_LOWTAG); - lispobj layout = instance_layout(package); - layout_of_layout = instance_layout(LAYOUT(layout)); -} - /* Garbage collect a generation. If raise is 0 then the remains of the * generation are not raised to the next generation. */ static void NO_SANITIZE_ADDRESS NO_SANITIZE_MEMORY @@ -3319,6 +3371,19 @@ // for traceroot, which reads n_stack_pins from the previous GC cycle gc_n_stack_pins = 0;; +#ifdef LISP_FEATURE_SB_THREAD + pin_all_dynamic_space_code = 0; + for_each_thread(th) { + if (th->state_word.state != STATE_DEAD && \ + (read_TLS(GC_PIN_CODE_PAGES, th) & make_fixnum(1))) { + pin_all_dynamic_space_code = 1; + break; + } + } +#else + pin_all_dynamic_space_code = read_TLS(GC_PIN_CODE_PAGES, 0) & make_fixnum(1); +#endif + /* Set the global src and dest. generations */ if (generation < PSEUDO_STATIC_GENERATION) { @@ -3339,9 +3404,19 @@ * This will also obviate the extra test at the comment * "pinned is cleared lazily" in move_pinned_pages_to_newspace(). */ - for (i = 0; i < next_free_page; i++) - if(page_table[i].gen==from_space) - page_table[i].pinned = 0; + if (pin_all_dynamic_space_code) { + /* This needs to happen before ambiguous root pinning, as the mechanisms + * overlap in a way that all-code pinning wouldn't do the right thing if flipped. + * Code objects should never get into the pins table in this case */ + for (i = 0; i < next_free_page; i++) { + if (page_table[i].gen == from_space) + page_table[i].pinned = page_bytes_used(i) != 0 + && is_code(page_table[i].type); + } + } else { + for (i = 0; i < next_free_page; i++) + if (page_table[i].gen == from_space) page_table[i].pinned = 0; + } /* Un-write-protect the old-space pages. This is essential for the * promoted pages as they may contain pointers into the old-space @@ -3353,6 +3428,8 @@ } else { // "full" [sic] GC + gc_assert(!pin_all_dynamic_space_code); // not supported (but could be) + /* This is a full mark-and-sweep of all generations without compacting * and without returning free space to the allocator. The intent is to * break chains of objects causing accidental reachability. @@ -3391,7 +3468,7 @@ if (conservative_stack) { for_each_thread(th) { void* esp = (void*)-1; - if (th->state == STATE_DEAD) + if (th->state_word.state == STATE_DEAD) continue; # if defined(LISP_FEATURE_SB_SAFEPOINT) /* Conservative collect_garbage is always invoked with a @@ -3401,7 +3478,7 @@ * at. For threads that were running Lisp code, the pitstop * and edge functions maintain this value within the * interrupt or exception handler. */ - esp = (void*)os_get_csp(th); + esp = os_get_csp(th); assert_on_stack(th, esp); /* And on platforms with interrupts: scavenge ctx registers. */ @@ -3514,6 +3591,54 @@ } #endif + // Thread creation optionally no longer synchronizes the creating and + // created thread. When synchronized, the parent thread is responsible + // for pinning the start function for handoff to the created thread. + // When not synchronized, The startup parameters are pinned via this list + // which will always be NIL if the feature is not enabled. +#ifdef STARTING_THREADS + lispobj pin_list = SYMBOL(STARTING_THREADS)->value; + for ( ; pin_list != NIL ; pin_list = CONS(pin_list)->cdr ) { + lispobj thing = CONS(pin_list)->car; + // It might be tempting to say that only the SB-THREAD:THREAD instance + // requires pinning - because right after we access it to extract the + // primitive thread, we link into all_threads - but it may be that the code + // emitted by the C compiler in new_thread_trampoline computes untagged pointers + // when accessing the vector and the start function, so those would not be + // seen as valid lisp pointers by the implicit pinning logic. + // And the precisely GC'd platforms would not pin anything from C code. + // The tests in 'threads.impure.lisp' are good at detecting omissions here. + if (thing) { // Nothing to worry about when 'thing' is already smashed + gc_assert(instancep(thing)); + struct thread_instance *lispthread = (void*)(thing - INSTANCE_POINTER_LOWTAG); + lispobj info = lispthread->startup_info; + // INFO gets set to a fixnum when the thread is exiting. I *think* it won't + // ever be seen in the starting-threads list, but let's be cautious. + if (is_lisp_pointer(info)) { + gc_assert(simple_vector_p(info)); + gc_assert(VECTOR(info)->length >= make_fixnum(1)); + lispobj fun = VECTOR(info)->data[0]; + gc_assert(functionp(fun)); +#ifdef LISP_FEATURE_X86_64 + // slight KLUDGE: 'fun' is a simple-fun in immobile-space, + // and pin_exact_root() doesn't work. In all probability 'fun' + // is pseudo-static, but let's use the right pinning function. + // (This line of code is so rarely executed that it doesn't + // impact performance to search for the object) + preserve_pointer((void*)fun); +#else + pin_exact_root(fun); +#endif + // pin_exact_root is more efficient than preserve_pointer() + // because it does not search for the object. + pin_exact_root(thing); + pin_exact_root(info); + pin_exact_root(lispthread->name); + } + } + } +#endif + if (gencgc_verbose > 1) show_pinnedobj_count(); @@ -3553,21 +3678,12 @@ } #endif - /* Scavenge the Lisp functions of the interrupt handlers, taking - * care to avoid SIG_DFL and SIG_IGN. */ - for (i = 0; i < NSIG; i++) { - union interrupt_handler handler = interrupt_handlers[i]; - if (!ARE_SAME_HANDLER(handler.c, SIG_IGN) && - !ARE_SAME_HANDLER(handler.c, SIG_DFL) && - // BUG: if a C function pointer can be misaligned such that it - // looks to satisfy functionp() then we do the wrong thing. - is_lisp_pointer(handler.lisp)) { - if (compacting_p()) - scavenge((lispobj *)(interrupt_handlers + i), 1); - else - gc_mark_obj(handler.lisp); - } - } + /* Scavenge the Lisp functions of the interrupt handlers */ + if (compacting_p()) + scavenge(lisp_sig_handlers, NSIG); + else + gc_mark_range(lisp_sig_handlers, NSIG); + /* Scavenge the binding stacks. */ { struct thread *th; @@ -3577,13 +3693,13 @@ compacting_p() ? 0 : gc_mark_obj); #ifdef LISP_FEATURE_SB_THREAD /* do the tls as well */ - sword_t len; - len=(SymbolValue(FREE_TLS_INDEX,0) >> WORD_SHIFT) - - (sizeof (struct thread))/(sizeof (lispobj)); + lispobj* from = &th->lisp_thread; + lispobj* to = (lispobj*)(SymbolValue(FREE_TLS_INDEX,0) + (char*)th); + sword_t nwords = to - from; if (compacting_p()) - scavenge((lispobj *) (th+1), len); + scavenge(from, nwords); else - gc_mark_range((lispobj *) (th+1), len); + gc_mark_range(from, nwords); #endif } } @@ -3664,9 +3780,6 @@ g->num_gc = raise ? 0 : (1 + g->num_gc); maybe_verify: -#ifndef LISP_FEATURE_IMMOBILE_SPACE - compute_layout_of_layout(); // if it moved -#endif if (generation >= verify_gens) verify_heap(VERIFY_POST_GC | (generation<<16)); } @@ -3759,6 +3872,7 @@ // one pair of counters per widetag, though we're only tracking code as yet int n_scav_calls[64], n_scav_skipped[64]; +extern int finalizer_thread_runflag; /* GC all generations newer than last_gen, raising the objects in each * to the next older generation - we finish when all generations below @@ -3815,9 +3929,6 @@ struct thread *th; for_each_thread(th) { ensure_region_closed(&th->alloc_region, BOXED_PAGE_FLAG); -#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32) - ensure_region_closed(&th->sprof_alloc_region, BOXED_PAGE_FLAG); -#endif } gc_close_all_regions(); @@ -3985,6 +4096,14 @@ log_generation_stats(gc_logfile, "=== GC End ==="); SHOW("returning from collect_garbage"); + // Increment the finalizer runflag. This acts as a count of the number + // of GCs as well as a notification to wake the finalizer thread. + if (finalizer_thread_runflag != 0) { + int newval = 1 + finalizer_thread_runflag; + // check if counter wrapped around. Don't store 0 as the new value, + // as that causes the thread to exit. + finalizer_thread_runflag = newval ? newval : 1; + } } /* Initialization of gencgc metadata is split into two steps: @@ -3995,8 +4114,12 @@ void gc_init(void) { +#ifdef LISP_FEATURE_WIN32 + InitializeCriticalSection(&free_pages_lock); +#endif #if defined(LISP_FEATURE_SB_SAFEPOINT) - alloc_gc_page(); + extern void safepoint_init(void); + safepoint_init(); #endif // Verify that foo_BIT constants agree with the C compiler's bit packing // and that we can compute the correct adddress of the bitfields. @@ -4042,7 +4165,7 @@ page_table = calloc(1+page_table_pages, sizeof(struct page)); gc_assert(page_table); - weakobj_init(); + gc_common_init(); hopscotch_create(&pinned_objects, HOPSCOTCH_HASH_FUN_DEFAULT, 0 /* hashset */, 32 /* logical bin count */, 0 /* default range */); @@ -4147,7 +4270,7 @@ * look up the most context if it's from a trap. */ { os_context_t *context = - thread->interrupt_data->allocation_trap_context; + thread_interrupt_data(thread).allocation_trap_context; maybe_save_gc_mask_and_block_deferrables (context ? os_context_sigmask_addr(context) : NULL); } @@ -4289,7 +4412,7 @@ } else { #if CODE_PAGES_USE_SOFT_PROTECTION - gc_assert((page_table[page_index].type & PAGE_TYPE_MASK) != CODE_PAGE_TYPE); + gc_assert(!is_code(page_table[page_index].type)); #endif // There can not be an open region. gc_close_region() does not attempt // to flip that bit atomically. Other threads in the wp violation handler @@ -4389,7 +4512,7 @@ // Avoid tenuring of otherwise-dead objects referenced by // dynamic bindings which disappear on image restart. struct thread *thread = arch_os_get_current_thread(); - char *start = (char*)(thread + 1); + char *start = (char*)&thread->lisp_thread; char *end = (char*)thread + dynamic_values_bytes; memset(start, 0, end-start); #endif @@ -4437,10 +4560,7 @@ { int i; for (i=0; ifree_pointer = region->end_addr = (void*)0x1000; + /* Start 0 is the indicator of closed-ness. */ + region->start_addr = 0; /* last_page is not reset. It can be used as a hint where to resume * allocating after closing and re-opening the region */ - region->start_addr = region->free_pointer = region->end_addr = 0; } static inline void gc_init_region(struct alloc_region *region) @@ -247,10 +252,8 @@ int packed; struct { unsigned char flags; - /* space per object in Lisp words. Can exceed obj_size - to align on a larger boundary */ - unsigned char obj_align; - unsigned char obj_size; /* in Lisp words, incl. header */ + unsigned char obj_align; // object spacing expressed in lisp words + unsigned char unused1; /* Which generations have data on this page */ unsigned char gens_; // a bitmap } parts; @@ -262,7 +265,6 @@ }; extern struct fixedobj_page *fixedobj_pages; #define fixedobj_page_obj_align(i) (fixedobj_pages[i].attr.parts.obj_align< $@ -sbcl.nm: $(TARGET) - $(NM) $(TARGET) | $(GREP) -v " [FUw] " > ,$@ - mv -f ,$@ $@ - sbcl.h: $(wildcard genesis/*.h) echo '#include "genesis/config.h"' >sbcl.h echo '#include "genesis/constants.h"' >>sbcl.h @@ -178,7 +169,7 @@ @etags $(SRCS) $(HEADERS) || true clean: - -rm -f *.[do] $(TARGET) sbcl.nm sbcl.h core *.tmp $(OS_CLEAN_FILES) libsbcl.a shrinkwrap-sbcl* sbcl.mk + -rm -f *.[do] $(TARGET) sbcl.h core *.tmp $(OS_CLEAN_FILES) libsbcl.a shrinkwrap-sbcl* sbcl.mk %.d: %.c sbcl.h @$(CC) $(DEPEND_FLAGS) $(CPPFLAGS) $< > $@.tmp; \ diff -Nru sbcl-2.0.6/src/runtime/haiku-os.c sbcl-2.1.1/src/runtime/haiku-os.c --- sbcl-2.0.6/src/runtime/haiku-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/haiku-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -79,10 +79,9 @@ void os_install_interrupt_handlers(void) { - undoably_install_low_level_interrupt_handler(SIGSEGV, sigsegv_handler); + ll_install_handler(SIGSEGV, sigsegv_handler); #ifdef LISP_FEATURE_SB_THREAD - undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC, - sig_stop_for_gc_handler); + ll_install_handler(SIG_STOP_FOR_GC, sig_stop_for_gc_handler); #endif } diff -Nru sbcl-2.0.6/src/runtime/hopscotch.c sbcl-2.1.1/src/runtime/hopscotch.c --- sbcl-2.0.6/src/runtime/hopscotch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hopscotch.c 2021-01-30 11:22:38.000000000 +0000 @@ -17,13 +17,64 @@ */ #include "os.h" -#include "gc-internal.h" // for os_allocate() +#include "gc-internal.h" // for sizetab[] and os_allocate() #include "hopscotch.h" #include #include +#ifdef LISP_FEATURE_WIN32 +/* I don't know where ffs() is prototyped */ +extern int ffs(int); +#else +/* https://www.freebsd.org/cgi/man.cgi?query=fls&sektion=3&manpath=FreeBSD+7.1-RELEASE + says strings.h */ +#include +#endif #include "genesis/vector.h" #include "murmur_hash.h" +#ifdef LISP_FEATURE_USE_SYS_MMAP +/// +/// ********************************** +/// * GC MUST NOT ACQUIRE ANY LOCKS * +/// ********************************** +/// +/// It's normally fine to use the mmap() system call to obtain memory for the +/// hopscotch tables, unless your C runtime intercepts mmap() and causes it +/// to sometimes (or always?) need a spinlock. That lock may be owned already, +/// so GC will patiently wait forever; meanwhile the lock owner is also +/// waiting forever on GC to finish. +/// So bypass the C library routine and call the OS directly +/// in case of a non-signal-safe interceptor such as +/// https://chromium.googlesource.com/chromium/src/third_party/tcmalloc/chromium/+/refs/heads/master/src/malloc_hook_mmap_linux.h#146 +/// +static inline void* sys_mmap(void* addr, size_t length, int prot, int flags, + int fd, off_t offset) { + // "linux-os.h" brings in , others may need something different. + // mmap2 allows large file access with 32-bit off_t. We don't care about that, + // but _usually_ only one or the other of the syscalls exists depending on, + // various factors. Basing it on word size will pick the right one. +#ifdef LISP_FEATURE_64_BIT + void* result = (void*)syscall(SYS_mmap, addr, length, prot, flags, fd, offset); +#else + void* result = (void*)syscall(SYS_mmap2, addr, length, prot, flags, fd, offset); +#endif + if (result == MAP_FAILED) lose("mmap failed in GC"); + return result; +} +static inline int sys_munmap(void* addr, size_t length) { + return syscall(__NR_munmap, addr, length); +} +#define hopscotch_allocate(nbytes) \ + sys_mmap(0, nbytes, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0) +#define hopscotch_deallocate(addr,length) sys_munmap(addr, length) + +#else + +#define hopscotch_allocate(nbytes) os_allocate(nbytes) +#define hopscotch_deallocate(addr,length) os_deallocate(addr, length) + +#endif + typedef struct hopscotch_table* tableptr; void hopscotch_integrity_check(tableptr,char*,int); @@ -104,6 +155,20 @@ static sword_t get_val2(tableptr ht, int index) { return ((int16_t*)ht->values)[index]; } static sword_t get_val1(tableptr ht, int index) { return ((int8_t *)ht->values)[index]; } +#ifdef LISP_FEATURE_SB_SAFEPOINT + +// We can safely use malloc + free because there should be no +// problem of holding a malloc lock from another thread. +#include +#define cached_allocate(n) calloc(1,n) +#define cached_deallocate(ptr,size) free(ptr) +void hopscotch_init() { } + +#else + +/// We can't safely use malloc because the stop-for-GC signal might be received +/// in the midst of a malloc while holding a global malloc lock. + /// Hopscotch storage allocation granularity. /// Our usual value of "page size" is the GC page size, which is /// coarser than necessary (cf {target}/backend-parms.lisp). @@ -121,9 +186,9 @@ void hopscotch_init() // Called once on runtime startup, from gc_init(). { // Prefill the cache with 2 entries, each the size of a kernel page. - int n_bytes_per_slice = getpagesize(); + int n_bytes_per_slice = os_reported_page_size; int n_bytes_total = N_CACHED_ALLOCS * n_bytes_per_slice; - char* mem = os_allocate(n_bytes_total); + char* mem = hopscotch_allocate(n_bytes_total); gc_assert(mem); cached_alloc[0] = mem + ALLOCATION_OVERHEAD; cached_alloc[1] = cached_alloc[0] + n_bytes_per_slice; @@ -158,7 +223,7 @@ // not a multiple of the mmap granularity, which we'll assume is 4K. // (It doesn't actually matter.) nbytes = ALIGN_UP(nbytes, hh_allocation_granularity); - char* result = os_allocate(nbytes); + char* result = hopscotch_allocate(nbytes); gc_assert(result); result += ALLOCATION_OVERHEAD; usable_size(result) = nbytes - ALLOCATION_OVERHEAD; @@ -185,19 +250,20 @@ int cached_size1 = usable_size(cached_alloc[1]); if (!(this_size > cached_size0 || this_size > cached_size1)) { // mem is not strictly larger than either cached block. Release it. - os_deallocate(mem - ALLOCATION_OVERHEAD, - usable_size(mem) + ALLOCATION_OVERHEAD); + hopscotch_deallocate(mem - ALLOCATION_OVERHEAD, + usable_size(mem) + ALLOCATION_OVERHEAD); return; } // Evict and replace the smaller of the two cache entries. if (cached_size1 < cached_size0) line = 1; - os_deallocate(cached_alloc[line] - ALLOCATION_OVERHEAD, - usable_size(cached_alloc[line]) + ALLOCATION_OVERHEAD); + hopscotch_deallocate(cached_alloc[line] - ALLOCATION_OVERHEAD, + usable_size(cached_alloc[line]) + ALLOCATION_OVERHEAD); } memset(mem, 0, zero_fill_length); cached_alloc[line] = mem; } +#endif /* Initialize 'ht' for 'size' logical bins with a max hop of 'hop_range'. * 'valuesp' makes a hash-map if true; a hash-set if false. @@ -226,9 +292,13 @@ uword_t storage_size = (sizeof (uword_t) + ht->value_size) * n_keys + sizeof (int) * size; // hop bitmasks - if (ht->keys) + if (ht->keys) { +#ifndef LISP_FEATURE_SB_SAFEPOINT + // the usable size is a private-but-visible aspect of the memory block + // if not using malloc(). But with malloc we can't really ask the question. gc_assert(usable_size(ht->keys) >= storage_size); - else +#endif + } else ht->keys = (uword_t*)cached_allocate(storage_size); ht->mem_size = storage_size; @@ -258,6 +328,7 @@ #ifdef SIMPLE_CHARACTER_STRING_WIDETAG case SIMPLE_CHARACTER_STRING_WIDETAG: for(i=0;i - -/* Copied from sparc-arch.c. Not all of these are necessary, probably */ -#include "sbcl.h" -#include "runtime.h" -#include "arch.h" -#include "globals.h" -#include "validate.h" -#include "os.h" -#include "lispregs.h" -#include "signal.h" -#include "alloc.h" -#include "interrupt.h" -#include "interr.h" -#include "breakpoint.h" - -static inline unsigned int -os_context_pc(os_context_t *context) -{ - return (unsigned int)(*os_context_pc_addr(context)); -} - -os_vm_address_t arch_get_bad_addr(int signal, siginfo_t *siginfo, os_context_t *context) -{ - return (os_vm_address_t)siginfo->si_addr; -#if 0 -#ifdef LISP_FEATURE_HPUX - struct save_state *state; - os_vm_address_t addr; - - state = (struct save_state *)(&(scp->sc_sl.sl_ss)); - - if (state == NULL) - return NULL; - - /* Check the instruction address first. */ - addr = (os_vm_address_t)((unsigned long)scp->sc_pcoq_head & ~3); - if (addr < (os_vm_address_t)0x1000) - return addr; - - /* Otherwise, it must have been a data fault. */ - return (os_vm_address_t)state->ss_cr21; -#else - struct hp800_thread_state *state; - os_vm_address_t addr; - - state = (struct hp800_thread_state *)(scp->sc_ap); - - if (state == NULL) - return NULL; - - /* Check the instruction address first. */ - addr = scp->sc_pcoqh & ~3; - if (addr < 0x1000) - return addr; - - /* Otherwise, it must have been a data fault. */ - return state->cr21; -#endif -#endif -} - -unsigned char *arch_internal_error_arguments(os_context_t *context) -{ - return (unsigned char *)((*os_context_pc_addr(context) & ~3) + 4); -} - -boolean arch_pseudo_atomic_atomic(os_context_t *context) -{ - /* FIXME: this foreign_function_call_active test is dubious at - * best. If a foreign call is made in a pseudo atomic section - * (?) or more likely a pseudo atomic section is in a foreign - * call then an interrupt is executed immediately. Maybe it - * has to do with C code not maintaining pseudo atomic - * properly. MG - 2005-08-10 - * - * The foreign_function_call_active used to live at each call-site - * to arch_pseudo_atomic_atomic, but this seems clearer. - * --NS 2007-05-15 */ - -#if defined(LISP_FEATURE_HPUX) - // FIX-lav: use accessor macro instead - return (!foreign_function_call_active) && - *(&((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64.ss_gr7) & 4; -#else - return (!foreign_function_call_active) && - ((*os_context_register_addr(context,reg_ALLOC)) & 4); -#endif -} - -void arch_set_pseudo_atomic_interrupted(os_context_t *context) -{ -#if defined(LISP_FEATURE_HPUX) - *(&((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64.ss_gr7) |= 1; -/* on hpux do we need to watch out for the barbarian ? */ - *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags) - |= SS_MODIFIEDWIDE; -#else - *os_context_register_addr(context,reg_ALLOC) |= 1; -#endif -} - -/* FIXME: untested */ -void arch_clear_pseudo_atomic_interrupted(os_context_t *context) -{ -#if defined(LISP_FEATURE_HPUX) - *(&((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64.ss_gr7) &= ~1; - *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags) - |= SS_MODIFIEDWIDE; -#else - *os_context_register_addr(context,reg_ALLOC) &= ~1; -#endif -} - -void arch_skip_instruction(os_context_t *context) -{ - *((unsigned int *) os_context_pc_addr(context)) = *((unsigned int *) os_context_npc_addr(context)); - *((unsigned int *) os_context_npc_addr(context)) += 4; -#ifdef LISP_FEATURE_HPUX - *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags) - |= SS_MODIFIEDWIDE; -#endif -} - -unsigned int arch_install_breakpoint(void *pc) -{ - unsigned int *ulpc = (unsigned int *)pc; - unsigned int orig_inst = *ulpc; - - *ulpc = trap_Breakpoint; - os_flush_icache((os_vm_address_t)pc, sizeof(*ulpc)); - return orig_inst; -} - -void arch_remove_breakpoint(void *pc, unsigned int orig_inst) -{ - unsigned int *ulpc = (unsigned int *)pc; - - *ulpc = orig_inst; - os_flush_icache((os_vm_address_t)pc, sizeof(*ulpc)); -} - -void arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst) -{ - fprintf(stderr, "arch_do_displaced_inst() WARNING: stub.\n"); - /* FIXME: Fill this in */ -#if 0 -#ifdef LISP_FEATURE_HPUX - /* We change the next-pc to point to a breakpoint instruction, restore */ - /* the original instruction, and exit. We would like to be able to */ - /* sigreturn, but we can't, because this is hpux. */ - unsigned int *pc = (unsigned int *)(SC_PC(scp) & ~3); - - NextPc = SC_NPC(scp); - SC_NPC(scp) = (unsigned int)SingleStepTraps | (SC_NPC(scp)&3); - - BreakpointAddr = pc; - *pc = orig_inst; - os_flush_icache((os_vm_address_t)pc, sizeof(unsigned int)); -#else - /* We set the recovery counter to cover one instruction, put the */ - /* original instruction back in, and then resume. We will then trap */ - /* after executing that one instruction, at which time we can put */ - /* the breakpoint back in. */ - - ((struct hp800_thread_state *)scp->sc_ap)->cr0 = 1; - scp->sc_ps |= 0x10; - *(unsigned int *)SC_PC(scp) = orig_inst; - - sigreturn(scp); -#endif -#endif -} - -#ifdef LISP_FEATURE_HPUX -#if 0 -static void restore_breakpoint(struct sigcontext *scp) -{ - /* We just single-stepped over an instruction that we want to replace */ - /* with a breakpoint. So we put the breakpoint back in, and tweek the */ - /* state so that we will continue as if nothing happened. */ - - if (NextPc == NULL) - lose("SingleStepBreakpoint trap at strange time."); - - if ((SC_PC(scp)&~3) == (unsigned int)SingleStepTraps) { - /* The next instruction was not nullified. */ - SC_PC(scp) = NextPc; - if ((SC_NPC(scp)&~3) == (unsigned int)SingleStepTraps + 4) { - /* The instruction we just stepped over was not a branch, so */ - /* we need to fix it up. If it was a branch, it will point to */ - /* the correct place. */ - SC_NPC(scp) = NextPc + 4; - } - } - else { - /* The next instruction was nullified, so we want to skip it. */ - SC_PC(scp) = NextPc + 4; - SC_NPC(scp) = NextPc + 8; - } - NextPc = NULL; - - if (BreakpointAddr) { - *BreakpointAddr = trap_Breakpoint; - os_flush_icache((os_vm_address_t)BreakpointAddr, - sizeof(unsigned int)); - BreakpointAddr = NULL; - } -} -#endif -#endif - - - -void -arch_handle_breakpoint(os_context_t *context) -{ - /*sigsetmask(scp->sc_mask); */ - handle_breakpoint(context); -} - -void -arch_handle_fun_end_breakpoint(os_context_t *context) -{ - /*sigsetmask(scp->sc_mask); */ - unsigned long pc; - pc = (unsigned long) - handle_fun_end_breakpoint(context); - *os_context_pc_addr(context) = pc; - *os_context_npc_addr(context) = pc + 4; -#ifdef LISP_FEATURE_HPUX - *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags) - |= SS_MODIFIEDWIDE; -#endif -} - - -//FIX-lav: this whole is copied from mips -void -arch_handle_single_step_trap(os_context_t *context, int trap) -{ - unsigned int code = *((u32 *)(os_context_pc(context))); - int register_offset = code >> 11 & 0x1f; - handle_single_step_trap(context, trap, register_offset); - arch_skip_instruction(context); -} - -static void -sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) -{ - unsigned int bad_inst; - - bad_inst = *(unsigned int *)(*os_context_pc_addr(context) & ~3); - if (bad_inst & 0xfc001fe0) - interrupt_handle_now(signal, siginfo, context); - else { - int im5 = bad_inst & 0x1f; - handle_trap(context, im5); - } -} - -static void -sigill_handler(int signal, siginfo_t *siginfo, os_context_t *context) -{ - unsigned int bad_inst; - - bad_inst = *(unsigned int *)(*os_context_pc_addr(context) & ~3); - if (bad_inst == 9) { /* pending-interrupt */ - arch_clear_pseudo_atomic_interrupted(context); - arch_skip_instruction(context); - interrupt_handle_pending(context); - } else { - handle_trap(context,bad_inst); - } -} - -static void sigfpe_handler(int signal, siginfo_t *siginfo, - os_context_t *context) -{ - unsigned badinst = *(unsigned *)(*os_context_pc_addr(context) & ~3); - -#ifdef LISP_FEATURE_LINUX - if (!siginfo->si_code && /* Linux 3.14 seems to set si_code to 0 for this case */ -#else - if (siginfo->si_code == FPE_COND && -#endif - (badinst&0xfffff800) == (0xb000e000|reg_ALLOC<<21|reg_ALLOC<<16)) { - /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped. - * That means that it is the end of a pseudo-atomic. So do the - * add stripping off the pseudo-atomic-interrupted bit, and then - * tell the machine-independent code to process the pseudo- - * atomic. We cant skip the instruction because it holds - * extra-bytes that we must add to reg_alloc in context. - * It is so because we optimized away 'addi ,extra-bytes reg_alloc' - */ - int immed = (badinst>>1)&0x3ff; - if (badinst & 1) - immed |= -1<<10; - *os_context_register_addr(context, reg_ALLOC) += (immed-1); - arch_skip_instruction(context); - interrupt_handle_pending(context); - } else { - interrupt_handle_now(signal, siginfo, context); - } -} - -/* Merrily cut'n'pasted from sigfpe_handler. On Linux, until - 2.4.19-pa4 (hopefully), the overflow_trap wasn't implemented, - resulting in a SIGBUS instead. We adapt the sigfpe_handler here, in - the hope that it will do as a replacement until the new kernel sees - the light of day. Since the instructions that we need to fix up - tend not to be doing unaligned memory access, this should be a safe - workaround. -- CSR, 2002-08-17 */ -static void sigbus_handler(int signal, siginfo_t *siginfo, - os_context_t *context) -{ - - unsigned badinst = *(unsigned *)(*os_context_pc_addr(context) & ~3); - - /* First, test for the pseudo-atomic instruction */ - if ((badinst & 0xfffff800) == (0xb000e000 | reg_ALLOC<<21 | - reg_ALLOC<<16)) { - /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped. - That means that it is the end of a pseudo-atomic. So do - the add stripping off the pseudo-atomic-interrupted bit, - and then tell the machine-independent code to process the - pseudo-atomic. */ - int immed = (badinst>>1) & 0x3ff; - if (badinst & 1) - immed |= -1<<10; - *os_context_register_addr(context, reg_ALLOC) += (immed-1); - arch_skip_instruction(context); - interrupt_handle_pending(context); - } else { - interrupt_handle_now(signal, siginfo, context); - } -} - -#ifdef LISP_FEATURE_HPUX -static void -ignore_handler(int signal, siginfo_t *siginfo, os_context_t *context) -{ -} -#endif - -/* this routine installs interrupt handlers that will - * bypass the lisp interrupt handlers */ -void arch_install_interrupt_handlers(void) -{ - undoably_install_low_level_interrupt_handler(SIGTRAP,sigtrap_handler); - undoably_install_low_level_interrupt_handler(SIGILL,sigill_handler); - undoably_install_low_level_interrupt_handler(SIGFPE,sigfpe_handler); - /* FIXME: beyond 2.4.19-pa4 this shouldn't be necessary. */ - undoably_install_low_level_interrupt_handler(SIGBUS,sigbus_handler); -#ifdef LISP_FEATURE_HPUX - undoably_install_low_level_interrupt_handler(SIGXCPU,ignore_handler); - undoably_install_low_level_interrupt_handler(SIGXFSZ,ignore_handler); -#endif -} diff -Nru sbcl-2.0.6/src/runtime/hppa-arch.h sbcl-2.1.1/src/runtime/hppa-arch.h --- sbcl-2.0.6/src/runtime/hppa-arch.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hppa-arch.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -#ifndef _HPPA_ARCH_H -#define _HPPA_ARCH_H - -#define ARCH_HAS_NPC_REGISTER -#define ALIEN_STACK_GROWS_UPWARD - -#endif /* _HPPA_ARCH_H */ diff -Nru sbcl-2.0.6/src/runtime/hppa-assem.S sbcl-2.1.1/src/runtime/hppa-assem.S --- sbcl-2.0.6/src/runtime/hppa-assem.S 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hppa-assem.S 1970-01-01 00:00:00.000000000 +0000 @@ -1,473 +0,0 @@ -#ifdef __ELF__ -// Mark the object as not requiring an executable stack. -.section .note.GNU-stack,"",%progbits -#endif - -#include "sbcl.h" -#include "lispregs.h" -#include "genesis/closure.h" -#include "genesis/code.h" -#include "genesis/fdefn.h" -#include "genesis/simple-fun.h" -#include "genesis/return-pc.h" -#include "genesis/static-symbols.h" -#include "genesis/funcallable-instance.h" - - .level 2.0 - .text - - .import $global$,data - .import $$dyncall,MILLICODE - .import foreign_function_call_active,data - .import current_control_stack_pointer,data - .import current_control_frame_pointer,data - .import current_binding_stack_pointer,data - .import dynamic_space_free_pointer,data -/* .import return_from_lisp_function,data */ - - -/* - * Call-into-lisp - */ - - .export call_into_lisp -call_into_lisp: - .proc - .callinfo entry_gr=18,save_rp - .entry - /* %arg0=function, %arg1=cfp, %arg2=nargs */ - - stw %rp,-0x14(%sr0,%sp) - stwm %r3,0x40(%sr0,%sp) - stw %r4,-0x3c(%sr0,%sp) - stw %r5,-0x38(%sr0,%sp) - stw %r6,-0x34(%sr0,%sp) - stw %r7,-0x30(%sr0,%sp) - stw %r8,-0x2c(%sr0,%sp) - stw %r9,-0x28(%sr0,%sp) - stw %r10,-0x24(%sr0,%sp) - stw %r11,-0x20(%sr0,%sp) - stw %r12,-0x1c(%sr0,%sp) - stw %r13,-0x18(%sr0,%sp) - stw %r14,-0x14(%sr0,%sp) - stw %r15,-0x10(%sr0,%sp) - stw %r16,-0xc(%sr0,%sp) - stw %r17,-0x8(%sr0,%sp) - stw %r18,-0x4(%sr0,%sp) - - /* Clear the descriptor regs, moving in args as approporate. */ - copy %r0,reg_CODE - copy %r0,reg_FDEFN - copy %arg0,reg_LEXENV - zdep %arg2,29,30,reg_NARGS - copy %r0,reg_OCFP - copy %r0,reg_LRA - copy %r0,reg_A0 - copy %r0,reg_A1 - copy %r0,reg_A2 - copy %r0,reg_A3 - copy %r0,reg_A4 - copy %r0,reg_A5 - copy %r0,reg_L0 - copy %r0,reg_L1 - copy %r0,reg_L2 - - /* Establish NIL. */ - ldil L%NIL,reg_NULL - ldo R%NIL(reg_NULL),reg_NULL - - /* Turn on pseudo-atomic. */ - ldo 4(%r0),reg_ALLOC - - /* No longer in foreign function call land. */ - addil L%foreign_function_call_active-$global$,%dp - stw %r0,R%foreign_function_call_active-$global$(0,%r1) - - /* Load lisp state. */ - addil L%dynamic_space_free_pointer-$global$,%dp - ldw R%dynamic_space_free_pointer-$global$(0,%r1),%r1 - add reg_ALLOC,%r1,reg_ALLOC - addil L%current_binding_stack_pointer-$global$,%dp - ldw R%current_binding_stack_pointer-$global$(0,%r1),reg_BSP - addil L%current_control_stack_pointer-$global$,%dp - ldw R%current_control_stack_pointer-$global$(0,%r1),reg_CSP - addil L%current_control_frame_pointer-$global$,%dp - ldw R%current_control_frame_pointer-$global$(0,%r1),reg_OCFP - copy %arg1,reg_CFP - - /* End of pseudo-atomic. */ - addit,od -4,reg_ALLOC,reg_ALLOC - - /* Establish lisp arguments. */ - ldw 0(reg_CFP),reg_A0 - ldw 4(reg_CFP),reg_A1 - ldw 8(reg_CFP),reg_A2 - ldw 12(reg_CFP),reg_A3 - ldw 16(reg_CFP),reg_A4 - ldw 20(reg_CFP),reg_A5 - - /* Calculate the LRA. */ - ldil L%lra-RETURN_PC_RETURN_POINT_OFFSET,reg_LRA - ldo R%lra-RETURN_PC_RETURN_POINT_OFFSET(reg_LRA),reg_LRA - - /* Indirect the closure */ - ldw CLOSURE_FUN_OFFSET(0,reg_LEXENV),reg_CODE - addi SIMPLE_FUN_INSTS_OFFSET,reg_CODE,reg_LIP - -#ifdef LISP_FEATURE_HPUX - /* Get the stub address, ie assembly-routine return-from-lisp */ - addil L%return_from_lisp_stub-$global$,%dp - ldw R%return_from_lisp_stub-$global$(0,%r1),reg_NL0 - be,n 0(%sr5,reg_NL0) -#else - be,n 0(%sr5,reg_LIP) -#endif - - break 0,0 - - .align 8 -lra: - nop /* a few nops because we dont know where we land */ - nop /* the return convention would govern this */ - nop - nop - - /* Copy CFP (%r4) into someplace else and restore r4. */ - copy reg_CFP,reg_NL1 - ldw -0x3c(0,%sp),%r4 - - /* Copy the return value. */ - copy reg_A0,%ret0 - - /* Turn on pseudo-atomic. */ - addi 4,reg_ALLOC,reg_ALLOC - - /* Store the lisp state. */ - copy reg_ALLOC,reg_NL0 - depi 0,31,3,reg_NL0 - addil L%dynamic_space_free_pointer-$global$,%dp - stw reg_NL0,R%dynamic_space_free_pointer-$global$(0,%r1) - addil L%current_binding_stack_pointer-$global$,%dp - stw reg_BSP,R%current_binding_stack_pointer-$global$(0,%r1) - addil L%current_control_stack_pointer-$global$,%dp - stw reg_CSP,R%current_control_stack_pointer-$global$(0,%r1) - addil L%current_control_frame_pointer-$global$,%dp - stw reg_NL1,R%current_control_frame_pointer-$global$(0,%r1) - - /* Back in C land. [CSP is just a handy non-zero value.] */ - addil L%foreign_function_call_active-$global$,%dp - stw reg_CSP,R%foreign_function_call_active-$global$(0,%r1) - - /* Turn off pseudo-atomic and check for traps. */ - addit,od -4,reg_ALLOC,reg_ALLOC - - ldw -0x54(%sr0,%sp),%rp - ldw -0x4(%sr0,%sp),%r18 - ldw -0x8(%sr0,%sp),%r17 - ldw -0xc(%sr0,%sp),%r16 - ldw -0x10(%sr0,%sp),%r15 - ldw -0x14(%sr0,%sp),%r14 - ldw -0x18(%sr0,%sp),%r13 - ldw -0x1c(%sr0,%sp),%r12 - ldw -0x20(%sr0,%sp),%r11 - ldw -0x24(%sr0,%sp),%r10 - ldw -0x28(%sr0,%sp),%r9 - ldw -0x2c(%sr0,%sp),%r8 - ldw -0x30(%sr0,%sp),%r7 - ldw -0x34(%sr0,%sp),%r6 - ldw -0x38(%sr0,%sp),%r5 - ldw -0x3c(%sr0,%sp),%r4 - bv %r0(%rp) - ldwm -0x40(%sr0,%sp),%r3 - - /* And thats all. */ - .exit - .procend - - -/* - * Call-into-C - */ - - .export call_into_c -call_into_c: - /* Set up a lisp stack frame. */ - copy reg_CFP, reg_OCFP - copy reg_CSP, reg_CFP - addi 32, reg_CSP, reg_CSP - stw reg_OCFP, 0(0,reg_CFP) ; save old cfp - stw reg_CFP, 4(0,reg_CFP) ; save old csp - /* convert raw return PC into a fixnum PC-offset, because we dont - have ahold of an lra object */ - sub reg_LIP, reg_CODE, reg_NL5 - addi 3-OTHER_POINTER_LOWTAG, reg_NL5, reg_NL5 - stw reg_NL5, 8(0,reg_CFP) - stw reg_CODE, 0xc(0,reg_CFP) - - /* set pseudo-atomic flag */ - addi 4, reg_ALLOC, reg_ALLOC - - /* Store the lisp state. */ - copy reg_ALLOC,reg_NL5 - depi 0,31,3,reg_NL5 - addil L%dynamic_space_free_pointer-$global$,%dp - stw reg_NL5,R%dynamic_space_free_pointer-$global$(0,%r1) - addil L%current_binding_stack_pointer-$global$,%dp - stw reg_BSP,R%current_binding_stack_pointer-$global$(0,%r1) - addil L%current_control_stack_pointer-$global$,%dp - stw reg_CSP,R%current_control_stack_pointer-$global$(0,%r1) - addil L%current_control_frame_pointer-$global$,%dp - stw reg_CFP,R%current_control_frame_pointer-$global$(0,%r1) - - /* Back in C land. [CSP is just a handy non-zero value.] */ - addil L%foreign_function_call_active-$global$,%dp - stw reg_CSP,R%foreign_function_call_active-$global$(0,%r1) - - /* Turn off pseudo-atomic and check for traps. */ - addit,od -4,reg_ALLOC,reg_ALLOC - - /* in order to be able to call incrementally linked (ld -A) functions, - we have to do some mild trickery here */ - copy reg_CFUNC, %r22 - bl $$dyncall,%r31 - copy %r31, %r2 -call_into_c_return: - /* Clear the callee saves descriptor regs. */ - copy %r0, reg_A5 - copy %r0, reg_L0 - copy %r0, reg_L1 - copy %r0, reg_L2 - - /* Turn on pseudo-atomic. */ - ldi 4, reg_ALLOC - - /* Turn off foreign function call. */ - addil L%foreign_function_call_active-$global$,%dp - stw %r0,R%foreign_function_call_active-$global$(0,%r1) - - /* Load ALLOC. */ - addil L%dynamic_space_free_pointer-$global$,%dp - ldw R%dynamic_space_free_pointer-$global$(0,%r1),%r1 - add reg_ALLOC,%r1,reg_ALLOC - - /* We don't need to load OCFP, CFP, CSP, or BSP because they are - * in caller saves registers. - */ - - /* End of pseudo-atomic. */ - addit,od -4,reg_ALLOC,reg_ALLOC - - /* Restore CODE. Even though it is in a callee saves register - * it might have been GC'ed. - */ - ldw 0xc(0,reg_CFP), reg_CODE - - /* Restore the return pc. */ - ldw 8(0,reg_CFP), reg_NL0 - addi OTHER_POINTER_LOWTAG-3, reg_NL0, reg_NL0 -/* - addi -3, reg_NL0, reg_NL0 - ldi OTHER_POINTER_LOWTAG, reg_NL1 - sub reg_NL0, reg_NL1, reg_NL0 -*/ - add reg_CODE, reg_NL0, reg_LIP - - /* Pop the lisp stack frame, and back we go. */ - ldw 4(0,reg_CFP), reg_CSP - ldw 0(0,reg_CFP), reg_OCFP - copy reg_OCFP, reg_CFP - be 0(5,reg_LIP) - nop - - -/* - * Stuff to sanctify a block of memory for execution. - */ - - .EXPORT sanctify_for_execution -sanctify_for_execution: - .proc - .callinfo - .entry - /* %arg0=start addr, %arg1=length in bytes */ - add %arg0,%arg1,%arg1 - copy %arg0,%arg2 - ldo -1(%arg1),%arg1 - depi 0,31,5,%arg0 - depi 0,31,5,%arg1 - ldsid (%arg0),%r1 - mtsp %r1,%sr1 - ldi 32,%r1 ; bytes per cache line - /* parisc 1.1 and 2.0 manuals say to flush the dcache, SYNC, - * flush the icache, SYNC again, and burn seven instructions - * before executing modified code. */ -sanctify_loop: - comb,< %arg0,%arg1,sanctify_loop - fdc,m %r1(%sr1,%arg0) - sync -sanctify_loop_2: - comb,< %arg2,%arg1,sanctify_loop_2 - fic,m %r1(%sr1,%arg2) - sync - - bv %r0(%rp) - nop - - .exit - .procend - - -/* - * Core saving/restoring support - */ - - .export call_on_stack -call_on_stack: - /* %arg0 = fn to invoke, %arg1 = new stack base */ - - /* Compute the new stack pointer. */ - addi 64,%arg1,%sp - - /* Zero out the previous stack pointer. */ - stw %r0,-4(0,%sp) - - /* Invoke the function. */ - ble 0(4,%arg0) - copy %r31, %r2 - - /* Flame out. */ - break 0,0 - - .export save_state -save_state: - .proc - .callinfo entry_gr=18,entry_fr=21,save_rp,calls - .entry - - stw %rp,-0x14(%sr0,%sp) - fstds,ma %fr12,8(%sr0,%sp) - fstds,ma %fr13,8(%sr0,%sp) - fstds,ma %fr14,8(%sr0,%sp) - fstds,ma %fr15,8(%sr0,%sp) - fstds,ma %fr16,8(%sr0,%sp) - fstds,ma %fr17,8(%sr0,%sp) - fstds,ma %fr18,8(%sr0,%sp) - fstds,ma %fr19,8(%sr0,%sp) - fstds,ma %fr20,8(%sr0,%sp) - fstds,ma %fr21,8(%sr0,%sp) - stwm %r3,0x70(%sr0,%sp) - stw %r4,-0x6c(%sr0,%sp) - stw %r5,-0x68(%sr0,%sp) - stw %r6,-0x64(%sr0,%sp) - stw %r7,-0x60(%sr0,%sp) - stw %r8,-0x5c(%sr0,%sp) - stw %r9,-0x58(%sr0,%sp) - stw %r10,-0x54(%sr0,%sp) - stw %r11,-0x50(%sr0,%sp) - stw %r12,-0x4c(%sr0,%sp) - stw %r13,-0x48(%sr0,%sp) - stw %r14,-0x44(%sr0,%sp) - stw %r15,-0x40(%sr0,%sp) - stw %r16,-0x3c(%sr0,%sp) - stw %r17,-0x38(%sr0,%sp) - stw %r18,-0x34(%sr0,%sp) - - - /* Remember the function we want to invoke */ - copy %arg0,%r19 - - /* Pass the new stack pointer in as %arg0 */ - copy %sp,%arg0 - - /* Leave %arg1 as %arg1. */ - - /* do the call. */ - ble 0(4,%r19) - copy %r31, %r2 - - .export _restore_state -_restore_state: - - ldw -0xd4(%sr0,%sp),%rp - ldw -0x34(%sr0,%sp),%r18 - ldw -0x38(%sr0,%sp),%r17 - ldw -0x3c(%sr0,%sp),%r16 - ldw -0x40(%sr0,%sp),%r15 - ldw -0x44(%sr0,%sp),%r14 - ldw -0x48(%sr0,%sp),%r13 - ldw -0x4c(%sr0,%sp),%r12 - ldw -0x50(%sr0,%sp),%r11 - ldw -0x54(%sr0,%sp),%r10 - ldw -0x58(%sr0,%sp),%r9 - ldw -0x5c(%sr0,%sp),%r8 - ldw -0x60(%sr0,%sp),%r7 - ldw -0x64(%sr0,%sp),%r6 - ldw -0x68(%sr0,%sp),%r5 - ldw -0x6c(%sr0,%sp),%r4 - ldwm -0x70(%sr0,%sp),%r3 - fldds,mb -8(%sr0,%sp),%fr21 - fldds,mb -8(%sr0,%sp),%fr20 - fldds,mb -8(%sr0,%sp),%fr19 - fldds,mb -8(%sr0,%sp),%fr18 - fldds,mb -8(%sr0,%sp),%fr17 - fldds,mb -8(%sr0,%sp),%fr16 - fldds,mb -8(%sr0,%sp),%fr15 - fldds,mb -8(%sr0,%sp),%fr14 - fldds,mb -8(%sr0,%sp),%fr13 - bv %r0(%rp) - fldds,mb -8(%sr0,%sp),%fr12 - - - .exit - .procend - - .export restore_state -restore_state: - .proc - .callinfo - copy %arg0,%sp - b _restore_state - copy %arg1,%ret0 - .procend - - - -/* FIX, add support for singlestep - break trap_SingleStepBreakpoint,0 - break trap_SingleStepBreakpoint,0 -*/ - .export SingleStepTraps -SingleStepTraps: - -/* Missing !! NOT - there's a break 0,0 in the new version here!!! -*/ - -/* - * For an explanation of the magic involved in function-end - * breakpoints, see the implementation in ppc-assem.S. - */ - - .align 8 - .export fun_end_breakpoint_guts -fun_end_breakpoint_guts: - .word (((CODE_SIZE+1)&~1)< -#include -#include -#include "sbcl.h" -#include "./signal.h" -#include "os.h" -#include "arch.h" -#include "globals.h" -#include "interrupt.h" -#include "interr.h" -#include "lispregs.h" -#include -#include - -#include -#include -#include -#include -#include - -#include "validate.h" - -#ifdef LISP_FEATURE_SB_THREAD -#error "Define threading support functions" -#else -int arch_os_thread_init(struct thread *thread) { - return 1; /* success */ -} -int arch_os_thread_cleanup(struct thread *thread) { - return 1; /* success */ -} -#endif - -/* for hpux read /usr/include/machine/save_state.h - * os_context_register_addr() may not be used - * to modify registers without setting a state-flag too */ -os_context_register_t * -os_context_register_addr(os_context_t *context, int offset) -{ - return (os_context_register_t *) - ((unsigned int)(&((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64)) + (offset * 2) + 1; -} - -os_context_register_t * -os_context_pc_addr(os_context_t *context) -{ - /* Why do I get all the silly ports? -- CSR, 2002-08-11 */ - return ((unsigned int) &((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64.ss_pcoq_head + 4); -} - -os_context_register_t * -os_context_npc_addr(os_context_t *context) -{ - return ((unsigned int) &((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64.ss_pcoq_tail + 4); -} - -sigset_t * -os_context_sigmask_addr(os_context_t *context) -{ - return &(((ucontext_t *)context)->uc_subcontext.__uc_sigmask); -} - -void -os_restore_fp_control(os_context_t *context) -{ - /* FIXME: Probably do something. */ -} - -void -os_flush_icache(os_vm_address_t address, os_vm_size_t length) -{ - /* FIXME: Maybe this is OK. */ - sanctify_for_execution(address,length); -} diff -Nru sbcl-2.0.6/src/runtime/hppa-hpux-os.h sbcl-2.1.1/src/runtime/hppa-hpux-os.h --- sbcl-2.0.6/src/runtime/hppa-hpux-os.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hppa-hpux-os.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -#ifndef _HPPA_HPUX_OS_H -#define _HPPA_HPUX_OS_H - -typedef struct ucontext_t os_context_t; -typedef unsigned long os_context_register_t; - -#include "arch-os-generic.inc" - -unsigned long os_context_fp_control(os_context_t *context); -void os_restore_fp_control(os_context_t *context); - -#define REGISTER_ACCESS(context,offset) ((os_context_register_t *) ((unsigned int)(&((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64)) + (offset * 2) + 1) - -#endif /* _HPPA_HPUX_OS_H */ diff -Nru sbcl-2.0.6/src/runtime/hppa-linux-os.c sbcl-2.1.1/src/runtime/hppa-linux-os.c --- sbcl-2.0.6/src/runtime/hppa-linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hppa-linux-os.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -/* - * This is the HPPA Linux incarnation of arch-dependent OS-dependent - * routines. See also "linux-os.c". - */ - -/* - * 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. - */ - -#include -#include -#include -#include "sbcl.h" -#include "./signal.h" -#include "os.h" -#include "arch.h" -#include "globals.h" -#include "interrupt.h" -#include "interr.h" -#include "lispregs.h" -#include -#include - -#include -#include -#include -#include -#include - -#include "validate.h" - -#ifdef LISP_FEATURE_SB_THREAD -#error "Define threading support functions" -#else -int arch_os_thread_init(struct thread *thread) { - return 1; /* success */ -} -int arch_os_thread_cleanup(struct thread *thread) { - return 1; /* success */ -} -#endif - -os_context_register_t * -os_context_register_addr(os_context_t *context, int offset) -{ - if (offset == 0) { - /* KLUDGE: I'm not sure, but it's possible that Linux puts the - contents of the Processor Status Word in the (wired-zero) - slot in the mcontext. In any case, the following is - unlikely to do any harm: */ - static int zero; - zero = 0; - return &zero; - } else { - return &context->uc_mcontext.sc_gr[offset]; - } -} - -os_context_register_t * -os_context_pc_addr(os_context_t *context) -{ - /* Why do I get all the silly ports? -- CSR, 2002-08-11 */ - return &context->uc_mcontext.sc_iaoq[0]; -} - -os_context_register_t * -os_context_npc_addr(os_context_t *context) -{ - return &context->uc_mcontext.sc_iaoq[1]; -} - -sigset_t * -os_context_sigmask_addr(os_context_t *context) -{ - return &context->uc_sigmask; -} - -void -os_restore_fp_control(os_context_t *context) -{ - /* FIXME: Probably do something. */ -} - -void -os_flush_icache(os_vm_address_t address, os_vm_size_t length) -{ - /* FIXME: Maybe this is OK. */ - sanctify_for_execution(address,length); -} diff -Nru sbcl-2.0.6/src/runtime/hppa-linux-os.h sbcl-2.1.1/src/runtime/hppa-linux-os.h --- sbcl-2.0.6/src/runtime/hppa-linux-os.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hppa-linux-os.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -#ifndef _HPPA_LINUX_OS_H -#define _HPPA_LINUX_OS_H - -typedef struct ucontext_t os_context_t; -/* FIXME: This will change if the parisc-linux people implement - wide-sigcontext for 32-bit kernels */ -typedef unsigned long os_context_register_t; - -#include "arch-os-generic.inc" - -unsigned long os_context_fp_control(os_context_t *context); -void os_restore_fp_control(os_context_t *context); - -#define SC_REG(sc, n) (((unsigned long *)((sc)->sc_ap))[n]) -#define SC_PC(sc) ((sc)->sc_pcoqh) -#define SC_NPC(sc) ((sc)->sc_pcoqt) - -#endif /* _HPPA_LINUX_OS_H */ diff -Nru sbcl-2.0.6/src/runtime/hppa-lispregs.h sbcl-2.1.1/src/runtime/hppa-lispregs.h --- sbcl-2.0.6/src/runtime/hppa-lispregs.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hppa-lispregs.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -#define NREGS (32) - -#ifdef __ASSEMBLER__ -#define REG(num) num -#else -#define REG(num) num -#endif - -#define reg_ZERO REG(0) -#define reg_NFP REG(1) -#define reg_CFUNC REG(2) -#define reg_CSP REG(3) -#define reg_CFP REG(4) -#define reg_BSP REG(5) -#define reg_NULL REG(6) -#define reg_ALLOC REG(7) -#define reg_CODE REG(8) -#define reg_FDEFN REG(9) -#define reg_LEXENV REG(10) -#define reg_NARGS REG(11) -#define reg_OCFP REG(12) -#define reg_LRA REG(13) -#define reg_A0 REG(14) -#define reg_A1 REG(15) -#define reg_A2 REG(16) -#define reg_A3 REG(17) -#define reg_A4 REG(18) -#define reg_A5 REG(19) -#define reg_L0 REG(20) -#define reg_L1 REG(21) -#define reg_L2 REG(22) -#define reg_NL3 REG(23) -#define reg_NL2 REG(24) -#define reg_NL1 REG(25) -#define reg_NL0 REG(26) -#define reg_DP REG(27) -#define reg_NL4 REG(28) -#define reg_NL5 REG(29) -#define reg_NSP REG(30) -#define reg_LIP REG(31) diff -Nru sbcl-2.0.6/src/runtime/hpux-os.c sbcl-2.1.1/src/runtime/hpux-os.c --- sbcl-2.0.6/src/runtime/hpux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hpux-os.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,113 +0,0 @@ -#include -#include -#include -#include - -#include -#include -#include -#include - -#include "sbcl.h" -#include "os.h" -#include "arch.h" -#include "interr.h" -#include "interrupt.h" -#include "globals.h" -#include "validate.h" -#include "target-arch-os.h" - -#ifdef LISP_FEATURE_GENCGC -#error gencgc not ported to hpux -#endif - -#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK -#error C_STACK_IS_CONTROL_STACK isnt supported -#endif - -void -os_init(char *argv[], char *envp[]) -{ -} - -os_vm_address_t -os_validate(int attributes, os_vm_address_t addr, os_vm_size_t len) -{ - int protection = attributes & IS_GUARD_PAGE ? OS_VM_PROT_NONE : OS_VM_PROT_ALL; - attributes &= ~IS_GUARD_PAGE; - os_vm_address_t actual; - int flags = MAP_PRIVATE | MAP_ANONYMOUS; - if (addr) flags |= MAP_FIXED; - - actual = mmap(addr, len, protection, flags, -1, 0); - - if (actual == MAP_FAILED) { - perror("mmap"); - lose("os_validate(): mmap() failure"); - } - - if (addr && (addr!=actual)) { - fprintf(stderr, "mmap: wanted %lu bytes at %p, actually mapped at %p\n", - (unsigned long) len, addr, actual); - return 0; - } - - return actual; -} - -void -os_invalidate(os_vm_address_t addr, os_vm_size_t len) -{ - if (munmap(addr,len) == -1) { - perror("munmap"); - lose("os_invalidate(): mmap() failure"); - } -} - -void -os_protect(os_vm_address_t addr, os_vm_size_t len, os_vm_prot_t prot) -{ - if (mprotect(addr, len, prot) == -1) { - perror("mprotect"); - } -} - -/* - * any OS-dependent special low-level handling for signals - */ - -static void -sigsegv_handler(int signal, siginfo_t *info, os_context_t *context) -{ - os_vm_address_t addr = arch_get_bad_addr(signal, info, context); - - if (!cheneygc_handle_wp_violation(context, addr)) - if (!handle_guard_page_triggered(context, addr)) - lisp_memory_fault_error(context, addr); - *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags) - |= SS_MODIFIEDWIDE; -} - -void -os_install_interrupt_handlers(void) -{ - undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT, - sigsegv_handler); -} - -char *os_get_runtime_executable_path() -{ - return NULL; -} - -/* when inside call_into_lisp, we will first jump to the stub - * and then the stub will jump into the lisp function. Then - * the lisp function will return to the stub function and - * the stub will return to the call_into_lisp function. - */ -void *return_from_lisp_stub; -void -setup_return_from_lisp_stub (void *addr) -{ - return_from_lisp_stub = addr; -} diff -Nru sbcl-2.0.6/src/runtime/hpux-os.h sbcl-2.1.1/src/runtime/hpux-os.h --- sbcl-2.0.6/src/runtime/hpux-os.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/hpux-os.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -#include /* warnings in os-common */ -#include -#include -#include /* recognize signal_t */ -#include "target-arch-os.h" -#include "target-arch.h" - -typedef caddr_t os_vm_address_t; -typedef size_t os_vm_size_t; -typedef off_t os_vm_offset_t; -typedef int os_vm_prot_t; - -#define OS_VM_PROT_READ PROT_READ -#define OS_VM_PROT_WRITE PROT_WRITE -#define OS_VM_PROT_EXECUTE PROT_EXEC - -#define SIG_MEMORY_FAULT SIGSEGV - diff -Nru sbcl-2.0.6/src/runtime/immobile-space.c sbcl-2.1.1/src/runtime/immobile-space.c --- sbcl-2.0.6/src/runtime/immobile-space.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/immobile-space.c 2021-01-30 11:22:38.000000000 +0000 @@ -58,6 +58,7 @@ #include "immobile-space.h" #include "unaligned.h" #include "code.h" +#include "lispstring.h" #include #include @@ -104,7 +105,7 @@ // Packing and unpacking attributes // the low two flag bits are for write-protect status -#define MAKE_ATTR(spacing,size,flags) (((spacing)<<8)|((size)<<16)|flags) +#define MAKE_ATTR(spacing) ((spacing)<<8) #define OBJ_SPACING(attr) ((attr>>8) & 0xFF) // Ignore the write-protect bits and the generations when comparing attributes @@ -232,60 +233,9 @@ lose("No more immobile pages available"); } -/// The size classes are: 2w, 4w, 6w, 8w, ..., up to 20w. -/// Each size class can store at most 2 different alignments. So for example in -/// the size class for 14 words there will be a page hint for 14-word-aligned -/// objects and at most one other alignment. -#define MAX_SIZE_CLASSES 10 -#define MAX_HINTS_PER_CLASS 2 -long page_hints[MAX_SIZE_CLASSES*MAX_HINTS_PER_CLASS]; -static inline int hint_attributes(long hint) { return hint & 0xFFFFFFFF; } -static int hint_page(long hint) { return hint>>32; } -static long make_hint(int page, int attributes) { - return ((long)page << 32) | attributes; -} - -static int get_hint(int attributes, int *page) -{ - long hint; - unsigned int size = attributes >> 16; - int hint_index = size - 2, limit = hint_index + 1, free_slot = -1; - if (hint_index > (int)(sizeof page_hints / sizeof (long))) - lose("Unexpectedly large fixedobj allocation request"); - for ( ; hint_index <= limit; ++hint_index ) { -#ifdef __ATOMIC_SEQ_CST - __atomic_load(&page_hints[hint_index], &hint, __ATOMIC_SEQ_CST); -#else - hint = __sync_fetch_and_add(&page_hints[hint_index], 0); -#endif - if (hint_attributes(hint) == attributes) { - *page = hint_page(hint); - return hint_index; - } else if (hint == 0 && free_slot < 0) - free_slot = hint_index; - } - if (free_slot<0) - lose("Should not happen"); // TODO: evict a hint - // Linearly search for a free page from the beginning - int free_page = get_freeish_page(0, attributes); - *page = free_page; - int existing = __sync_val_compare_and_swap(&page_hints[free_slot], 0, - make_hint(free_page, attributes)); - if (existing) // collided. don't worry about it - return -1; - return free_slot; -} - -static void unset_hint(int page) -{ - int attributes = fixedobj_pages[page].attr.packed; - unsigned int size = (attributes >> 16) & 0xff; // mask off the generation bits - int hint_index = size - 2; - if (hint_page(page_hints[hint_index]) == page) - page_hints[hint_index] = 0; - if (hint_page(page_hints[hint_index+1]) == page) - page_hints[hint_index+1] = 0; -} +/// Size class is specified by lisp now +#define MAX_ALLOCATOR_SIZE_CLASSES 10 +long fixedobj_page_hint[MAX_ALLOCATOR_SIZE_CLASSES]; // Unused, but possibly will be for some kind of collision-avoidance scheme // on claiming of new free pages. @@ -311,15 +261,22 @@ masking. if the next address is above or equal to the page start, store it in the hint, otherwise mark the page full */ -static lispobj* alloc_immobile_obj(int page_attributes, lispobj header) +lispobj AMD64_SYSV_ABI +alloc_immobile_fixedobj(int size_class, int spacing_words, uword_t header) { - int hint_index, page; + size_class = fixnum_value(size_class); + spacing_words = fixnum_value(spacing_words); + header = fixnum_value(header); + + int page; lispobj word; char * page_data, * obj_ptr, * next_obj_ptr, * limit, * next_free; - int spacing_in_bytes = OBJ_SPACING(page_attributes) << WORD_SHIFT; + int page_attributes = MAKE_ATTR(spacing_words); + int spacing_in_bytes = spacing_words << WORD_SHIFT; const int npages = FIXEDOBJ_SPACE_SIZE / IMMOBILE_CARD_BYTES; - hint_index = get_hint(page_attributes, &page); + page = fixedobj_page_hint[size_class]; + if (!page) page = get_freeish_page(0, page_attributes); gc_dcheck(fixedobj_page_address(page) < (void*)fixedobj_free_pointer); do { page_data = fixedobj_page_address(page); @@ -335,7 +292,7 @@ // the next hole. Use it to update the freelist pointer. // Just slam it in. fixedobj_pages[page].free_index = next_obj_ptr + word - page_data; - return (lispobj*)obj_ptr; + return compute_lispobj((lispobj*)obj_ptr); } // If some other thread updated the free_index // to a larger value, use that. (See example below) @@ -346,11 +303,9 @@ int old_page = page; page = get_freeish_page(page+1 >= npages ? 0 : page+1, page_attributes); - if (hint_index >= 0) { // try to update the hint - __sync_val_compare_and_swap(page_hints + hint_index, - make_hint(old_page, page_attributes), - make_hint(page, page_attributes)); - } + // try to update the hint + __sync_val_compare_and_swap(&fixedobj_page_hint[size_class], + old_page, page); } while (1); } @@ -492,9 +447,9 @@ char* page_start_addr = PTR_ALIGN_DOWN(addr, IMMOBILE_CARD_BYTES); object_start = (lispobj*)(page_start_addr + obj_index * obj_spacing); valid = !fixnump(*object_start) - && (lispobj*)addr < object_start + fixedobj_page_obj_size(page_index) - && (properly_tagged_descriptor_p(addr, object_start) - || widetag_of(object_start) == FUNCALLABLE_INSTANCE_WIDETAG); + && (widetag_of(object_start) == FUNCALLABLE_INSTANCE_WIDETAG || + widetag_of(object_start) == FDEFN_WIDETAG || + properly_tagged_descriptor_p(addr, object_start)); } else { return 0; } @@ -774,11 +729,11 @@ // Scan a fixed-size object for old-to-young pointers. // Since fixed-size objects are boxed and on known boundaries, // we never start in the middle of random bytes, so the answer is exact. -static inline boolean +static boolean fixedobj_points_to_younger_p(lispobj* obj, int n_words, int gen, int keep_gen, int new_gen) { - lispobj layout, lbitmap; + lispobj layout; switch (widetag_of(obj)) { case FDEFN_WIDETAG: @@ -795,12 +750,14 @@ layout = instance_layout(obj); if (younger_p(layout, gen, keep_gen, new_gen)) return 1; - if ((lbitmap = LAYOUT(layout)->bitmap) != make_fixnum(-1)) { - gc_assert(fixnump(lbitmap)); // No bignums (yet) - sword_t bitmap = fixnum_value(lbitmap); + struct bitmap bitmap = get_layout_bitmap(LAYOUT(layout)); + gc_assert(bitmap.nwords == 1); + if (bitmap.bits[0] != (sword_t)-1) { + sword_t mask = bitmap.bits[0]; lispobj* where = obj + 1; - for ( ; --n_words ; ++where, bitmap >>= 1 ) - if ((bitmap & 1) != 0 && younger_p(*where, gen, keep_gen, new_gen)) + lispobj* limit = obj + n_words; + for ( ; where < limit ; ++where, mask >>= 1 ) + if ((mask & 1) != 0 && younger_p(*where, gen, keep_gen, new_gen)) return 1; return 0; } @@ -858,12 +815,12 @@ static inline boolean can_wp_fixedobj_page(page_index_t page, int keep_gen, int new_gen) { int obj_spacing = fixedobj_page_obj_align(page); - int obj_size_words = fixedobj_page_obj_size(page); lispobj* obj = fixedobj_page_address(page); lispobj* limit = compute_fixedobj_limit(obj, obj_spacing); do { if (!fixnump(*obj) && // an object header - fixedobj_points_to_younger_p(obj, obj_size_words, + fixedobj_points_to_younger_p(obj, + sizetab[widetag_of(obj)](obj), immobile_obj_generation(obj), keep_gen, new_gen)) return 0; @@ -942,7 +899,6 @@ // at the start of the prior GC, and subtracting from that the number // that exist now, we know how much usable space was obtained (per page). int n_holes = 0; - int word_idx; SETUP_GENS(); @@ -963,7 +919,6 @@ continue; } int obj_spacing = fixedobj_page_obj_align(page); - int obj_size_words = fixedobj_page_obj_size(page); page_base = fixedobj_page_address(page); limit = compute_fixedobj_limit(page_base, obj_spacing); obj = (lispobj*)page_base; @@ -989,17 +944,18 @@ hole = obj; n_holes ++; } else if ((gen = immobile_obj_gen_bits(obj)) == discard_gen) { // trash - for (word_idx=obj_size_words-1 ; word_idx > 0 ; --word_idx) - obj[word_idx] = 0; + memset(obj, 0, obj_spacing); goto trash_it; } else if (gen == keep_gen) { assign_generation(obj, gen = new_gen); #ifdef DEBUG - gc_assert(!fixedobj_points_to_younger_p(obj, obj_size_words, + gc_assert(!fixedobj_points_to_younger_p(obj, + sizetab[widetag_of(obj)](obj), gen, keep_gen, new_gen)); #endif any_kept = -1; - } else if (wp_it && fixedobj_points_to_younger_p(obj, obj_size_words, + } else if (wp_it && fixedobj_points_to_younger_p(obj, + sizetab[widetag_of(obj)](obj), gen, keep_gen, new_gen)) wp_it = 0; } while (NEXT_FIXEDOBJ(obj, obj_spacing) <= limit); @@ -1017,7 +973,6 @@ } } else { dprintf((logfile,"page %d is all garbage\n", page)); - unset_hint(page); fixedobj_pages[page].attr.packed = 0; } #ifdef DEBUG @@ -1025,6 +980,7 @@ #endif dprintf((logfile,"page %d: %d holes\n", page, n_holes)); } + memset(fixedobj_page_hint, 0, sizeof fixedobj_page_hint); } static void make_filler(void* where, int nbytes) @@ -1191,7 +1147,6 @@ for (page = 0; page <= FIXEDOBJ_RESERVED_PAGES; ++page) { // set page attributes that can't match anything in get_freeish_page() fixedobj_pages[page].attr.parts.obj_align = 1; - fixedobj_pages[page].attr.parts.obj_size = 1; if (gen != 0 && ENABLE_PAGE_PROTECTION) fixedobj_pages[page].attr.parts.flags = WRITE_PROTECT; fixedobj_pages[page].gens |= 1 << gen; @@ -1204,7 +1159,6 @@ if (!fixnump(header)) { gc_assert(other_immediate_lowtag_p(*obj)); int size = sizetab[header_widetag(header)](obj); - fixedobj_pages[page].attr.parts.obj_size = size; fixedobj_pages[page].attr.parts.obj_align = size; fixedobj_pages[page].gens |= 1 << immobile_obj_gen_bits(obj); if (gen != 0 && ENABLE_PAGE_PROTECTION) @@ -1377,6 +1331,13 @@ return 1; } +/// For defragmentation + +static struct tempspace { + char* start; + int n_bytes; +} fixedobj_tempspace, varyobj_tempspace; + // Find the object that encloses pointer. lispobj * search_immobile_space(void *pointer) @@ -1406,9 +1367,19 @@ if (page_attributes_valid && page_index >= FIXEDOBJ_RESERVED_PAGES) { int spacing = fixedobj_page_obj_align(page_index); int index = ((char*)pointer - page_base) / spacing; - char *begin = page_base + spacing * index; - char *end = begin + (fixedobj_page_obj_size(page_index) << WORD_SHIFT); - if ((char*)pointer < end) return (lispobj*)begin; + lispobj *obj = (void*)(page_base + spacing * index); + char* end; + /* When defragmenting, there are forwarding pointers in object headers + * so the sizing functions don't work. Following the forwarding pointer + * isn't right, because it points to where the object _will_ be, + * but it isn't actually there. So we have to conservatively assume + * that the object size is the object alignment. + * It all other situations, it is OK to call the sizing function. */ + if (fixedobj_tempspace.start) // defragmenting + end = (char*)obj + spacing; + else + end = (char*)(obj + sizetab[widetag_of(obj)](obj)); + if ((char*)pointer < end) return obj; } else { return gc_search_space((lispobj*)page_base, pointer); } @@ -1444,37 +1415,12 @@ } } -lispobj* AMD64_SYSV_ABI alloc_fixedobj(int nwords, uword_t header) -{ - return alloc_immobile_obj(MAKE_ATTR(ALIGN_UP(nwords,2), // spacing - ALIGN_UP(nwords,2), // size - 0), - header); -} - -static const int LAYOUT_NWORDS = sizeof (struct layout)/N_WORD_BYTES; - -lispobj AMD64_SYSV_ABI alloc_layout() -{ - lispobj* l = - alloc_immobile_obj(MAKE_ATTR(ALIGN_UP(LAYOUT_NWORDS,2), - ALIGN_UP(LAYOUT_NWORDS,2), - 0), - (LAYOUT_NWORDS-1)<header) == INSTANCE_WIDETAG); @@ -1605,13 +1540,6 @@ return native_layout; } -static lispobj follow_fp(lispobj ptr) -{ - if (forwarding_pointer_p(native_pointer(ptr))) - return forwarding_pointer_value(native_pointer(ptr)); - else - return ptr; -} static void apply_absolute_fixups(lispobj, struct code*); /// It's tricky to try to use the scavtab[] functions for fixing up moved @@ -1629,7 +1557,7 @@ gc_assert(!forwarding_pointer_p(where)); lispobj header_word = *where; if (!is_header(header_word)) { - adjust_words(where, 2, 0); // A cons. (It can only be filler?) + adjust_words(where, 2); // A cons. (It can only be filler?) where += 2; continue; } @@ -1640,18 +1568,20 @@ if (!leaf_obj_widetag_p(widetag)) lose("Unhandled widetag in fixup_space: %p", (void*)header_word); break; -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER - case FUNCALLABLE_INSTANCE_WIDETAG: -#endif case INSTANCE_WIDETAG: - instance_scan(adjust_words, where+1, size-1, - fix_object_layout(where)->bitmap, - 0); + case FUNCALLABLE_INSTANCE_WIDETAG: + { + lispobj* slots = where+1; + int i; + struct bitmap bitmap = get_layout_bitmap(fix_object_layout(where)); + for(i=0; i<(size-1); ++i) + if (bitmap_logbitp(i, bitmap)) adjust_words(slots+i, 1); + } break; case CODE_HEADER_WIDETAG: // Fixup the constant pool. code = (struct code*)where; - adjust_words(where+2, code_header_words(code)-2, 0); + adjust_words(where+2, code_header_words(code)-2); apply_absolute_fixups(code->fixups, code); break; case CLOSURE_WIDETAG: @@ -1661,17 +1591,17 @@ case FUNCALLABLE_INSTANCE_WIDETAG: #endif // skip the trampoline word at where[1] - adjust_words(where+2, size-2, 0); + adjust_words(where+2, size-2); break; case FDEFN_WIDETAG: - adjust_words(where+1, 2, 0); + adjust_words(where+1, 2); adjust_fdefn_raw_addr((struct fdefn*)where); break; // Special case because we might need to mark hashtables // as needing rehash. case SIMPLE_VECTOR_WIDETAG: - if (is_vector_subtype(header_word, VectorAddrHashing)) { + if (vector_flagp(header_word, VectorAddrHashing)) { struct vector* kv_vector = (struct vector*)where; lispobj* data = kv_vector->data; gc_assert(kv_vector->length >= 5); @@ -1692,16 +1622,14 @@ if (needs_rehash) KV_PAIRS_REHASH(data) |= make_fixnum(1); break; - } else { - // FALLTHROUGH_INTENDED } + // INTENTIONAL FALLTHROUGH // All the other array header widetags. case SIMPLE_ARRAY_WIDETAG: #ifdef COMPLEX_CHARACTER_STRING_WIDETAG case COMPLEX_CHARACTER_STRING_WIDETAG: #endif case COMPLEX_BASE_STRING_WIDETAG: - case COMPLEX_VECTOR_NIL_WIDETAG: case COMPLEX_BIT_VECTOR_WIDETAG: case COMPLEX_VECTOR_WIDETAG: case COMPLEX_ARRAY_WIDETAG: @@ -1714,7 +1642,7 @@ // Use the sizing functions for generality. // Symbols can contain strange header bytes, // and vectors might have a padding word, etc. - adjust_words(where+1, size-1, 0); + adjust_words(where+1, size-1); break; } where += size; @@ -1734,17 +1662,6 @@ } #if DEFRAGMENT_FIXEDOBJ_SUBSPACE -// This does not accept (SIMPLE-ARRAY NIL (*)) -// (You'd have a pretty bad time trying making a symbol like that) -static int schar(struct vector* string, int index) -{ -#ifdef LISP_FEATURE_SB_UNICODE - if (widetag_of(&string->header) == SIMPLE_CHARACTER_STRING_WIDETAG) - return ((int*)string->data)[index]; -#endif - return ((char*)string->data)[index]; -} - #include "genesis/package.h" #define N_SYMBOL_KINDS 5 @@ -1850,6 +1767,59 @@ *alloc_ptr = new + size_in_bytes; } +/// Like above, but specifically for layouts; +struct size_class { + char* alloc_ptr; + /* Initially this is a count of the number of layouts in the size class. + * After computing the total number of layout pages needed, this becomes a count + * of how many objects can be allocated starting from 'alloc_ptr' without + * overflowing the page. When zero, we grab the next available page. */ + int count; +}; + +/* Defragmentation needs more size classes than allocation because a + * restarted core can not discern the original (coarser) size class + * in which a layout was allocated. It can only use the actual size. + * 2n+14 words for N from 0..17 gives a range from 14 to 48 words */ +#define MAX_LAYOUT_DEFRAG_SIZE_CLASSES 18 +static inline int layout_size_class_nwords(int index) { + return 14 + 2*index ; +} +static inline int nwords_to_layout_size_class(unsigned int nwords) { + // the smallest layout size class is 14 words + int index = nwords <= 14 ? 0 : (nwords - 14)/2; + if (index >= MAX_LAYOUT_DEFRAG_SIZE_CLASSES) + lose("Oversized layout: can't defragment"); + return index; +} + +static void place_layout(lispobj* obj, + struct size_class size_classes[], + char** alloc_ptr, char *alloc_ptr_limit) +{ + // Layouts may occur in different sizes. + int nwords = 1 + (instance_length(*obj) | 1); + int size_class_index = nwords_to_layout_size_class(nwords); + if (size_classes[size_class_index].count == 0) { + gc_assert(*alloc_ptr <= alloc_ptr_limit); + size_classes[size_class_index].alloc_ptr = *alloc_ptr; + size_classes[size_class_index].count = (IMMOBILE_CARD_BYTES>>WORD_SHIFT) / nwords; + *alloc_ptr += IMMOBILE_CARD_BYTES; + } else { + gc_assert(size_classes[size_class_index].alloc_ptr != 0); + gc_assert(size_classes[size_class_index].count > 0); + } + size_classes[size_class_index].count--; + char* new = size_classes[size_class_index].alloc_ptr; + gc_assert(!*tempspace_addr(new)); + memcpy(tempspace_addr(new), obj, nwords*N_WORD_BYTES); + set_forwarding_pointer(obj, make_lispobj(new, INSTANCE_POINTER_LOWTAG)); + // Use nbytes for the defragmentation size class when bumping the pointer, + // and not the object spacing for the page on which obj resides. + size_classes[size_class_index].alloc_ptr += + layout_size_class_nwords(size_class_index) << WORD_SHIFT; +} + static void __attribute__((unused)) add_filler_if_needed(char* from, char* to) { if (to>from) @@ -1883,6 +1853,8 @@ struct { int size, count; } sym_kind_histo[N_SYMBOL_KINDS]; bzero(obj_type_histo, sizeof obj_type_histo); bzero(sym_kind_histo, sizeof sym_kind_histo); + struct size_class layout_size_class[MAX_LAYOUT_DEFRAG_SIZE_CLASSES]; + bzero(layout_size_class, sizeof layout_size_class); // Count the fdefns, trampolines, and GFs already in varyobj sapace. // There are 3 kinds of code objects we might see - @@ -1911,14 +1883,23 @@ lispobj word = *obj; if (!fixnump(word)) { int widetag = header_widetag(word); + int size = sizetab[widetag](obj); ++obj_type_histo[widetag/4]; - if (widetag == SYMBOL_WIDETAG) { + switch (widetag) { + case SYMBOL_WIDETAG: + { int kind = classify_symbol(obj); - int size = sizetab[widetag](obj); ++sym_kind_histo[kind].count; if (!sym_kind_histo[kind].size) sym_kind_histo[kind].size = size; gc_assert(sym_kind_histo[kind].size == size); + } + break; + case INSTANCE_WIDETAG: + gc_assert(layoutp(make_lispobj(obj, INSTANCE_POINTER_LOWTAG))); + int class_index = nwords_to_layout_size_class(size); + ++layout_size_class[class_index].count; + break; } } } while (NEXT_FIXEDOBJ(obj, obj_spacing) <= limit); @@ -1930,8 +1911,14 @@ // page order is: layouts, symbols, fdefns, trampolines, GFs // If the text segment is writable, then the last 3 of those are // moved into varyobj space. - int n_layout_pages = calc_n_fixedobj_pages(obj_type_histo[INSTANCE_WIDETAG/4], - LAYOUT_NWORDS); + int n_layout_pages = 0; + int class_index; + for (class_index = 0; class_index < MAX_LAYOUT_DEFRAG_SIZE_CLASSES; ++class_index) { + int count = layout_size_class[class_index].count; + n_layout_pages += calc_n_fixedobj_pages(count, layout_size_class_nwords(class_index)); + layout_size_class[class_index].count = 0; + } + char* layout_alloc_ptr = defrag_base; char* symbol_alloc_ptrs[N_SYMBOL_KINDS+1]; symbol_alloc_ptrs[0] = layout_alloc_ptr + n_layout_pages * IMMOBILE_CARD_BYTES; @@ -2097,7 +2084,12 @@ lispobj* limit = compute_fixedobj_limit(obj, obj_spacing); do { if (fixnump(*obj)) continue; - place_fixedobj(obj, obj_spacing, alloc_ptrs, symbol_alloc_ptrs); + if (widetag_of(obj) == INSTANCE_WIDETAG) { + place_layout(obj, layout_size_class, + &layout_alloc_ptr, symbol_alloc_ptrs[0]); + } else { + place_fixedobj(obj, obj_spacing, alloc_ptrs, symbol_alloc_ptrs); + } } while (NEXT_FIXEDOBJ(obj, obj_spacing) <= limit); } #if WRITABLE_TEXT_SEGMENT diff -Nru sbcl-2.0.6/src/runtime/interr.c sbcl-2.1.1/src/runtime/interr.c --- sbcl-2.0.6/src/runtime/interr.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/interr.c 2021-01-30 11:22:38.000000000 +0000 @@ -99,10 +99,7 @@ static void print_message(char *fmt, va_list ap) { - fprintf(stderr, " in SBCL pid %d",getpid()); -#if defined(LISP_FEATURE_SB_THREAD) - fprintf(stderr, "(tid %p)", (void*)thread_self()); -#endif + fprintf(stderr, " in SBCL pid %d" THREAD_ID_LABEL, getpid(), THREAD_ID_VALUE); if (fmt) { fprintf(stderr, ":\n"); vfprintf(stderr, fmt, ap); @@ -137,6 +134,32 @@ call_lossage_handler(); } +#if 0 +/// thread printf. This was used to produce the 2-column output +/// at the bottom of "src/code/final". The main thread'd os_kernel_tid +/// must be assigned a constant in main_thread_trampoline(). +void tprintf(char *fmt, ...) +{ + va_list ap; + char buf[200]; + char *ptr; + const char spaces[] = " "; + struct thread*th = arch_os_get_current_thread(); + buf[0] = ';'; buf[1] = ' '; + ptr = buf+2; + if (th->os_kernel_tid == 'A') { + strcpy(ptr, spaces); + ptr += (sizeof spaces)-1; + } + va_start(ap, fmt); + int n = vsprintf(ptr, fmt, ap); + va_end(ap); + ptr += n; + *ptr++ = '\n'; + write(2, buf, ptr-buf); +} +#endif + boolean lose_on_corruption_p = 0; void @@ -203,7 +226,7 @@ // value, and therefore shifting right by 13 bits extracts a 0. // Internal error number 0 has 0 arguments, so we skip nothing in the varint // decoder loop, which is the right thing for the wrong reason. - u32 trap_instruction = *(u32 *)ptr; + uint32_t trap_instruction = *(uint32_t *)ptr; unsigned char code = trap_instruction >> 13 & 0xFF; ptr += 4; #else @@ -235,7 +258,7 @@ unsigned char code; #ifdef LISP_FEATURE_ARM64 - u32 trap_instruction = *(u32 *)ptr; + uint32_t trap_instruction = *(uint32_t *)ptr; code = trap_instruction >> 13 & 0xFF; ptr += 4; #else @@ -319,26 +342,3 @@ } } } - -/* utility routines used by miscellaneous pieces of code */ - -lispobj debug_print(lispobj string) -{ - /* This is a kludge. It's not actually safe - in general - to use - %primitive print on the alpha, because it skips half of the - number stack setup that should usually be done on a function - call, so the called routine (i.e. this one) ends up being able - to overwrite local variables in the caller. Rather than fix - this everywhere that %primitive print is used (it's only a - debugging aid anyway) we just guarantee our safety by putting - an unused buffer on the stack before doing anything else - here */ - char untouched[32]; - if (header_widetag(VECTOR(string)->header) != SIMPLE_BASE_STRING_WIDETAG) - fprintf(stderr, "debug_print: can't display string\n"); - else - fprintf(stderr, "%s\n", (char *)(VECTOR(string)->data)); - /* shut GCC up about not using this, because that's the point.. */ - (void)untouched; - return NIL; -} diff -Nru sbcl-2.0.6/src/runtime/interr.h sbcl-2.1.1/src/runtime/interr.h --- sbcl-2.0.6/src/runtime/interr.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/interr.h 2021-01-30 11:22:38.000000000 +0000 @@ -17,6 +17,7 @@ __attribute__((format(printf,1,2))) // clang and gcc support this, MSVC doesn't #endif never_returns; +extern void tprintf(char *fmt, ...); extern boolean lose_on_corruption_p; extern void corruption_warning_and_maybe_lose(char *fmt, ...); extern void enable_lossage_handler(void); @@ -24,8 +25,12 @@ extern void describe_internal_error(os_context_t *context); extern void skip_internal_error (os_context_t *context); -extern lispobj debug_print(lispobj string); - +#ifdef LISP_FEATURE_WIN32 +/* thread ID is a more useful identifer than thread handle */ +#define UNKNOWN_STACK_POINTER_ERROR(function_name, thread) \ + lose(function_name": no SP known for thread %p (ID %p)", \ + thread, (void*)thread->os_kernel_tid); +#else /* Portably printf()ing a pthread_t is tricky. It has to be printed * as opaque bytes by taking &id and sizeof id. * As the man page says: @@ -38,10 +43,11 @@ * pthread_t to the list of types that are not required to be arithmetic types, * thus allowing pthread_t to be defined as a structure." * - * We assume that it can be cast to 'long' which is a total KLUDGE + * We assume that it can be cast to 'void*' */ #define UNKNOWN_STACK_POINTER_ERROR(function_name, thread) \ - lose(function_name": no SP known for thread %p (OS %ld)", \ - thread, (long)thread->os_thread); + lose(function_name": no SP known for thread %p (pthread %p)", \ + thread, (void*)thread->os_thread); +#endif #endif diff -Nru sbcl-2.0.6/src/runtime/interrupt.c sbcl-2.1.1/src/runtime/interrupt.c --- sbcl-2.0.6/src/runtime/interrupt.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/interrupt.c 2021-01-30 11:22:38.000000000 +0000 @@ -33,10 +33,10 @@ * the value from interrupt_low_level_handlers[..], instead of the * ordinary interrupt_handle_now(..) or interrupt_handle_later(..). * - * o the SIGTRAP (Linux/Alpha) which Lisp code uses to handle breakpoints, + * o the SIGTRAP which Lisp code may uses to handle breakpoints, * pseudo-atomic sections, and some classes of error (e.g. "function * not defined"). This never goes anywhere near the Lisp handlers at all. - * See runtime/alpha-arch.c and code/signal.lisp + * See src/code/signal.lisp * * - WHN 20000728, dan 20010128 */ @@ -69,6 +69,16 @@ #include "genesis/cons.h" #include "genesis/vector.h" +#ifdef ATOMIC_LOGGING +#include "atomiclog.inc" +uword_t *eventdata; +int n_logevents; +#endif + +#ifdef ADDRESS_SANITIZER +#include +#endif + /* * This is a workaround for some slightly silly Linux/GNU Libc * behaviour: glibc defines sigset_t to support 1024 signals, which is @@ -96,6 +106,9 @@ static inline void sigcopyset(sigset_t *new, sigset_t *old) { +#ifdef ADDRESS_SANITIZER + sigemptyset(new); +#endif memcpy(new, old, REAL_SIGSET_SIZE_BYTES); } @@ -112,7 +125,7 @@ static void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, os_context_t*); #endif -union interrupt_handler interrupt_handlers[NSIG]; +lispobj lisp_sig_handlers[NSIG]; /* Under Linux on some architectures, we appear to have to restore the * FPU control word from the context, as after the signal is delivered @@ -171,56 +184,61 @@ /* Foreign code may want to start some threads on its own. * Non-targetted, truly asynchronous signals can be delivered to - * basically any thread, but invoking Lisp handlers in such foregign + * basically any thread, but invoking Lisp handlers in such foreign * threads is really bad, so let's resignal it. * * This should at least bring attention to the problem, but it cannot * work for SIGSEGV and similar. It is good enough for timers, and * maybe all deferrables. */ -#ifndef LISP_FEATURE_WIN32 +#if defined LISP_FEATURE_DARWIN && defined LISP_FEATURE_SB_THREAD +pthread_key_t sigwait_bug_mitigation; +int sigwait_bug_mitigation_count; +#endif + +#ifdef LISP_FEATURE_WIN32 +#define resignal_to_lisp_thread(dummy1,dummy2) {} +#else static void -add_handled_signals(sigset_t *sigset) +resignal_to_lisp_thread(int signal, os_context_t *context) { - int i; - for(i = 1; i < NSIG; i++) { - if (!(ARE_SAME_HANDLER(interrupt_low_level_handlers[i], SIG_DFL)) || - !(ARE_SAME_HANDLER(interrupt_handlers[i].c, SIG_DFL))) { - sigaddset(sigset, i); - } +#if defined LISP_FEATURE_DARWIN && defined LISP_FEATURE_SB_THREAD + if (signal == SIG_STOP_FOR_GC && pthread_getspecific(sigwait_bug_mitigation)) { + // fprintf(stderr, "ignored a STOP_FOR_GC signal\n"); + __sync_fetch_and_add(&sigwait_bug_mitigation_count, 1); + pthread_setspecific(sigwait_bug_mitigation, 0); + return; } -} #endif - -static boolean -maybe_resignal_to_lisp_thread(int signal, os_context_t *context) -{ -#ifndef LISP_FEATURE_WIN32 - if (!lisp_thread_p(context)) { - if (!(sigismember(&deferrable_sigset,signal))) { - corruption_warning_and_maybe_lose + if (!sigismember(&deferrable_sigset,signal)) { + corruption_warning_and_maybe_lose #ifdef LISP_FEATURE_SB_THREAD - ("Received signal %d in non-lisp thread %lu, resignalling to a lisp thread.", - signal, pthread_self()); + ("Received signal %d @ %lx in non-lisp"THREAD_ID_LABEL", resignaling to a lisp thread.", + signal, *os_context_pc_addr(context), THREAD_ID_VALUE); #else - ("Received signal %d in non-lisp thread, resignalling to a lisp thread.", - signal); + ("Received signal %d in non-lisp thread, resignaling to a lisp thread.", signal); #endif + } + sigset_t sigset; + sigemptyset(&sigset); + int i; + for(i = 1; i < NSIG; i++) { + // This use of SIG_DFL is a bit disingenous. It actually means "is it 0", + // because the low_level_handlers array is never explicitly initialized + // with SIG_DFL in each element, but SIG_DFL happens to be 0. + if (!ARE_SAME_HANDLER(interrupt_low_level_handlers[i], SIG_DFL) + || lisp_sig_handlers[i]) { + sigaddset(&sigset, i); } - sigset_t sigset; - sigemptyset(&sigset); - add_handled_signals(&sigset); - thread_sigmask(SIG_BLOCK, &sigset, 0); - // This arranges for every handled signal to be blocked on return from this - // handler invocation, presumably because that avoids further detours through - // this thread's handler for signals that we don't want it to handle. - sigmask_logior(os_context_sigmask_addr(context), &sigset); - kill(getpid(), signal); - return 1; - } else -#endif - return 0; + } + thread_sigmask(SIG_BLOCK, &sigset, 0); + // This arranges for every handled signal to be blocked on return from this + // handler invocation, presumably because that avoids further detours through + // this thread's handler for signals that we don't want it to handle. + sigmask_logior(os_context_sigmask_addr(context), &sigset); + kill(getpid(), signal); } +#endif #if INSTALL_SIG_MEMORY_FAULT_HANDLER && defined(THREAD_SANITIZER) /* Under TSAN, any delivered signal blocks all other signals regardless of the @@ -245,15 +263,26 @@ # define UNBLOCK_SIGSEGV() {} #endif +/* Not safe in general, but if your thread names are all + * simple-base-string and won't move, this is slightly ok */ +__attribute__((unused)) static char* cur_thread_name() +{ + struct thread* th = arch_os_get_current_thread(); + struct thread_instance *lispthread = + (void*)(th->lisp_thread - INSTANCE_POINTER_LOWTAG); + struct vector* name = VECTOR(lispthread->name); + if (widetag_of(&name->header) == SIMPLE_BASE_STRING_WIDETAG) return (char*)name->data; + return "?"; +} + /* These are to be used in signal handlers. Currently all handlers are * called from one of: * * interrupt_handle_now_handler * maybe_now_maybe_later * low_level_handle_now_handler - * low_level_maybe_now_maybe_later * - * This gives us a single point of control (or six) over errno, fp + * This gives us a single point of control (or three) over errno, fp * control word, and fixing up signal context on sparc. * * The SPARC/Linux platform doesn't quite do signals the way we want @@ -261,37 +290,61 @@ * kernel properly, so we fix it up ourselves in the * arch_os_get_context(..) function. -- CSR, 2002-07-23 */ +#ifdef ATOMIC_LOGGING +void dump_eventlog() +{ + int i = 0; + uword_t *e = eventdata; + while (ios_kernel_tid); +} +#define RECORD_SIGNAL(sig,ctxt) if(sig!=SIGSEGV)record_signal(sig,ctxt); +#else +#define RECORD_SIGNAL(sig,ctxt) +#endif + +#ifdef LISP_FEATURE_WIN32 +# define should_handle_in_this_thread(c) (1) +#else +# define should_handle_in_this_thread(c) lisp_thread_p(c) +#endif #define SAVE_ERRNO(signal,context,void_context) \ { \ int _saved_errno = errno; \ + RECORD_SIGNAL(signal,void_context); \ UNBLOCK_SIGSEGV(); \ RESTORE_FP_CONTROL_WORD(context,void_context); \ - if (!maybe_resignal_to_lisp_thread(signal, context)) \ - { + if (should_handle_in_this_thread(context)) { #define RESTORE_ERRNO \ - } \ + } else resignal_to_lisp_thread(signal,void_context); \ errno = _saved_errno; \ } static void run_deferred_handler(struct interrupt_data *data, os_context_t *context); #if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) -static void store_signal_data_for_later (struct interrupt_data *data, - void *handler, int signal, - siginfo_t *info, - os_context_t *context); /* Generic signal related utilities. */ -void -get_current_sigmask(sigset_t *sigset) -{ - /* Get the current sigmask, by blocking the empty set. */ - thread_sigmask(SIG_BLOCK, 0, sigset); -} - // Stringify sigset into the supplied result buffer. void sigset_tostring(const sigset_t *sigset, char* result, int result_length) @@ -309,39 +362,6 @@ } result[len] = 0; } - -/* Return 1 if all signals in sigset2 are masked in sigset, return 0 - * if all are unmasked, else die. Passing NULL for sigset is a shorthand - * for the current sigmask. */ -boolean -all_signals_blocked_p(const sigset_t *sigset, sigset_t *sigset2, - const char *name) -{ - int i; - boolean has_blocked = 0, has_unblocked = 0; - sigset_t current; - if (sigset == 0) { - get_current_sigmask(¤t); - sigset = ¤t; - } - for(i = 1; i <= MAX_SIGNUM; i++) { - if (sigismember(sigset2, i)) { - if (sigismember(sigset, i)) - has_blocked = 1; - else - has_unblocked = 1; - } - } - if (has_blocked && has_unblocked) { - char buf[3*64]; // assuming worst case 64 signals present in sigset - sigset_tostring(sigset, buf, sizeof buf); - lose("%s signals partially blocked: {%s}", name, buf); - } - if (has_blocked) - return 1; - else - return 0; -} /* Deferrables, blockables, gc signals. */ @@ -353,7 +373,6 @@ sigaddset(s, SIGINT); sigaddset(s, SIGTERM); sigaddset(s, SIGQUIT); - sigaddset(s, SIGPIPE); sigaddset(s, SIGALRM); sigaddset(s, SIGURG); sigaddset(s, SIGTSTP); @@ -363,23 +382,16 @@ #else sigaddset(s, SIGPOLL); #endif -#ifndef LISP_FEATURE_HPUX +#ifndef LISP_FEATURE_BACKTRACE_ON_SIGNAL sigaddset(s, SIGXCPU); - sigaddset(s, SIGXFSZ); #endif + sigaddset(s, SIGXFSZ); sigaddset(s, SIGVTALRM); sigaddset(s, SIGPROF); sigaddset(s, SIGWINCH); } -void -sigaddset_blockable(sigset_t *sigset) -{ - sigaddset_deferrable(sigset); - sigaddset_gc(sigset); -} - -void +static void sigaddset_gc(sigset_t __attribute__((unused)) *sigset) { #ifdef THREADS_USING_GCSIGNAL @@ -387,15 +399,75 @@ #endif } +void +sigaddset_blockable(sigset_t *sigset) +{ + sigaddset_deferrable(sigset); + sigaddset_gc(sigset); + // SIGPIPE is *NOT* an asynchronous signal. In normal usage you receive this signal + // synchronously in response to a system call. As such we do not place it in the + // deferrable set, but it _is_ blockable. If you're doing something wherein SIGPIPE + // interrupts a pseudo-atomic section, then you're doing something wrong for sure. + sigaddset(sigset, SIGPIPE); +} + /* initialized in interrupt_init */ sigset_t deferrable_sigset; sigset_t blockable_sigset; +/* gc_sigset will have exactly 1 bit on, for SIG_STOP_FOR_GC, or no bits on. + * We always use SIGUSR2 as SIG_STOP_FOR_GC, though in days past it may have + * varied by OS. Also, long ago, there was a different signal to resume after + * suspension, but now we use a semaphore for that, which is technically + * on shaky ground, but seems to work. e.g. consider an implementation of + * of sem_wait that requires a call to malloc; it could fail badly for us */ sigset_t gc_sigset; +/* Return 1 if almost all deferrable signals are blocked, 0 if not, + * and fail if there is a mixture. Explicitly ignore SIGALRM which we now + * allow to be always blocked in a thread and/or manipulated. + * Also don't bother with ones guarded by #ifdef in sigaddset_deferrable + * (SIGIO, SIGPOLL, SIGXCPU). + * The intent is to perform a best-effort check that the runtime's assumptions + * are not egregiously violated, not to enforce proper use of each and every signal. + * (Who would add a SIGTSTP handler that is not completely async safe anyway?) + */ boolean deferrables_blocked_p(sigset_t *sigset) { - return all_signals_blocked_p(sigset, &deferrable_sigset, "deferrable"); + sigset_t current; + if (sigset == 0) { + thread_sigmask(SIG_BLOCK, 0, ¤t); + sigset = ¤t; + } + /* SIGPROF must not be here. Some people use an async-signal-safe profiler + * which not only doesn't rely on signal deferral, but wants to manipulate the + * blocked/unblocked bit completely independently of SBCL's requirements. + * Such usage would have needed to either modify the global deferrable_sigset + * at runtime, or locally patch it out of sigaddset_deferrable. + * I'd prefer to remove external access to deferrable_sigset which suggests that + * this predicate should be insensitive to whether SIGPROF is deferrable. + * The actual deferral mechanmism still works, because remember, this test does + * not affect behavior of correct code - it is just to decide whether we understand + * the signal mask to be in a valid state, but it was overly restrictive. + * + * Also SIGPWR is conspicuously absent. SB-THREAD:INTERRUPT-THREAD used it long ago, + * but I don't know why it was never in sigaddset_deferrable. + */ + int mask = (sigismember(sigset, SIGHUP) << 10) | + (sigismember(sigset, SIGINT) << 9) | + (sigismember(sigset, SIGTERM) << 8) | + (sigismember(sigset, SIGQUIT) << 7) | + (sigismember(sigset, SIGURG) << 6) | + (sigismember(sigset, SIGTSTP) << 5) | + (sigismember(sigset, SIGCHLD) << 4) | + (sigismember(sigset, SIGXFSZ) << 3) | + (sigismember(sigset, SIGVTALRM) << 2) | + (sigismember(sigset, SIGWINCH) << 1); + if (mask == 0x7fe) return 1; + if (!mask) return 0; + char buf[3*64]; // assuming worst case 64 signals present in sigset + sigset_tostring(sigset, buf, sizeof buf); + lose("deferrable signals partially blocked: {%s}", buf); } #endif @@ -417,25 +489,7 @@ #endif } -#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) -boolean -blockables_blocked_p(sigset_t *sigset) -{ - return all_signals_blocked_p(sigset, &blockable_sigset, "blockable"); -} -#endif - -void -check_blockables_unblocked_or_lose(sigset_t *sigset) -{ -#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) - if (blockables_blocked_p(sigset)) - lose("blockables blocked"); -#endif -} - -void -check_blockables_blocked_or_lose(sigset_t *sigset) +static void assert_blockables_blocked() { #if !defined(LISP_FEATURE_WIN32) /* On Windows, there are no actual signals, but since the win32 port @@ -456,36 +510,39 @@ * So we merely skip this assertion. * -- DFL, trying to expand on a comment by AK. */ - if (!blockables_blocked_p(sigset)) + sigset_t mask; + thread_sigmask(SIG_BLOCK, 0, &mask); + /* Test a representative bit from each set of signals of interest: + * (1) stop-for-GC + * (2) other blockable asynchronous signals + * (3) other blockable synchronous signals (SIGPIPE) + * If the representative bit is in the mask, say the whole set is. + * Since this is just a check of an invariant which correct execution + * will always adhere to, there is not much additional advantage to + * looking at all the signal bits, unlike the situation where the + * mask test is used as a predicate to decide on control flow. + */ + if (!( +#ifdef THREADS_USING_GCSIGNAL + sigismember(&mask, SIG_STOP_FOR_GC) && // (1) +#endif + sigismember(&mask, SIGHUP) && // (2) + sigismember(&mask, SIGPIPE))) // (3) lose("blockables unblocked"); #endif } #ifndef LISP_FEATURE_SB_SAFEPOINT -#if !defined(LISP_FEATURE_WIN32) -boolean -gc_signals_blocked_p(sigset_t *sigset) -{ - return all_signals_blocked_p(sigset, &gc_sigset, "gc"); -} -#endif - void check_gc_signals_unblocked_or_lose(sigset_t *sigset) { -#if !defined(LISP_FEATURE_WIN32) - if (gc_signals_blocked_p(sigset)) + sigset_t current; + if (!sigset) { + thread_sigmask(SIG_BLOCK, 0, ¤t); + sigset = ¤t; + } + if (sigismember(sigset, SIG_STOP_FOR_GC)) lose("gc signals blocked"); -#endif -} - -void -check_gc_signals_blocked_or_lose(sigset_t *sigset) -{ -#if !defined(LISP_FEATURE_WIN32) - if (!gc_signals_blocked_p(sigset)) - lose("gc signals unblocked"); -#endif } #endif @@ -521,10 +578,22 @@ // fetch the current signal mask (from the OS) and check that. check_gc_signals_unblocked_or_lose(where); #endif + sigset_t localmask, *sigset; + if (arch_os_get_current_thread()->state_word.user_thread_p) { + sigset = &deferrable_sigset; + } else { + /* ASSUMPTION: the baseline signal mask for non-user threads + * is the deferrable mask minus SIGALRM. + * Actually, if we get here in the finalizer thread, things are + * in bad shape - stack exhaustion or something */ + localmask = deferrable_sigset; + sigdelset(&localmask, SIGALRM); + sigset = &localmask; + } if (where) - sigmask_logandc(where, &deferrable_sigset); + sigmask_logandc(where, sigset); else - thread_sigmask(SIG_UNBLOCK, &deferrable_sigset, 0); + thread_sigmask(SIG_UNBLOCK, sigset, 0); #endif } @@ -542,12 +611,12 @@ #if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) sigset_t *sigset = os_context_sigmask_addr(context); #ifndef LISP_FEATURE_SB_SAFEPOINT - if (all_signals_blocked_p(sigset, &gc_sigset, "gc")) { + if (sigismember(sigset, SIG_STOP_FOR_GC)) { corruption_warning_and_maybe_lose( "Enabling blocked gc signals to allow returning to Lisp without risking\n\ gc deadlocks. Since GC signals are only blocked in signal handlers when \n\ they are not safe to interrupt at all, this is a pretty severe occurrence.\n"); - sigmask_logandc(sigset, &gc_sigset); + sigdelset(sigset, SIG_STOP_FOR_GC); } #endif if (!interrupt_handler_pending_p()) { @@ -578,7 +647,7 @@ { #ifndef LISP_FEATURE_WIN32 struct thread *thread = arch_os_get_current_thread(); - struct interrupt_data *data = thread->interrupt_data; + struct interrupt_data *data = &thread_interrupt_data(thread); sigset_t oldset; /* Obviously, this function is called when signals may not be * blocked. Let's make sure we are not interrupted. */ @@ -604,7 +673,7 @@ * unblock gc signals. In the end, this is equivalent to * blocking the deferrables. */ sigcopyset(&data->pending_mask, &oldset); - thread_sigmask(SIG_UNBLOCK, &gc_sigset, 0); + unblock_gc_signals(); return; } } @@ -630,12 +699,12 @@ } /* Check our baroque invariants. */ -void +static void check_interrupt_context_or_lose(os_context_t *context) { #if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) struct thread *thread = arch_os_get_current_thread(); - struct interrupt_data *data = thread->interrupt_data; + struct interrupt_data *data = &thread_interrupt_data(thread); int interrupt_deferred_p = (data->pending_handler != 0); int interrupt_pending = (read_TLS(INTERRUPT_PENDING,thread) != NIL); sigset_t *sigset = os_context_sigmask_addr(context); @@ -775,15 +844,11 @@ /* Stores the context for gc to scavange and builds fake stack * frames. */ -void -fake_foreign_function_call(os_context_t *context) +void fake_foreign_function_call_noassert(os_context_t *context) { int context_index; struct thread *thread=arch_os_get_current_thread(); - /* context_index incrementing must not be interrupted */ - check_blockables_blocked_or_lose(0); - #ifdef reg_ALLOC #ifdef LISP_FEATURE_SB_THREAD thread->pseudo_atomic_bits = @@ -794,17 +859,11 @@ (*os_context_register_addr(context, reg_ALLOC)); /* fprintf(stderr,"dynamic_space_free_pointer: %p\n", */ /* dynamic_space_free_pointer); */ -#if defined(LISP_FEATURE_ALPHA) || defined(LISP_FEATURE_MIPS) +#if defined(LISP_FEATURE_MIPS) if ((sword_t)dynamic_space_free_pointer & 1) { lose("dead in fake_foreign_function_call, context = %x", context); } #endif -/* why doesnt PPC and SPARC do something like this: */ -#if defined(LISP_FEATURE_HPPA) - if ((sword_t)dynamic_space_free_pointer & 4) { - lose("dead in fake_foreign_function_call, context = %x, d_s_f_p = %x", context, dynamic_space_free_pointer); - } -#endif #endif #ifdef reg_BSP set_binding_stack_pointer(thread, @@ -825,10 +884,8 @@ context_index = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,thread)); - if (context_index >= (MAX_INTERRUPTS-THREAD_HEADER_SLOTS)) { - lose("maximum interrupt nesting depth (%d) exceeded", - MAX_INTERRUPTS-THREAD_HEADER_SLOTS); - } + if (context_index >= MAX_INTERRUPTS) + lose("maximum interrupt nesting depth (%d) exceeded", MAX_INTERRUPTS); bind_variable(FREE_INTERRUPT_CONTEXT_INDEX, make_fixnum(context_index + 1),thread); @@ -842,6 +899,12 @@ foreign_function_call_active_p(thread) = 1; #endif } +void fake_foreign_function_call(os_context_t *context) +{ + /* context_index incrementing must not be interrupted */ + assert_blockables_blocked(); + fake_foreign_function_call_noassert(context); +} /* blocks all blockable signals. If you are calling from a signal handler, * the usual signal mask will be restored from the context when the handler @@ -944,14 +1007,16 @@ boolean interrupt_handler_pending_p(void) { - struct thread *thread = arch_os_get_current_thread(); - struct interrupt_data *data = thread->interrupt_data; + struct interrupt_data *data = &thread_interrupt_data(arch_os_get_current_thread()); return (data->pending_handler != 0); } void interrupt_handle_pending(os_context_t *context) { +#ifdef ADDRESS_SANITIZER + __asan_unpoison_memory_region(context, sizeof *context); +#endif /* There are three ways we can get here. First, if an interrupt * occurs within pseudo-atomic, it will be deferred, and we'll * trap to here at the end of the pseudo-atomic block. Second, if @@ -971,7 +1036,7 @@ * pending asynchronous tasks. */ struct thread *thread = arch_os_get_current_thread(); - struct interrupt_data *data = thread->interrupt_data; + struct interrupt_data *data = &thread_interrupt_data(thread); if (arch_pseudo_atomic_atomic(context)) { lose("Handling pending interrupt in pseudo atomic."); @@ -979,7 +1044,7 @@ FSHOW_SIGNAL((stderr, "/entering interrupt_handle_pending\n")); - check_blockables_blocked_or_lose(0); + assert_blockables_blocked(); #ifndef LISP_FEATURE_SB_SAFEPOINT /* * (On safepoint builds, there is no gc_blocked_deferrables nor @@ -1077,7 +1142,7 @@ lose("Trapping to run pending handler while GC in progress."); } - check_blockables_blocked_or_lose(0); + assert_blockables_blocked(); /* No GC shall be lost. If SUB_GC triggers another GC then * that should be handled on the spot. */ @@ -1139,88 +1204,55 @@ interrupt_handle_now(int signal, siginfo_t *info, os_context_t *context) { boolean were_in_lisp; - union interrupt_handler handler; + lispobj handler = lisp_sig_handlers[signal]; + + if (!functionp(handler)) return; - check_blockables_blocked_or_lose(0); + assert_blockables_blocked(); #if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) if (sigismember(&deferrable_sigset,signal)) check_interrupts_enabled_or_lose(context); #endif - handler = interrupt_handlers[signal]; - - if (ARE_SAME_HANDLER(handler.c, SIG_IGN)) { - return; - } - were_in_lisp = !foreign_function_call_active_p(arch_os_get_current_thread()); if (were_in_lisp) { - fake_foreign_function_call(context); + // Use the variant of fake_ffc that doesn't do another pthread_sigmask syscall, + // as we've just asserted that signals are blocked. + fake_foreign_function_call_noassert(context); } - FSHOW_SIGNAL((stderr, - "/entering interrupt_handle_now(%d, info, context)\n", - signal)); - - if (ARE_SAME_HANDLER(handler.c, SIG_DFL)) { - - /* This can happen if someone tries to ignore or default one - * of the signals we need for runtime support, and the runtime - * support decides to pass on it. */ - lose("no handler for signal %d in interrupt_handle_now(..)", signal); - - // BUG: if a C function pointer can be misaligned such that it - // looks to satisfy functionp() then we do the wrong thing. - } else if (functionp(handler.lisp)) { /* Once we've decided what to do about contexts in a * return-elsewhere world (the original context will no longer * be available; should we copy it or was nobody using it anyway?) * then we should convert this to return-elsewhere */ -#ifndef LISP_FEATURE_SB_SAFEPOINT +#if !defined(LISP_FEATURE_SB_SAFEPOINT) && defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK) /* Leave deferrable signals blocked, the handler itself will * allow signals again when it sees fit. */ -#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK /* handler.lisp will hide from the GC, will be enabled in the handler itself. * Not a problem for the conservative GC. */ unblock_gc_signals(); #endif -#else + WITH_GC_AT_SAFEPOINTS_ONLY() -#endif { // the block is needed for WITH_GC_AT_SAFEPOINTS_ONLY() to work DX_ALLOC_SAP(context_sap, context); DX_ALLOC_SAP(info_sap, info); FSHOW_SIGNAL((stderr,"/calling Lisp-level handler\n")); - funcall3(handler.lisp, + funcall3(handler, make_fixnum(signal), info_sap, context_sap); } - } else { - /* This cannot happen in sane circumstances. */ - - FSHOW_SIGNAL((stderr,"/calling C-level handler\n")); - -#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) - /* Allow signals again. */ - thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); - (*handler.c)(signal, info, context); -#endif - } if (were_in_lisp) { undo_fake_foreign_function_call(context); /* block signals again */ } - - FSHOW_SIGNAL((stderr, - "/returning from interrupt_handle_now(%d, info, context)\n", - signal)); } /* This is called at the end of a critical section if the indications @@ -1244,21 +1276,49 @@ } #ifndef LISP_FEATURE_WIN32 -boolean -maybe_defer_handler(void *handler, struct interrupt_data *data, - int signal, siginfo_t *info, os_context_t *context) +static void +store_signal_data_for_later (struct interrupt_data *data, void *handler, + int signal, + siginfo_t *info, os_context_t *context) { - struct thread *thread=arch_os_get_current_thread(); + if (!context || !handler || data->pending_handler) + lose("can't defer signal: context=%p handler=%p pending=%p", + context, handler, data->pending_handler); + data->pending_handler = handler; + data->pending_signal = signal; + if (info) + memcpy(&data->pending_info, info, sizeof *info); + else + memset(&data->pending_info, 0, sizeof *info); + /* the signal mask in the context (from before we were + * interrupted) is copied to be restored when run_deferred_handler + * happens. Then the usually-blocked signals are added to the mask + * in the context so that we are running with blocked signals when + * the handler returns */ + sigcopyset(&data->pending_mask, os_context_sigmask_addr(context)); + sigaddset_deferrable(os_context_sigmask_addr(context)); +} - check_blockables_blocked_or_lose(0); +static boolean +can_handle_now(void *handler, struct interrupt_data *data, + int signal, siginfo_t *info, os_context_t *context) +{ +#ifdef DEBUG + // All this might prove is that you set sa_mask correctly when calling + // sigaction. That's not worth an extra system call. + assert_blockables_blocked(); +#endif + + struct thread *thread = arch_os_get_current_thread(); if (read_TLS(INTERRUPT_PENDING,thread) != NIL) lose("interrupt already pending"); - if (thread->interrupt_data->pending_handler) + if (thread_interrupt_data(thread).pending_handler) lose("there is a pending handler already (PA)"); if (data->gc_blocked_deferrables) - lose("maybe_defer_handler: gc_blocked_deferrables true"); + lose("can_handle_now: gc_blocked_deferrables true"); + int answer = 1; /* If interrupts are disabled then INTERRUPT_PENDING is set and * not PSEDUO_ATOMIC_INTERRUPTED. This is important for a pseudo * atomic section inside a WITHOUT-INTERRUPTS. @@ -1270,63 +1330,28 @@ if ((read_TLS(INTERRUPTS_ENABLED,thread) == NIL) || in_leaving_without_gcing_race_p(thread)) { FSHOW_SIGNAL((stderr, - "/maybe_defer_handler(%p,%d): deferred (RACE=%d)\n", + "/can_handle_now(%p,%d): deferred (RACE=%d)\n", handler,signal, in_leaving_without_gcing_race_p(thread))); store_signal_data_for_later(data,handler,signal,info,context); write_TLS(INTERRUPT_PENDING, T,thread); - check_interrupt_context_or_lose(context); - return 1; + answer = 0; } /* a slightly confusing test. arch_pseudo_atomic_atomic() doesn't * actually use its argument for anything on x86, so this branch * may succeed even when context is null (gencgc alloc()) */ - if (arch_pseudo_atomic_atomic(context)) { + else if (arch_pseudo_atomic_atomic(context)) { FSHOW_SIGNAL((stderr, - "/maybe_defer_handler(%p,%d): deferred(PA)\n", + "/can_handle_now(%p,%d): deferred(PA)\n", handler,signal)); store_signal_data_for_later(data,handler,signal,info,context); arch_set_pseudo_atomic_interrupted(context); - check_interrupt_context_or_lose(context); - return 1; + answer = 0; } check_interrupt_context_or_lose(context); - FSHOW_SIGNAL((stderr, - "/maybe_defer_handler(%p,%d): not deferred\n", - handler,signal)); - return 0; -} - -static void -store_signal_data_for_later (struct interrupt_data *data, void *handler, - int signal, - siginfo_t *info, os_context_t *context) -{ - if (data->pending_handler) - lose("tried to overwrite pending interrupt handler %p with %p", - data->pending_handler, handler); - if (!handler) - lose("tried to defer null interrupt handler"); - data->pending_handler = handler; - data->pending_signal = signal; - if(info) - memcpy(&(data->pending_info), info, sizeof(siginfo_t)); - - FSHOW_SIGNAL((stderr, "/store_signal_data_for_later: signal: %d\n", - signal)); - - if(!context) - lose("Null context"); - - /* the signal mask in the context (from before we were - * interrupted) is copied to be restored when run_deferred_handler - * happens. Then the usually-blocked signals are added to the mask - * in the context so that we are running with blocked signals when - * the handler returns */ - sigcopyset(&(data->pending_mask),os_context_sigmask_addr(context)); - sigaddset_deferrable(os_context_sigmask_addr(context)); + return answer; } static void @@ -1334,34 +1359,11 @@ { SAVE_ERRNO(signal,context,void_context); struct thread *thread = arch_os_get_current_thread(); - struct interrupt_data *data = thread->interrupt_data; - if(!maybe_defer_handler(interrupt_handle_now,data,signal,info,context)) + struct interrupt_data *data = &thread_interrupt_data(thread); + if (can_handle_now(interrupt_handle_now, data, signal, info, context)) interrupt_handle_now(signal, info, context); RESTORE_ERRNO; } - -static void -low_level_interrupt_handle_now(int signal, siginfo_t *info, - os_context_t *context) -{ - /* No FP control fixage needed, caller has done that. */ - check_blockables_blocked_or_lose(0); - check_interrupts_enabled_or_lose(context); - (*interrupt_low_level_handlers[signal])(signal, info, context); -} - -static void -low_level_maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context) -{ - SAVE_ERRNO(signal,context,void_context); - struct thread *thread = arch_os_get_current_thread(); - struct interrupt_data *data = thread->interrupt_data; - - if(!maybe_defer_handler(low_level_interrupt_handle_now,data, - signal,info,context)) - low_level_interrupt_handle_now(signal, info, context); - RESTORE_ERRNO; -} #endif #ifdef THREADS_USING_GCSIGNAL @@ -1414,22 +1416,25 @@ * pseudo_atomic_interrupted but without a pending interrupt or * GC. GC_BLOCKED_DEFERRABLES is also left at 1. So let's tidy it * up. */ - if (thread->interrupt_data->gc_blocked_deferrables) { + if (thread_interrupt_data(thread).gc_blocked_deferrables) { FSHOW_SIGNAL((stderr,"cleaning up after gc_blocked_deferrables\n")); clear_pseudo_atomic_interrupted(thread); - sigcopyset(os_context_sigmask_addr(context), - &thread->interrupt_data->pending_mask); - thread->interrupt_data->gc_blocked_deferrables = 0; - } - - if(thread_state(thread)!=STATE_RUNNING) { - // macOS warns if OBJ_FMTX is used to format a 'sword_t' - // which fixnum_value() returns. - lose("sig_stop_for_gc_handler: wrong thread state: %"OBJ_FMTX, - (lispobj)fixnum_value(thread->state)); - } - - set_thread_state(thread,STATE_STOPPED); + struct interrupt_data *interrupt_data = &thread_interrupt_data(thread); + sigcopyset(os_context_sigmask_addr(context), &interrupt_data->pending_mask); + interrupt_data->gc_blocked_deferrables = 0; + } + + /* No need to use an atomic memory load here - this thead "owns" its state + * for now, and nobody else touches it, the sole exception being that GC + * sets it to RUNNING. The loads inside thread_wait_until_not() + * are slightly more interesting from that perspective */ + if (thread->state_word.state != STATE_RUNNING) + lose("stop_for_gc: bad thread state: %x", (int)thread->state_word.state); + + /* We say that the thread is "stopped" as of now, but the blocking operation + * occurs below at thread_wait_until_not(STATE_STOPPED). Note that sem_post() + * is expressly permitted in signal handlers, and set_thread_state uses it */ + set_thread_state(thread, STATE_STOPPED, 0); FSHOW_SIGNAL((stderr,"suspended\n")); /* While waiting for gc to finish occupy ourselves with zeroing @@ -1438,13 +1443,19 @@ * actually a must. */ scrub_control_stack(); - wait_for_thread_state_change(thread, STATE_STOPPED); + /* Now we wait on a semaphore, which, to be pedantic, is not specified as async-safe. + * Normally the way to implement a "suspend" operation is to issue any blocking + * syscall such as sigsuspend() or select(). Apparently every OS + C runtime that + * we wish to support has no problem with sem_wait() here in the signal handler. */ + int my_state = thread_wait_until_not(STATE_STOPPED, thread); FSHOW_SIGNAL((stderr,"resumed\n")); - if(thread_state(thread)!=STATE_RUNNING) { - lose("sig_stop_for_gc_handler: wrong thread state on wakeup: %"OBJ_FMTX, - (lispobj)fixnum_value(thread_state(thread))); - } + /* The state can't go from STOPPED to DEAD because it's this thread is reading + * its own state, hence it must be running. + * (If we tried to observe a different thread, it could appear to change from + * STOPPED to DEAD, skipping RUNNING, because if you blink you might miss it) */ + if (my_state != STATE_RUNNING) + lose("stop_for_gc: bad state on wakeup: %x", my_state); if (was_in_lisp) { undo_fake_foreign_function_call(context); @@ -1539,11 +1550,11 @@ */ #ifndef LISP_FEATURE_DARWIN - u32 *sp=(u32 *)*os_context_register_addr(context,reg_ESP); + uint32_t *sp=(uint32_t *)*os_context_register_addr(context,reg_ESP); #endif #if defined(LISP_FEATURE_DARWIN) - u32 *register_save_area = (u32 *)os_allocate(0x40); + uint32_t *register_save_area = (uint32_t *)os_allocate(0x40); FSHOW_SIGNAL((stderr, "/arrange_return_to_lisp_function: preparing to go to function %x, sp: %x\n", function, *os_context_register_addr(context,reg_ESP))); @@ -1575,7 +1586,7 @@ #else /* return address for call_into_lisp: */ - *(sp-15) = (u32)post_signal_tramp; + *(sp-15) = (uint32_t)post_signal_tramp; *(sp-14) = function; /* args for call_into_lisp : function*/ *(sp-13) = 0; /* arg array */ *(sp-12) = 0; /* no. args */ @@ -1598,10 +1609,10 @@ #endif #elif defined(LISP_FEATURE_X86_64) - u64 *sp=(u64 *)*os_context_register_addr(context,reg_RSP); + uword_t *sp=(uword_t *)*os_context_register_addr(context,reg_RSP); /* return address for call_into_lisp: */ - *(sp-18) = (u64)post_signal_tramp; + *(sp-18) = (uint64_t)post_signal_tramp; *(sp-17)=*os_context_register_addr(context,reg_R15); *(sp-16)=*os_context_register_addr(context,reg_R14); @@ -1705,7 +1716,7 @@ { protect_control_stack_guard_page(0, th); protect_control_stack_return_guard_page(1, th); - th->control_stack_guard_page_protected = NIL; + th->state_word.control_stack_guard_page_protected = 0; fprintf(stderr, "INFO: Control stack guard page unprotected\n"); } @@ -1714,7 +1725,7 @@ memset(CONTROL_STACK_GUARD_PAGE(th), 0, os_vm_page_size); protect_control_stack_guard_page(1, th); protect_control_stack_return_guard_page(0, th); - th->control_stack_guard_page_protected = T; + th->state_word.control_stack_guard_page_protected = 1; fprintf(stderr, "INFO: Control stack guard page reprotected\n"); } @@ -1750,7 +1761,7 @@ lose("Control stack exhausted, fault: %p, PC: %p", addr, (void*)*os_context_pc_addr(context)); } - if (th->control_stack_guard_page_protected == NIL) + if (!th->state_word.control_stack_guard_page_protected) lose("control_stack_guard_page_protected NIL"); lower_thread_control_stack_guard_page(th); #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK @@ -1768,7 +1779,7 @@ * unprotect this one. This works even if we somehow missed * the return-guard-page, and hit it on our way to new * exhaustion instead. */ - if (th->control_stack_guard_page_protected != NIL) + if (th->state_word.control_stack_guard_page_protected) lose("control_stack_guard_page_protected not NIL"); reset_thread_control_stack_guard_page(th); return 1; @@ -1842,94 +1853,11 @@ for (signal = 0; signal < NSIG; signal++) { interrupt_handler_t handler = interrupt_low_level_handlers[signal]; if (handler) { - undoably_install_low_level_interrupt_handler(signal, handler); + ll_install_handler(signal, handler); } } } -#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32) - -static void * -signal_thread_trampoline(void *pthread_arg) -{ - intptr_t signo = (intptr_t) pthread_arg; - os_context_t fake_context; - siginfo_t fake_info; -#if defined LISP_FEATURE_PPC || defined LISP_FEATURE_PPC64 - mcontext_t uc_regs; -#endif - - memset(&fake_info, 0, sizeof(fake_info)); - memset(&fake_context, 0, sizeof(fake_context)); -#if defined LISP_FEATURE_PPC || defined LISP_FEATURE_PPC64 - memset(&uc_regs, 0, sizeof(uc_regs)); - fake_context.uc_mcontext.uc_regs = &uc_regs; -#endif - - *os_context_pc_addr(&fake_context) = (intptr_t) &signal_thread_trampoline; -#ifdef ARCH_HAS_STACK_POINTER /* aka x86(-64) */ - *os_context_sp_addr(&fake_context) = (intptr_t) __builtin_frame_address(0); -#endif - - signal_handler_callback(interrupt_handlers[signo].lisp, - signo, &fake_info, &fake_context); - return 0; -} - -static void -sigprof_handler_trampoline(int signal, siginfo_t *info, void *void_context) -{ - SAVE_ERRNO(signal,context,void_context); - struct thread *self = arch_os_get_current_thread(); - - /* alloc() is not re-entrant and still uses pseudo atomic (even though - * inline allocation does not). In this case, give up. */ - if (get_pseudo_atomic_atomic(self)) - goto cleanup; - - struct alloc_region tmp = self->alloc_region; - self->alloc_region = self->sprof_alloc_region; - self->sprof_alloc_region = tmp; - - interrupt_handle_now_handler(signal, info, void_context); - - /* And we're back. We know that the SIGPROF handler never unwinds - * non-locally, and can simply swap things back: */ - - tmp = self->alloc_region; - self->alloc_region = self->sprof_alloc_region; - self->sprof_alloc_region = tmp; - -cleanup: - ; /* Dear C compiler, it's OK to have a label here. */ - RESTORE_ERRNO; -} - -static void -spawn_signal_thread_handler(int signal, siginfo_t *info, void *void_context) -{ - SAVE_ERRNO(signal,context,void_context); - - pthread_attr_t attr; - pthread_t th; - - if (pthread_attr_init(&attr)) - goto lost; - if (pthread_attr_setstacksize(&attr, thread_control_stack_size)) - goto lost; - if (pthread_create(&th, &attr, &signal_thread_trampoline, (void*)(intptr_t) signal)) - goto lost; - if (pthread_attr_destroy(&attr)) - goto lost; - - RESTORE_ERRNO; - return; - -lost: - lose("spawn_signal_thread_handler"); -} -#endif - static void low_level_handle_now_handler(int signal, siginfo_t *info, void *void_context) { @@ -1939,8 +1867,7 @@ } void -undoably_install_low_level_interrupt_handler (int signal, - interrupt_handler_t handler) +ll_install_handler (int signal, interrupt_handler_t handler) { struct sigaction sa; @@ -1950,26 +1877,26 @@ if (ARE_SAME_HANDLER(handler, SIG_DFL)) sa.sa_sigaction = (void (*)(int, siginfo_t*, void*))handler; - else if (sigismember(&deferrable_sigset,signal)) - sa.sa_sigaction = low_level_maybe_now_maybe_later; - else - sa.sa_sigaction = low_level_handle_now_handler; - + else if ( #ifdef LISP_FEATURE_SB_THRUPTION /* It's in `deferrable_sigset' so that we block&unblock it properly, - * but we don't actually want to defer it. And if we put it only + * but we don't actually want to defer it, at least not here. + * (It might get deferred until a safepoint). And if we put it only * into blockable_sigset, we'd have to special-case it around thread * creation at least. */ - if (signal == SIGPIPE) - sa.sa_sigaction = low_level_handle_now_handler; + (signal == SIGURG) || #endif + !sigismember(&deferrable_sigset,signal)) + sa.sa_sigaction = low_level_handle_now_handler; + else + lose("Can't install low-level handler"); sa.sa_mask = blockable_sigset; sa.sa_flags = SA_SIGINFO | SA_RESTART | OS_SA_NODEFER; #if defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK) if(signal==SIG_MEMORY_FAULT) { sa.sa_flags |= SA_ONSTACK; -# ifdef LISP_FEATURE_SB_SAFEPOINT +# if defined LISP_FEATURE_SB_SAFEPOINT && !defined LISP_FEATURE_DARWIN sigaddset(&sa.sa_mask, SIGRTMIN); sigaddset(&sa.sa_mask, SIGRTMIN+1); # endif @@ -1983,76 +1910,42 @@ #endif /* This is called from Lisp. */ -uword_t -install_handler(int signal, void handler(int, siginfo_t*, os_context_t*), - lispobj ohandler, // (SIMPLE-VECTOR 1) as a tagged pointer - int __attribute__((unused)) synchronous) +void install_handler(int signal, lispobj handler) { #ifndef LISP_FEATURE_WIN32 struct sigaction sa; - sigset_t old; - - FSHOW((stderr, "/entering POSIX install_handler(%d, ..)\n", signal)); - block_blockable_signals(&old); - - FSHOW((stderr, "/interrupt_low_level_handlers[signal]=%p\n", - interrupt_low_level_handlers[signal])); - if (interrupt_low_level_handlers[signal]==0) { - if (handler == 0) - sa.sa_sigaction = (void (*)(int, siginfo_t*, void*))SIG_DFL; - else if ((lispobj)handler == 1) - sa.sa_sigaction = (void (*)(int, siginfo_t*, void*))SIG_IGN; -#ifdef LISP_FEATURE_SB_SAFEPOINT_STRICTLY - else if (signal == SIGPROF) - sa.sa_sigaction = sigprof_handler_trampoline; - else if (!synchronous) - sa.sa_sigaction = spawn_signal_thread_handler; -#endif - else if (sigismember(&deferrable_sigset, signal)) + if (interrupt_low_level_handlers[signal]) { + // When there's a low-level handler, we must leave it alone. + // Give it the lisp function to call if it decides to forward a signal. + // SIG_IGN and SIG_DFL don't always do what you think in such case. + lisp_sig_handlers[signal] = functionp(handler) ? handler : 0; + } else { + // Our "abstract" values for SIG_DFL and SIG_IGN are 0 and 1 + // respectively which are probably the real values from signal.h + // but this way way don't need to put them in grovel-headers.c + if (handler==0 || handler==1) { + memset(&sa, 0, sizeof sa); + sa.sa_handler = handler ? SIG_IGN : SIG_DFL; + // assign the OS level action before clearing the lisp function. + // (If a signal were to be delivered to the C trampoline when the lisp + // function is NIL, we'd get the effect of :IGNORE regardless + // of what the default action should be) + sigaction(signal, &sa, NULL); + lisp_sig_handlers[signal] = 0; + return; + } + if (sigismember(&deferrable_sigset, signal)) sa.sa_sigaction = maybe_now_maybe_later; else sa.sa_sigaction = interrupt_handle_now_handler; sa.sa_mask = blockable_sigset; sa.sa_flags = SA_SIGINFO | SA_RESTART | OS_SA_NODEFER; + // ensure the C handler sees a lisp function before doing sigaction() + lisp_sig_handlers[signal] = handler; sigaction(signal, &sa, NULL); } - - // We can GC-safely read interrupt_low_level_handlers[signal] and assign - // into ohandler despite that the C stack and registers are not roots on - // precise GC. That is, if GC were to occur as depicted: - // obj = old_handler - // -- GC signal occurs here -- - // result = obj - // then the register or stack word holding 'obj' could be obsolete. - // But that won't happen- the STOP_FOR_GC signal is currently blocked - // due to the block_blockable_signals() at the top of this function. - // However, there is an unlikely other reason for a wrong result - - // if the C function address does not have at least N_FIXNUM_TAG_BITS - // of alignment, then we say that it was NIL instead of a fixnum. - lispobj obj = interrupt_handlers[signal].lisp; - uword_t result = -1; - if ((void*)obj == (void*)SIG_DFL) - result = 0; - else if ((void*)obj == (void*)SIG_IGN) - result = 1; - else if (ohandler) // only store into 'ohandler' when it was supplied - VECTOR(ohandler)->data[0] = (functionp(obj)||fixnump(obj)) ? obj : NIL; - - interrupt_handlers[signal].c = handler; - - thread_sigmask(SIG_SETMASK, &old, 0); - - FSHOW((stderr, "/leaving POSIX install_handler(%d, ..)\n", signal)); - - // After the thread's signal mask is restored to the mask in 'old', - // it is not possible to GC-safely refer to a Lisp function from C code, - // which is to say, naively utilizing "return obj;" would be wrong. - return result; -#else - /* Probably-wrong Win32 hack */ - return 0; #endif } @@ -2072,8 +1965,11 @@ void interrupt_init(void) { +#ifdef ATOMIC_LOGGING + eventdata = calloc(EVENTBUFMAX, N_WORD_BYTES); +#endif #if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) - int i; + int __attribute__((unused)) i; SHOW("entering interrupt_init()"); sigemptyset(&deferrable_sigset); sigemptyset(&blockable_sigset); @@ -2083,20 +1979,15 @@ sigaddset_gc(&gc_sigset); #endif +#ifdef LISP_FEATURE_BACKTRACE_ON_SIGNAL + // Use this only if you know what you're doing + void backtrace_lisp_threads(int, siginfo_t*, os_context_t*); + ll_install_handler(SIGXCPU, backtrace_lisp_threads); +#endif + #ifndef LISP_FEATURE_WIN32 - /* Set up high level handler information. */ - for (i = 0; i < NSIG; i++) { - interrupt_handlers[i].c = - /* (The cast here blasts away the distinction between - * SA_SIGACTION-style three-argument handlers and - * signal(..)-style one-argument handlers, which is OK - * because it works to call the 1-argument form where the - * 3-argument form is expected.) */ - (void (*)(int, siginfo_t*, os_context_t*))SIG_DFL; - } - undoably_install_low_level_interrupt_handler(SIGABRT, sigabrt_handler); + ll_install_handler(SIGABRT, sigabrt_handler); #endif - SHOW("returning from interrupt_init()"); } #ifndef LISP_FEATURE_WIN32 @@ -2119,15 +2010,15 @@ unsigned int offset = code ? pc - (char*)code : 0; if (offset) corruption_warning_and_maybe_lose( - "Memory fault at %p (pc=%p [code %p+0x%X ID 0x%x], fp=%p, sp=%p) tid %#lx", + "Memory fault at %p (pc=%p [code %p+0x%X ID 0x%x], fp=%p, sp=%p)" THREAD_ID_LABEL, addr, pc, code, offset, code_serialno(code), os_context_frame_pointer(context), - *os_context_sp_addr(context), thread_self()); // = 0 if -sb-thread + *os_context_sp_addr(context), THREAD_ID_VALUE); else corruption_warning_and_maybe_lose( - "Memory fault at %p (pc=%p, fp=%p, sp=%p) tid %#lx", + "Memory fault at %p (pc=%p, fp=%p, sp=%p)" THREAD_ID_LABEL, addr, pc, os_context_frame_pointer(context), - *os_context_sp_addr(context), thread_self()); // = 0 if -sb-thread + *os_context_sp_addr(context), THREAD_ID_VALUE); #else corruption_warning_and_maybe_lose("Memory fault at %p (pc=%p)", addr, *os_context_pc_addr(context)); diff -Nru sbcl-2.0.6/src/runtime/interrupt.h sbcl-2.1.1/src/runtime/interrupt.h --- sbcl-2.0.6/src/runtime/interrupt.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/interrupt.h 2021-01-30 11:22:38.000000000 +0000 @@ -16,36 +16,29 @@ #include #include "genesis/static-symbols.h" -extern void get_current_sigmask(sigset_t *sigset); +extern void sigset_tostring(const sigset_t *sigset, char* result, int result_length); /* Set all deferrable signals into *s. */ extern void sigaddset_deferrable(sigset_t *s); /* Set all blockable signals into *s. */ extern void sigaddset_blockable(sigset_t *s); -/* Set all gc signals into *s. */ -extern void sigaddset_gc(sigset_t *s); extern sigset_t deferrable_sigset; extern sigset_t blockable_sigset; extern sigset_t gc_sigset; extern boolean deferrables_blocked_p(sigset_t *sigset); -extern boolean blockables_blocked_p(sigset_t *sigset); -extern boolean gc_signals_blocked_p(sigset_t *sigset); extern void check_deferrables_blocked_or_lose(sigset_t *sigset); -extern void check_blockables_blocked_or_lose(sigset_t *sigset); -extern void check_gc_signals_blocked_or_lose(sigset_t *sigset); extern void check_deferrables_unblocked_or_lose(sigset_t *sigset); -extern void check_blockables_unblocked_or_lose(sigset_t *sigset); extern void check_gc_signals_unblocked_or_lose(sigset_t *sigset); extern void block_deferrable_signals(sigset_t *old); extern void block_blockable_signals(sigset_t *old); extern void unblock_deferrable_signals(sigset_t *where); -extern void unblock_gc_signals(); +extern void unblock_gc_signals(void); extern void maybe_save_gc_mask_and_block_deferrables(sigset_t *sigset); @@ -74,12 +67,7 @@ * * -- NS 2007-01-29 */ -union interrupt_handler { - lispobj lisp; - void (*c)(int, siginfo_t*, os_context_t*); -}; - -extern union interrupt_handler interrupt_handlers[NSIG]; +extern lispobj lisp_sig_handlers[NSIG]; struct interrupt_data { /* signal information for pending signal. pending_signal=0 when there @@ -117,9 +105,6 @@ extern void interrupt_handle_pending(os_context_t*); extern void interrupt_internal_error(os_context_t*, boolean continuable); extern boolean handle_guard_page_triggered(os_context_t *,os_vm_address_t); -extern boolean maybe_defer_handler(void *handler, struct interrupt_data *data, - int signal, siginfo_t *info, - os_context_t *context); #ifdef DO_PENDING_INTERRUPT #define do_pending_interrupt ((void(*)(void))SYMBOL(DO_PENDING_INTERRUPT)->value) @@ -132,13 +117,7 @@ extern void sig_stop_for_gc_handler(int, siginfo_t*, os_context_t*); #endif typedef void (*interrupt_handler_t)(int, siginfo_t *, os_context_t *); -extern void undoably_install_low_level_interrupt_handler ( - int signal, - interrupt_handler_t handler); -extern uword_t install_handler(int signal, - interrupt_handler_t handler, - lispobj ohandler, - int synchronous); +extern void ll_install_handler(int signal, interrupt_handler_t handler); /* The void* casting here avoids having to mess with the various types * of function argument lists possible for signal handlers: diff -Nru sbcl-2.0.6/src/runtime/ld-script.alpha-linux sbcl-2.1.1/src/runtime/ld-script.alpha-linux --- sbcl-2.0.6/src/runtime/ld-script.alpha-linux 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/ld-script.alpha-linux 1970-01-01 00:00:00.000000000 +0000 @@ -1,163 +0,0 @@ -/* This script allegedly has the same effect as -taso would do on Digital - * Unix - that is, it forces stuff into the low 2Gb where 32-bit pointers - * can find it */ - -/* - * 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. - */ - -OUTPUT_FORMAT("elf64-alpha", "elf64-alpha", - "elf64-alpha") -OUTPUT_ARCH(alpha) -ENTRY(__start) -SEARCH_DIR(/lib); SEARCH_DIR(/usr/lib); SEARCH_DIR(/usr/local/lib); SEARCH_DIR(/usr/alpha-linux/lib); -/* Do we need any of these for elf? - __DYNAMIC = 0; */ -SECTIONS -{ - /* Read-only sections, merged into text segment: */ - . = 0x08048000 + SIZEOF_HEADERS; - .interp : { *(.interp) } - .hash : { *(.hash) } - .dynsym : { *(.dynsym) } - .dynstr : { *(.dynstr) } - .gnu.version : { *(.gnu.version) } - .gnu.version_d : { *(.gnu.version_d) } - .gnu.version_r : { *(.gnu.version_r) } - .rel.text : - { *(.rel.text) *(.rel.gnu.linkonce.t*) } - .rela.text : - { *(.rela.text) *(.rela.gnu.linkonce.t*) } - .rel.data : - { *(.rel.data) *(.rel.gnu.linkonce.d*) } - .rela.data : - { *(.rela.data) *(.rela.gnu.linkonce.d*) } - .rel.rodata : - { *(.rel.rodata) *(.rel.gnu.linkonce.r*) } - .rela.rodata : - { *(.rela.rodata) *(.rela.gnu.linkonce.r*) } - .rel.got : { *(.rel.got) } - .rela.got : { *(.rela.got) } - .rel.ctors : { *(.rel.ctors) } - .rela.ctors : { *(.rela.ctors) } - .rel.dtors : { *(.rel.dtors) } - .rela.dtors : { *(.rela.dtors) } - .rel.init : { *(.rel.init) } - .rela.init : { *(.rela.init) } - .rel.fini : { *(.rel.fini) } - .rela.fini : { *(.rela.fini) } - .rel.bss : { *(.rel.bss) } - .rela.bss : { *(.rela.bss) } - .rel.plt : { *(.rel.plt) } - .rela.plt : { *(.rela.plt) } - .init : { *(.init) } =0x47ff041f - .text : - { - *(.text) - *(.stub) - /* .gnu.warning sections are handled specially by elf32.em. */ - *(.gnu.warning) - *(.gnu.linkonce.t*) - } =0x47ff041f - _etext = .; - PROVIDE (etext = .); - .fini : { *(.fini) } =0x47ff041f - .preinit_array : { - __preinit_array_start = .; - *(.preinit_array) - __preinit_array_end = .; - } - .init_array : { - __init_array_start = .; - *(.init_array) - __init_array_end = .; - } - .fini_array : { - __fini_array_start = .; - *(.fini_array) - __fini_array_end = .; - } - .rodata : { *(.rodata) *(.gnu.linkonce.r*) } - .rodata1 : { *(.rodata1) } - .reginfo : { *(.reginfo) } - /* Adjust the address for the data segment. We want to adjust up to - the same address within the page on the next page up. */ - . = ALIGN(0x100000) + (. & (0x100000 - 1)); - .data : - { - *(.data) - *(.gnu.linkonce.d*) - CONSTRUCTORS - } - .data1 : { *(.data1) } - .ctors : - { - *(.ctors) - } - .dtors : - { - *(.dtors) - } - .plt : { *(.plt) } - .got : { *(.got.plt) *(.got) } - .dynamic : { *(.dynamic) } - /* We want the small data sections together, so single-instruction offsets - can access them all, and initialized data all before uninitialized, so - we can shorten the on-disk segment size. */ - .sdata : { *(.sdata) } - _edata = .; - PROVIDE (edata = .); - __bss_start = .; - .sbss : { *(.sbss) *(.scommon) } - .bss : - { - *(.dynbss) - *(.bss) - *(COMMON) - } - . = ALIGN(64 / 8); - _end = . ; - PROVIDE (end = .); - /* Stabs debugging sections. */ - .stab 0 : { *(.stab) } - .stabstr 0 : { *(.stabstr) } - .stab.excl 0 : { *(.stab.excl) } - .stab.exclstr 0 : { *(.stab.exclstr) } - .stab.index 0 : { *(.stab.index) } - .stab.indexstr 0 : { *(.stab.indexstr) } - .comment 0 : { *(.comment) } - /* DWARF debug sections. - Symbols in the DWARF debugging sections are relative to the beginning - of the section so we begin them at 0. */ - /* DWARF 1 */ - .debug 0 : { *(.debug) } - .line 0 : { *(.line) } - /* GNU DWARF 1 extensions */ - .debug_srcinfo 0 : { *(.debug_srcinfo) } - .debug_sfnames 0 : { *(.debug_sfnames) } - /* DWARF 1.1 and DWARF 2 */ - .debug_aranges 0 : { *(.debug_aranges) } - .debug_pubnames 0 : { *(.debug_pubnames) } - /* DWARF 2 */ - .debug_info 0 : { *(.debug_info) } - .debug_abbrev 0 : { *(.debug_abbrev) } - .debug_line 0 : { *(.debug_line) } - .debug_frame 0 : { *(.debug_frame) } - .debug_str 0 : { *(.debug_str) } - .debug_loc 0 : { *(.debug_loc) } - .debug_macinfo 0 : { *(.debug_macinfo) } - /* SGI/MIPS DWARF 2 extensions */ - .debug_weaknames 0 : { *(.debug_weaknames) } - .debug_funcnames 0 : { *(.debug_funcnames) } - .debug_typenames 0 : { *(.debug_typenames) } - .debug_varnames 0 : { *(.debug_varnames) } - /* These must appear regardless of . */ -} - diff -Nru sbcl-2.0.6/src/runtime/linux-mman.c sbcl-2.1.1/src/runtime/linux-mman.c --- sbcl-2.0.6/src/runtime/linux-mman.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/linux-mman.c 2021-01-30 11:22:38.000000000 +0000 @@ -8,22 +8,6 @@ #include "os.h" #include "interr.h" -#ifdef LISP_FEATURE_ALPHA -/* The Alpha is a 64 bit CPU. SBCL is a 32 bit application. Due to all - * the places that assume we can get a pointer into a fixnum with no - * information loss, we have to make sure it allocates all its ram in the - * 0-2Gb region. */ - -static void * under_2gb_free_pointer; -os_set_cheneygc_spaces(uword_t space0_start, uword_t space1_start) -{ - uword_t max; - max = (space1_start > space0_start) ? space1_start : space0_start; - under_2gb_free_pointer = max + dynamic_space_size; -} - -#endif - os_vm_address_t os_validate(int attributes, os_vm_address_t addr, os_vm_size_t len) { @@ -32,11 +16,6 @@ int flags = MAP_PRIVATE | MAP_ANONYMOUS | MAP_NORESERVE; os_vm_address_t actual; -#ifdef LISP_FEATURE_ALPHA - if (!addr) { - addr=under_2gb_free_pointer; - } -#endif #ifdef MAP_32BIT if (attributes & ALLOCATE_LOW) flags |= MAP_32BIT; @@ -62,12 +41,6 @@ return 0; } -#ifdef LISP_FEATURE_ALPHA - - len=(len+(os_vm_page_size-1))&(~(os_vm_page_size-1)); - under_2gb_free_pointer+=len; -#endif - return actual; } diff -Nru sbcl-2.0.6/src/runtime/linux-nm sbcl-2.1.1/src/runtime/linux-nm --- sbcl-2.0.6/src/runtime/linux-nm 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/linux-nm 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -#!/bin/sh - -# " A " used to be in the set of removed symbols, but it turns out -# that the alpha implementation of closure_tramp and undefined_tramp -# is as an A. Whatever that is. CSR, 2005-06-12. -# " A " is a global absolute symbol, that is a symbol with a fixed -# assembly time value (which is used for offset calculations). - -nm -p "$@" | GREP_OPTIONS='' grep -v " [abcdgIiNnrstUuvw?-] " diff -Nru sbcl-2.0.6/src/runtime/linux-os.c sbcl-2.1.1/src/runtime/linux-os.c --- sbcl-2.0.6/src/runtime/linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/linux-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -35,8 +35,6 @@ #include "genesis/static-symbols.h" #include "genesis/fdefn.h" -#include -#include #include #include @@ -55,8 +53,6 @@ # include #endif -int sb_GetTID() { return syscall(SYS_gettid); } - #ifdef LISP_FEATURE_X86 /* Prototype for personality(2). Done inline here since the header file * for this isn't available on old versions of glibc. */ @@ -66,11 +62,98 @@ #include #endif -#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_FUTEX) && !defined(LISP_FEATURE_SB_PTHREAD_FUTEX) +#ifdef LISP_FEATURE_SB_FUTEX #include #include #include +#ifdef MUTEX_EVENTRECORDING +#include "genesis/mutex.h" +#define MAXEVENTS 200 +static struct { + struct thread* th; + struct timespec ts; + char *label; + char *mutex_name; + sword_t timeout; +} events[MAXEVENTS]; +static int record_mutex_events; +static int eventcount; + +void lisp_mutex_event(char *string) { + if (record_mutex_events) { + int id = __sync_fetch_and_add(&eventcount, 1); + if (id >= MAXEVENTS) lose("event buffer overflow"); + clock_gettime(CLOCK_REALTIME, &events[id].ts); + events[id].th = current_thread; + events[id].label = string; + events[id].mutex_name = 0; + events[id].timeout = -1; + } +} +void lisp_mutex_event1(char *string, char *string2) { + if (record_mutex_events) { + int id = __sync_fetch_and_add(&eventcount, 1); + if (id >= MAXEVENTS) lose("event buffer overflow"); + clock_gettime(CLOCK_REALTIME, &events[id].ts); + events[id].th = current_thread; + events[id].label = string; + events[id].mutex_name = string2; + events[id].timeout = -1; + } +} +void lisp_mutex_event2(char *string, char *string2, uword_t usec) { + if (record_mutex_events) { + int id = __sync_fetch_and_add(&eventcount, 1); + if (id >= MAXEVENTS) lose("event buffer overflow"); + clock_gettime(CLOCK_REALTIME, &events[id].ts); + events[id].th = current_thread; + events[id].label = string; + events[id].mutex_name = string2; + events[id].timeout = usec; + } +} +void lisp_mutex_start_eventrecording() { + eventcount = 0; + record_mutex_events = 1; +} +void lisp_mutex_done_eventrecording() { + record_mutex_events = 0; + int i; + fprintf(stderr, "event log:\n"); + struct timespec basetime = events[0].ts; + for(i=0; ilisp_thread); + struct timespec rel_time = events[i].ts; + rel_time.tv_sec -= basetime.tv_sec; + rel_time.tv_nsec -= basetime.tv_nsec; + if (rel_time.tv_nsec<0) rel_time.tv_nsec += 1000 * 1000 * 1000, rel_time.tv_sec--; + lispobj threadname = ti->name; + if (events[i].timeout >= 0) // must also have mutex_name in this case + fprintf(stderr, "[%d.%09ld] %s: %s '%s' timeout %ld\n", + (int)rel_time.tv_sec, rel_time.tv_nsec, + (char*)VECTOR(threadname)->data, + events[i].label, events[i].mutex_name, events[i].timeout); + else if (events[i].mutex_name) + fprintf(stderr, "[%d.%09ld] %s: %s '%s'\n", + (int)rel_time.tv_sec, rel_time.tv_nsec, + (char*)VECTOR(threadname)->data, + events[i].label, events[i].mutex_name); + else + fprintf(stderr, "[%d.%09ld] %s: %s\n", + (int)rel_time.tv_sec, rel_time.tv_nsec, + (char*)VECTOR(threadname)->data, + events[i].label); + } + fprintf(stderr, "-----\n"); +} +#else +#define lisp_mutex_event(x) +#define lisp_mutex_event1(x,y) +#define lisp_mutex_event2(x,y,z) +#endif + /* values taken from the kernel's linux/futex.h. This header file doesn't exist in userspace, which is our excuse for not grovelling them automatically */ @@ -140,14 +223,21 @@ struct timespec timeout; int t; +#ifdef MUTEX_EVENTRECORDING + struct mutex* m = (void*)((char*)lock_word - offsetof(struct mutex,state)); + char *name = m->name != NIL ? (char*)VECTOR(m->name)->data : "(unnamed)"; +#endif if (sec<0) { + lisp_mutex_event1("start futex wait", name); t = sys_futex(lock_word, futex_wait_op(), oldval, 0); } else { timeout.tv_sec = sec; timeout.tv_nsec = usec * 1000; + lisp_mutex_event2("start futex timedwait", name, usec); t = sys_futex(lock_word, futex_wait_op(), oldval, &timeout); } + lisp_mutex_event1("back from sys_futex", name); if (t==0) return 0; else if (errno==ETIMEDOUT) @@ -162,6 +252,11 @@ int futex_wake(int *lock_word, int n) { +#ifdef MUTEX_EVENTRECORDING + struct mutex* m = (void*)((char*)lock_word - offsetof(struct mutex,state)); + char *name = m->name != NIL ? (char*)VECTOR(m->name)->data : "(unnamed)"; + lisp_mutex_event1("waking futex", name); +#endif return sys_futex(lock_word, futex_wake_op(),n,0); } #endif @@ -170,16 +265,9 @@ void os_init(char __attribute__((unused)) *argv[], char __attribute__((unused)) *envp[]) { -#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_FUTEX) && !defined(LISP_FEATURE_SB_PTHREAD_FUTEX) +#ifdef LISP_FEATURE_SB_FUTEX futex_init(); #endif - -#ifdef LISP_FEATURE_X86 - /* Use SSE detector. Recent versions of Linux enable SSE support - * on SSE capable CPUs. */ - /* FIXME: Are there any old versions that does not support SSE? */ - fast_bzero_pointer = fast_bzero_detect; -#endif } #if (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)) \ @@ -290,22 +378,6 @@ { os_vm_address_t addr = arch_get_bad_addr(signal, info, context); -#ifdef LISP_FEATURE_ALPHA - /* Alpha stuff: This is the end of a pseudo-atomic section during - which a signal was received. We must deal with the pending - interrupt (see also interrupt.c, ../code/interrupt.lisp) - - (how we got here: when interrupting, we set bit 63 in reg_ALLOC. - At the end of the atomic section we tried to write to reg_ALLOC, - got a SIGSEGV (there's nothing mapped there) so ended up here. */ - if (addr != NULL && - *os_context_register_addr(context, reg_ALLOC) & (1L<<63)) { - *os_context_register_addr(context, reg_ALLOC) -= (1L<<63); - interrupt_handle_pending(context); - return; - } -#endif - #ifdef LISP_FEATURE_SB_SAFEPOINT if (!handle_safepoint_violation(context, addr)) #endif @@ -323,8 +395,7 @@ os_install_interrupt_handlers(void) { if (INSTALL_SIG_MEMORY_FAULT_HANDLER) { - undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT, - sigsegv_handler); + ll_install_handler(SIG_MEMORY_FAULT, sigsegv_handler); } /* OAOOM c.f. sunos-os.c. @@ -332,11 +403,10 @@ #ifdef LISP_FEATURE_SB_THREAD # ifdef LISP_FEATURE_SB_SAFEPOINT # ifdef LISP_FEATURE_SB_THRUPTION - undoably_install_low_level_interrupt_handler(SIGPIPE, thruption_handler); + ll_install_handler(SIGURG, thruption_handler); # endif # else - undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC, - sig_stop_for_gc_handler); + ll_install_handler(SIG_STOP_FOR_GC, sig_stop_for_gc_handler); # endif #endif } diff -Nru sbcl-2.0.6/src/runtime/lispobj.h sbcl-2.1.1/src/runtime/lispobj.h --- sbcl-2.0.6/src/runtime/lispobj.h 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/runtime/lispobj.h 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,9 @@ +#ifndef _RUNTIME_LISPOBJ_H_ +#define _RUNTIME_LISPOBJ_H_ + +#include +typedef intptr_t sword_t; +typedef uintptr_t uword_t; +typedef uword_t lispobj; + +#endif diff -Nru sbcl-2.0.6/src/runtime/lispstring.h sbcl-2.1.1/src/runtime/lispstring.h --- sbcl-2.0.6/src/runtime/lispstring.h 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/src/runtime/lispstring.h 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,35 @@ +/* + * 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. + */ + +#ifndef _LISPSTRING_H_ +#define _LISPSTRING_H_ + +static inline boolean string_widetag_p(int widetag) +{ + // element type of NIL can just go to hell + return widetag == SIMPLE_BASE_STRING_WIDETAG +#ifdef SIMPLE_CHARACTER_STRING_WIDETAG + || widetag == SIMPLE_CHARACTER_STRING_WIDETAG +#endif + ; +} + +// This does not accept (SIMPLE-ARRAY NIL (*)) +// (You'd have a pretty bad time trying making a symbol like that) +static inline unsigned int schar(struct vector* string, int index) +{ + if (widetag_of(&string->header) == SIMPLE_BASE_STRING_WIDETAG) + return ((char*)string->data)[index]; + else + return ((unsigned int*)string->data)[index]; +} + +#endif diff -Nru sbcl-2.0.6/src/runtime/memcpy.h sbcl-2.1.1/src/runtime/memcpy.h --- sbcl-2.0.6/src/runtime/memcpy.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/memcpy.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -#ifdef __linux__ -#ifdef __amd64__ -#ifdef __ASSEMBLER__ -.symver memcpy,memcpy@GLIBC_2.2.5 -#else -__asm__(".symver memcpy,memcpy@GLIBC_2.2.5"); -#endif -#endif -#ifdef __i386__ -#ifdef __ASSEMBLER__ -.symver memcpy,memcpy@GLIBC_2.0 -#else -__asm__(".symver memcpy,memcpy@GLIBC_2.0"); -#endif -#endif -#endif diff -Nru sbcl-2.0.6/src/runtime/mips-arch.c sbcl-2.1.1/src/runtime/mips-arch.c --- sbcl-2.0.6/src/runtime/mips-arch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/mips-arch.c 2021-01-30 11:22:38.000000000 +0000 @@ -383,7 +383,7 @@ void arch_handle_single_step_trap(os_context_t *context, int trap) { - unsigned int code = *((u32 *)(os_context_pc(context))); + unsigned int code = *((uint32_t *)(os_context_pc(context))); int register_offset = code >> 16 & 0x1f; handle_single_step_trap(context, trap, register_offset); arch_skip_instruction(context); @@ -425,7 +425,7 @@ void arch_install_interrupt_handlers(void) { - undoably_install_low_level_interrupt_handler(SIGTRAP,sigtrap_handler); + ll_install_handler(SIGTRAP,sigtrap_handler); } // Calls into C are mediated by the handwritten call_into_c routine diff -Nru sbcl-2.0.6/src/runtime/monitor.c sbcl-2.1.1/src/runtime/monitor.c --- sbcl-2.0.6/src/runtime/monitor.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/monitor.c 2021-01-30 11:22:38.000000000 +0000 @@ -151,17 +151,9 @@ lispobj* next_object = decode ? (lispobj*)addr : 0; while (count-- > 0) { -#ifndef LISP_FEATURE_ALPHA printf("%p: ", (os_vm_address_t) addr); -#else - printf("0x%08X: ", (u32) addr); -#endif if (force || gc_managed_addr_p((lispobj)addr)) { -#ifndef LISP_FEATURE_ALPHA unsigned long *lptr = (unsigned long *)addr; -#else - u32 *lptr = (u32 *)addr; -#endif unsigned char *cptr = (unsigned char *)addr; #if N_WORD_BYTES == 8 @@ -492,18 +484,17 @@ printf("There are no active catchers!\n"); else { while (catch != NULL) { - printf("0x%08lX:\n\tuwp: 0x%08lX\n\tfp: 0x%08lX\n\t" - "code: 0x%08lX\n\tentry: 0x%08lX\n\ttag: ", - (long unsigned)catch, - (long unsigned)(catch->uwp), - (long unsigned)(catch->cfp), + printf("%p:\n\tuwp : %p\n\tfp : %p\n\t" + "code : %p\n\tentry: %p\n\ttag: ", + catch, + catch->uwp, + catch->cfp, #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) - (long unsigned)component_ptr_from_pc((void*)catch->entry_pc) - + OTHER_POINTER_LOWTAG, + component_ptr_from_pc((void*)catch->entry_pc), #else - (long unsigned)(catch->code), + catch->code, #endif - (long unsigned)(catch->entry_pc)); + (void*)(catch->entry_pc)); brief_print((lispobj)catch->tag); catch = catch->previous_catch; } @@ -511,13 +502,31 @@ return 0; } +/* SIGINT handler that invokes the monitor (for when Lisp isn't up to it) */ +static void +sigint_handler(int __attribute__((unused)) signal, + siginfo_t __attribute__((unused)) *info, + void *context) +{ + extern void ldb_monitor(); + fprintf(stderr, "\nSIGINT hit at %p\n", (void*)*os_context_pc_addr(context)); + ldb_monitor(); + fprintf(stderr, "Returning to lisp (if you're lucky).\n"); +} + static int grab_sigs_cmd(char __attribute__((unused)) **ptr) { - extern void sigint_init(void); - - printf("Grabbing signals.\n"); - sigint_init(); +#ifdef LISP_FEATURE_WIN32 + fprintf(stderr, "sorry no can do\n"); fflush(stderr); +#else + printf("Grabbing SIGINT.\n"); + struct sigaction sa; + sigemptyset(&sa.sa_mask); + sa.sa_flags = SA_SIGINFO; + sa.sa_sigaction = sigint_handler; + sigaction(SIGINT, &sa, 0); +#endif return 0; } diff -Nru sbcl-2.0.6/src/runtime/os-common.c sbcl-2.1.1/src/runtime/os-common.c --- sbcl-2.0.6/src/runtime/os-common.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/os-common.c 2021-01-30 11:22:38.000000000 +0000 @@ -46,8 +46,7 @@ /* Except for os_zero, these routines are only called by Lisp code. * These routines may also be replaced by os-dependent versions - * instead. See hpux-os.c for some useful restrictions on actual - * usage. */ + * instead. */ #ifdef LISP_FEATURE_CHENEYGC void @@ -101,8 +100,8 @@ return errno; } - -#if defined(LISP_FEATURE_SB_THREAD) && (!defined(CANNOT_USE_POSIX_SEM_T) || defined(LISP_FEATURE_WIN32)) +#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_SB_SAFEPOINT \ + && !defined CANNOT_USE_POSIX_SEM_T void os_sem_init(os_sem_t *sem, unsigned int value) @@ -139,10 +138,9 @@ #endif -/* When :LINKAGE-TABLE is enabled, the special category of /static/ foreign - * symbols disappears. Foreign fixups are resolved to linkage table locations - * during genesis, and for each of them a record is added to - * REQUIRED_FOREIGN_SYMBOLS vector, of the form "name" for a function reference, +/* Genesis-time foreign fixups are resolved to linkage table locations + * and for each of them a record is added to the REQUIRED_FOREIGN_SYMBOLS + * vector, of the form "name" for a function reference, * or ("name") for a data reference. "name" is a base-string. * * Before any code in lisp image can be called, we have to resolve all @@ -150,7 +148,7 @@ * table entry for each element of REQUIRED_FOREIGN_SYMBOLS. */ -#if defined(LISP_FEATURE_LINKAGE_TABLE) && !defined(LISP_FEATURE_WIN32) +#ifndef LISP_FEATURE_WIN32 void * os_dlsym_default(char *name) { @@ -162,12 +160,6 @@ int lisp_linkage_table_n_prelinked; void os_link_runtime() { - // There is a potentially better technique we could use which would simplify - // this function, rendering REQUIRED_FOREIGN_SYMBOLS unnecessary, namely: - // all we need are two prefilled entries: one for dlsym() itself, and one - // for the allocation region overflow handler ("alloc" or "alloc_tramp"). - // Lisp can fill in the linkage table as the very first action on startup. -#ifdef LISP_FEATURE_LINKAGE_TABLE int entry_index = 0; lispobj symbol_name; char *namechars; @@ -188,11 +180,6 @@ namechars = (void*)(intptr_t)(VECTOR(symbol_name)->data); result = os_dlsym_default(namechars); - if (entry_index == 0) { -#ifdef LISP_FEATURE_WIN32 - os_validate_recommit(LINKAGE_TABLE_SPACE_START, os_vm_page_size); -#endif - } if (result) { arch_write_linkage_table_entry(entry_index, result, datap); } else { // startup might or might not work. ymmv @@ -201,7 +188,6 @@ ++entry_index; } -#endif /* LISP_FEATURE_LINKAGE_TABLE */ } void os_unlink_runtime() @@ -235,14 +221,6 @@ void* load_core_bytes(int fd, os_vm_offset_t offset, os_vm_address_t addr, os_vm_size_t len) { int fail = 0; -#ifdef LISP_FEATURE_HPUX - // Revision afcfb8b5da said that mmap() didn't work on HPUX, changing to use read() instead. - // Strangely it also read 4K at a time into a buffer and used memcpy to transfer the buffer. - // I don't see why, and given the lack of explanation, I've simplified to 1 read. - fail = lseek(fd, offset, SEEK_SET) == (off_t)-1 || read(fd, addr, len) != (ssize_t)len; - // This looks bogus but harmlesss, so I'm leaving it. - os_flush_icache(addr, len); -#else os_vm_address_t actual; actual = mmap(addr, len, // If mapping to a random address, then the assumption is @@ -260,11 +238,11 @@ } else if (addr && (addr != actual)) { fail = 1; } -#endif if (fail) lose("load_core_bytes(%d,%zx,%p,%zx) failed", fd, offset, addr, len); return (void*)actual; } +#endif boolean gc_managed_addr_p(lispobj addr) @@ -284,4 +262,4 @@ return 0; } -#endif + diff -Nru sbcl-2.0.6/src/runtime/os.h sbcl-2.1.1/src/runtime/os.h --- sbcl-2.0.6/src/runtime/os.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/os.h 2021-01-30 11:22:38.000000000 +0000 @@ -31,10 +31,10 @@ #define ENABLE_PAGE_PROTECTION 1 #endif -#ifdef LISP_FEATURE_CHENEYGC +#if defined LISP_FEATURE_CHENEYGC || defined LISP_FEATURE_SB_SAFEPOINT +// safepoint traps always require a signal handler #define INSTALL_SIG_MEMORY_FAULT_HANDLER 1 -#endif -#ifdef LISP_FEATURE_GENCGC +#elif defined LISP_FEATURE_GENCGC #define INSTALL_SIG_MEMORY_FAULT_HANDLER ENABLE_PAGE_PROTECTION #endif @@ -112,7 +112,8 @@ os_vm_size_t len); #ifdef LISP_FEATURE_WIN32 -void* os_validate_recommit(os_vm_address_t addr, os_vm_size_t len); +void* os_commit_memory(os_vm_address_t addr, os_vm_size_t len); +os_vm_address_t os_validate_nocommit(int attributes, os_vm_address_t addr, os_vm_size_t len); #endif /* This function seems to undo the effect of os_validate(..). */ @@ -221,7 +222,7 @@ #define OS_VM_SIZE_FMT PRIuPTR #define OS_VM_SIZE_FMTX PRIxPTR -#ifdef LISP_FEATURE_SB_THREAD +#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_SB_SAFEPOINT # ifndef CANNOT_USE_POSIX_SEM_T # include typedef sem_t os_sem_t; @@ -232,4 +233,6 @@ void os_sem_destroy(os_sem_t *sem); #endif +extern int os_reported_page_size; + #endif diff -Nru sbcl-2.0.6/src/runtime/ppc64-assem.S sbcl-2.1.1/src/runtime/ppc64-assem.S --- sbcl-2.0.6/src/runtime/ppc64-assem.S 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/ppc64-assem.S 2021-01-30 11:22:38.000000000 +0000 @@ -148,9 +148,6 @@ indirect_ptr(foreign_function_call_active) #endif indirect_ptr(all_threads) -#if defined(LISP_FEATURE_SB_THREAD) -indirect_ptr(specials) -#endif .text @@ -163,26 +160,10 @@ C_FULL_PROLOG /* NL0 - function, NL1 - frame pointer, NL2 - nargs. */ #ifdef LISP_FEATURE_SB_THREAD - /* We need to obtain a pointer to our TLS block before we do - * anything else. For this, we call pthread_getspecific(). - * We've preserved all of the callee-saves registers, so we - * can use them to stash our arguments temporarily while we - * make the call. */ - mr reg_A0, reg_NL0 - mr reg_A1, reg_NL1 - mr reg_A2, reg_NL2 - - /* Call out to obtain our TLS block. */ - load(reg_NL0,specials) - bl pthread_getspecific - nop - - mr reg_THREAD, reg_NL0 - - /* Restore our original parameters. */ - mr reg_NL2, reg_A2 - mr reg_NL1, reg_A1 - mr reg_NL0, reg_A0 + // Copy ABI TLS value of current_thread into lisp thread base + addis reg_THREAD,13,current_thread@tprel@ha + addi reg_THREAD,reg_THREAD,current_thread@tprel@l + ld reg_THREAD,0(reg_THREAD) #endif /* Initialize tagged registers */ li reg_ZERO,0 diff -Nru sbcl-2.0.6/src/runtime/ppc-arch.c sbcl-2.1.1/src/runtime/ppc-arch.c --- sbcl-2.0.6/src/runtime/ppc-arch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/ppc-arch.c 2021-01-30 11:22:38.000000000 +0000 @@ -400,8 +400,7 @@ char *memory; { extern lispobj *alloc(sword_t), *alloc_list(sword_t); - struct interrupt_data *data = - arch_os_get_current_thread()->interrupt_data; + struct interrupt_data *data = &thread_interrupt_data(arch_os_get_current_thread()); data->allocation_trap_context = context; memory = (char*)(alloc_trap_p < 0 ? alloc_list(size) : alloc(size)); data->allocation_trap_context = 0; @@ -467,7 +466,7 @@ boolean handle_it = 0; unsigned prev_inst; if ((code & ~(31 << 16)) == ((3<<26)|(4<<21))) { // mask out RA for test - prev_inst= ((u32*)pc)[-1]; + prev_inst= ((uint32_t*)pc)[-1]; int16_t disp = (prev_inst & 0xFFFF); handle_it = (prev_inst >> 26) == 32 // a load // RT of the load must be RA of the trap @@ -554,7 +553,7 @@ void arch_handle_single_step_trap(os_context_t *context, int trap) { - unsigned int code = *((u32 *)(*os_context_pc_addr(context))); + unsigned int code = *((uint32_t *)(*os_context_pc_addr(context))); int register_offset = code >> 8 & 0x1f; handle_single_step_trap(context, trap, register_offset); arch_skip_instruction(context); @@ -563,7 +562,6 @@ #if 0 static void dump_cpu_state(char *reason, os_context_t* context) { - extern void sigset_tostring(const sigset_t *sigset, char* result, int result_length); int i,j,r=0; sigset_t cur_sigset; char buf[100]; @@ -591,7 +589,7 @@ sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) { uword_t pc = *os_context_pc_addr(context); - unsigned int code = *(u32*)pc; + unsigned int code = *(uint32_t*)pc; #ifdef LISP_FEATURE_SIGILL_TRAPS if (signal == SIGILL) { @@ -656,8 +654,8 @@ void arch_install_interrupt_handlers() { - undoably_install_low_level_interrupt_handler(SIGILL, sigtrap_handler); - undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); + ll_install_handler(SIGILL, sigtrap_handler); + ll_install_handler(SIGTRAP, sigtrap_handler); } void diff -Nru sbcl-2.0.6/src/runtime/ppc-assem.S sbcl-2.1.1/src/runtime/ppc-assem.S --- sbcl-2.0.6/src/runtime/ppc-assem.S 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/ppc-assem.S 2021-01-30 11:22:38.000000000 +0000 @@ -289,7 +289,7 @@ #endif .text -#ifdef OS_THREAD_STACK +#ifdef LISP_FEATURE_OS_THREAD_STACK GFUNCDEF(funcall1_switching_stack) /* The arguments are switched, funcall1_switching_stack(arg, function) to avoid shuffling registers diff -Nru sbcl-2.0.6/src/runtime/ppc-bsd-os.c sbcl-2.1.1/src/runtime/ppc-bsd-os.c --- sbcl-2.0.6/src/runtime/ppc-bsd-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/ppc-bsd-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -77,7 +77,6 @@ } int arch_os_thread_init(struct thread *thread) { - #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK stack_t sigstack; @@ -89,15 +88,9 @@ sigstack.ss_size = calc_altstack_size(thread); sigaltstack(&sigstack,0); #endif - -#if defined(LISP_FEATURE_SB_THREAD) - pthread_setspecific(specials,thread); -#endif - return 1; /* success */ } int arch_os_thread_cleanup(struct thread *thread) { - return 1; /* success */ } diff -Nru sbcl-2.0.6/src/runtime/ppc-linux-os.c sbcl-2.1.1/src/runtime/ppc-linux-os.c --- sbcl-2.0.6/src/runtime/ppc-linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/ppc-linux-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -26,8 +26,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include @@ -40,10 +38,6 @@ #include "ppc-linux-mcontext.h" int arch_os_thread_init(struct thread *thread) { -#if defined(LISP_FEATURE_SB_THREAD) - pthread_setspecific(specials,thread); -#endif - /* For some reason, PPC Linux appears to default to not generating * floating point exceptions. PR_SET_FPEXC is a PPC-specific * option new in kernel 2.4.21 and 2.5.32 that allows us to diff -Nru sbcl-2.0.6/src/runtime/print.c sbcl-2.1.1/src/runtime/print.c --- sbcl-2.0.6/src/runtime/print.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/print.c 2021-01-30 11:22:38.000000000 +0000 @@ -25,6 +25,7 @@ #include "runtime.h" #include "code.h" #include "gc-internal.h" +#include "gc-private.h" #include #include "thread.h" /* genesis/primitive-objects.h needs this */ #include @@ -152,16 +153,11 @@ #endif int original_errno = errno; - QSHOW_BLOCK; - char buf[1024]; int n = 0; #ifdef LISP_FEATURE_SB_THREAD - struct thread *arch_os_get_current_thread(void); - struct thread *self = arch_os_get_current_thread(); - void *pth = self ? (void *) self->os_thread : 0; - snprintf(buf, sizeof(buf), "[%p/%p] ", self, pth); + snprintf(buf, sizeof(buf), "["THREAD_ID_LABEL"] ", THREAD_ID_VALUE); n = strlen(buf); #endif @@ -184,8 +180,6 @@ fflush(stderr); #endif - QSHOW_UNBLOCK; - #ifdef LISP_FEATURE_WIN32 SetLastError(lastError); #endif @@ -216,9 +210,6 @@ #ifdef LISP_FEATURE_GENCGC #include "gencgc-alloc-region.h" /* genesis/thread.h needs this */ #endif -#if defined(LISP_FEATURE_WIN32) -# include "win32-thread-private-events.h" /* genesis/thread.h needs this */ -#endif #include "genesis/static-symbols.h" #include "genesis/primitive-objects.h" #include "genesis/static-symbols.h" @@ -293,12 +284,7 @@ printf("unknown object: %p", (void *)obj); } -/* Except for Alpha, we define sword_t as intptr_t, and 32-bit Darwin - * defines intptr_t as long, so the printf conversion is "ld", not "d". - * Alpha (32-on-64) defines sword_t as s32, so we need just "d". */ -#ifdef LISP_FEATURE_ALPHA -# define OBJ_FMTd "d" -#elif defined(PRIdPTR) +#ifdef PRIdPTR # define OBJ_FMTd PRIdPTR #else # error "Your inttypes.h is lame" @@ -449,15 +435,23 @@ } #include "genesis/layout.h" +#include "genesis/defstruct-description.h" +#include "genesis/defstruct-slot-description.h" static boolean tagged_slot_p(struct layout *layout, int slot_index) { - lispobj bitmap = layout->bitmap; - sword_t fixnum = fixnum_value(bitmap); // optimistically - return fixnump(bitmap) - ? bitmap == make_fixnum(-1) || - (slot_index < N_WORD_BITS && ((fixnum >> slot_index) & 1) != 0) - : positive_bignum_logbitp(slot_index, - (struct bignum*)native_pointer(bitmap)); + // Since we're doing this scan, we could return the name + // and exact raw type. + if (instancep(layout->_info)) { + struct defstruct_description* dd = (void*)(layout->_info-INSTANCE_POINTER_LOWTAG); + lispobj slots = dd->slots; + for ( ; slots != NIL ; slots = CONS(slots)->cdr ) { + struct defstruct_slot_description* dsd = + (void*)(CONS(slots)->car-INSTANCE_POINTER_LOWTAG); + if ((fixnum_value(dsd->bits) >> DSD_INDEX_SHIFT) == slot_index) + return (fixnum_value(dsd->bits) & DSD_RAW_TYPE_MASK) == 0; + } + } + return 0; } static void print_struct(lispobj obj) @@ -591,13 +585,8 @@ static void print_fun_or_otherptr(lispobj obj) { -#ifndef LISP_FEATURE_ALPHA lispobj *ptr; unsigned long header; -#else - u32 *ptr; - u32 header; -#endif int count, type, index; char buffer[16]; @@ -647,6 +636,14 @@ print_slots(symbol_slots, count & 0xFF, ptr); if (symbol_function(ptr-1) != NIL) print_obj("fun: ", symbol_function(ptr-1)); +#ifdef LISP_FEATURE_SB_THREAD + int tlsindex = tls_index_of((struct symbol*)(ptr-1)); + struct thread*th = arch_os_get_current_thread(); + if (th != 0 && tlsindex != 0) { + lispobj v = *(lispobj*)(tlsindex + (char*)th); + print_obj("tlsval: ", v); + } +#endif break; #if N_WORD_BITS == 32 @@ -774,11 +771,7 @@ case SAP_WIDETAG: NEWLINE_OR_RETURN; -#ifndef LISP_FEATURE_ALPHA - printf("0x%08lx", (unsigned long) *ptr); -#else - printf("0x%016lx", *(lispobj*)(ptr+1)); -#endif + printf("%p", (void*)*ptr); break; case WEAK_POINTER_WIDETAG: @@ -921,10 +914,7 @@ sym = native_pointer(forwarding_pointer_value(sym)); if (lowtag_of(((struct symbol*)sym)->name) != OTHER_POINTER_LOWTAG) return NULL; - lispobj * name = native_pointer(((struct symbol*)sym)->name); - if (forwarding_pointer_p(name)) - name = native_pointer(forwarding_pointer_value(name)); - return (struct vector*)name; + return VECTOR(follow_maybe_fp(((struct symbol*)sym)->name)); } struct vector * classoid_name(lispobj * classoid) { diff -Nru sbcl-2.0.6/src/runtime/pthread-futex.c sbcl-2.1.1/src/runtime/pthread-futex.c --- sbcl-2.0.6/src/runtime/pthread-futex.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/pthread-futex.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,339 +0,0 @@ -/* An approximation of Linux futexes implemented using pthread mutexes - * and pthread condition variables. - */ - -/* - * This software is part of the SBCL system. See the README file for - * more information. - * - * The software is in the public domain and is provided with - * absolutely no warranty. See the COPYING and CREDITS files for more - * information. - */ - -#include "sbcl.h" - -#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_PTHREAD_FUTEX) - -#include -#include -#include - -#include "runtime.h" -#include "arch.h" -#include "target-arch-os.h" -#include "os.h" - -#define FUTEX_WAIT_NSEC (10000000) /* 10 msec */ - -#if 1 -# define futex_assert(ex) \ -do { \ - if (!(ex)) futex_abort(); \ -} while (0) -# define futex_assert_verbose(ex, fmt, ...) \ -do { \ - if (!(ex)) { \ - fprintf(stderr, fmt, ## __VA_ARGS__); \ - futex_abort(); \ - } \ -} while (0) -#else -# define futex_assert(ex) -# define futex_assert_verbose(ex, fmt, ...) -#endif - -#define futex_abort() \ - lose("Futex assertion failure, file \"%s\", line %d", __FILE__, __LINE__) - -struct futex { - struct futex *prev; - struct futex *next; - int *lock_word; - pthread_mutex_t mutex; - pthread_cond_t cond; - int count; -}; - -static pthread_mutex_t futex_lock = PTHREAD_MUTEX_INITIALIZER; - -static struct futex *futex_head = NULL; -static struct futex *futex_free_head = NULL; - -static struct futex * -futex_add(struct futex *head, struct futex *futex) -{ - futex->prev = NULL; - futex->next = head; - if (head != NULL) - head->prev = futex; - head = futex; - - return head; -} - -static struct futex * -futex_delete(struct futex *head, struct futex *futex) -{ - if (head == futex) - head = futex->next; - if (futex->prev != NULL) - futex->prev->next = futex->next; - if (futex->next != NULL) - futex->next->prev = futex->prev; - - return head; -} - -static struct futex * -futex_find(struct futex *head, int *lock_word) -{ - struct futex *futex; - - for (futex = head; futex != NULL; futex = futex->next) { - if (futex->lock_word == lock_word) - break; - } - - return futex; -} - -static struct futex * -futex_get(int *lock_word) -{ - int ret; - struct futex *futex; - - ret = pthread_mutex_lock(&futex_lock); - futex_assert(ret == 0); - - futex = futex_find(futex_head, lock_word); - - if (futex != NULL) - futex->count++; - - ret = pthread_mutex_unlock(&futex_lock); - futex_assert(ret == 0); - - if (futex != NULL) { - ret = pthread_mutex_lock(&futex->mutex); - futex_assert(ret == 0); - } - - return futex; -} - -static struct futex * -futex_allocate(int *lock_word) -{ - int ret; - struct futex *futex; - - ret = pthread_mutex_lock(&futex_lock); - futex_assert(ret == 0); - - futex = futex_free_head; - - if (futex != NULL) - futex_free_head = futex_delete(futex_free_head, futex); - - ret = pthread_mutex_unlock(&futex_lock); - futex_assert(ret == 0); - - if (futex == NULL) { - futex = malloc(sizeof(struct futex)); - futex_assert(futex != NULL); - - ret = pthread_mutex_init(&futex->mutex, NULL); - futex_assert(ret == 0); - - ret = pthread_cond_init(&futex->cond, NULL); - futex_assert(ret == 0); - } - - futex->lock_word = lock_word; - futex->count = 1; - - /* Lock mutex before register to avoid race conditions. */ - ret = pthread_mutex_lock(&futex->mutex); - futex_assert(ret == 0); - - ret = pthread_mutex_lock(&futex_lock); - futex_assert(ret == 0); - - futex_head = futex_add(futex_head, futex); - - ret = pthread_mutex_unlock(&futex_lock); - futex_assert(ret == 0); - - return futex; -} - -static void -futex_cleanup(void *p) -{ - struct futex *futex = (struct futex *)p; - int ret, count; - - ret = pthread_mutex_lock(&futex_lock); - futex_assert(ret == 0); - - count = --futex->count; - if (count <= 0) { - futex_head = futex_delete(futex_head, futex); - futex_free_head = futex_add(futex_free_head, futex); - } - - ret = pthread_mutex_unlock(&futex_lock); - futex_assert(ret == 0); - - ret = pthread_mutex_unlock(&futex->mutex); - futex_assert(ret == 0); -} - -static int -futex_relative_to_abs(struct timespec *tp, int relative) -{ - int ret; - struct timeval tv; - - ret = gettimeofday(&tv, NULL); - if (ret != 0) - return ret; - tp->tv_sec = tv.tv_sec + (tv.tv_usec * 1000 + relative) / 1000000000; - tp->tv_nsec = (tv.tv_usec * 1000 + relative) % 1000000000; - return 0; -} - -static int -futex_istimeout(struct timeval *timeout) -{ - int ret; - struct timeval tv; - - if (timeout == NULL) - return 0; - - ret = gettimeofday(&tv, NULL); - if (ret != 0) - return ret; - - return (tv.tv_sec > timeout->tv_sec) || - ((tv.tv_sec == timeout->tv_sec) && tv.tv_usec > timeout->tv_usec); -} - -int -futex_wait(int *lock_word, int oldval, long sec, unsigned long usec) -{ - int ret, result; - struct futex *futex; - sigset_t oldset; - struct timeval tv, *timeout; - -again: - if (sec < 0) - timeout = NULL; - else { - ret = gettimeofday(&tv, NULL); - if (ret != 0) - return ret; - tv.tv_sec = tv.tv_sec + sec + (tv.tv_usec + usec) / 1000000; - tv.tv_usec = (tv.tv_usec + usec) % 1000000; - timeout = &tv; - } - - block_deferrable_signals(&oldset); - - futex = futex_get(lock_word); - - if (futex == NULL) - futex = futex_allocate(lock_word); - - pthread_cleanup_push(futex_cleanup, futex); - - /* Compare lock_word after the lock is aquired to avoid race - * conditions. */ - if (*(volatile int *)lock_word != oldval) { - result = EWOULDBLOCK; - goto done; - } - - /* It's not possible to unwind frames across pthread_cond_wait(3). */ - for (;;) { - int i; - sigset_t pendset; - struct timespec abstime; - - ret = futex_relative_to_abs(&abstime, FUTEX_WAIT_NSEC); - futex_assert(ret == 0); - - result = pthread_cond_timedwait(&futex->cond, &futex->mutex, - &abstime); - futex_assert(result == 0 || result == ETIMEDOUT); - - if (result != ETIMEDOUT || futex_istimeout(timeout)) - break; - - /* futex system call of Linux returns with EINTR errno when - * it's interrupted by signals. Check pending signals here to - * emulate this behaviour. */ - sigpending(&pendset); - for (i = 1; i < NSIG; i++) { - if (sigismember(&pendset, i) && sigismember(&newset, i)) { - result = EINTR; - goto done; - } - } - } -done: - ; /* Null statement is required between label and pthread_cleanup_pop. */ - pthread_cleanup_pop(1); - thread_sigmask(SIG_SETMASK, &oldset, NULL); - - /* futex_wake() in linux-os.c loops when futex system call returns - * EINTR. */ - if (result == EINTR) { - sched_yield(); - goto again; - } - - if (result == ETIMEDOUT) - return 1; - - return result; -} - -int -futex_wake(int *lock_word, int n) -{ - int ret; - struct futex *futex; - sigset_t oldset; - - block_deferrable_signals(&oldset); - - futex = futex_get(lock_word); - - if (futex != NULL) { - pthread_cleanup_push(futex_cleanup, futex); - - /* The lisp-side code passes N=2**29-1 for a broadcast. */ - if (n >= ((1 << 29) - 1)) { - /* CONDITION-BROADCAST */ - ret = pthread_cond_broadcast(&futex->cond); - futex_assert(ret == 0); - } else { - while (n-- > 0) { - ret = pthread_cond_signal(&futex->cond); - futex_assert(ret == 0); - } - } - - pthread_cleanup_pop(1); - } - - thread_sigmask(SIG_SETMASK, &oldset, NULL); - - return 0; -} -#endif diff -Nru sbcl-2.0.6/src/runtime/pthreads_win32.c sbcl-2.1.1/src/runtime/pthreads_win32.c --- sbcl-2.0.6/src/runtime/pthreads_win32.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/pthreads_win32.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1216 +0,0 @@ -#include "sbcl.h" -#ifdef LISP_FEATURE_SB_THREAD /* entire file */ - -#define PTHREAD_INTERNALS -#include "pthreads_win32.h" -#include -#include -#include -#include - -#ifdef PTHREAD_DEBUG_OUTPUT -#define pthshow(fmt,...) \ - do { \ - fprintf(stderr,fmt "\n", __VA_ARGS__); \ - fflush(stderr); \ - } while (0) - -#define DEBUG_OWN(cs) do {(cs)->owner=pthread_self(); } while(0) -#define DEBUG_RELEASE(cs) do {(cs)->owner=0;} while(0) - -#else -#define pthshow(fmt,...) do {} while (0) -#define DEBUG_OWN(cs) do {} while(0) -#define DEBUG_RELEASE(cs) do {} while(0) -#endif - - -struct freelist_cell { - struct freelist_cell * next; - void* data; -}; - -struct freelist { - void* (*create_fn)(); - pthread_mutex_t lock; - struct freelist_cell * empty; - struct freelist_cell * full; - unsigned int count; -}; - -#define FREELIST_INITIALIZER(create_fn) \ - { \ - event_create, PTHREAD_MUTEX_INITIALIZER, \ - NULL, NULL, 0 \ - } \ - - -static void* freelist_get(struct freelist *fl) -{ - void* result = NULL; - if (fl->full) { - pthread_mutex_lock(&fl->lock); - if (fl->full) { - struct freelist_cell *cell = fl->full; - fl->full = cell->next; - result = cell->data; - cell->next = fl->empty; - fl->empty = cell; - } - pthread_mutex_unlock(&fl->lock); - } - if (!result) { - result = fl->create_fn(); - } - return result; -} - -static void freelist_return(struct freelist *fl, void*data) -{ - struct freelist_cell* cell = NULL; - if (fl->empty) { - pthread_mutex_lock(&fl->lock); - if (fl->empty) { - cell = fl->empty; - fl->empty = cell->next; - goto add_locked; - } - pthread_mutex_unlock(&fl->lock); - } - if (!cell) { - int i,n=32; - cell = malloc(sizeof(*cell)*n); - for (i=0; i<(n-1); ++i) - cell[i].next = &cell[i+1]; - cell[i].next = NULL; - } - - pthread_mutex_lock(&fl->lock); - ++fl->count; - add_locked: - cell->data = data; - cell->next = fl->full; - fl->full = cell; - pthread_mutex_unlock(&fl->lock); -} - -int pthread_attr_init(pthread_attr_t *attr) -{ - attr->stack_size = 0; - return 0; -} - -int pthread_attr_destroy(pthread_attr_t *attr) -{ - return 0; -} - -int pthread_attr_setstack(pthread_attr_t *attr, void *stackaddr, size_t stacksize) -{ - fprintf(stderr, "pthread_attr_setstack called\n"); - ExitProcess(1); - return 0; -} - -int pthread_attr_setstacksize(pthread_attr_t *attr, size_t stacksize) -{ - attr->stack_size = stacksize; - return 0; -} - - -typedef unsigned char boolean; - -/* TLS management internals */ - -static DWORD thread_self_tls_index; - -static void (*tls_destructors[PTHREAD_KEYS_MAX])(void*); -static boolean tls_used[PTHREAD_KEYS_MAX]; -static pthread_key_t tls_max_used_key; -static pthread_mutex_t thread_key_lock = PTHREAD_MUTEX_INITIALIZER; -static void tls_call_destructors(); -static pthread_t tls_impersonate(pthread_t other) { - pthread_t old = pthread_self(); - TlsSetValue(thread_self_tls_index,other); - return old; -} - -/* Thread identity, as much as pthreads are concerned, is determined - by pthread_t structure that is stored in TLS slot - (thread_self_tls_index). This slot is reassigned when fibers are - switched with pthread_np API. - - Two reasons for not using fiber-local storage for this purpose: (1) - Fls is too young: all other things work with Win2000, it requires - WinXP; (2) this implementation works also with threads that aren't - fibers, and it's a good thing. - - There is one more case, besides fiber switching, when pthread_self - identity migrates between system threads: for non-main system - thread that is not [pthread_create]d, thread-specific data - destructors run in a thread from a system thread pool, after the - original thread dies. In order to provide compatibility with - classic pthread TSD, the system pool thread acquires dead thread's - identity for the duration of destructor calls. -*/ -pthread_t pthread_self() -{ - return (pthread_t)TlsGetValue(thread_self_tls_index); -} - -const char * state_to_str(pthread_thread_state state) -{ - switch (state) { - case pthread_state_running: return "running"; - case pthread_state_finished: return "finished"; - case pthread_state_joined: return "joined"; - default: return "unknown"; - } -} - -/* Thread function for [pthread_create]d threads. -*/ -DWORD WINAPI Thread_Function(LPVOID param) -{ - pthread_t self = (pthread_t) param; - - self->teb = NtCurrentTeb(); - - pthread_t prev = tls_impersonate(self); - void* arg = self->arg; - pthread_fn fn = self->start_routine; - - self->retval = fn(arg); - pthread_mutex_lock(&self->lock); - self->state = pthread_state_finished; - pthread_cond_broadcast(&self->cond); - while (!self->detached && self->state != pthread_state_joined) { - pthread_cond_wait(&self->cond, &self->lock); - } - pthread_mutex_unlock(&self->lock); - pthread_mutex_destroy(&self->lock); - pthread_cond_destroy(&self->cond); - tls_call_destructors(); - - CloseHandle(self->handle); - - return 0; -} - -/* Signals */ -struct sigaction signal_handlers[NSIG]; - -/* Never called for now */ -int sigaction(int signum, const struct sigaction* act, struct sigaction* oldact) -{ - struct sigaction newact = *act; - if (oldact) - *oldact = signal_handlers[signum]; - if (!(newact.sa_flags & SA_SIGINFO)) { - newact.sa_sigaction = (typeof(newact.sa_sigaction))newact.sa_handler; - } - signal_handlers[signum] = newact; - return 0; -} - -int pthread_create(pthread_t *thread, const pthread_attr_t *attr, - void *(*start_routine) (void *), void *arg) -{ - pthread_t pth = (pthread_t)calloc(sizeof(pthread_thread),1); - pthread_t self = pthread_self(); - int i; - HANDLE createdThread = NULL; - - - createdThread = CreateThread(NULL, attr ? attr->stack_size : 0, - Thread_Function, pth, CREATE_SUSPENDED, NULL); - if (!createdThread) return 1; - pth->handle = createdThread; - - pth->start_routine = start_routine; - pth->arg = arg; - if (self) { - pth->blocked_signal_set = self->blocked_signal_set; - } else { - sigemptyset(&pth->blocked_signal_set); - } - pth->state = pthread_state_running; - pthread_mutex_init(&pth->lock, NULL); - pthread_cond_init(&pth->cond, NULL); - pth->detached = 0; - if (thread) *thread = pth; - ResumeThread(createdThread); - return 0; -} - -int pthread_equal(pthread_t thread1, pthread_t thread2) -{ - return thread1 == thread2; -} - -int pthread_detach(pthread_t thread) -{ - int retval = 0; - pthread_mutex_lock(&thread->lock); - thread->detached = 1; - pthread_cond_broadcast(&thread->cond); - pthread_mutex_unlock(&thread->lock); - return retval; -} - -int pthread_join(pthread_t thread, void **retval) -{ - pthread_mutex_lock(&thread->lock); - while (thread->state != pthread_state_finished) { - pthread_cond_wait(&thread->cond, &thread->lock); - } - thread->state = pthread_state_joined; - pthread_cond_broadcast(&thread->cond); - if (retval) - *retval = thread->retval; - pthread_mutex_unlock(&thread->lock); - return 0; -} - -/* We manage our own TSD instead of relying on system TLS for anything - other than pthread identity itself. Reasons: (1) Windows NT TLS - slots are expensive, (2) pthread identity migration requires only - one TLS slot assignment, instead of massive copying. */ -int pthread_key_create(pthread_key_t *key, void (*destructor)(void*)) -{ - pthread_key_t index; - boolean success = 0; - pthread_mutex_lock(&thread_key_lock); - for (index = 0; index < PTHREAD_KEYS_MAX; ++index) { - if (!tls_used[index]) { - if (tls_max_used_keyspecifics[key]; -} - -/* Internal function calling destructors for current pthread */ -static void tls_call_destructors() -{ - pthread_key_t key; - int i; - int called; - - for (i = 0; iblocked_signal_set; - if (set) { - switch (how) { - case SIG_BLOCK: - self->blocked_signal_set |= *set; - break; - case SIG_UNBLOCK: - self->blocked_signal_set &= ~(*set); - break; - case SIG_SETMASK: - self->blocked_signal_set = *set; - break; - } - } - return 0; -} - -pthread_mutex_t mutex_init_lock; - -int pthread_mutex_init(pthread_mutex_t * mutex, const pthread_mutexattr_t * attr) -{ - *mutex = (struct _pthread_mutex_info*)malloc(sizeof(struct _pthread_mutex_info)); - InitializeCriticalSection(&(*mutex)->cs); - (*mutex)->file = " (free) "; - return 0; -} - -int pthread_mutexattr_init(pthread_mutexattr_t* attr) -{ - return 0; -} -int pthread_mutexattr_destroy(pthread_mutexattr_t* attr) -{ - return 0; -} - -int pthread_mutexattr_settype(pthread_mutexattr_t* attr,int mutex_type) -{ - return 0; -} - -struct _pthread_mutex_info DEAD_MUTEX; - -int pthread_mutex_destroy(pthread_mutex_t *mutex) -{ - if (*mutex != PTHREAD_MUTEX_INITIALIZER) { - pthread_np_assert_live_mutex(mutex,"destroy"); - DeleteCriticalSection(&(*mutex)->cs); - free(*mutex); - *mutex = &DEAD_MUTEX; - } - return 0; -} - -/* Add pending signal to (other) thread */ -void pthread_np_add_pending_signal(pthread_t thread, int signum) -{ - /* See __sync_fetch_and_or() for gcc 4.4, at least. As some - people are still using gcc 3.x, I prefer to do this in asm. - - For win64 we'll HAVE to rewrite it. __sync_fetch_and_or() seems - to be a rational choice -- there are plenty of GCCisms in SBCL - anyway. - */ - sigset_t to_add = 1<pending_signal_set):"r"(to_add)); -} - -static void futex_interrupt(pthread_t thread); - -/* This pthread_kill doesn't do anything to notify target pthread of a - * new pending signal. - * - * DFL: ... or so the original comment claimed, but that was before - * futexes. Now that we wake up futexes, it's not entirely accurate - * anymore, is it? */ -int pthread_kill(pthread_t thread, int signum) -{ - pthread_np_add_pending_signal(thread,signum); - futex_interrupt(thread); - return 0; -} - -void pthread_np_remove_pending_signal(pthread_t thread, int signum) -{ - sigset_t to_and = ~(1<pending_signal_set):"r"(to_and)); -} - -sigset_t pthread_np_other_thread_sigpending(pthread_t thread) -{ - return - InterlockedCompareExchange((volatile LONG*)&thread->pending_signal_set, - 0, 0); -} - -/* Mutex implementation uses CRITICAL_SECTIONs. Somethings to keep in - mind: (1) uncontested locking is cheap; (2) long wait on a busy - lock causes exception, so it should never be attempted; (3) those - mutexes are recursive; (4) one thread locks, the other unlocks -> - the next one hangs. */ -int pthread_mutex_lock(pthread_mutex_t *mutex) -{ - pthread_np_assert_live_mutex(mutex,"lock"); - if (*mutex == PTHREAD_MUTEX_INITIALIZER) { - pthread_mutex_lock(&mutex_init_lock); - if (*mutex == PTHREAD_MUTEX_INITIALIZER) { - pthread_mutex_init(mutex, NULL); - } - pthread_mutex_unlock(&mutex_init_lock); - } - EnterCriticalSection(&(*mutex)->cs); - DEBUG_OWN(*mutex); - return 0; -} - -int pthread_mutex_trylock(pthread_mutex_t *mutex) -{ - pthread_np_assert_live_mutex(mutex,"trylock"); - if (*mutex == PTHREAD_MUTEX_INITIALIZER) { - pthread_mutex_lock(&mutex_init_lock); - if (*mutex == PTHREAD_MUTEX_INITIALIZER) { - pthread_mutex_init(mutex, NULL); - } - pthread_mutex_unlock(&mutex_init_lock); - } - if (TryEnterCriticalSection(&(*mutex)->cs)) { - DEBUG_OWN(*mutex); - return 0; - } - else - return EBUSY; -} - -/* Versions of lock/trylock useful for debugging. Our header file - conditionally redefines lock/trylock to call them. */ - -int pthread_mutex_lock_annotate_np(pthread_mutex_t *mutex, const char* file, int line) -{ - int contention = 0; - pthread_np_assert_live_mutex(mutex,"lock"); - if (*mutex == PTHREAD_MUTEX_INITIALIZER) { - pthread_mutex_lock(&mutex_init_lock); - if (*mutex == PTHREAD_MUTEX_INITIALIZER) { - pthread_mutex_init(mutex, NULL); - pthshow("Mutex #x%p: automatic initialization; #x%p %s +%d", - mutex, *mutex, - file, line); - } - pthread_mutex_unlock(&mutex_init_lock); - } - if ((*mutex)->owner) { - pthshow("Mutex #x%p -> #x%p: contention; owned by #x%p, wanted by #x%p", - mutex, *mutex, - (*mutex)->owner, - pthread_self()); - pthshow("Mutex #x%p -> #x%p: contention notes: old %s +%d, new %s +%d", - mutex, *mutex, - (*mutex)->file,(*mutex)->line, file, line); - contention = 1; - } - EnterCriticalSection(&(*mutex)->cs); - if (contention) { - pthshow("Mutex #x%p -> #x%p: contention end; left by #x%p, taken by #x%p", - mutex, *mutex, - (*mutex)->owner, - pthread_self()); - pthshow("Mutex #x%p -> #x%p: contention notes: old %s +%d, new %s +%d", - mutex, *mutex, - (*mutex)->file,(*mutex)->line, file, line); - } - (*mutex)->owner = pthread_self(); - (*mutex)->file = file; - (*mutex)->line = line; - return 0; -} - -int pthread_mutex_trylock_annotate_np(pthread_mutex_t *mutex, const char* file, int line) -{ - int contention = 0; - pthread_np_assert_live_mutex(mutex,"trylock"); - if (*mutex == PTHREAD_MUTEX_INITIALIZER) { - pthread_mutex_lock(&mutex_init_lock); - if (*mutex == PTHREAD_MUTEX_INITIALIZER) { - pthread_mutex_init(mutex, NULL); - } - pthread_mutex_unlock(&mutex_init_lock); - } - if ((*mutex)->owner) { - pthshow("Mutex #x%p -> #x%p: tried contention; owned by #x%p, wanted by #x%p", - mutex, *mutex, - (*mutex)->owner, - pthread_self()); - pthshow("Mutex #x%p -> #x%p: contention notes: old %s +%d, new %s +%d", - mutex, *mutex, - (*mutex)->file,(*mutex)->line, file, line); - contention = 1; - } - if (TryEnterCriticalSection(&(*mutex)->cs)) { - if (contention) { - pthshow("Mutex #x%p -> #x%p: contention end; left by #x%p, taken by #x%p", - mutex, *mutex, - (*mutex)->owner, - pthread_self()); - pthshow("Mutex #x%p -> #x%p: contention notes: old %s +%d, new %s +%d", - mutex, *mutex, - (*mutex)->file,(*mutex)->line, file, line); - } - (*mutex)->owner = pthread_self(); - (*mutex)->file = file; - (*mutex)->line = line; - return 0; - } - else - return EBUSY; -} - -int pthread_mutex_unlock(pthread_mutex_t *mutex) -{ - /* Owner is for debugging only; NB if mutex is used recursively, - owner field will lie. */ - pthread_np_assert_live_mutex(mutex,"unlock"); - DEBUG_RELEASE(*mutex); - LeaveCriticalSection(&(*mutex)->cs); - return 0; -} - -/* Condition variables implemented with events and wakeup queues. */ - -/* Thread-local wakeup events are kept in TSD to avoid kernel object - creation on each call to pthread_cond_[timed]wait */ -static pthread_key_t cv_event_key; - -/* .info field in wakeup record is an "opportunistic" indicator that - wakeup has happened. On timeout from WaitForSingleObject, thread - doesn't know (1) whether to reset event, (2) whether to (try) to - find and unlink wakeup record. Let's let it know (of course, - it will know for sure only under cv_wakeup_lock). */ - -#define WAKEUP_WAITING_NOTIMEOUT 0 -#define WAKEUP_WAITING_TIMEOUT 4 - -#define WAKEUP_HAPPENED 1 -#define WAKEUP_BY_INTERRUPT 2 - -static void* event_create() -{ - return (void*)CreateEvent(NULL,FALSE,FALSE,NULL); -} - -static struct freelist event_freelist = FREELIST_INITIALIZER(event_create); - - -unsigned int pthread_free_event_pool_size() -{ - return event_freelist.count; -} - -static HANDLE fe_get_event() -{ - return (HANDLE)freelist_get(&event_freelist); -} - -static void fe_return_event(HANDLE handle) -{ - freelist_return(&event_freelist, (void*)handle); -} - -static void cv_event_destroy(void* event) -{ - CloseHandle((HANDLE)event); -} - -static HANDLE cv_default_event_get_fn() -{ - HANDLE event = pthread_getspecific(cv_event_key); - if (!event) { - event = CreateEvent(NULL, FALSE, FALSE, NULL); - pthread_setspecific(cv_event_key, event); - } else { - /* ResetEvent(event); used to be here. Let's try without. It's - safe in pthread_cond_wait: if WaitForSingleObjectEx ever - returns, event is reset automatically, and the wakeup queue item - is removed by the signaller under wakeup_lock. - - pthread_cond_timedwait should reset the event if - cv_wakeup_remove failed to find its wakeup record, otherwise - it's safe too. */ - } - return event; -} - -static void cv_default_event_return_fn(HANDLE event) -{ - /* ResetEvent(event); could be here as well (and used to be). - Avoiding syscalls makes sense, however. */ -} - -static pthread_condattr_t cv_default_attr = { - 0, /* alertable */ - fe_get_event, - fe_return_event, - /* cv_default_event_get_fn, /\* get_fn *\/ */ - /* cv_default_event_return_fn /\* return_fn *\/ */ -}; - -int pthread_cond_init(pthread_cond_t * cv, const pthread_condattr_t * attr) -{ - if (!attr) - attr = &cv_default_attr; - pthread_mutex_init(&cv->wakeup_lock, NULL); - cv->first_wakeup = NULL; - cv->last_wakeup = NULL; - cv->alertable = attr->alertable; - cv->get_fn = attr->get_fn; - cv->return_fn = attr->return_fn; - return 0; -} - -int pthread_condattr_init(pthread_condattr_t *attr) -{ - *attr = cv_default_attr; - return 0; -} - -int pthread_condattr_destroy(pthread_condattr_t *attr) -{ - return 0; -} -int pthread_condattr_setevent_np(pthread_condattr_t *attr, - cv_event_get_fn get_fn, cv_event_return_fn ret_fn) -{ - attr->get_fn = get_fn ? get_fn : fe_get_event;// cv_default_event_get_fn; - attr->return_fn = ret_fn ? ret_fn : fe_return_event; // cv_default_event_return_fn; - return 0; -} - -int pthread_cond_destroy(pthread_cond_t *cv) -{ - pthread_mutex_destroy(&cv->wakeup_lock); - return 0; -} - -int pthread_cond_broadcast(pthread_cond_t *cv) -{ - int count = 0; - - HANDLE postponed[128]; - int npostponed = 0,i; - - /* No strict requirements to memory visibility model, because of - mutex unlock around waiting. */ - if (!cv->first_wakeup) - return 0; - pthread_mutex_lock(&cv->wakeup_lock); - while (cv->first_wakeup) - { - struct thread_wakeup * w = cv->first_wakeup; - HANDLE waitevent = w->event; - cv->first_wakeup = w->next; - w->info = WAKEUP_HAPPENED; - postponed[npostponed++] = waitevent; - if (/* w->info == WAKEUP_WAITING_TIMEOUT || */ npostponed == - sizeof(postponed)/sizeof(postponed[0])) { - for (i=0; ilast_wakeup = NULL; - pthread_mutex_unlock(&cv->wakeup_lock); - for (i=0; ifirst_wakeup) - return 0; - pthread_mutex_lock(&cv->wakeup_lock); - w = cv->first_wakeup; - if (w) { - HANDLE waitevent = w->event; - cv->first_wakeup = w->next; - if (!cv->first_wakeup) - cv->last_wakeup = NULL; - w->info = WAKEUP_HAPPENED; - SetEvent(waitevent); - } - pthread_mutex_unlock(&cv->wakeup_lock); - return 0; -} - -/* Return value is used for futexes: 0=ok, 1 on unexpected word change. */ -int cv_wakeup_add(struct pthread_cond_t* cv, struct thread_wakeup* w) -{ - HANDLE event; - w->next = NULL; - pthread_mutex_lock(&cv->wakeup_lock); - if (w->uaddr) { - if (w->uval != *w->uaddr) { - pthread_mutex_unlock(&cv->wakeup_lock); - return 1; - } - pthread_self()->futex_wakeup = w; - } - event = cv->get_fn(); - w->event = event; - if (cv->last_wakeup == w) { - fprintf(stderr, "cv->last_wakeup == w\n"); - fflush(stderr); - ExitProcess(0); - } - if (cv->last_wakeup != NULL) - { - cv->last_wakeup->next = w; - cv->last_wakeup = w; - } - else - { - cv->first_wakeup = w; - cv->last_wakeup = w; - } - pthread_mutex_unlock(&cv->wakeup_lock); - return 0; -} - -/* Return true if wakeup found, false if missing */ -int cv_wakeup_remove(struct pthread_cond_t* cv, struct thread_wakeup* w) -{ - int result = 0; - if (w->info == WAKEUP_HAPPENED || w->info == WAKEUP_BY_INTERRUPT) - goto finish; - pthread_mutex_lock(&cv->wakeup_lock); - { - if (w->info == WAKEUP_HAPPENED || w->info == WAKEUP_BY_INTERRUPT) - goto unlock; - if (cv->first_wakeup == w) { - cv->first_wakeup = w->next; - if (cv->last_wakeup == w) - cv->last_wakeup = NULL; - result = 1; - } else { - struct thread_wakeup * prev = cv->first_wakeup; - while (prev && prev->next != w) - prev = prev->next; - if (!prev) { - goto unlock; - } - prev->next = w->next; - if (cv->last_wakeup == w) - cv->last_wakeup = prev; - result = 1; - } - } - unlock: - pthread_mutex_unlock(&cv->wakeup_lock); - finish: - return result; -} - - -int pthread_cond_wait(pthread_cond_t * cv, pthread_mutex_t * cs) -{ - struct thread_wakeup w; - w.uaddr = 0; - w.info = WAKEUP_WAITING_NOTIMEOUT; - cv_wakeup_add(cv, &w); - if (cv->last_wakeup->next == cv->last_wakeup) { - pthread_np_lose(5,"cv->last_wakeup->next == cv->last_wakeup\n"); - } - if (cv->last_wakeup->next != NULL) { - pthread_np_lose(5,"cv->last_wakeup->next == cv->last_wakeup\n"); - } - pthread_self()->waiting_cond = cv; - DEBUG_RELEASE(*cs); - pthread_mutex_unlock(cs); - do { - if (cv->alertable) { - while (WaitForSingleObjectEx(w.event, INFINITE, TRUE) == WAIT_IO_COMPLETION); - } else { - WaitForSingleObject(w.event, INFINITE); - } - } while (w.info == WAKEUP_WAITING_NOTIMEOUT); - pthread_self()->waiting_cond = NULL; - /* Event is signalled once, wakeup is dequeued by signaller. */ - cv->return_fn(w.event); - pthread_mutex_lock(cs); - DEBUG_OWN(*cs); - return 0; -} - -int pthread_cond_timedwait(pthread_cond_t * cv, pthread_mutex_t * cs, - const struct timespec * abstime) -{ - DWORD rv; - struct thread_wakeup w; - pthread_t self = pthread_self(); - - w.info = WAKEUP_WAITING_TIMEOUT; - w.uaddr = 0; - cv_wakeup_add(cv, &w); - if (cv->last_wakeup->next == cv->last_wakeup) { - fprintf(stderr, "cv->last_wakeup->next == cv->last_wakeup\n"); - ExitProcess(0); - } - self->waiting_cond = cv; - DEBUG_RELEASE(*cs); - /* barrier (release); waiting_cond globally visible */ - pthread_mutex_unlock(cs); - { - struct timeval cur_tm; - long sec, msec; - gettimeofday(&cur_tm, NULL); - sec = abstime->tv_sec - cur_tm.tv_sec; - msec = sec * 1000 + abstime->tv_nsec / 1000000 - cur_tm.tv_usec / 1000; - if (msec < 0) - msec = 0; - do { - if (cv->alertable) { - while ((rv = WaitForSingleObjectEx(w.event, msec, TRUE)) - == WAIT_IO_COMPLETION); - } else { - rv = WaitForSingleObject(w.event, msec); - } - } while (rv == WAIT_OBJECT_0 && w.info == WAKEUP_WAITING_TIMEOUT); - } - self->waiting_cond = NULL; - - if (rv == WAIT_TIMEOUT) { - if (!cv_wakeup_remove(cv, &w)) { - /* Someone removed our wakeup record: though we got a timeout, - event was (will be) signalled before we are here. - Consume this wakeup. */ - WaitForSingleObject(w.event, INFINITE); - } - } - cv->return_fn(w.event); - pthread_mutex_lock(cs); - DEBUG_OWN(*cs); - if (rv == WAIT_TIMEOUT) - return ETIMEDOUT; - else - return 0; -} - -int sched_yield() -{ - /* http://stackoverflow.com/questions/1383943/switchtothread-vs-sleep1 - SwitchToThread(); was here. Unsure what's better for us, just trying.. */ - - if(!SwitchToThread()) - Sleep(0); - return 0; -} - -void pthread_lock_structures() -{ - pthread_mutex_lock(&mutex_init_lock); -} - -void pthread_unlock_structures() -{ - pthread_mutex_unlock(&mutex_init_lock); -} - -static int pthread_initialized = 0; - -static pthread_cond_t futex_pseudo_cond; - -void pthreads_win32_init() -{ - if (!pthread_initialized) { - thread_self_tls_index = TlsAlloc(); - pthread_mutex_init(&mutex_init_lock, NULL); - pthread_np_notice_thread(); - pthread_key_create(&cv_event_key,cv_event_destroy); - pthread_cond_init(&futex_pseudo_cond, NULL); - pthread_initialized = 1; - } -} - -static -VOID CALLBACK pthreads_win32_unnotice(void* parameter, BOOLEAN timerOrWait) -{ - pthread_t pth = parameter; - pthread_t self = tls_impersonate(pth); - - tls_call_destructors(); - CloseHandle(pth->handle); - - UnregisterWait(pth->wait_handle); - - tls_impersonate(self); - pthread_mutex_destroy(&pth->lock); - free(pth); -} - -int pthread_np_notice_thread() -{ - if (!pthread_self()) { - pthread_t pth = (pthread_t)calloc(sizeof(pthread_thread),1); - pth->teb = NtCurrentTeb(); - pthread_mutex_init(&pth->lock,NULL); - pth->state = pthread_state_running; - - sigemptyset(&pth->blocked_signal_set); - - DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), - GetCurrentProcess(), &pth->handle, 0, TRUE, - DUPLICATE_SAME_ACCESS); - tls_impersonate(pth); - - if (pthread_initialized) { - RegisterWaitForSingleObject(&pth->wait_handle, - pth->handle, - pthreads_win32_unnotice, - pth, - INFINITE, - WT_EXECUTEONLYONCE); - } - return 1; - } else { - return 0; - } -} - -int sigemptyset(sigset_t *set) -{ - *set = 0; - return 0; -} - -int sigfillset(sigset_t *set) -{ - *set = 0xfffffffful; - return 0; -} - -int sigaddset(sigset_t *set, int signum) -{ - *set |= 1 << signum; - return 0; -} - -int sigdelset(sigset_t *set, int signum) -{ - *set &= ~(1 << signum); - return 0; -} - -int sigismember(const sigset_t *set, int signum) -{ - return (*set & (1 << signum)) != 0; -} -int sigpending(sigset_t *set) -{ - int i; - *set = InterlockedCompareExchange((volatile LONG*)&pthread_self()->pending_signal_set, - 0, 0); - return 0; -} - - -#define FUTEX_EWOULDBLOCK 3 -#define FUTEX_EINTR 2 -#define FUTEX_ETIMEDOUT 1 - -int -futex_wait(volatile intptr_t *lock_word, intptr_t oldval, long sec, unsigned long usec) -{ - struct thread_wakeup w; - pthread_t self = pthread_self(); - DWORD msec = sec<0 ? INFINITE : (sec*1000 + usec/1000); - DWORD wfso; - int result; - sigset_t pendset, blocked; - int maybeINTR; - int info = sec<0 ? WAKEUP_WAITING_NOTIMEOUT: WAKEUP_WAITING_TIMEOUT; - - sigpending(&pendset); - if (pendset & ~self->blocked_signal_set) - return FUTEX_EINTR; - w.uaddr = lock_word; - w.uval = oldval; - w.info = info; - - if (cv_wakeup_add(&futex_pseudo_cond,&w)) { - return FUTEX_EWOULDBLOCK; - } - self->futex_wakeup = &w; - do { - wfso = WaitForSingleObject(w.event, msec); - } while (wfso == WAIT_OBJECT_0 && w.info == info); - self->futex_wakeup = NULL; - sigpending(&pendset); - maybeINTR = (pendset & ~self->blocked_signal_set)? FUTEX_EINTR : 0; - - switch(wfso) { - case WAIT_TIMEOUT: - if (!cv_wakeup_remove(&futex_pseudo_cond,&w)) { - /* timeout, but someone other removed wakeup. */ - result = maybeINTR; - WaitForSingleObject(w.event,INFINITE); - } else { - result = FUTEX_ETIMEDOUT; - } - break; - case WAIT_OBJECT_0: - result = maybeINTR; - break; - default: - result = -1; - break; - } - futex_pseudo_cond.return_fn(w.event); - return result; -} - -int -futex_wake(volatile intptr_t *lock_word, int n) -{ - pthread_cond_t *cv = &futex_pseudo_cond; - int result = 0; - struct thread_wakeup *w, *prev; - HANDLE postponed[128]; - int npostponed = 0,i; - - if (n==0) return 0; - - pthread_mutex_lock(&cv->wakeup_lock); - for (w = cv->first_wakeup, prev = NULL; w && n;) { - if (w->uaddr == lock_word) { - HANDLE event = w->event; - int oldinfo = w->info; - w->info = WAKEUP_HAPPENED; - if (cv->last_wakeup == w) - cv->last_wakeup = prev; - w = w->next; - if (!prev) { - cv->first_wakeup = w; - } else { - prev->next = w; - } - n--; - postponed[npostponed++] = event; - if (npostponed == sizeof(postponed)/sizeof(postponed[0])) { - for (i=0; inext; - } - } - pthread_mutex_unlock(&cv->wakeup_lock); - for (i=0; ifutex_wakeup) { - pthread_cond_t *cv = &futex_pseudo_cond; - struct thread_wakeup *w; - HANDLE event; - pthread_mutex_lock(&cv->wakeup_lock); - if ((w = thread->futex_wakeup)) { - /* we are taking wakeup_lock recursively - ok with - CRITICAL_SECTIONs */ - if (cv_wakeup_remove(&futex_pseudo_cond,w)) { - event = w->event; - w->info = WAKEUP_BY_INTERRUPT; - thread->futex_wakeup = NULL; - } else { - w = NULL; - } - } - if (w) { - SetEvent(event); - } - pthread_mutex_unlock(&cv->wakeup_lock); - } -} - -void pthread_np_lose(int trace_depth, const char* fmt, ...) -{ - va_list header; - void* frame; - int n = 0; - void** lastseh; - - va_start(header,fmt); - vfprintf(stderr,fmt,header); - for (lastseh = *(void**)NtCurrentTeb(); - lastseh && (lastseh!=(void*)0xFFFFFFFF); - lastseh = *lastseh); - - fprintf(stderr, "Backtrace: %s (pthread %p)\n", header, pthread_self()); - for (frame = __builtin_frame_address(0); frame; frame=*(void**)frame) - { - if ((n++)>trace_depth) - return; - fprintf(stderr, "[#%02d]: ebp = %p, ret = %p\n",n, - frame, ((void**)frame)[1]); - } - ExitProcess(0); -} - -int -sem_init(sem_t *sem, int pshared_not_implemented, unsigned int value) -{ - sem_t semh = CreateSemaphore(NULL, value, SEM_VALUE_MAX, NULL); - if (!semh) - return -1; - *sem = semh; - return 0; -} - -int -sem_post(sem_t *sem) -{ - return !ReleaseSemaphore(*sem, 1, NULL); -} - -static int -sem_wait_timeout(sem_t *sem, DWORD ms) -{ - switch (WaitForSingleObject(*sem, ms)) { - case WAIT_OBJECT_0: - return 0; - case WAIT_TIMEOUT: - /* errno = EAGAIN; */ - return -1; - default: - /* errno = EINVAL; */ - return -1; - } -} - -int -sem_wait(sem_t *sem) -{ - return sem_wait_timeout(sem, INFINITE); -} - -int -sem_trywait(sem_t *sem) -{ - return sem_wait_timeout(sem, 0); -} - -int -sem_destroy(sem_t *sem) -{ - return !CloseHandle(*sem); -} - -#endif diff -Nru sbcl-2.0.6/src/runtime/pthreads_win32.h sbcl-2.1.1/src/runtime/pthreads_win32.h --- sbcl-2.0.6/src/runtime/pthreads_win32.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/pthreads_win32.h 2021-01-30 11:22:38.000000000 +0000 @@ -2,8 +2,6 @@ #define WIN32_PTHREAD_INCLUDED #include -#include -#include #ifndef _SIGSET_T typedef int sigset_t; @@ -12,7 +10,6 @@ #define WIN32_LEAN_AND_MEAN #include -#include /* 0 - Misc */ @@ -50,104 +47,11 @@ #define NSIG 32 /* maximum signal number + 1 */ #endif -/* To avoid overusing system TLS, pthread provides its own */ -#define PTHREAD_KEYS_MAX 128 - -#define PTHREAD_DESTRUCTOR_ITERATIONS 4 - -void pthreads_win32_init(); - /* 1 - Thread */ -typedef struct pthread_thread* pthread_t; - -typedef struct pthread_attr_t { - unsigned int stack_size; -} pthread_attr_t; - -int pthread_attr_init(pthread_attr_t *attr); -int pthread_attr_destroy(pthread_attr_t *attr); -int pthread_attr_setstack(pthread_attr_t *attr, void *stackaddr, size_t stacksize); -int pthread_attr_setstacksize(pthread_attr_t *attr, size_t stacksize); - -typedef void (*pthread_cleanup_fn)(void* arg); - -#define pthread_cleanup_push(fn, arg) { pthread_cleanup_fn __pthread_fn = fn; void *__pthread_arg = arg; -#define pthread_cleanup_pop(execute) if (execute) __pthread_fn(__pthread_arg); } - -int pthread_create(pthread_t *thread, const pthread_attr_t *attr, void *(*start_routine) (void *), void *arg); -int pthread_equal(pthread_t thread1, pthread_t thread2); -int pthread_detach(pthread_t thread); -int pthread_join(pthread_t thread, void **retval); -int pthread_kill(pthread_t thread, int signum); - -#ifndef PTHREAD_INTERNALS -pthread_t pthread_self(void) __attribute__((__const__)); -#else -pthread_t pthread_self(void); -#endif - -typedef DWORD pthread_key_t; -int pthread_key_create(pthread_key_t *key, void (*destructor)(void*)); - #define SIG_BLOCK 1 #define SIG_UNBLOCK 2 #define SIG_SETMASK 3 -#ifdef PTHREAD_INTERNALS -int _sbcl_pthread_sigmask(int how, const sigset_t *set, sigset_t *oldset); -#endif - -/* 2 - Mutex */ - -typedef struct _pthread_mutex_info { - char padding[64]; - CRITICAL_SECTION cs; - pthread_t owner; - const char* file; - int line; -} __attribute__((aligned(128))) *pthread_mutex_t; - -typedef int pthread_mutexattr_t; -#define PTHREAD_MUTEX_INITIALIZER ((pthread_mutex_t)-1) -int pthread_mutex_init(pthread_mutex_t * mutex, const pthread_mutexattr_t * attr); -int pthread_mutexattr_init(pthread_mutexattr_t*); -int pthread_mutexattr_destroy(pthread_mutexattr_t*); -int pthread_mutexattr_settype(pthread_mutexattr_t*, int); -#define PTHREAD_MUTEX_ERRORCHECK 0 -int pthread_mutex_destroy(pthread_mutex_t *mutex); -int pthread_mutex_lock(pthread_mutex_t *mutex); -int pthread_mutex_trylock(pthread_mutex_t *mutex); -int pthread_mutex_lock_annotate_np(pthread_mutex_t *mutex, const char* file, int line); -int pthread_mutex_trylock_annotate_np(pthread_mutex_t *mutex, const char* file, int line); -int pthread_mutex_unlock(pthread_mutex_t *mutex); - -/* 3 - Condition variable */ - -typedef struct thread_wakeup { - HANDLE event; - struct thread_wakeup *next; - volatile intptr_t *uaddr; - intptr_t uval; - int info; -} thread_wakeup; - -typedef HANDLE (*cv_event_get_fn)(); -typedef void (*cv_event_return_fn)(HANDLE event); - -typedef struct pthread_cond_t { - pthread_mutex_t wakeup_lock; - struct thread_wakeup *first_wakeup; - struct thread_wakeup *last_wakeup; - unsigned char alertable; - cv_event_get_fn get_fn; - cv_event_return_fn return_fn; -} pthread_cond_t; - -typedef struct pthread_condattr_t { - unsigned char alertable; - cv_event_get_fn get_fn; - cv_event_return_fn return_fn; -} pthread_condattr_t; #ifndef _TIMESPEC_DEFINED typedef struct timespec { @@ -156,18 +60,6 @@ } timespec; #endif -// not implemented: PTHREAD_COND_INITIALIZER -int pthread_condattr_init(pthread_condattr_t *attr); -int pthread_condattr_destroy(pthread_condattr_t *attr); -int pthread_condattr_setevent_np(pthread_condattr_t *attr, - cv_event_get_fn get_fn, cv_event_return_fn ret_fn); -int pthread_cond_destroy(pthread_cond_t *cond); -int pthread_cond_init(pthread_cond_t * cond, const pthread_condattr_t * attr); -int pthread_cond_broadcast(pthread_cond_t *cond); -int pthread_cond_signal(pthread_cond_t *cond); -int pthread_cond_timedwait(pthread_cond_t * cond, pthread_mutex_t * mutex, const struct timespec * abstime); -int pthread_cond_wait(pthread_cond_t * cond, pthread_mutex_t * mutex); - /* some MinGWs seem to include it, others not: */ #ifndef ETIMEDOUT # define ETIMEDOUT 123 //Something @@ -175,49 +67,6 @@ int sched_yield(); -void pthread_lock_structures(); -void pthread_unlock_structures(); - -typedef void *(*pthread_fn)(void*); - -typedef enum { - pthread_state_running, - pthread_state_finished, - pthread_state_joined -} pthread_thread_state; - -typedef struct pthread_thread { - pthread_fn start_routine; - void* arg; - HANDLE handle; - pthread_cond_t *waiting_cond; - void *futex_wakeup; - sigset_t blocked_signal_set; - volatile sigset_t pending_signal_set; - void * retval; - - pthread_mutex_t lock; - pthread_cond_t cond; - int detached; - pthread_thread_state state; - - /* For noticed foreign threads, wait_handle contains a result of - RegisterWaitForSingleObject. */ - HANDLE wait_handle; - - /* Thread TEB base (mostly informative/debugging) */ - void* teb; - - /* Pthread TLS, detached from windows system TLS */ - void *specifics[PTHREAD_KEYS_MAX]; -} pthread_thread; - -static inline int pthread_setspecific(pthread_key_t key, const void *value) -{ - pthread_self()->specifics[key] = (void*)value; - return 0; -} - typedef struct { int bogus; } siginfo_t; @@ -237,110 +86,10 @@ int sigpending(sigset_t *set); -void pthread_np_add_pending_signal(pthread_t thread, int signum); -void pthread_np_remove_pending_signal(pthread_t thread, int signum); -sigset_t pthread_np_other_thread_sigpending(pthread_t thread); - -int pthread_np_notice_thread(); - int sigemptyset(sigset_t *set); int sigfillset(sigset_t *set); int sigaddset(sigset_t *set, int signum); int sigdelset(sigset_t *set, int signum); int sigismember(const sigset_t *set, int signum); -typedef int sig_atomic_t; - -/* Futexes */ -int futex_wait(volatile intptr_t *lock_word, intptr_t oldval, long sec, unsigned long usec); -int futex_wake(volatile intptr_t *lock_word, int n); - -/* Debugging */ -void pthread_np_lose(int trace_depth, const char* fmt, ...); -extern struct _pthread_mutex_info DEAD_MUTEX; - -static inline void pthread_np_assert_live_mutex(pthread_mutex_t* ptr, - const char *action) -{ - if (*ptr == &DEAD_MUTEX) { - pthread_np_lose(5,"Trying to %s dead mutex %p\n",action,ptr); - } -} - -typedef HANDLE sem_t; - -#define SEM_VALUE_MAX (int) (~0U >>1) - -int sem_init(sem_t *sem, int pshared_not_implemented, unsigned int value); -int sem_post(sem_t *sem); -int sem_wait(sem_t *sem); -int sem_trywait(sem_t *sem); -int sem_destroy(sem_t *sem); - -#ifndef PTHREAD_INTERNALS -static inline int _sbcl_pthread_sigmask(int how, const sigset_t *set, sigset_t *oldset) -{ - pthread_t self = pthread_self(); - if (oldset) - *oldset = self->blocked_signal_set; - if (set) { - switch (how) { - case SIG_BLOCK: - self->blocked_signal_set |= *set; - break; - case SIG_UNBLOCK: - self->blocked_signal_set &= ~(*set); - break; - case SIG_SETMASK: - self->blocked_signal_set = *set; - break; - } - } - return 0; -} - -/* Make speed-critical TLS access inline. - - We don't check key range or validity here: (1) pthread spec is - explicit about undefined behavior for bogus keys, (2) - setspecific/getspecific should be as fast as possible. */ -#define pthread_getspecific pthread_getspecific_np_inline - -static inline void *pthread_getspecific_np_inline(pthread_key_t key) -{ - return pthread_self()->specifics[key]; -} - -#ifdef PTHREAD_DEBUG_OUTPUT -#define pthread_mutex_lock(mutex) \ - pthread_mutex_lock_annotate_np(mutex, __FILE__, __LINE__ ) -#define pthread_mutex_trylock(mutex) \ - pthread_mutex_trylock_annotate_np(mutex, __FILE__ ,__LINE__) -#else - -/* I'm not after inlinining _everything_, but those two things below are - (1) fast, (2) critical (3) short */ -static inline int pthread_mutex_lock_np_inline(pthread_mutex_t *mutex) -{ - pthread_np_assert_live_mutex(mutex,"lock"); - if ((*mutex) == PTHREAD_MUTEX_INITIALIZER) { - return pthread_mutex_lock(mutex); - } else { - EnterCriticalSection(&(*mutex)->cs); - return 0; - } -} - -static inline int pthread_mutex_unlock_np_inline(pthread_mutex_t *mutex) -{ - pthread_np_assert_live_mutex(mutex,"unlock"); - LeaveCriticalSection(&(*mutex)->cs); - return 0; -} - -#define pthread_mutex_lock pthread_mutex_lock_np_inline -#define pthread_mutex_unlock pthread_mutex_unlock_np_inline - -#endif /* !PTHREAD_DEBUG_OUTPUT */ -#endif /* !PTHREAD_INTERNALS */ #endif /* WIN32_PTHREAD_INCLUDED */ diff -Nru sbcl-2.0.6/src/runtime/purify.c sbcl-2.1.1/src/runtime/purify.c --- sbcl-2.0.6/src/runtime/purify.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/purify.c 2021-01-30 11:22:38.000000000 +0000 @@ -160,8 +160,8 @@ ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant) { constant = 0; - lispobj info = LAYOUT(instance_layout(native_pointer(thing)))->info; - if (info != NIL) { + lispobj info = LAYOUT(instance_layout(native_pointer(thing)))->_info; + if (instancep(info)) { lispobj pure = ((struct defstruct_description*)native_pointer(info))->pure; if (pure != NIL && pure != T) { gc_abort(); @@ -259,7 +259,7 @@ #endif /* Put in forwarding pointers for all the functions. */ for_each_simple_fun(i, newfunc, new, 1, { - lispobj* old = (lispobj*)LOW_WORD((char*)newfunc - displacement); + lispobj* old = (lispobj*)((char*)newfunc - displacement); *old = make_lispobj(newfunc, FUN_POINTER_LOWTAG); pscav(&newfunc->self, 1, 1); // and fix the self-pointer now }); @@ -410,7 +410,6 @@ case COMPLEX_CHARACTER_STRING_WIDETAG: #endif case COMPLEX_BIT_VECTOR_WIDETAG: - case COMPLEX_VECTOR_NIL_WIDETAG: case COMPLEX_VECTOR_WIDETAG: case COMPLEX_ARRAY_WIDETAG: return ptrans_boxed(thing, header, constant); @@ -529,7 +528,7 @@ // [1] : vector length // [2] : element[0] = high-water mark // [3] : element[1] = rehash bit - if (is_vector_subtype(thing, VectorAddrHashing)) + if (vector_flagp(thing, VectorAddrHashing)) addr[3] = make_fixnum(1); // just flag it for rehash count = 2; break; @@ -560,23 +559,14 @@ case INSTANCE_WIDETAG: { - lispobj lbitmap = LAYOUT(instance_layout(addr))->bitmap; - lispobj* slots = addr + 1; - long nslots = instance_length(*addr) | 1; - int index; - if (fixnump(lbitmap)) { - sword_t bitmap = fixnum_value(lbitmap); - for (index = 0; index < nslots ; index++, bitmap >>= 1) - if (bitmap & 1) - pscav(slots + index, 1, constant); - } else { - struct bignum * bitmap; - bitmap = (struct bignum*)native_pointer(lbitmap); - for (index = 0; index < nslots ; index++) - if (positive_bignum_logbitp(index, bitmap)) - pscav(slots + index, 1, constant); - } - count = 1 + nslots; + struct bitmap bitmap = get_layout_bitmap(LAYOUT(instance_layout(addr))); + long nslots = instance_length(*addr); + int index; + for (index = 0; index < nslots ; index++) + // logically treat index 0 (layout) as a tagged slot + if (index == 0 || bitmap_logbitp(index, bitmap)) + pscav((addr+1) + index, 1, constant); + count = 1 + (nslots | 1); } break; @@ -667,9 +657,7 @@ printf(" handlers"); fflush(stdout); #endif - pscav((lispobj *) interrupt_handlers, - sizeof(interrupt_handlers) / sizeof(lispobj), - 0); + pscav(lisp_sig_handlers, NSIG, 0); #ifdef PRINTNOISE printf(" stack"); @@ -735,9 +723,6 @@ printf(" cleanup"); fflush(stdout); #endif -#ifdef LISP_FEATURE_HPUX - clear_auto_gc_trigger(); /* restore mmap as it was given by os */ -#endif os_zero((os_vm_address_t) current_dynamic_space, dynamic_space_size); diff -Nru sbcl-2.0.6/src/runtime/riscv-arch.c sbcl-2.1.1/src/runtime/riscv-arch.c --- sbcl-2.0.6/src/runtime/riscv-arch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/riscv-arch.c 2021-01-30 11:22:38.000000000 +0000 @@ -121,14 +121,14 @@ void sigtrap_handler(int signal, siginfo_t *info, os_context_t *context) { - u32 trap_instruction = *((u32 *)*os_context_pc_addr(context)); + uint32_t trap_instruction = *((uint32_t *)*os_context_pc_addr(context)); if (trap_instruction != 0x100073) { lose("Unrecognized trap instruction %08x in sigtrap_handler()", trap_instruction); } - u32 code = *((u32 *)(4 + *os_context_pc_addr(context))); + uint32_t code = *((uint32_t *)(4 + *os_context_pc_addr(context))); if (code == trap_PendingInterrupt) { arch_skip_instruction(context); @@ -140,7 +140,7 @@ void arch_install_interrupt_handlers(void) { - undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); + ll_install_handler(SIGTRAP, sigtrap_handler); } /* Linkage table */ diff -Nru sbcl-2.0.6/src/runtime/riscv-linux-os.c sbcl-2.1.1/src/runtime/riscv-linux-os.c --- sbcl-2.0.6/src/runtime/riscv-linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/riscv-linux-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -26,8 +26,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include @@ -41,9 +39,6 @@ int arch_os_thread_init(struct thread *thread) { -#ifdef LISP_FEATURE_SB_THREAD - pthread_setspecific(specials,thread); -#endif return 1; /* success */ } diff -Nru sbcl-2.0.6/src/runtime/run-program.c sbcl-2.1.1/src/runtime/run-program.c --- sbcl-2.0.6/src/runtime/run-program.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/run-program.c 2021-01-30 11:22:38.000000000 +0000 @@ -27,6 +27,7 @@ #include #include #include +#include "interr.h" // for lose() #ifdef LISP_FEATURE_OPENBSD #include @@ -76,7 +77,7 @@ { int fd; -#if !defined(LISP_FEATURE_HPUX) && !defined(SVR4) && !defined(__HAIKU__) +#if !defined(SVR4) && !defined(__HAIKU__) fd = open("/dev/tty", O_RDWR, 0); if (fd >= 0) { ioctl(fd, TIOCNOTTY, 0); @@ -132,8 +133,26 @@ return 0; } -void closefds_from(int lowfd) +void closefds_from(int lowfd, int* dont_close) { + if (dont_close) { + /* dont_close is a sorted simple-array of ints */ + uword_t length = fixnum_value(((uword_t*)dont_close)[-1]); + uword_t i; + for (i = 0; i < length; i++) + { + int fd = dont_close[i]; + int close_fd; + + /* Close the gaps between the fds */ + for (close_fd = lowfd; close_fd < fd; close_fd++) + { + close(close_fd); + } + lowfd = fd+1; + } + } + #if defined(LISP_FEATURE_OPENBSD) || defined(LISP_FEATURE_NETBSD) \ || defined(LISP_FEATURE_DRAGONFLY) || defined(LISP_FEATURE_FREEBSD) \ || defined(LISP_FEATURE_SUNOS) @@ -198,7 +217,7 @@ int spawn(char *program, char *argv[], int sin, int sout, int serr, int search, char *envp[], char *pty_name, int channel[2], - char *pwd) + char *pwd, int* dont_close) { pid_t pid; sigset_t sset; @@ -206,7 +225,8 @@ channel[0] = -1; channel[1] = -1; - pipe(channel); + // Surely we can do better than to lose() + if (pipe(channel)) lose("can't run-program"); pid = fork(); if (pid) { @@ -218,7 +238,7 @@ * share stdin with our parent. In the latter case we claim * control of the terminal. */ if (sin >= 0) { -#if defined(LISP_FEATURE_HPUX) || defined(LISP_FEATURE_OPENBSD) +#ifdef LISP_FEATURE_OPENBSD setsid(); #elif defined(LISP_FEATURE_DARWIN) setpgid(0, getpid()); @@ -250,7 +270,7 @@ /* Close all other fds. First arrange for the pipe fd to be the * lowest free fd, then close every open fd above that. */ channel[1] = dup2(channel[1], 3); - closefds_from(4); + closefds_from(4, dont_close); if (-1 != channel[1]) { if (-1==fcntl(channel[1], F_SETFD, FD_CLOEXEC)) { diff -Nru sbcl-2.0.6/src/runtime/runtime.c sbcl-2.1.1/src/runtime/runtime.c --- sbcl-2.0.6/src/runtime/runtime.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/runtime.c 2021-01-30 11:22:38.000000000 +0000 @@ -33,14 +33,14 @@ #include "runtime.h" #ifndef LISP_FEATURE_WIN32 #include +#else +#include #endif #include #include #include -#if defined(SVR4) || defined(__linux__) #include -#endif #if !(defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD)) #include "signal.h" @@ -64,36 +64,12 @@ #include "genesis/static-symbols.h" #include "genesis/symbol.h" +struct timespec lisp_init_time; + static char libpath[] = "../lib/sbcl"; char *sbcl_runtime_home; char *sbcl_runtime; -#ifdef LISP_FEATURE_HPUX -extern void *return_from_lisp_stub; -#include "genesis/closure.h" -#include "genesis/simple-fun.h" -#endif - - -/* SIGINT handler that invokes the monitor (for when Lisp isn't up to it) */ -static void -sigint_handler(int __attribute__((unused)) signal, - siginfo_t __attribute__((unused)) *info, - os_context_t *context) -{ - lose("\nSIGINT hit at 0x%08lX", - (unsigned long) *os_context_pc_addr(context)); -} - -/* (This is not static, because we want to be able to call it from - * Lisp land.) */ -void -sigint_init(void) -{ - SHOW("entering sigint_init()"); - install_handler(SIGINT, sigint_handler, 0, 1); - SHOW("leaving sigint_init()"); -} /* * helper functions for dealing with command line args @@ -364,7 +340,13 @@ return res; } -char **posix_argv; +#ifdef LISP_FEATURE_WIN32 + wchar_t +#else + char +#endif + **posix_argv; + char *core_string; #if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD) @@ -423,11 +405,26 @@ /* Exception handling support structure. Evil Win32 hack. */ struct lisp_exception_frame exception_frame; #endif +#ifdef LISP_FEATURE_UNIX + clock_gettime( +#ifdef LISP_FEATURE_LINUX + CLOCK_MONOTONIC_COARSE +#else + CLOCK_MONOTONIC +#endif + , &lisp_init_time); +#endif /* the name of the core file we're to execute. Note that this is * a malloc'ed string which should be freed eventually. */ char *core = 0; - char **sbcl_argv = 0; + +#ifdef LISP_FEATURE_WIN32 + wchar_t +#else + char +#endif + **sbcl_argv = 0; os_vm_offset_t embedded_core_offset = 0; /* other command line options */ @@ -447,12 +444,14 @@ memsize_options.present_in_core = 0; boolean have_hardwired_spaces = os_preinit(argv, envp); -#if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD) - pthreads_win32_init(); -#endif interrupt_init(); +#ifdef LISP_FEATURE_UNIX + /* Not sure why anyone sends signals to this process so early. + * But win32 models the signal mask as part of 'struct thread' + * which doesn't exist yet, so don't do this */ block_blockable_signals(0); +#endif /* Check early to see if this executable has an embedded core, * which also populates runtime_options if the core has runtime @@ -478,7 +477,12 @@ dynamic_space_size = memsize_options.dynamic_space_size; thread_control_stack_size = memsize_options.thread_control_stack_size; dynamic_values_bytes = memsize_options.thread_tls_bytes; +#ifndef LISP_FEATURE_WIN32 sbcl_argv = argv; +#else + int wargc; + sbcl_argv = CommandLineToArgvW(GetCommandLineW(), &wargc); +#endif } else { int argi = 1; @@ -585,6 +589,7 @@ { char *argi0 = argv[argi]; int argj = 1; +#ifndef LISP_FEATURE_WIN32 /* (argc - argi) for the arguments, one for the binary, and one for the terminating NULL. */ sbcl_argv = successful_malloc((2 + argc - argi) * sizeof(char *)); @@ -602,6 +607,24 @@ } sbcl_argv[argj++] = arg; } +#else + /* The runtime options are processed as chars above, which may + * not always work but may be good enough for now, as it + * has been for a long time. */ + int wargc; + wchar_t** wargv; + wargv = CommandLineToArgvW(GetCommandLineW(), &wargc); + sbcl_argv = successful_malloc((2 + wargc - argi) * sizeof(wchar_t *)); + sbcl_argv[0] = wargv[0]; + while (argi < wargc) { + wchar_t *warg = wargv[argi++]; + if (!end_runtime_options && + 0 == wcscmp(warg, L"--end-runtime-options")) { + lose("bad runtime option \"%s\"", argi0); + } + sbcl_argv[argj++] = warg; + } +#endif sbcl_argv[argj] = 0; } } @@ -619,12 +642,6 @@ print_environment(argc, argv); } dyndebug_init(); -#ifdef LISP_FEATURE_ALPHA // When we remove Alpha, this #if can go away - /* KLUDGE: os_vm_page_size is set by os_init(), and on some - * systems (e.g. Alpha) arch_init() needs need os_vm_page_size, so - * it must follow os_init(). -- WHN 2000-01-26 */ - arch_init(); -#endif // FIXME: if the 'have' flag is 0 and you've disabled disabling of ASLR // then we haven't done an exec(), nor unmapped the mappings that were obtained // already obtained (if any) so it is unhelpful to try again here. @@ -701,13 +718,6 @@ * since it was too soon earlier to handle write faults. */ write_protect_immobile_space(); #endif -#ifdef LISP_FEATURE_HPUX - // FIXME: obvious bitrot here. 23 isn't the offset to anything. - /* -1 = CLOSURE_FUN_OFFSET, 23 = SIMPLE_FUN_CODE_OFFSET, we are - * not in __ASSEMBLER__ so we cant reach them. */ - return_from_lisp_stub = (void *) ((char *)*((unsigned long *) - ((char *)initial_function + -1)) + 23); -#endif arch_install_interrupt_handlers(); #ifndef LISP_FEATURE_WIN32 @@ -725,7 +735,7 @@ FSHOW((stderr, "/funcalling initial_function=0x%lx\n", (unsigned long)initial_function)); - create_initial_thread(initial_function); + create_main_lisp_thread(initial_function); lose("unexpected return from initial thread in main()"); return 0; } diff -Nru sbcl-2.0.6/src/runtime/runtime.h sbcl-2.1.1/src/runtime/runtime.h --- sbcl-2.0.6/src/runtime/runtime.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/runtime.h 2021-01-30 11:22:38.000000000 +0000 @@ -15,6 +15,8 @@ #ifndef _SBCL_RUNTIME_H_ #define _SBCL_RUNTIME_H_ +#include "lispobj.h" + #if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD) # include "pthreads_win32.h" #else @@ -28,22 +30,26 @@ #include #if defined(LISP_FEATURE_SB_THREAD) -#define thread_self() pthread_self() -#define thread_equal(a,b) pthread_equal(a,b) -#define thread_kill pthread_kill #ifdef LISP_FEATURE_WIN32 -#define thread_sigmask _sbcl_pthread_sigmask +#define thread_sigmask sb_pthread_sigmask +// wrap CriticalSection operators in a function returning 0 to satisfy assertions +static inline int cs_mutex_lock(void* l) { EnterCriticalSection(l); return 0; } +static inline int cs_mutex_unlock(void* l) { LeaveCriticalSection(l); return 0; } +#define thread_mutex_lock(l) cs_mutex_lock(l) +#define thread_mutex_unlock(l) cs_mutex_unlock(l) #else +#define thread_self() pthread_self() +#define thread_equal(a,b) pthread_equal(a,b) #define thread_sigmask pthread_sigmask -#endif - #define thread_mutex_lock(l) pthread_mutex_lock(l) #define thread_mutex_unlock(l) pthread_mutex_unlock(l) +#endif + #else +// not SB_THREAD #define thread_self() 0 #define thread_equal(a,b) ((a)==(b)) -#define thread_kill kill_safely #define thread_sigmask sigprocmask #define thread_mutex_lock(l) 0 #define thread_mutex_unlock(l) 0 @@ -80,13 +86,6 @@ * you are a developer and want to affect FSHOW behaviour. */ -/* Block blockable interrupts for each SHOW, if not 0. - * (On Windows, this setting has no effect.) - * - * In principle, this is a "configuration option", but I am not aware of - * any reason why or when it would be advantageous to disable it. */ -#define QSHOW_SIGNAL_SAFE 1 - /* Enable extra-verbose low-level debugging output for signals? (You * probably don't want this unless you're trying to debug very early * cold boot on a new machine, or one where you've just messed up @@ -165,19 +164,6 @@ void dyndebug_init(void); -#if QSHOW_SIGNAL_SAFE == 1 && !defined(LISP_FEATURE_WIN32) - -extern sigset_t blockable_sigset; - -#define QSHOW_BLOCK \ - sigset_t oldset; \ - thread_sigmask(SIG_BLOCK, &blockable_sigset, &oldset) -#define QSHOW_UNBLOCK thread_sigmask(SIG_SETMASK,&oldset,0) -#else -#define QSHOW_BLOCK -#define QSHOW_UNBLOCK -#endif - /* The following macros duplicate the expansion of odxprint, because the * extra level of parentheses around `args' prevents us from * implementing FSHOW in terms of odxprint directly. (They also differ @@ -200,24 +186,6 @@ # define FSHOW_SIGNAL(args) #endif -/* KLUDGE: These are in theory machine-dependent and OS-dependent, but - * in practice the "foo int" definitions work for all the machines - * that SBCL runs on as of 0.6.7. If we port to the Alpha or some - * other non-32-bit machine we'll probably need real machine-dependent - * and OS-dependent definitions again. */ -/* even on alpha, int happens to be 4 bytes. long is longer. */ -/* FIXME: these names really shouldn't reflect their length and this - is not quite right for some of the FFI stuff */ -#if defined(LISP_FEATURE_WIN32)&&defined(LISP_FEATURE_X86_64) -typedef unsigned long long u64; -typedef signed long long s64; -#else -typedef unsigned long u64; -typedef signed long s64; -#endif -typedef unsigned int u32; -typedef signed int s32; - #ifdef _WIN64 #define AMD64_SYSV_ABI __attribute__((sysv_abi)) #else @@ -226,33 +194,7 @@ #include -#if defined(LISP_FEATURE_SB_THREAD) -typedef pthread_t os_thread_t; -#else -typedef pid_t os_thread_t; -#endif - -#ifndef LISP_FEATURE_ALPHA -typedef uintptr_t uword_t; -typedef intptr_t sword_t; -#else -/* The alpha32 port uses non-intptr-sized words */ -typedef u32 uword_t; -typedef s32 sword_t; -#endif - -/* FIXME: we do things this way because of the alpha32 port. once - alpha64 has arrived, all this nastiness can go away */ -#if 64 == N_WORD_BITS -#define LOW_WORD(c) ((uintptr_t)c) #define OBJ_FMTX PRIxPTR -typedef uintptr_t lispobj; -#else -#define OBJ_FMTX "x" -#define LOW_WORD(c) ((long)(c) & 0xFFFFFFFFL) -/* fake it on alpha32 */ -typedef unsigned int lispobj; -#endif static inline int lowtag_of(lispobj obj) @@ -298,36 +240,6 @@ widetag_of((lispobj*)(obj-OTHER_POINTER_LOWTAG)) == SIMPLE_VECTOR_WIDETAG; } -/* This is NOT the same value that lisp's %INSTANCE-LENGTH returns. - * Lisp always uses the logical length (as originally allocated), - * except when heap-walking which requires exact physical sizes */ -static inline int instance_length(lispobj header) -{ - // * Byte 3 of an instance header word holds the immobile gen# and visited bit, - // so those have to be masked off. - // * fullcgc uses bit index 31 as a mark bit, so that has to - // be cleared. Lisp does not have to clear bit 31 because fullcgc does not - // operate concurrently. - // * If the object is in hashed-and-moved state and the original instance payload - // length was odd (total object length was even), then add 1. - // This can be detected by ANDing some bits, bit 10 being the least-significant - // bit of the original size, and bit 9 being the 'hashed+moved' bit. - // * 64-bit machines do not need 'long' right-shifts, so truncate to int. - - int extra = ((unsigned int)header >> 10) & ((unsigned int)header >> 9) & 1; - return (((unsigned int)header >> INSTANCE_LENGTH_SHIFT) & 0x3FFF) + extra; -} - -/// instance_layout() macro takes a lispobj* and is an lvalue -#ifndef LISP_FEATURE_COMPACT_INSTANCE_HEADER -# define instance_layout(instance_ptr) ((lispobj*)instance_ptr)[1] -#elif defined(LISP_FEATURE_64_BIT) && defined(LISP_FEATURE_LITTLE_ENDIAN) - // so that this stays an lvalue, it can't be cast to lispobj -# define instance_layout(instance_ptr) ((uint32_t*)(instance_ptr))[1] -#else -# error "No instance_layout() defined" -#endif - /* Is the Lisp object obj something with pointer nature (as opposed to * e.g. a fixnum or character or unbound marker)? */ static inline int @@ -381,15 +293,10 @@ static inline lispobj make_lispobj(void *o, int low_tag) { - return LOW_WORD(o) | low_tag; + return (lispobj)o | low_tag; } -#define MAKE_FIXNUM(n) (n << N_FIXNUM_TAG_BITS) -static inline lispobj -make_fixnum(uword_t n) // '<<' on negatives is _technically_ undefined behavior -{ - return MAKE_FIXNUM(n); -} +#define make_fixnum(n) ((uword_t)(n) << N_FIXNUM_TAG_BITS) static inline sword_t fixnum_value(lispobj n) diff -Nru sbcl-2.0.6/src/runtime/safepoint.c sbcl-2.1.1/src/runtime/safepoint.c --- sbcl-2.0.6/src/runtime/safepoint.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/safepoint.c 2021-01-30 11:22:38.000000000 +0000 @@ -106,8 +106,8 @@ #define SET_THREAD_STOP_PENDING(th,state) \ write_TLS(STOP_FOR_GC_PENDING,state,th) #define WITH_ALL_THREADS_LOCK \ - pthread_mutex_lock(&all_threads_lock); \ - RUN_BODY_ONCE(all_threads_lock, pthread_mutex_unlock(&all_threads_lock)) + thread_mutex_lock(&all_threads_lock); \ + RUN_BODY_ONCE(all_threads_lock, thread_mutex_unlock(&all_threads_lock)) #else #define CURRENT_THREAD_VAR(name) #define THREAD_STOP_PENDING(th) NIL @@ -120,12 +120,6 @@ * definition goes here. Fixme: (Why) don't these work for Windows? */ void -alloc_gc_page() -{ - os_validate(NOT_MOVABLE, GC_SAFEPOINT_PAGE_ADDR, BACKEND_PAGE_BYTES); -} - -void map_gc_page() { odxprint(misc, "map_gc_page"); @@ -142,15 +136,14 @@ } #endif /* !LISP_FEATURE_WIN32 */ -struct gc_state { -#ifdef LISP_FEATURE_SB_THREAD - /* Flag: conditions are initialized */ - boolean initialized; - +static struct gc_state { +#ifdef LISP_FEATURE_WIN32 /* Per-process lock for gc_state */ - pthread_mutex_t lock; - + CRITICAL_SECTION lock;; /* Conditions: one per phase */ + CONDITION_VARIABLE phase_cond[GC_NPHASES]; +#else + pthread_mutex_t lock; pthread_cond_t phase_cond[GC_NPHASES]; #endif @@ -164,21 +157,37 @@ /* Current GC phase */ gc_phase_t phase; -}; +} gc_state +#ifdef LISP_FEATURE_UNIX + = { PTHREAD_MUTEX_INITIALIZER, + { PTHREAD_COND_INITIALIZER, PTHREAD_COND_INITIALIZER, PTHREAD_COND_INITIALIZER, + PTHREAD_COND_INITIALIZER, PTHREAD_COND_INITIALIZER, PTHREAD_COND_INITIALIZER, + PTHREAD_COND_INITIALIZER }, + { 0, 0, 0, 0, 0, 0, 0 }, NULL, NULL, GC_NONE } +#endif + ; -static struct gc_state gc_state = { -#ifdef LISP_FEATURE_SB_THREAD - .lock = PTHREAD_MUTEX_INITIALIZER, +void safepoint_init() +{ +# ifdef LISP_FEATURE_WIN32 + int i; + extern void alloc_gc_page(void); + alloc_gc_page(); + for (i=GC_NONE; i GC_QUIET))) { -#ifdef LISP_FEATURE_SB_THREAD +#ifdef LISP_FEATURE_WIN32 + SleepConditionVariableCS(&gc_state.phase_cond[phase], &gc_state.lock, INFINITE); +#elif defined LISP_FEATURE_SB_THREAD pthread_cond_wait(&gc_state.phase_cond[phase],&gc_state.lock); #else lose("gc_state_wait() blocks, but we're #-SB-THREAD"); @@ -271,7 +274,7 @@ * disconcerting. */ void **sp = (void **) access_control_stack_pointer(self); #endif - *self->csp_around_foreign_call = (lispobj) sp; + csp_around_foreign_call(self) = (lispobj) sp; } @@ -282,15 +285,8 @@ static inline boolean thread_blocks_gc(struct thread *thread) { - /* Note that, unlike thread_may_gc(), this may be called on - * another thread, and that other thread may be in any state */ - - boolean inhibit = (read_TLS(GC_INHIBIT,thread)==T)|| - (read_TLS(IN_WITHOUT_GCING,thread)==IN_WITHOUT_GCING); - - return inhibit; + return read_TLS(GC_INHIBIT,thread)==T; } - /* set_thread_csp_access -- alter page permissions for not-in-Lisp flag (Lisp Stack Top) of the thread `p'. The flag may be modified if `writable' is true. @@ -311,11 +307,11 @@ static inline boolean set_thread_csp_access(struct thread* p, boolean writable) { - os_protect((char *) p->csp_around_foreign_call + N_WORD_BYTES - THREAD_CSP_PAGE_SIZE, + os_protect((char *) p - THREAD_CSP_PAGE_SIZE, THREAD_CSP_PAGE_SIZE, writable? (OS_VM_PROT_READ|OS_VM_PROT_WRITE) : (OS_VM_PROT_READ)); - return !!*p->csp_around_foreign_call; + return csp_around_foreign_call(p) != 0; } static inline void gc_notify_early() @@ -338,7 +334,7 @@ * thread. */ if (p==gc_state.collector) continue; - odxprint(safepoints,"notifying thread %p csp %p",p,*p->csp_around_foreign_call); + odxprint(safepoints,"notifying thread %p csp %p",p,csp_around_foreign_call(p)); boolean was_in_lisp = !set_thread_csp_access(p,0); if (was_in_lisp) { /* Threads "in-lisp" block leaving GC_MESSAGE, as we @@ -372,7 +368,7 @@ for_each_thread(p) { if (p == gc_state.collector) continue; - odxprint(safepoints,"notifying thread %p csp %p",p,*p->csp_around_foreign_call); + odxprint(safepoints,"notifying thread %p csp %p",p,csp_around_foreign_call(p)); boolean was_in_lisp = !set_thread_csp_access(p,0); if (was_in_lisp) { gc_state.phase_wait[GC_SETTLED]++; @@ -456,7 +452,9 @@ gc_state.phase = gc_phase_next(gc_state.phase); odxprint(safepoints,"no blockers, direct advance to %d (%s)",gc_state.phase,gc_phase_names[gc_state.phase]); gc_handle_phase(); -#ifdef LISP_FEATURE_SB_THREAD +#ifdef LISP_FEATURE_WIN32 + WakeAllConditionVariable(&gc_state.phase_cond[gc_state.phase]); +#elif defined LISP_FEATURE_SB_THREAD pthread_cond_broadcast(&gc_state.phase_cond[gc_state.phase]); #endif } @@ -486,17 +484,6 @@ } } -static inline int -thread_may_gc() -{ - /* Thread may gc if all of these are true: - * 1) GC_INHIBIT == NIL (outside of protected part of without-gcing) - * Note that we are in a safepoint here, which is always outside of PA. */ - - CURRENT_THREAD_VAR(self); - return (read_TLS(GC_INHIBIT, self) == NIL); -} - #ifdef LISP_FEATURE_SB_THRUPTION static inline int thread_may_thrupt(os_context_t *ctx) @@ -530,7 +517,7 @@ return 0; #ifdef LISP_FEATURE_WIN32 - if (deferrables_blocked_p(&self->os_thread->blocked_signal_set)) + if (deferrables_blocked_p(&thread_extra_data(self)->blocked_signal_set)) return 0; #else /* ctx is NULL if the caller wants to ignore the sigmask. */ @@ -550,13 +537,12 @@ struct thread *p = arch_os_get_current_thread(); #ifdef LISP_FEATURE_WIN32 - pthread_t pself = p->os_thread; sigset_t oldset; /* On Windows, wake_thread/kill_safely does not set THRUPTION_PENDING * in the self-kill case; instead we do it here while also clearing the * "signal". */ - if (pself->pending_signal_set) - if (__sync_fetch_and_and(&pself->pending_signal_set,0)) + if (thread_extra_data(p)->pending_signal_set) + if (__sync_fetch_and_and(&thread_extra_data(p)->pending_signal_set,0)) write_TLS(THRUPTION_PENDING, T, p); #endif @@ -567,8 +553,8 @@ write_TLS(THRUPTION_PENDING, NIL, p); #ifdef LISP_FEATURE_WIN32 - oldset = pself->blocked_signal_set; - pself->blocked_signal_set = deferrable_sigset; + oldset = thread_extra_data(p)->blocked_signal_set; + thread_extra_data(p)->blocked_signal_set = deferrable_sigset; #else sigset_t oldset; block_deferrable_signals(&oldset); @@ -589,7 +575,7 @@ undo_fake_foreign_function_call(ctx); #ifdef LISP_FEATURE_WIN32 - pself->blocked_signal_set = oldset; + thread_extra_data(p)->blocked_signal_set = oldset; if (ctx) ctx->sigmask = oldset; #else thread_sigmask(SIG_SETMASK, &oldset, 0); @@ -630,7 +616,18 @@ if (on_altstack_p(th, esp)) lose("thread %p: esp on altstack: %p", th, esp); #endif - lose("thread %p: bogus esp: %p", th, esp); + lose("thread %p: bogus esp: %p (range=%p..%p)", th, esp, + th->control_stack_start, th->control_stack_end); +} + +/// Similar to the one in gc-common, but without the sigmask test. +static boolean can_invoke_post_gc(struct thread* th) +{ + lispobj obj = th->lisp_thread; + if (!obj) return 0; + struct thread_instance* lispthread = (void*)(obj - INSTANCE_POINTER_LOWTAG); + if (!lispthread->primitive_thread) return 0; + return 1; } // returns 0 if skipped, 1 otherwise @@ -647,7 +644,7 @@ (read_TLS(GC_PENDING,self) == NIL))) { write_TLS(IN_SAFEPOINT,NIL,self); } - if (thread_may_gc() && (read_TLS(IN_SAFEPOINT, self) == NIL)) { + if (!thread_blocks_gc(self) && (read_TLS(IN_SAFEPOINT, self) == NIL)) { if (read_TLS(GC_PENDING, self) == T) { lispobj gc_happened = NIL; @@ -659,11 +656,10 @@ thread_sigmask(SIG_SETMASK,&sigset,NULL); if (gc_happened == T) { /* POST_GC wants to enable interrupts */ - if (read_TLS(INTERRUPTS_ENABLED,self) == T || - read_TLS(ALLOW_WITH_INTERRUPTS,self) == T) { - odxprint(misc, "going to call POST_GC"); + if ((read_TLS(INTERRUPTS_ENABLED,self) == T || + read_TLS(ALLOW_WITH_INTERRUPTS,self) == T) + && can_invoke_post_gc(self)) funcall0(StaticSymbolFunction(POST_GC)); - } done = 1; } } @@ -683,8 +679,7 @@ WITH_GC_STATE_LOCK { if (gc_state.phase == GC_FLIGHT && read_TLS(GC_PENDING,self)==T && - !thread_blocks_gc(self) && - thread_may_gc() && read_TLS(IN_SAFEPOINT,self)!=T) { + !thread_blocks_gc(self) && read_TLS(IN_SAFEPOINT,self)!=T) { /* Some thread (possibly even this one) that does not have * GC_INHIBIT set has noticed that a GC is warranted and * advanced the phase to GC_FLIGHT, arming the GSP trap, @@ -706,7 +701,7 @@ /* ??? Isn't this already T? */ write_TLS(GC_PENDING,T,self); } - *self->csp_around_foreign_call = 0; + csp_around_foreign_call(self) = 0; check_gc_and_thruptions = 1; } else { /* This thread isn't a candidate for running the GC @@ -727,7 +722,7 @@ gc_advance(GC_NONE,gc_state.phase); else gc_state_wait(GC_NONE); - *self->csp_around_foreign_call = 0; + csp_around_foreign_call(self) = 0; check_gc_and_thruptions = 1; } else { /* This thread has GC_INHIBIT set, meaning that it's @@ -789,7 +784,7 @@ gc_advance(GC_NONE,gc_state.phase); else gc_state_wait(GC_NONE); - *self->csp_around_foreign_call = 0; + csp_around_foreign_call(self) = 0; } else { /* This thread has GC_INHIBIT set, meaning that it's * within a WITHOUT-GCING, so advance from wherever we @@ -897,8 +892,6 @@ odxprint(safepoints,"%s","start the world"); WITH_GC_STATE_LOCK { gc_state.collector = NULL; - write_TLS(IN_WITHOUT_GCING,IN_WITHOUT_GCING, - arch_os_get_current_thread()); gc_advance(GC_NONE,GC_COLLECT); } } @@ -913,15 +906,13 @@ void wake_thread_io(struct thread * thread) { - SetEvent(thread->private_events.events[1]); + SetEvent(thread_private_events(thread,1)); win32_maybe_interrupt_io(thread); } -void -wake_thread_win32(struct thread *thread) +void wake_thread_impl(struct thread_instance *lispthread) { - struct thread *self = arch_os_get_current_thread(); - + struct thread* thread = (void*)lispthread->primitive_thread; wake_thread_io(thread); if (read_TLS(THRUPTION_PENDING,thread)==T) @@ -935,7 +926,7 @@ return; wake_thread_io(thread); - pthread_mutex_unlock(&all_threads_lock); + thread_mutex_unlock(&all_threads_lock); WITH_GC_STATE_LOCK { if (gc_state.phase == GC_NONE) { @@ -944,24 +935,22 @@ } } - pthread_mutex_lock(&all_threads_lock); + thread_mutex_lock(&all_threads_lock); return; } # else -int -wake_thread_posix(os_thread_t os_thread) +void wake_thread_impl(struct thread_instance *lispthread) { - int found = 0; - struct thread *thread; + struct thread *thread = (void*)lispthread->primitive_thread; struct thread *self = arch_os_get_current_thread(); /* Must not and need not attempt to signal ourselves while we're the * STW initiator. */ - if (self->os_thread == os_thread) { + if (thread == self) { write_TLS(THRUPTION_PENDING,T,self); while (check_pending_thruptions(0 /* ignore the sigmask */)) ; - return 0; + return; } /* We are not in a signal handler here, so need to block signals @@ -974,13 +963,14 @@ odxprint(safepoints, "wake_thread_posix: invoking"); gc_advance(GC_INVOKED,GC_NONE); { + /* I do not know whether WITH_ALL_THREADS_LOCK was only to avoid + * hitting wild pointers in the loop over threads (gone now) + * or whether it _also_ had an effect on the safepoint state. + * Out of caution I'm leaving it in despite removing the loop */ + /* only if in foreign code, notify using signal */ WITH_ALL_THREADS_LOCK { - for_each_thread (thread) - if (thread->os_thread == os_thread) { - /* it's still alive... */ - found = 1; - + do { odxprint(safepoints, "wake_thread_posix: found"); write_TLS(THRUPTION_PENDING,T,thread); if (read_TLS(GC_PENDING,thread) == T @@ -991,56 +981,41 @@ odxprint(safepoints, "wake_thread_posix: kill"); /* ... and in foreign code. Push it into a safety * transition. */ - int status = pthread_kill(os_thread, SIGPIPE); + int status = pthread_kill((pthread_t)lispthread->os_thread, SIGURG); if (status) lose("wake_thread_posix: pthread_kill failed with %d", status); } - break; - } + } while(0); } } gc_advance(GC_NONE,GC_INVOKED); } else { odxprint(safepoints, "wake_thread_posix: passive"); - /* We are not able to wake the thread up actively, but maybe - * some other thread will take care of it. Kludge: Unless it is - * in foreign code. Let's at least try to get our return value - * right. */ - WITH_ALL_THREADS_LOCK { - for_each_thread (thread) - if (thread->os_thread == os_thread) { - write_TLS(THRUPTION_PENDING,T,thread); - found = 1; - break; - } - } + write_TLS(THRUPTION_PENDING, T, thread); } } - - odxprint(safepoints, "wake_thread_posix leaving, found=%d", found); thread_sigmask(SIG_SETMASK, &oldset, 0); - return found ? 0 : -1; } #endif /* !LISP_FEATURE_WIN32 */ #endif /* LISP_FEATURE_SB_THRUPTION */ -void** -os_get_csp(struct thread* th) +void* os_get_csp(struct thread* th) { - FSHOW_SIGNAL((stderr, "Thread %p has CSP *(%p) == %p, stack [%p,%p]\n", + FSHOW_SIGNAL((stderr, "Thread %p has CSP %p, stack [%p,%p]\n", th, - th->csp_around_foreign_call, - *(void***)th->csp_around_foreign_call, + (void*)csp_around_foreign_call(th), th->control_stack_start, th->control_stack_end)); - return *(void***)th->csp_around_foreign_call; + return (void*)csp_around_foreign_call(th); } #ifndef LISP_FEATURE_WIN32 # ifdef LISP_FEATURE_SB_THRUPTION +/* This is basically what 'low_level_maybe_now_maybe_later' was (which doesn't exist), + * but with a different name, and different way of deciding to defer the signal */ void thruption_handler(int signal, siginfo_t *info, os_context_t *ctx) { @@ -1058,9 +1033,9 @@ #endif /* In C code. As a rule, we assume that running thruptions is OK. */ - *self->csp_around_foreign_call = 0; + csp_around_foreign_call(self) = 0; thread_in_lisp_raised(ctx); - *self->csp_around_foreign_call = (intptr_t) transition_sp; + csp_around_foreign_call(self) = (intptr_t) transition_sp; } # endif @@ -1076,12 +1051,12 @@ int handle_safepoint_violation(os_context_t *ctx, os_vm_address_t fault_address) { + struct thread *self = arch_os_get_current_thread(); + FSHOW_SIGNAL((stderr, "fault_address = %p, sp = %p, &csp = %p\n", fault_address, - GC_SAFEPOINT_TRAP_ADDR, - arch_os_get_current_thread()->csp_around_foreign_call)); + GC_SAFEPOINT_TRAP_ADDR, csp_around_foreign_call(self))); - struct thread *self = arch_os_get_current_thread(); if (fault_address == (os_vm_address_t) GC_SAFEPOINT_TRAP_ADDR) { #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK @@ -1096,7 +1071,7 @@ return 1; } - if (fault_address == (os_vm_address_t) self->csp_around_foreign_call) { + if (1+(lispobj*)fault_address == (lispobj*)self) { #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK arrange_return_to_c_function(ctx, handle_csp_safepoint_violation, 0); #else @@ -1111,28 +1086,4 @@ } #endif /* LISP_FEATURE_WIN32 */ -#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32) -void -signal_handler_callback(lispobj run_handler, int signo, void *info, void *ctx) -{ - init_thread_data scribble; - void *args[2]; - DX_ALLOC_SAP(args_sap, args); - - args[0] = info; - args[1] = ctx; - - attach_os_thread(&scribble); - - odxprint(misc, "callback from signal handler thread for: %d\n", signo); - WITH_GC_AT_SAFEPOINTS_ONLY() { - funcall3(StaticSymbolFunction(SIGNAL_HANDLER_CALLBACK), - run_handler, make_fixnum(signo), args_sap); - } - - detach_os_thread(&scribble); - return; -} -#endif - #endif /* LISP_FEATURE_SB_SAFEPOINT -- entire file */ diff -Nru sbcl-2.0.6/src/runtime/sparc-arch.c sbcl-2.1.1/src/runtime/sparc-arch.c --- sbcl-2.0.6/src/runtime/sparc-arch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/sparc-arch.c 2021-01-30 11:22:38.000000000 +0000 @@ -239,7 +239,7 @@ void arch_handle_single_step_trap(os_context_t *context, int trap) { - unsigned int code = *((u32 *)(*os_context_pc_addr(context))); + unsigned int code = *((uint32_t *)(*os_context_pc_addr(context))); int register_offset = code >> 8 & 0x1f; handle_single_step_trap(context, trap, register_offset); arch_skip_instruction(context); @@ -291,8 +291,7 @@ */ lispobj* memory; { - struct interrupt_data *data = - arch_os_get_current_thread()->interrupt_data; + struct interrupt_data *data = &thread_interrupt_data(arch_os_get_current_thread()); data->allocation_trap_context = context; extern lispobj *alloc(sword_t), *alloc_list(sword_t); memory = (rd & 1) ? alloc_list(size) : alloc(size); @@ -339,7 +338,7 @@ void arch_install_interrupt_handlers() { - undoably_install_low_level_interrupt_handler(SIGILL, sigill_handler); + ll_install_handler(SIGILL, sigill_handler); } diff -Nru sbcl-2.0.6/src/runtime/sparc-bsd-os.c sbcl-2.1.1/src/runtime/sparc-bsd-os.c --- sbcl-2.0.6/src/runtime/sparc-bsd-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/sparc-bsd-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -25,8 +25,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include diff -Nru sbcl-2.0.6/src/runtime/sparc-linux-os.c sbcl-2.1.1/src/runtime/sparc-linux-os.c --- sbcl-2.0.6/src/runtime/sparc-linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/sparc-linux-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -25,8 +25,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include diff -Nru sbcl-2.0.6/src/runtime/sparc-sunos-os.c sbcl-2.1.1/src/runtime/sparc-sunos-os.c --- sbcl-2.0.6/src/runtime/sparc-sunos-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/sparc-sunos-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -25,8 +25,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include diff -Nru sbcl-2.0.6/src/runtime/sunos-os.c sbcl-2.1.1/src/runtime/sunos-os.c --- sbcl-2.0.6/src/runtime/sunos-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/sunos-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -2,11 +2,11 @@ #include #include #include +#include #include #include #include -#include #include "sbcl.h" #include "os.h" @@ -111,19 +111,17 @@ void os_install_interrupt_handlers() { - undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT, - sigsegv_handler); + ll_install_handler(SIG_MEMORY_FAULT, sigsegv_handler); /* OAOOM c.f. linux-os.c. * Should we have a reusable function gc_install_interrupt_handlers? */ #ifdef LISP_FEATURE_SB_THREAD # ifdef LISP_FEATURE_SB_SAFEPOINT # ifdef LISP_FEATURE_SB_THRUPTION - undoably_install_low_level_interrupt_handler(SIGPIPE, thruption_handler); + ll_install_handler(SIGURG, thruption_handler); # endif # else - undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC, - sig_stop_for_gc_handler); + ll_install_handler(SIG_STOP_FOR_GC, sig_stop_for_gc_handler); # endif #endif } diff -Nru sbcl-2.0.6/src/runtime/thread.c sbcl-2.1.1/src/runtime/thread.c --- sbcl-2.0.6/src/runtime/thread.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/thread.c 2021-01-30 11:22:38.000000000 +0000 @@ -9,6 +9,9 @@ * files for more information. */ +#ifdef __linux__ +#define _GNU_SOURCE // for pthread_setname_np() +#endif #include "sbcl.h" #include @@ -57,29 +60,31 @@ #ifdef LISP_FEATURE_SUNOS #include #endif - -#if defined(LISP_FEATURE_WIN32) || defined(OS_THREAD_STACK) -# define IMMEDIATE_POST_MORTEM -#else -static struct thread *postmortem_thread; -#endif - #endif int dynamic_values_bytes = 4096 * sizeof(lispobj); // same for all threads +// exposed to lisp for pthread_create if not C_STACK_IS_CONTROL_STACK +os_vm_size_t thread_alien_stack_size = ALIEN_STACK_SIZE; struct thread *all_threads; #ifdef LISP_FEATURE_SB_THREAD -pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER; - -static pthread_mutex_t create_thread_lock = PTHREAD_MUTEX_INITIALIZER; #ifdef LISP_FEATURE_GCC_TLS __thread struct thread *current_thread; -__thread int is_lisp_thread; +#elif !defined LISP_FEATURE_WIN32 +pthread_key_t specials = 0; +#endif + +#ifdef LISP_FEATURE_WIN32 +CRITICAL_SECTION all_threads_lock; +static CRITICAL_SECTION recyclebin_lock; +static CRITICAL_SECTION in_gc_lock; #else -pthread_key_t lisp_thread = 0; +pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t recyclebin_lock = PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t in_gc_lock = PTHREAD_MUTEX_INITIALIZER; #endif + #endif #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) @@ -111,107 +116,177 @@ th->next->prev = th->prev; } +#define get_thread_state(thread) \ + (int)__sync_val_compare_and_swap(&thread->state_word.state, -1, -1) + #ifndef LISP_FEATURE_SB_SAFEPOINT -/* Only access thread state with blockables blocked. */ -lispobj -thread_state(struct thread *thread) -{ - lispobj state; - sigset_t old; - block_blockable_signals(&old); - os_sem_wait(thread->state_sem, "thread_state"); - state = thread->state; - os_sem_post(thread->state_sem, "thread_state"); - thread_sigmask(SIG_SETMASK, &old, NULL); - return state; -} void -set_thread_state(struct thread *thread, lispobj state) +set_thread_state(struct thread *thread, + char state, + boolean signals_already_blocked) // for foreign thread { + struct extra_thread_data *semaphores = thread_extra_data(thread); int i, waitcount = 0; sigset_t old; - block_blockable_signals(&old); - os_sem_wait(thread->state_sem, "set_thread_state"); - if (thread->state != state) { + // If we've already masked the blockable signals we can avoid two syscalls here. + if (!signals_already_blocked) + block_blockable_signals(&old); + os_sem_wait(&semaphores->state_sem, "set_thread_state"); + if (thread->state_word.state != state) { if ((STATE_STOPPED==state) || (STATE_DEAD==state)) { - waitcount = thread->state_not_running_waitcount; - thread->state_not_running_waitcount = 0; + waitcount = semaphores->state_not_running_waitcount; + semaphores->state_not_running_waitcount = 0; for (i=0; istate_not_running_sem, "set_thread_state (not running)"); + os_sem_post(&semaphores->state_not_running_sem, "set_thread_state (not running)"); } if ((STATE_RUNNING==state) || (STATE_DEAD==state)) { - waitcount = thread->state_not_stopped_waitcount; - thread->state_not_stopped_waitcount = 0; + waitcount = semaphores->state_not_stopped_waitcount; + semaphores->state_not_stopped_waitcount = 0; for (i=0; istate_not_stopped_sem, "set_thread_state (not stopped)"); + os_sem_post(&semaphores->state_not_stopped_sem, "set_thread_state (not stopped)"); } - thread->state = state; + thread->state_word.state = state; } - os_sem_post(thread->state_sem, "set_thread_state"); - thread_sigmask(SIG_SETMASK, &old, NULL); + os_sem_post(&semaphores->state_sem, "set_thread_state"); + if (!signals_already_blocked) + thread_sigmask(SIG_SETMASK, &old, NULL); } -void -wait_for_thread_state_change(struct thread *thread, lispobj state) +// Wait until "thread's" state is something other than 'undesired_state' +// and return whatever the new state is. +int thread_wait_until_not(int undesired_state, + struct thread *thread) { + struct extra_thread_data *semaphores = thread_extra_data(thread); sigset_t old; os_sem_t *wait_sem; block_blockable_signals(&old); start: - os_sem_wait(thread->state_sem, "wait_for_thread_state_change"); - if (thread->state == state) { - switch (state) { + os_sem_wait(&semaphores->state_sem, "wait_for_thread_state_change"); + /* "The following functions synchronize memory with respect to other threads: + * ... pthread_mutex_lock() ... " + * https://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap04.html#tag_04_11 + * But we still have to ensure no compiler reordering. + */ + int ending_state = get_thread_state(thread); + if (ending_state == undesired_state) { + switch (undesired_state) { case STATE_RUNNING: - wait_sem = thread->state_not_running_sem; - thread->state_not_running_waitcount++; + wait_sem = &semaphores->state_not_running_sem; + semaphores->state_not_running_waitcount++; break; case STATE_STOPPED: - wait_sem = thread->state_not_stopped_sem; - thread->state_not_stopped_waitcount++; + wait_sem = &semaphores->state_not_stopped_sem; + semaphores->state_not_stopped_waitcount++; break; default: - lose("Invalid state in wait_for_thread_state_change: %"OBJ_FMTX, state); + lose("thread_wait_until_not: invalid argument %x", ending_state); } } else { wait_sem = NULL; } - os_sem_post(thread->state_sem, "wait_for_thread_state_change"); + os_sem_post(&semaphores->state_sem, "wait_for_thread_state_change"); if (wait_sem) { os_sem_wait(wait_sem, "wait_for_thread_state_change"); goto start; } thread_sigmask(SIG_SETMASK, &old, NULL); + return ending_state; } #endif /* sb-safepoint */ #endif /* sb-thread */ -static int -initial_thread_trampoline(struct thread *th) +#ifdef LISP_FEATURE_WIN32 +#define sb_GetTID() GetCurrentThreadId() +#elif defined __linux__ +// gettid() was added in glibc 2.30 but we support older glibc +int sb_GetTID() { return syscall(SYS_gettid); } +#elif defined __DragonFly__ +#include +lwpid_t sb_GetTID() { return lwp_gettid(); } +#else +#define sb_GetTID() 0 +#endif + +static int get_nonzero_tid() { - lispobj function; + int tid = sb_GetTID(); + gc_dcheck(tid != 0); + return tid; +} + +// Only a single 'attributes' object is used if #+pauseless-threadstart. +// This is ok because creation is synchronized by *MAKE-THREAD-LOCK*. +#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_WIN32 +pthread_attr_t new_lisp_thread_attr; +#define init_shared_attr_object() (pthread_attr_init(&new_lisp_thread_attr)==0) +#else +#define init_shared_attr_object() (1) +#endif +struct thread *alloc_thread_struct(void*,lispobj); + +#ifdef LISP_FEATURE_WIN32 +#define ASSOCIATE_OS_THREAD(thread) \ + DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), \ + GetCurrentProcess(), (LPHANDLE)&thread->os_thread, 0, TRUE, \ + DUPLICATE_SAME_ACCESS) +#else +#define ASSOCIATE_OS_THREAD(thread) thread->os_thread = thread_self() +#endif + +#ifndef LISP_FEATURE_SB_THREAD +# define ASSIGN_CURRENT_THREAD(dummy) +#elif defined LISP_FEATURE_GCC_TLS +# define ASSIGN_CURRENT_THREAD(x) current_thread = x +#elif !defined LISP_FEATURE_WIN32 +# define ASSIGN_CURRENT_THREAD(x) pthread_setspecific(specials, x) +#else +# define ASSIGN_CURRENT_THREAD(x) TlsSetValue(OUR_TLS_INDEX, x) +#endif + +#ifdef LISP_FEATURE_WIN32 +// Need a function callable from assembly code. The inline one won't do. +// This is basically pthread_getspecific without an argument. +void* get_current_vm_thread() { + return arch_os_get_current_thread(); +} +#endif + +#if defined LISP_FEATURE_DARWIN && defined LISP_FEATURE_SB_THREAD + extern pthread_key_t sigwait_bug_mitigation; +#endif + +void create_main_lisp_thread(lispobj function) { +#ifdef LISP_FEATURE_WIN32 + InitializeCriticalSection(&all_threads_lock); + InitializeCriticalSection(&recyclebin_lock); + InitializeCriticalSection(&in_gc_lock); +#endif + struct thread *th = alloc_thread_struct(0, NO_TLS_VALUE_MARKER_WIDETAG); + if (!th || arch_os_thread_init(th)==0 || !init_shared_attr_object()) + lose("can't create initial thread"); +#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_GCC_TLS && !defined LISP_FEATURE_WIN32 + pthread_key_create(&specials, 0); +#endif +#if defined LISP_FEATURE_DARWIN && defined LISP_FEATURE_SB_THREAD + pthread_key_create(&sigwait_bug_mitigation, 0); +#endif #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) lispobj *args = NULL; #endif -#ifdef LISP_FEATURE_SB_THREAD -# ifdef LISP_FEATURE_GCC_TLS - is_lisp_thread = 1; -# else - pthread_setspecific(lisp_thread, (void *)1); -# endif -#endif + ASSOCIATE_OS_THREAD(th); + ASSIGN_CURRENT_THREAD(th); #if defined THREADS_USING_GCSIGNAL && \ (defined LISP_FEATURE_PPC || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_ARM64 || defined LISP_FEATURE_RISCV) /* SIG_STOP_FOR_GC defaults to blocked on PPC? */ - unblock_gc_signals(0,0); + unblock_gc_signals(); #endif - function = th->no_tls_value_marker; - th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG; - if(arch_os_thread_init(th)==0) return 1; link_thread(th); - th->os_thread=thread_self(); + th->os_kernel_tid = get_nonzero_tid(); + #ifndef LISP_FEATURE_WIN32 protect_control_stack_hard_guard_page(1, NULL); #endif @@ -230,118 +305,21 @@ /* WIN32 has a special stack arrangement, calling * call_into_lisp_first_time will put the new stack in the middle * of the current stack */ -#if !defined(LISP_FEATURE_WIN32) && (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)) - return call_into_lisp_first_time(function,args,0); +#if !(defined(LISP_FEATURE_WIN32) && !defined(OS_THREAD_STACK)) \ + && (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)) + call_into_lisp_first_time(function,args,0); #else - return funcall0(function); + funcall0(function); #endif } #ifdef LISP_FEATURE_SB_THREAD -/* THREAD POST MORTEM CLEANUP - * - * Memory allocated for the thread stacks cannot be reclaimed while - * the thread is still alive, so we need a mechanism for post mortem - * cleanups. FIXME: We actually have two, for historical reasons as - * the saying goes. Do we really need two? Nikodemus guesses that - * not anymore, now that we properly call pthread_attr_destroy before - * freeing the stack. */ - -static void free_thread_struct(struct thread *th) +void free_thread_struct(struct thread *th) { -#if defined(LISP_FEATURE_WIN32) - os_invalidate_free((os_vm_address_t) th->os_address, THREAD_STRUCT_SIZE); -#else os_invalidate((os_vm_address_t) th->os_address, THREAD_STRUCT_SIZE); -#endif -} - -# if defined(IMMEDIATE_POST_MORTEM) - -/* - * If this feature is set, we are running on a stack managed by the OS, - * and no fancy delays are required for anything. Just do it. - */ -static void -schedule_thread_post_mortem(struct thread *corpse) -{ - pthread_detach(pthread_self()); - free_thread_struct(corpse); } -# else - -static void -perform_thread_post_mortem(struct thread *post_mortem) -{ - gc_assert(post_mortem); - /* The thread may exit before pthread_create() has finished - initialization and it may write into already unmapped - memory. This lock doesn't actually need to protect - anything, just to make sure that at least one call to - pthread_create() has finished. - - Possible improvements: stash the address of the thread - struct for which a pthread is being created and don't lock - here if it's not the one being terminated. */ - int result = pthread_mutex_lock(&create_thread_lock); - gc_assert(result == 0); - result = pthread_mutex_unlock(&create_thread_lock); - gc_assert(result == 0); - - if ((result = pthread_join(post_mortem->os_thread, NULL))) { - lose("Error calling pthread_join in perform_thread_post_mortem:\n%s", - strerror(result)); - } - free_thread_struct(post_mortem); -} - -static inline struct thread* -fifo_buffer_shift(struct thread** dest, struct thread* value) -{ -#ifdef __ATOMIC_SEQ_CST - return __atomic_exchange_n(dest, value, __ATOMIC_SEQ_CST); -#elif defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) - /* I'd like to remove this case but I don't know whether MSVC has - * either of __atomic_exchange_n() or __sync_val_compare_and_swap() */ - lispobj old_value; - asm volatile - ("lock xchg %0,(%1)" - : "=r" (old_value) - : "r" (dest), "0" (value) - : "memory"); - return old_value; -#else - // We don't want a compare-and-swap, but if that's all we have, - // then build an atomic exchange out of compare-and-swap - lispobj old = *dest; - while (1) { - lispobj actual = __sync_val_compare_and_swap(dest, old, value); - if (actual == old) - return old; - old = actual; - } -#endif -} - -static void -schedule_thread_post_mortem(struct thread *corpse) -{ - gc_assert(corpse); - // This strange little mechanism is a FIFO buffer of capacity 1. - // By stuffing one new thing in and reading the old one out, we ensure - // that at least one pthread_create() has completed by this point. - // In particular, the thread we're post-morteming must have completed - // because thread creation is completely serialized (which is - // somewhat unfortunate). - struct thread* previous = fifo_buffer_shift(&postmortem_thread, corpse); - if (previous) // any random thread which pre-deceased me - perform_thread_post_mortem(previous); -} - -# endif /* !IMMEDIATE_POST_MORTEM */ - /* Note: scribble must be stack-allocated */ static void init_new_thread(struct thread *th, @@ -350,33 +328,34 @@ { int lock_ret; -#ifdef LISP_FEATURE_GCC_TLS - is_lisp_thread = 1; -#else - pthread_setspecific(lisp_thread, (void *)1); -#endif + ASSIGN_CURRENT_THREAD(th); if(arch_os_thread_init(th)==0) { /* FIXME: handle error */ lose("arch_os_thread_init failed"); } - th->os_thread=thread_self(); - if (guardp) +#define GUARD_CONTROL_STACK 1 +#define GUARD_BINDING_STACK 2 +#define GUARD_ALIEN_STACK 4 + + if (guardp & GUARD_CONTROL_STACK) protect_control_stack_guard_page(1, NULL); - protect_binding_stack_guard_page(1, NULL); - protect_alien_stack_guard_page(1, NULL); + if (guardp & GUARD_BINDING_STACK) + protect_binding_stack_guard_page(1, NULL); + if (guardp & GUARD_ALIEN_STACK) + protect_alien_stack_guard_page(1, NULL); + /* Since GC can only know about this thread from the all_threads * list and we're just adding this thread to it, there is no * danger of deadlocking even with SIG_STOP_FOR_GC blocked (which * it is not). */ #ifdef LISP_FEATURE_SB_SAFEPOINT - *th->csp_around_foreign_call = (lispobj)scribble; + csp_around_foreign_call(th) = (lispobj)scribble; #endif - lock_ret = pthread_mutex_lock(&all_threads_lock); + lock_ret = thread_mutex_lock(&all_threads_lock); gc_assert(lock_ret == 0); link_thread(th); - lock_ret = pthread_mutex_unlock(&all_threads_lock); - gc_assert(lock_ret == 0); + thread_mutex_unlock(&all_threads_lock); /* Kludge: Changed the order of some steps between the safepoint/ * non-safepoint versions of this code. Can we unify this more? @@ -390,8 +369,8 @@ } static void -undo_init_new_thread(struct thread *th, - init_thread_data __attribute__((unused)) *scribble) +unregister_thread(struct thread *th, + init_thread_data __attribute__((unused)) *scribble) { int lock_ret; @@ -399,42 +378,48 @@ * non-safepoint versions of this code. Can we unify this more? */ #ifdef LISP_FEATURE_SB_SAFEPOINT + block_blockable_signals(0); ensure_region_closed(&th->alloc_region, BOXED_PAGE_FLAG); -#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32) - ensure_region_closed(&th->sprof_alloc_region, BOXED_PAGE_FLAG); -#endif pop_gcing_safety(&scribble->safety); - lock_ret = pthread_mutex_lock(&all_threads_lock); + lock_ret = thread_mutex_lock(&all_threads_lock); gc_assert(lock_ret == 0); unlink_thread(th); - lock_ret = pthread_mutex_unlock(&all_threads_lock); + lock_ret = thread_mutex_unlock(&all_threads_lock); gc_assert(lock_ret == 0); + #else + /* Block GC */ block_blockable_signals(0); - set_thread_state(th, STATE_DEAD); + /* This state change serves to "acknowledge" any stop-the-world + * signal received while the STOP_FOR_GC signal is blocked */ + set_thread_state(th, STATE_DEAD, 1); /* SIG_STOP_FOR_GC is blocked and GC might be waiting for this - * thread, but since we are already dead it won't wait long. */ - lock_ret = pthread_mutex_lock(&all_threads_lock); + * thread, but since we are either exiting lisp code as a lisp + * thread that is dying, or exiting lisp code to return to + * former status as a C thread, it won't wait long. */ + lock_ret = thread_mutex_lock(&all_threads_lock); gc_assert(lock_ret == 0); + /* FIXME: this nests the free_pages_lock inside the all_threads_lock. + * There's no reason for that, so closing of regions should be done + * sooner to eliminate an ordering constraint. */ ensure_region_closed(&th->alloc_region, BOXED_PAGE_FLAG); -#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32) - ensure_region_closed(&th->sprof_alloc_region, BOXED_PAGE_FLAG); -#endif unlink_thread(th); - pthread_mutex_unlock(&all_threads_lock); + thread_mutex_unlock(&all_threads_lock); gc_assert(lock_ret == 0); + #endif arch_os_thread_cleanup(th); #ifndef LISP_FEATURE_SB_SAFEPOINT - os_sem_destroy(th->state_sem); - os_sem_destroy(th->state_not_running_sem); - os_sem_destroy(th->state_not_stopped_sem); + struct extra_thread_data *semaphores = thread_extra_data(th); + os_sem_destroy(&semaphores->state_sem); + os_sem_destroy(&semaphores->state_not_running_sem); + os_sem_destroy(&semaphores->state_not_stopped_sem); #endif @@ -443,23 +428,22 @@ #endif #if defined(LISP_FEATURE_WIN32) + CloseHandle((HANDLE)th->os_thread); int i; - for (i = 0; i< - (int) (sizeof(th->private_events.events)/ - sizeof(th->private_events.events[0])); ++i) { - CloseHandle(th->private_events.events[i]); - } - TlsSetValue(OUR_TLS_INDEX,NULL); + for (i = 0; ilisp_thread' remains valid despite not being in all_threads + // due to the pinning via *STARTING-THREADS*. + struct thread_instance *lispthread = (void*)native_pointer(th->lisp_thread); + if (lispthread->_ephemeral_p == T) th->state_word.user_thread_p = 0; + + /* Potentially set the externally-visible name of this thread, + * and for a whole pile of crazy, look at get_max_thread_name_length_impl() in + * https://github.com/llvm-mirror/llvm/blob/394ea6522c69c2668bf328fc923e1a11cd785265/lib/Support/Unix/Threading.inc + * which among other things, suggests that Linux might not even have the syscall */ + lispobj name = lispthread->name; // pinned + if (other_pointer_p(name) && + header_widetag(VECTOR(name)->header) == SIMPLE_BASE_STRING_WIDETAG) { +#ifdef LISP_FEATURE_LINUX + /* "The thread name is a meaningful C language string, whose length is + * restricted to 16 characters, including the terminating null byte ('\0'). + * The pthread_setname_np() function can fail with the following error: + * ERANGE The length of the string ... exceeds the allowed limit." */ + if (fixnum_value(VECTOR(name)->length) <= 15) + pthread_setname_np(pthread_self(), (char*)VECTOR(name)->data); +#endif +#ifdef LISP_FEATURE_NETBSD + /* This constant is an upper bound on the length including the NUL. + * Exceeding it will fail the call. It happens to be 32. + * Also, don't want to printf-format a name containing a '%' */ + if (fixnum_value(VECTOR(name)->length) < PTHREAD_MAX_NAMELEN_NP) + pthread_setname_np(pthread_self(), "%s", (char*)VECTOR(name)->data); +#endif +#if defined LISP_FEATURE_FREEBSD || defined LISP_FEATURE_OPENBSD + /* Some places document that the length limit is either 16 or 32, + * but my testing showed that 12.1 seems to accept any length */ + pthread_set_name_np(pthread_self(), (char*)VECTOR(name)->data); +#endif +#ifdef LISP_FEATURE_DARWIN + if (fixnum_value(VECTOR(name)->length) < 64) + pthread_setname_np((char*)VECTOR(name)->data); #endif + } + + struct vector* startup_info = VECTOR(lispthread->startup_info); // 'lispthread' is pinned + gc_assert(header_widetag(startup_info->header) == SIMPLE_VECTOR_WIDETAG); + lispobj startfun = startup_info->data[0]; // 'startup_info' is pinned + gc_assert(functionp(startfun)); + // GC can benefit from knowing the _effective_ end of the ambiguous root range. + // Nothing at a higher address than &arg needs to be scanned for ambiguous roots. + // For x86 + linux this optimization skips over about 800 words in the stack scan, + // and for x86-64 it skip about 550 words as observed via: + // fprintf(stderr, "%d non-lisp stack words\n", + // (int)((lispobj*)th->control_stack_end - (lispobj*)&arg)); + // ADDRESS_SANITIZER doesn't allow this optimization. + // Both of these assertions fail with the sanitizer enabled: + // gc_assert(th->control_stack_start <= (lispobj*)&arg + // && (lispobj*)&arg <= th->control_stack_end); + // gc_assert(th->control_stack_start <= (lispobj*)&startup_info + // && (lispobj*)&startup_info <= th->control_stack_end); + // It seems to subvert the "&" and "*" operators in a way that only it understands, + // while the stack pointer register is unperturbed. + // (gencgc takes '&raise' for the current thread, but it disables the sanitizers) + // + // A stop-for-GC signal that hits after init_new_thread() releases the all_threads lock + // and returns control here needs to see in the interrupt context a stack pointer + // strictly below the computed th->control_stack_end. So make sure the value we pick + // is strictly above any value of SP that the interrupt context could have. +#if defined LISP_FEATURE_C_STACK_IS_CONTROL_STACK && !defined ADDRESS_SANITIZER \ + && !defined LISP_FEATURE_SB_SAFEPOINT + th->control_stack_end = (lispobj*)&arg + 1; +#endif + th->os_kernel_tid = get_nonzero_tid(); + init_new_thread(th, SCRIBBLE, 0); + // Passing the untagged pointer ensures 2 things: + // - that the pinning mechanism works as designed, and not just by accident. + // - that the initial stack does not contain a lisp pointer after it is not needed. + // (a regression test asserts that not even a THREAD instance is on the stack) + funcall1(startfun, (lispobj)lispthread); // both pinned + // Close the GC region and unlink from all_threads + unregister_thread(th, SCRIBBLE); + +#else // !PAUSELESS_THREADSTART + + th->os_kernel_tid = get_nonzero_tid(); + init_thread_data scribble; lispobj function = th->no_tls_value_marker; th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG; - init_new_thread(th, &scribble, 1); - result = funcall0(function); - undo_init_new_thread(th, &scribble); - -#ifndef OS_THREAD_STACK - schedule_thread_post_mortem(th); + init_new_thread(th, &scribble, + GUARD_CONTROL_STACK|GUARD_BINDING_STACK|GUARD_ALIEN_STACK); + funcall0(function); + unregister_thread(th, &scribble); +#ifdef LISP_FEATURE_WIN32 + free_thread_struct(th); // no recycling of 'struct thread' #endif - FSHOW((stderr,"/exiting thread %p\n", thread_self())); - return (void*)(uintptr_t)result; +#endif + return 0; } -#ifdef OS_THREAD_STACK -extern void* funcall1_switching_stack(void*, void *(*fun)(void *)) -# ifdef LISP_FEATURE_X86_64 - __attribute__((sysv_abi)) -# endif - ; - -void* new_thread_trampoline_switch_stack(void* arg) { - struct thread *th = (struct thread *)arg; - void* ret = funcall1_switching_stack(arg, new_thread_trampoline); - - schedule_thread_post_mortem(th); - return ret; +#ifdef LISP_FEATURE_OS_THREAD_STACK +extern void* funcall1_switching_stack(void*, void *(*fun)(void *)); +void* new_thread_trampoline_switch_stack(void* th) { + return funcall1_switching_stack(th, new_thread_trampoline); } #endif -static struct thread *create_thread_struct(lispobj); - -void -attach_os_thread(init_thread_data *scribble) +static struct thread* recyclebin_threads; +static struct thread* get_recyclebin_item() +{ + struct thread* result = 0; + int rc; + rc = thread_mutex_lock(&recyclebin_lock); + gc_assert(!rc); + if (recyclebin_threads) { + result = recyclebin_threads; + recyclebin_threads = result->next; + } + thread_mutex_unlock(&recyclebin_lock); + return result ? result->os_address : 0; +} +static void put_recyclebin_item(struct thread* th) +{ + int rc; + rc = thread_mutex_lock(&recyclebin_lock); + gc_assert(!rc); + th->next = recyclebin_threads; + recyclebin_threads = th; + thread_mutex_unlock(&recyclebin_lock); +} +void empty_thread_recyclebin() { - os_thread_t os = pthread_self(); - odxprint(misc, "attach_os_thread: attaching to %p", os); + if (!recyclebin_threads) return; + sigset_t old; + block_deferrable_signals(&old); + // no big deal if already locked (recursive GC?) +#ifdef LISP_FEATURE_WIN32 + if (TryEnterCriticalSection(&recyclebin_lock)) { +#else + if (!pthread_mutex_trylock(&recyclebin_lock)) { +#endif + struct thread* this = recyclebin_threads; + while (this) { + struct thread* next = this->next; + free_thread_struct(this); + this = next; + } + recyclebin_threads = 0; + thread_mutex_unlock(&recyclebin_lock); + } + thread_sigmask(SIG_SETMASK, &old, 0); +} - struct thread *th = create_thread_struct(NO_TLS_VALUE_MARKER_WIDETAG); +static void attach_os_thread(init_thread_data *scribble) +{ +#ifndef LISP_FEATURE_WIN32 // native threads have no signal maskk block_deferrable_signals(&scribble->oldset); +#endif + void* recycled_memory = get_recyclebin_item(); + struct thread *th = alloc_thread_struct(recycled_memory, + NO_TLS_VALUE_MARKER_WIDETAG); #ifndef LISP_FEATURE_SB_SAFEPOINT /* new-lisp-thread-trampoline doesn't like when the GC signal is blocked */ /* FIXME: could be done using a single call to pthread_sigmask together with locking the deferrable signals above. */ - unblock_gc_signals(0, 0); + unblock_gc_signals(); #endif + th->os_kernel_tid = get_nonzero_tid(); + /* win32: While ASSOCIATE_OS_THREAD performs a relatively expensive DuplicateHandle(), + * simplicity here is preferable to the complexity entailed by memoizing the handle + * in a TLS slot and registering a waiter on the foreign thread to close to handle. + * In contrast to the previous approach, the new handle is closed in detach_os_thread(), + * and if C calls lisp again in this thread... then lather, rinse, repeat. + * A benchmark based on 'fcb-threads.impure' shows that we're still 8x faster + * at callback entry than the code as it was prior to git rev 91f86339b4 */ + ASSOCIATE_OS_THREAD(th); + #if !defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK) /* On windows, arch_os_thread_init will take care of finding the * stack. */ void *stack_addr; size_t stack_size; -#ifdef LISP_FEATURE_OPENBSD +# ifdef LISP_FEATURE_OPENBSD stack_t stack; - pthread_stackseg_np(os, &stack); + pthread_stackseg_np(th->os_thread, &stack); stack_size = stack.ss_size; stack_addr = (void*)((size_t)stack.ss_sp - stack_size); -#elif defined LISP_FEATURE_SUNOS - stack_t stack; - thr_stksegment(&stack); - stack_size = stack.ss_size; - stack_addr = (void*)((size_t)stack.ss_sp - stack_size); -#elif defined(LISP_FEATURE_DARWIN) - stack_size = pthread_get_stacksize_np(os); - stack_addr = (char*)pthread_get_stackaddr_np(os) - stack_size; -#else +# elif defined LISP_FEATURE_SUNOS + stack_t stack; + thr_stksegment(&stack); + stack_size = stack.ss_size; + stack_addr = (void*)((size_t)stack.ss_sp - stack_size); +# elif defined(LISP_FEATURE_DARWIN) + stack_size = pthread_get_stacksize_np(th->os_thread); + stack_addr = (char*)pthread_get_stackaddr_np(th->os_thread) - stack_size; +# else pthread_attr_t attr; -#if defined LISP_FEATURE_FREEBSD || defined LISP_FEATURE_DRAGONFLY - pthread_attr_get_np(os, &attr); -#else + pthread_attr_init(&attr); +# if defined LISP_FEATURE_FREEBSD || defined LISP_FEATURE_DRAGONFLY + pthread_attr_get_np(th->os_thread, &attr); +# else int pthread_getattr_np(pthread_t, pthread_attr_t *); - pthread_getattr_np(os, &attr); -#endif + pthread_getattr_np(th->os_thread, &attr); +# endif pthread_attr_getstack(&attr, &stack_addr, &stack_size); pthread_attr_destroy(&attr); -#endif - +# endif th->control_stack_start = stack_addr; th->control_stack_end = (void *) (((uintptr_t) stack_addr) + stack_size); #endif - init_new_thread(th, scribble, 0); - - uword_t stacksize - = (uword_t) th->control_stack_end - (uword_t) th->control_stack_start; - odxprint(misc, "attach_os_thread: attached %p as %p (0x%lx bytes stack)", - os, th, (long) stacksize); + /* We don't protect the control stack when adopting a foreign thread + * because we wouldn't know where to put the guard */ + init_new_thread(th, scribble, + /* recycled memory already had mprotect() done, + * so avoid 2 syscalls when possible */ + recycled_memory ? 0 : GUARD_BINDING_STACK|GUARD_ALIEN_STACK); } -void -detach_os_thread(init_thread_data *scribble) +static void detach_os_thread(init_thread_data *scribble) { struct thread *th = arch_os_get_current_thread(); - odxprint(misc, "detach_os_thread: detaching"); - undo_init_new_thread(th, scribble); + unregister_thread(th, scribble); - odxprint(misc, "deattach_os_thread: detached"); -#ifdef LISP_FEATURE_GCC_TLS - is_lisp_thread = 0; -#else - pthread_setspecific(lisp_thread, (void *)0); + /* We have to clear a STOP_FOR_GC signal if pending. Consider: + * - on entry to unregister_thread, we block all signals + * - simultaneously some other thread decides that it needs to initiate a GC + * - that thread observes that this thread exists in all_threads and sends + * STOP_FOR_GC, so it becomes pending but undeliverable in this thread + * - immediately after blocking signals, we change state to DEAD, + * which allows the GCing thread to ignore this thread + * (it sees the state change criterion as having been satisfied) + * - the GCing thread releases the all_threads lock + * - this thread acquires the lock and removes itself from all_threads, + * and indicates that it is no longer a lisp thread + * - but STOP_FOR_GC is pending because it was in the blocked set. + * Bad things happen unless we clear the pending GC signal. + */ +#ifndef LISP_FEATURE_SB_SAFEPOINT + sigset_t pending; + sigpending(&pending); + if (sigismember(&pending, SIG_STOP_FOR_GC)) { + int sig, rc; + rc = sigwait(&gc_sigset, &sig); + gc_assert(rc == 0 && sig == SIG_STOP_FOR_GC); +#ifdef LISP_FEATURE_DARWIN + sigpending(&pending); + if (sigismember(&pending, SIG_STOP_FOR_GC)) { + // fprintf(stderr, "Trying sigwait bug mitigation\n"); + pthread_setspecific(sigwait_bug_mitigation, (void*)1); + sigfillset(&pending); + sigdelset(&pending, SIG_STOP_FOR_GC); + // This might hang forever now, because the signal disappears + // despite that we just observed it to be pending. + // Basically you're screwed one way or the other - either + // by a spurious signal or a lost signal. + sigsuspend(&pending); + // fprintf(stderr, "Back from sigsuspend\n"); + } #endif + } +#endif + put_recyclebin_item(th); +#ifndef LISP_FEATURE_WIN32 // native threads have no signal mask thread_sigmask(SIG_SETMASK, &scribble->oldset, 0); - free_thread_struct(th); +#endif } #if defined(LISP_FEATURE_X86_64) && !defined(LISP_FEATURE_WIN32) @@ -607,16 +758,12 @@ #endif lispobj arg0, lispobj arg1, lispobj arg2) { -#if defined(LISP_FEATURE_WIN32) - pthread_np_notice_thread(); -#endif struct thread* th = arch_os_get_current_thread(); if (!th) { /* callback invoked in non-lisp thread */ init_thread_data scribble; attach_os_thread(&scribble); -#ifdef LISP_FEATURE_SB_SAFEPOINT + WITH_GC_AT_SAFEPOINTS_ONLY() -#endif { funcall3(StaticSymbolFunction(ENTER_FOREIGN_CALLBACK), arg0,arg1,arg2); } @@ -626,12 +773,10 @@ #ifdef LISP_FEATURE_WIN32 /* arg2 is the pointer to a return value, which sits on the stack */ - th->carried_base_pointer = (os_context_register_t) *(((void**)arg2)-1); + thread_extra_data(th)->carried_base_pointer = (os_context_register_t) *(((void**)arg2)-1); #endif -#ifdef LISP_FEATURE_SB_SAFEPOINT WITH_GC_AT_SAFEPOINTS_ONLY() -#endif { #if defined(LISP_FEATURE_X86_64) && !defined(LISP_FEATURE_WIN32) funcall_alien_callback(arg1, arg2, arg0, th); @@ -640,6 +785,7 @@ #endif } } + #endif /* LISP_FEATURE_SB_THREAD */ /* this is called from any other thread to create the new one, and @@ -658,35 +804,35 @@ * |...|------------------------------------------------------------| * 2MiB 1MiB 1MiB (*) (**) * - * | (*) interrupt contexts and Lisp TLS | (**) altstack | - * |-----------|--------------------------|------------|--------------| - * | interrupt | struct + dynamically | nonpointer | sigstack | - * | contexts | thread assigned TLS | data | | - * +-----------+--------------------------|------------+--------------| - * | 1K words | <--- TLS_SIZE words ---> | ~200 bytes | 32*SIGSTKSZ | - * ^ thread base + * | Lisp TLS | (**) altstack | + * |-----------------------------------|----------|--------------| + * | thread + struct + dynamically | extra | sigstack | + * | header thread assigned TLS | data | | + * +---------+-------------------------|----------+--------------| + * | | <--- TLS_SIZE words --> | ~1kb | 32*SIGSTKSZ | + * ^ thread base * * (1) = control stack start. default size shown * (2) = binding stack start. size = BINDING_STACK_SIZE * (3) = alien stack start. size = ALIEN_STACK_SIZE * (4) = C safepoint page. size = BACKEND_PAGE_BYTES or 0 - * (5) = per_thread_data. size = (MAX_INTERRUPTS + TLS_SIZE) words - * (6) = nonpointer_thread_data and signal stack. + * (5) = per_thread_data. size = (THREAD_HEADER_SLOTS+TLS_SIZE) words + * (6) = arbitrarily-sized "extra" data and signal stack. * * (0) and (1) may coincide; (4) and (5) may coincide * * - Lisp TLS overlaps 'struct thread' so that the first N (~30) words * have preassigned TLS indices. * - * - nonpointer data are not in 'struct thread' because placing them there + * - "extra" data are not in 'struct thread' because placing them there * makes it tough to calculate addresses in 'struct thread' from Lisp. * (Every 'struct thread' slot has a known size) * * On sb-safepoint builds one page before the thread base is used for the foreign calls safepoint. */ -static struct thread * -create_thread_struct(lispobj start_routine) { +struct thread * +alloc_thread_struct(void* spaces, lispobj start_routine) { #if defined(LISP_FEATURE_SB_THREAD) || defined(LISP_FEATURE_WIN32) unsigned int i; #endif @@ -699,38 +845,52 @@ * on the alignment passed from os_validate, since that might * assume the current (e.g. 4k) pagesize, while we calculate with * the biggest (e.g. 64k) pagesize allowed by the ABI. */ - void *spaces = os_validate(MOVABLE|IS_THREAD_STRUCT, NULL, THREAD_STRUCT_SIZE); - if(!spaces) - return NULL; + boolean zeroize_stack = 0; + if (spaces) { + // If reusing memory from a previously exited thread, start by removing + // some old junk from the stack. This is imperfect since we only clear a little + // at the top, but doing so enables diagnosing some garbage-retention issues + // using a fine-toothed comb. It would not be possible at all to diagnose + // if any newly started thread could refer a dead thread's heap objects. + zeroize_stack = 1; + } else { + spaces = os_validate(MOVABLE|IS_THREAD_STRUCT, NULL, THREAD_STRUCT_SIZE); + if (!spaces) return NULL; + } /* Aligning up is safe as THREAD_STRUCT_SIZE has * THREAD_ALIGNMENT_BYTES padding. */ char *aligned_spaces = PTR_ALIGN_UP(spaces, THREAD_ALIGNMENT_BYTES); - char* csp_page= - (aligned_spaces+ - thread_control_stack_size+ - BINDING_STACK_SIZE+ - ALIEN_STACK_SIZE + - (MAX_INTERRUPTS*sizeof(os_context_t*))); + char* csp_page = aligned_spaces + thread_control_stack_size + + BINDING_STACK_SIZE + ALIEN_STACK_SIZE; // Refer to the ASCII art in the block comment above - struct thread *th = (void*)(csp_page + THREAD_CSP_PAGE_SIZE); + struct thread *th = (void*)(csp_page + THREAD_CSP_PAGE_SIZE + + THREAD_HEADER_SLOTS*N_WORD_BYTES); + __attribute((unused)) lispobj* tls = (lispobj*)th; +#ifdef LISP_FEATURE_SB_SAFEPOINT + // Out of caution I'm supposing that the last thread to use this memory + // might have left this page as read-only. Could it? I have no idea. + os_protect(csp_page, THREAD_CSP_PAGE_SIZE, OS_VM_PROT_READ|OS_VM_PROT_WRITE); +#endif #ifdef LISP_FEATURE_SB_THREAD - lispobj* tls = (lispobj*)th; for(i = 0; i < (unsigned int)(dynamic_values_bytes/N_WORD_BYTES); i++) tls[i] = NO_TLS_VALUE_MARKER_WIDETAG; + th->lisp_thread = 0; // force it to be always-thread-local, of course th->tls_size = dynamic_values_bytes; #endif - uword_t* __attribute__((__unused__)) constants = (uword_t*)th; #if defined LISP_FEATURE_X86_64 && defined LISP_FEATURE_LINUX - constants[THREAD_MSAN_XOR_CONSTANT_SLOT] = 0x500000000000; + tls[THREAD_MSAN_XOR_CONSTANT_SLOT] = 0x500000000000; +#endif +#ifdef LAYOUT_OF_FUNCTION + tls[THREAD_FUNCTION_LAYOUT_SLOT] = LAYOUT_OF_FUNCTION << 32; #endif #ifdef LISP_FEATURE_GENCGC #ifdef THREAD_VARYOBJ_CARD_MARKS_SLOT extern unsigned int* varyobj_page_touched_bits; - constants[THREAD_VARYOBJ_SPACE_ADDR_SLOT] = VARYOBJ_SPACE_START; - constants[THREAD_VARYOBJ_CARD_COUNT_SLOT] = varyobj_space_size / IMMOBILE_CARD_BYTES; - constants[THREAD_VARYOBJ_CARD_MARKS_SLOT] = (lispobj)varyobj_page_touched_bits; + tls[THREAD_VARYOBJ_SPACE_ADDR_SLOT] = VARYOBJ_SPACE_START; + tls[THREAD_VARYOBJ_CARD_COUNT_SLOT] = varyobj_space_size / IMMOBILE_CARD_BYTES; + tls[THREAD_VARYOBJ_CARD_MARKS_SLOT] = (lispobj)varyobj_page_touched_bits; #endif th->dynspace_addr = DYNAMIC_SPACE_START; th->dynspace_card_count = page_table_pages; @@ -742,44 +902,60 @@ th->binding_stack_start= (lispobj*)((char*)th->control_stack_start+thread_control_stack_size); th->control_stack_end = th->binding_stack_start; - th->control_stack_guard_page_protected = T; + + if (zeroize_stack) { +#if GENCGC_IS_PRECISE + /* Clear the entire control stack. Without this I was able to induce a GC failure + * in a test which hammered on thread creation for hours. The control stack is + * scavenged before the heap, so a stale word could point to the start (or middle) + * of an object using a bad lowtag, for whatever object formerly was there. + * Then a wrong transport function would be called and (if it worked at all) would + * place a wrongly tagged FP into a word that might not be the base of an object. + * Assume for simplicity (as is true) that stacks grow upward if GENCGC_IS_PRECISE. + * This could just call scrub_thread_control_stack but the comment there says that + * it's a lame algorithm and only mostly right - it stops after (1<<12) words + * and checks if the next is nonzero, looping again if it isn't. + * There's no reason not to be exactly right here instead of probably right */ + memset((char*)th->control_stack_start, 0, + // take off 2 pages because of the soft and hard guard pages + thread_control_stack_size - 2*os_vm_page_size); +#else + /* This is a little wasteful of cycles to pre-zero the pthread overhead (which in glibc + * resides at the highest stack addresses) comprising about 5kb, below which is the lisp + * stack. We don't need to zeroize above the lisp stack end, but we don't know exactly + * where that will be. Zeroizing more than necessary is conservative, and helps ensure + * that garbage retention from reused stacks does not pose a huge problem. */ + memset((char*)th->control_stack_end - 16384, 0, 16384); +#endif + } + + th->state_word.control_stack_guard_page_protected = 1; th->alien_stack_start= (lispobj*)((char*)th->binding_stack_start+BINDING_STACK_SIZE); set_binding_stack_pointer(th,th->binding_stack_start); - th->this=th; - th->os_thread=0; -#if defined(LAYOUT_OF_FUNCTION) && defined(LISP_FEATURE_SB_THREAD) - constants[THREAD_FUNCTION_LAYOUT_SLOT] = LAYOUT_OF_FUNCTION << 32; -#endif + th->this = th; + th->os_kernel_tid = 0; + th->os_thread = 0; // Once allocated, the allocation profiling buffer sticks around. // If present and enabled, assign into the new thread. th->profile_data = (uword_t*)(alloc_profiling ? alloc_profile_buffer : 0); -#ifdef LISP_FEATURE_SB_SAFEPOINT # ifdef LISP_FEATURE_WIN32 - th->carried_base_pointer = 0; + thread_extra_data(th)->carried_base_pointer = 0; # endif - th->csp_around_foreign_call = (lispobj *)th - 1; -#endif - struct nonpointer_thread_data *nonpointer_data - = (void *)((char*)th + dynamic_values_bytes); - th->interrupt_data = &nonpointer_data->interrupt_data; - -#ifdef LISP_FEATURE_SB_THREAD -# ifndef LISP_FEATURE_SB_SAFEPOINT - th->state_sem = &nonpointer_data->state_sem; - th->state_not_running_sem = &nonpointer_data->state_not_running_sem; - th->state_not_stopped_sem = &nonpointer_data->state_not_stopped_sem; - os_sem_init(th->state_sem, 1); - os_sem_init(th->state_not_running_sem, 0); - os_sem_init(th->state_not_stopped_sem, 0); - th->state_not_running_waitcount = 0; - th->state_not_stopped_waitcount = 0; -# endif + struct extra_thread_data *extra_data = thread_extra_data(th); + memset(extra_data, 0, sizeof *extra_data); +#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_SB_SAFEPOINT + os_sem_init(&extra_data->state_sem, 1); + os_sem_init(&extra_data->state_not_running_sem, 0); + os_sem_init(&extra_data->state_not_stopped_sem, 0); #endif - th->state=STATE_RUNNING; + + th->state_word.state = STATE_RUNNING; + th->state_word.user_thread_p = 1; + #ifdef ALIEN_STACK_GROWS_DOWNWARD th->alien_stack_pointer=(lispobj*)((char*)th->alien_stack_start + ALIEN_STACK_SIZE-N_WORD_BYTES); @@ -796,9 +972,6 @@ #ifdef LISP_FEATURE_GENCGC gc_init_region(&th->alloc_region); -# if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32) - gc_init_region(&th->sprof_alloc_region); -# endif #endif #ifdef LISP_FEATURE_SB_THREAD /* This parallels the same logic in globals.c for the @@ -827,12 +1000,13 @@ #endif #ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK access_control_stack_pointer(th)=th->control_stack_start; + access_control_frame_pointer(th)=0; #endif - th->interrupt_data->pending_handler = 0; - th->interrupt_data->gc_blocked_deferrables = 0; + thread_interrupt_data(th).pending_handler = 0; + thread_interrupt_data(th).gc_blocked_deferrables = 0; #if GENCGC_IS_PRECISE - th->interrupt_data->allocation_trap_context = 0; + thread_interrupt_data(th).allocation_trap_context = 0; #endif #ifdef LISP_FEATURE_SB_THREAD @@ -849,110 +1023,74 @@ th->no_tls_value_marker = start_routine; #if defined(LISP_FEATURE_WIN32) - for (i = 0; iprivate_events.events)/ - sizeof(th->private_events.events[0]); ++i) { - th->private_events.events[i] = CreateEvent(NULL,FALSE,FALSE,NULL); - } - th->synchronous_io_handle_and_flag = 0; + for (i = 0; isynchronous_io_handle_and_flag = 0; #endif th->stepping = 0; return th; } - -void create_initial_thread(lispobj initial_function) { - struct thread *th = create_thread_struct(initial_function); -#if defined(LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_GCC_TLS) - pthread_key_create(&lisp_thread, 0); -#endif - if(th) { - initial_thread_trampoline(th); /* no return */ - } else lose("can't create initial thread"); -} - #ifdef LISP_FEATURE_SB_THREAD +#ifdef LISP_FEATURE_WIN32 +/* Allocate a thread structure, call CreateThread(), + * and return 1 for success, 0 for failure */ +uword_t create_thread(struct thread_instance* instance, lispobj start_routine) +{ + struct thread *th; -#ifndef __USE_XOPEN2K -extern int pthread_attr_setstack (pthread_attr_t *__attr, void *__stackaddr, - size_t __stacksize); -#endif + /* Must defend against async unwinds. */ + if (read_TLS(INTERRUPTS_ENABLED, arch_os_get_current_thread()) != NIL) + lose("create_thread is not safe when interrupts are enabled."); + + /* Assuming that a fresh thread struct has no lisp objects in it, + * linking it to all_threads can be left to the thread itself + * without fear of gc lossage. 'start_routine' violates this + * assumption and must stay pinned until the child starts up. */ + th = alloc_thread_struct(0, start_routine); + if (!th) return 0; -/* Call pthread_create() and return 1 for success, 0 for failure */ -boolean create_os_thread(struct thread *th,os_thread_t *kid_tid) -{ /* The new thread inherits the restrictive signal mask set here, * and enables signals again when it is set up properly. */ sigset_t oldset; - int retcode = 0; - boolean success = 0; /* Blocking deferrable signals is enough, no need to block * SIG_STOP_FOR_GC because the child process is not linked onto * all_threads until it's ready. */ block_deferrable_signals(&oldset); - - pthread_attr_t attr; - if (pthread_attr_init(&attr) == 0) { - - /* See perform_thread_post_mortem for at least one reason why this lock is necessary */ - retcode = pthread_mutex_lock(&create_thread_lock); - gc_assert(retcode == 0); - - /* call_into_lisp_first_time switches the stack for the initial - * thread. For the others, we use this. */ - if ( -#ifdef OS_THREAD_STACK - pthread_attr_setstacksize(&attr, PTHREAD_STACK_MIN) || - (retcode = pthread_create(kid_tid, &attr, new_thread_trampoline_switch_stack, th)) -#else - -# ifdef LISP_FEATURE_WIN32 - pthread_attr_setstacksize(&attr, thread_control_stack_size) || -# elif defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK) - pthread_attr_setstack(&attr, th->control_stack_start, thread_control_stack_size) || -# else - pthread_attr_setstack(&attr, th->alien_stack_start, ALIEN_STACK_SIZE) || -# endif -# ifdef LISP_FEATURE_NETBSD - /* Even though the manpage says pthread_attr_setstack - would override the guard page, it's no longer true. */ - pthread_attr_setguardsize(&attr, 0) || -# endif - - (retcode = pthread_create(kid_tid, &attr, new_thread_trampoline, th)) -#endif - ) { - perror("create_os_thread"); - } else { - success = 1; - } - retcode = pthread_mutex_unlock(&create_thread_lock); - gc_assert(retcode == 0); - pthread_attr_destroy(&attr); + unsigned int tid; + // Theoretically you should tell the new thread a signal mask to restore + // after it finishes any uninterruptable setup code, but the way this worked + // on windows is that we passed the mask of blocked signals in the parent + // *after* blocking deferrables. It's immaterial what mask is passed + // because the thread will unblock all deferrables, + // and we don't really have posix signals anyway. + struct extra_thread_data *data = thread_extra_data(th); + data->blocked_signal_set = deferrable_sigset; + data->pending_signal_set = 0; + // It's somewhat customary in the win32 API to start threads as suspended. + th->os_thread = + _beginthreadex(NULL, thread_control_stack_size, new_thread_trampoline, th, + CREATE_SUSPENDED, &tid); + boolean success = th->os_thread != 0; + if (success) { + instance->primitive_thread = (lispobj)th; + th->os_kernel_tid = tid; + ResumeThread((HANDLE)th->os_thread); + } else { + free_thread_struct(th); } - thread_sigmask(SIG_SETMASK,&oldset,0); return success; } +#endif -os_thread_t create_thread(lispobj start_routine) { - struct thread *th, *thread = arch_os_get_current_thread(); - os_thread_t kid_tid = 0; - - /* Must defend against async unwinds. */ - if (read_TLS(INTERRUPTS_ENABLED, thread) != NIL) - lose("create_thread is not safe when interrupts are enabled."); - - /* Assuming that a fresh thread struct has no lisp objects in it, - * linking it to all_threads can be left to the thread itself - * without fear of gc lossage. 'start_routine' violates this - * assumption and must stay pinned until the child starts up. */ - th = create_thread_struct(start_routine); - if (th && !create_os_thread(th, &kid_tid)) { - free_thread_struct(th); - kid_tid = 0; - } - return kid_tid; -} +#ifdef LISP_FEATURE_WIN32 +int try_acquire_gc_lock() { return TryEnterCriticalSection(&in_gc_lock); } +void release_gc_lock() { LeaveCriticalSection(&in_gc_lock); } +#else +int try_acquire_gc_lock() { return !pthread_mutex_trylock(&in_gc_lock); } +void release_gc_lock() { pthread_mutex_unlock(&in_gc_lock); } +#endif /* stopping the world is a two-stage process. From this thread we signal * all the others with SIG_STOP_FOR_GC. The handler for this signal does @@ -966,55 +1104,64 @@ /* To avoid deadlocks when gc stops the world all clients of each * mutex must enable or disable SIG_STOP_FOR_GC for the duration of - * holding the lock, but they must agree on which. */ + * holding the lock, but they must agree on which. + * [The preceding remark is probably wrong - STOP_FOR_GC is a signal + * that is directed to a thread, so the "wrong" thread would never + * respond to someone else's STOP_FOR_GC. I'm leaving the comment + * just case someone can decipher it and decide to delete it] + * + * A note about ESRCH: tchnically ESRCH can happen if an OS thread ceases + * to exist, while the thread library has a representation of the thread + * because pthread_join() wasn't invoked on it yet. + * ESRCH can't oocur for us because: + * - if a thread was still linked in all_threads at the acquire of all_threads lock, + * then that thread can't make progress in its termination code, because it's + * waiting on the lock. If it changed its state to DEAD, but we perceived it as + * RUNNING, it now must be blocked on the all_threads_lock and it can't disappear. + * - ESRCH is not guaranteed to be returned anyway, and Linux man page doesn't even + * list it as a possible outcome of pthread_kill. + * Also, there used to be assertion that "thread_state(p)==STATE_DEAD)" on ESRCH + * error, but that's saying that there is still memory backing 'struct thread' + * (so that dereferencing was valid), but if dereferencing was valid, then the thread + * can't have died (i.e. if ESRCH could be returned, then that implies that + * the memory shouldn't be there) */ void gc_stop_the_world() { - struct thread *p,*th=arch_os_get_current_thread(); - int status, lock_ret; - /* KLUDGE: Stopping the thread during pthread_create() causes deadlock - * on FreeBSD. */ - FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on create_thread_lock\n")); - lock_ret = pthread_mutex_lock(&create_thread_lock); - gc_assert(lock_ret == 0); - FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got create_thread_lock\n")); - FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on lock\n")); - /* keep threads from starting while the world is stopped. */ - lock_ret = pthread_mutex_lock(&all_threads_lock); \ - gc_assert(lock_ret == 0); + struct thread *th, *me = arch_os_get_current_thread(); + int rc; + + /* Keep threads from registering with GC while the world is stopped. */ + rc = thread_mutex_lock(&all_threads_lock); + gc_assert(rc == 0); - FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got lock\n")); /* stop all other threads by sending them SIG_STOP_FOR_GC */ - for(p=all_threads; p; p=p->next) { - gc_assert(p->os_thread != 0); - FSHOW_SIGNAL((stderr,"/gc_stop_the_world: thread=%lu, state=%x\n", - p->os_thread, thread_state(p))); - if((p!=th) && ((thread_state(p)==STATE_RUNNING))) { - FSHOW_SIGNAL((stderr,"/gc_stop_the_world: suspending thread %lu\n", - p->os_thread)); - /* We already hold all_thread_lock, P can become DEAD but - * cannot exit, ergo it's safe to use pthread_kill. */ - status=pthread_kill(p->os_thread,SIG_STOP_FOR_GC); - if (status==ESRCH) { - /* This thread has exited. */ - gc_assert(thread_state(p)==STATE_DEAD); - } else if (status) { - lose("cannot send suspend thread=%lx: %d, %s", - // KLUDGE: assume that os_thread can be cast as long. + for_each_thread(th) { + gc_assert(th->os_thread != 0); + /* We were going to extremes here to use acquire semantics on the state, + * while NOT ACTUALLY PREVENTING CHANGE OF THAT STATE. i.e. we released the + * state lock before returning with the determined state. That's no help. + * Just do an atomic load and we're good */ + int state = get_thread_state(th); + if (th != me && state == STATE_RUNNING) { + /* This pthread_kill is safe. + * A RUNNING thread can transition to DEAD but can't disappear either + * in terms of 'struct thread' being unmapped or the pthread exiting, + * because it'll be blocked on the all_threads lock */ + rc = pthread_kill(th->os_thread,SIG_STOP_FOR_GC); + /* This used to bogusly check for ESRCH. + * I changed the ESRCH case to just fall into lose() */ + if (rc) { + lose("cannot suspend thread %p: %d, %s", + // KLUDGE: assume that os_thread can be cast as pointer. // See comment in 'interr.h' about that. - (long)p->os_thread,status,strerror(status)); + (void*)th->os_thread, rc, strerror(rc)); } } } - FSHOW_SIGNAL((stderr,"/gc_stop_the_world:signals sent\n")); - for(p=all_threads;p;p=p->next) { - if (p!=th) { - FSHOW_SIGNAL - ((stderr, - "/gc_stop_the_world: waiting for thread=%lu: state=%x\n", - p->os_thread, thread_state(p))); - wait_for_thread_state_change(p, STATE_RUNNING); - if (p->state == STATE_RUNNING) - lose("/gc_stop_the_world: unexpected state"); + for_each_thread(th) { + if (th != me) { + __attribute__((unused)) int state = thread_wait_until_not(STATE_RUNNING, th); + gc_assert(state != STATE_RUNNING); } } FSHOW_SIGNAL((stderr,"/gc_stop_the_world:end\n")); @@ -1022,36 +1169,28 @@ void gc_start_the_world() { - struct thread *p,*th=arch_os_get_current_thread(); + struct thread *th, *me = arch_os_get_current_thread(); int lock_ret; /* if a resumed thread creates a new thread before we're done with - * this loop, the new thread will get consed on the front of - * all_threads, but it won't have been stopped so won't need - * restarting */ - FSHOW_SIGNAL((stderr,"/gc_start_the_world:begin\n")); - for(p=all_threads;p;p=p->next) { - gc_assert(p->os_thread!=0); - if (p!=th) { - lispobj state = thread_state(p); + * this loop, the new thread will be suspended waiting to acquire + * the all_threads lock */ + for_each_thread(th) { + gc_assert(th->os_thread); + if (th != me) { + /* I don't know if a normal load is fine here. I think we can't read + * any value other than what was already observed? + * No harm in being cautious though with regard to compiler reordering */ + int state = get_thread_state(th); if (state != STATE_DEAD) { - if(state != STATE_STOPPED) { - lose("gc_start_the_world: wrong thread state is %"OBJ_FMTX, - (lispobj)fixnum_value(state)); - } - FSHOW_SIGNAL((stderr, "/gc_start_the_world: resuming %lu\n", - p->os_thread)); - set_thread_state(p, STATE_RUNNING); + if(state != STATE_STOPPED) + lose("gc_start_the_world: bad thread state %x", state); + set_thread_state(th, STATE_RUNNING, 0); } } } - lock_ret = pthread_mutex_unlock(&all_threads_lock); - gc_assert(lock_ret == 0); - lock_ret = pthread_mutex_unlock(&create_thread_lock); + lock_ret = thread_mutex_unlock(&all_threads_lock); gc_assert(lock_ret == 0); - - - FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n")); } #endif /* !LISP_FEATURE_SB_SAFEPOINT */ @@ -1067,18 +1206,7 @@ #endif } -int -wake_thread(os_thread_t os_thread) -{ -#if defined(LISP_FEATURE_WIN32) - return kill_safely(os_thread, 1); -#elif !defined(LISP_FEATURE_SB_THRUPTION) - return kill_safely(os_thread, SIGPIPE); -#else - return wake_thread_posix(os_thread); -#endif -} - +#ifdef LISP_FEATURE_SB_SAFEPOINT /* If the thread id given does not belong to a running thread (it has * exited or never even existed) pthread_kill _may_ fail with ESRCH, * but it is also allowed to just segfault, see @@ -1095,18 +1223,12 @@ * Note (DFL, 2011-06-22): At the time of writing, this function is only * used for INTERRUPT-THREAD, hence the wake_thread special-case for * Windows is OK. */ -int -kill_safely(os_thread_t os_thread, int signal) +void wake_thread(struct thread_instance* lispthread) { - FSHOW_SIGNAL((stderr,"/kill_safely: %lu, %d\n", os_thread, signal)); - { -#ifdef LISP_FEATURE_SB_THREAD - sigset_t oldset; - struct thread *thread; - /* Frequent special case: resignalling to self. The idea is - * that leave_region safepoint will acknowledge the signal, so - * there is no need to take locks, roll thread to safepoint - * etc. */ +#ifdef LISP_FEATURE_WIN32 + /* META: why is this comment about safepoint builds mentioning + * gc_stop_the_world() ? Never the twain shall meet. */ + /* Kludge (on safepoint builds): At the moment, this isn't just * an optimization; rather it masks the fact that * gc_stop_the_world() grabs the all_threads mutex without @@ -1115,62 +1237,32 @@ * would go wrong. Why are we running interruptions while * stopping the world though? Test case is (:ASYNC-UNWIND * :SPECIALS), especially with s/10/100/ in both loops. */ - /* From the linux man page on pthread_self() - - * "variables of type pthread_t can't portably be compared using - * the C equality operator (==); use pthread_equal(3) instead." */ - if (thread_equal(os_thread, pthread_self())) { - pthread_kill(os_thread, signal); -#ifdef LISP_FEATURE_WIN32 + + /* Frequent special case: resignalling to self. The idea is + * that leave_region safepoint will acknowledge the signal, so + * there is no need to take locks, roll thread to safepoint + * etc. */ + struct thread* thread = (void*)lispthread->primitive_thread; + if (thread == arch_os_get_current_thread()) { + sb_pthr_kill(thread, 1); // can't fail check_pending_thruptions(NULL); -#endif - return 0; + return; } - - /* pthread_kill is not async signal safe and we don't want to be - * interrupted while holding the lock. */ + // block_deferrables + mutex_lock looks very unnecessary here, + // but without them, make-target-contrib hangs in bsd-sockets. + sigset_t oldset; block_deferrable_signals(&oldset); - pthread_mutex_lock(&all_threads_lock); - for (thread = all_threads; thread; thread = thread->next) { - if (thread->os_thread == os_thread) { - int status = pthread_kill(os_thread, signal); - if (status) - lose("kill_safely: pthread_kill failed with %d", status); -#if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THRUPTION) - wake_thread_win32(thread); -#endif - break; - } - } - pthread_mutex_unlock(&all_threads_lock); + thread_mutex_lock(&all_threads_lock); + sb_pthr_kill(thread, 1); // can't fail +# ifdef LISP_FEATURE_SB_THRUPTION + wake_thread_impl(lispthread); +# endif + thread_mutex_unlock(&all_threads_lock); thread_sigmask(SIG_SETMASK,&oldset,0); - if (thread) - return 0; - else - return -1; -#elif defined(LISP_FEATURE_WIN32) - return 0; +#elif defined LISP_FEATURE_SB_THRUPTION + wake_thread_impl(lispthread); #else - int status; - if (os_thread != 0) - lose("kill_safely: who do you want to kill? %d?", os_thread); - /* Dubious (as in don't know why it works) workaround for the - * signal sometimes not being generated on darwin. */ -#ifdef LISP_FEATURE_DARWIN - { - sigset_t oldset; - sigprocmask(SIG_BLOCK, &deferrable_sigset, &oldset); - status = raise(signal); - sigprocmask(SIG_SETMASK,&oldset,0); - } -#else - status = raise(signal); + pthread_kill(lispthread->os_thread, SIGURG); #endif - if (status == 0) { - return 0; - } else { - lose("cannot raise signal %d, %d %s", - signal, status, strerror(errno)); - } -#endif - } } +#endif diff -Nru sbcl-2.0.6/src/runtime/thread.h sbcl-2.1.1/src/runtime/thread.h --- sbcl-2.0.6/src/runtime/thread.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/thread.h 2021-01-30 11:22:38.000000000 +0000 @@ -11,32 +11,32 @@ #ifdef LISP_FEATURE_GENCGC #include "gencgc-alloc-region.h" #endif -#ifdef LISP_FEATURE_WIN32 -#include "win32-thread-private-events.h" -#endif #include "genesis/symbol.h" #include "genesis/static-symbols.h" +struct thread_state_word { + char control_stack_guard_page_protected; + char user_thread_p; // opposite of lisp's ephemeral-p + char state; +#ifdef LISP_FEATURE_64_BIT + char padding[5]; +#else + char padding[1]; +#endif +}; + #include "genesis/thread.h" +#include "genesis/thread-instance.h" #include "genesis/fdefn.h" #include "genesis/vector.h" #include "interrupt.h" #include "validate.h" /* for BINDING_STACK_SIZE etc */ -#define STATE_RUNNING MAKE_FIXNUM(1) -#define STATE_STOPPED MAKE_FIXNUM(2) -#define STATE_DEAD MAKE_FIXNUM(3) +enum threadstate {STATE_RUNNING=1, STATE_STOPPED, STATE_DEAD}; #ifdef LISP_FEATURE_SB_THREAD -lispobj thread_state(struct thread *thread); -void set_thread_state(struct thread *thread, lispobj state); -void wait_for_thread_state_change(struct thread *thread, lispobj state); - -#ifdef LISP_FEATURE_GCC_TLS -extern __thread int is_lisp_thread; -#else -extern pthread_key_t lisp_thread; -#endif +void set_thread_state(struct thread *thread, char state, boolean); +int thread_wait_until_not(int state, struct thread *thread); #endif #if defined(LISP_FEATURE_SB_SAFEPOINT) @@ -45,32 +45,59 @@ }; int handle_safepoint_violation(os_context_t *context, os_vm_address_t addr); -void** os_get_csp(struct thread* th); -void alloc_gc_page(); +void* os_get_csp(struct thread* th); void assert_on_stack(struct thread *th, void *esp); #endif /* defined(LISP_FEATURE_SB_SAFEPOINT) */ -extern int kill_safely(os_thread_t os_thread, int signal); - -#define THREAD_SLOT_OFFSET_WORDS(c) \ - (offsetof(struct thread,c)/(sizeof (struct thread *))) - /* The thread struct is generated from lisp during genesis and it * needs to know the sizes of all its members, but some types may have * arbitrary lengths, thus the pointers are stored instead. This - * structure is used to help allocation of those types, so that the - * pointers can be later shoved into the thread struct. */ -struct nonpointer_thread_data + * structure is used to help allocation of those types. + * This structure is located at an address computable based on a 'struct thread' + * so there is no need for a pointer from one to the other */ +struct extra_thread_data { -#ifdef LISP_FEATURE_SB_THREAD -#ifndef LISP_FEATURE_SB_SAFEPOINT + // Lisp needs to be able to access this array. KEEP IT AS THE FIRST FIELD! + os_context_t* sigcontexts[MAX_INTERRUPTS]; + + // Data from here down are never looked at from Lisp. + struct interrupt_data interrupt_data; +#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_SB_SAFEPOINT + // 'state_sem' is a binary semaphore used just like a mutex. + // I guess we figure that semaphores are OK to use in signal handlers (which is + // technically false), whereas a mutex would be more certainly wrong? os_sem_t state_sem; + // These are basically "gates" a la SB-CONCURRENCY:GATE. They might be better + // as condition variables, but condvars are not allowed in signal handlers. + // Strictly speaking, sem_wait isn't either, but it seems to work. os_sem_t state_not_running_sem; os_sem_t state_not_stopped_sem; + // We count waiters on each gate to know how many times to sem_post() to open them. + // The counts themselves are protected against concurrent access by 'state_sem'. + // Since we're not constrained by compiler/generic/objdef any more, we can + // make these "only" 4 bytes each, instead of lispwords. + uint32_t state_not_running_waitcount; + uint32_t state_not_stopped_waitcount; #endif +#ifdef LISP_FEATURE_WIN32 + // these are different from the masks that interrupt_data holds + sigset_t pending_signal_set; + sigset_t blocked_signal_set; +#define NUM_PRIVATE_EVENTS 2 +#define thread_private_events(th,i) thread_extra_data(th)->private_events[i] + HANDLE private_events[NUM_PRIVATE_EVENTS]; + // Context base pointer for running on top of system libraries built using + // -fomit-frame-pointer. Currently truly required and implemented only + // for (and win32 x86-64), + os_context_register_t carried_base_pointer; + HANDLE synchronous_io_handle_and_flag; + void* waiting_on_address; // used only if #+sb-futex #endif - struct interrupt_data interrupt_data; }; +#define thread_extra_data(thread) \ + ((struct extra_thread_data*)((char*)(thread) + dynamic_values_bytes)) +#define nth_interrupt_context(n,thread) thread_extra_data(thread)->sigcontexts[n] +#define thread_interrupt_data(thread) thread_extra_data(thread)->interrupt_data extern struct thread *all_threads; extern int dynamic_values_bytes; @@ -108,7 +135,7 @@ #endif } #else -# define tls_index_of(x) (x->tls_index) +# define tls_index_of(x) (x)->tls_index #endif # define per_thread_value(sym,th) *(lispobj*)(tls_index_of(sym) + (char*)th) #endif @@ -191,14 +218,19 @@ # endif #endif -#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_GCC_TLS) +#ifdef LISP_FEATURE_SB_THREAD +// FIXME: these names should be consistent with one another +# ifdef LISP_FEATURE_GCC_TLS extern __thread struct thread *current_thread; +# elif !defined LISP_FEATURE_WIN32 +extern pthread_key_t specials; +#endif #endif #ifndef LISP_FEATURE_SB_SAFEPOINT # define THREAD_CSP_PAGE_SIZE 0 #else -# define THREAD_CSP_PAGE_SIZE BACKEND_PAGE_BYTES +# define THREAD_CSP_PAGE_SIZE os_reported_page_size #endif #if defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_MACH_EXCEPTION_HANDLER) @@ -207,18 +239,14 @@ #define ALT_STACK_SIZE 32 * SIGSTKSZ #endif -/* context 0 is the word immediately before the thread struct, and so on. */ -#define nth_interrupt_context(n,thread) \ - ((os_context_t**)((char*)thread - THREAD_CSP_PAGE_SIZE))[-(THREAD_HEADER_SLOTS+n+1)] - -#define THREAD_STRUCT_SIZE (thread_control_stack_size + BINDING_STACK_SIZE + \ - ALIEN_STACK_SIZE + \ - sizeof(struct nonpointer_thread_data) + \ - (MAX_INTERRUPTS*sizeof(os_context_t*)) + \ - dynamic_values_bytes + \ - ALT_STACK_SIZE + \ - THREAD_ALIGNMENT_BYTES + \ - THREAD_CSP_PAGE_SIZE) +/* As a helpful reminder of how this calculation arises, the summands should + * correspond, in the correct order, to the picture in thread.c */ +#define THREAD_STRUCT_SIZE \ + (THREAD_ALIGNMENT_BYTES + \ + thread_control_stack_size + BINDING_STACK_SIZE + ALIEN_STACK_SIZE + \ + THREAD_CSP_PAGE_SIZE + \ + (THREAD_HEADER_SLOTS*N_WORD_BYTES) + dynamic_values_bytes + \ + sizeof (struct extra_thread_data) + ALT_STACK_SIZE) /* sigaltstack() - "Signal stacks are automatically adjusted * for the direction of stack growth and alignment requirements." */ @@ -226,7 +254,7 @@ // Refer to the picture in the comment above create_thread_struct(). // Always return the lower limit as the base even if stack grows down. return ((char*) thread) + dynamic_values_bytes - + ALIGN_UP(sizeof (struct nonpointer_thread_data), N_WORD_BYTES); + + ALIGN_UP(sizeof (struct extra_thread_data), N_WORD_BYTES); } static inline void* calc_altstack_end(struct thread* thread) { return (char*)thread->os_address + THREAD_STRUCT_SIZE; @@ -241,6 +269,7 @@ #if defined(LISP_FEATURE_WIN32) static inline struct thread* arch_os_get_current_thread() __attribute__((__const__)); +int sb_pthr_kill(struct thread* thread, int signum); #endif /* This is clearly per-arch and possibly even per-OS code, but we can't @@ -254,10 +283,14 @@ return all_threads; #elif defined(LISP_FEATURE_X86) && defined(LISP_FEATURE_WIN32) + // FIXME: why not use TlsGetvalue(OUR_TLS_INDEX) here? register struct thread *me=0; __asm__ volatile ("movl %%fs:0xE10+(4*63), %0" : "=r"(me) :); return me; +#elif defined LISP_FEATURE_WIN32 + return (struct thread*)TlsGetValue(OUR_TLS_INDEX); + #else # if defined(LISP_FEATURE_X86) @@ -276,10 +309,9 @@ th = pthread_getspecific(specials); # endif -# if defined(LISP_FEATURE_RESTORE_FS_SEGMENT_REGISTER_FROM_TLS) - /* If enabled by make-config (currently Darwin and FreeBSD only), - * re-setup %fs. This is an out-of-line call, and potentially - * expensive.*/ +# if defined LISP_FEATURE_X86 && (defined LISP_FEATURE_DARWIN || defined LISP_FEATURE_FREEBSD) + /* Restore the %FS register. This is potentially an "expensive" call. + * It rightfully belongs with RESTORE_FP_CONTROL_WORD, but I don't care to try it. */ if (th) { void arch_os_load_ldt(struct thread*); arch_os_load_ldt(th); @@ -293,9 +325,11 @@ inline static int lisp_thread_p(os_context_t __attribute__((unused)) *context) { #ifdef LISP_FEATURE_SB_THREAD # ifdef LISP_FEATURE_GCC_TLS - return is_lisp_thread; + return current_thread != 0; +# elif defined LISP_FEATURE_WIN32 + return TlsGetValue(OUR_TLS_INDEX) != 0; # else - return pthread_getspecific(lisp_thread) != NULL; + return pthread_getspecific(specials) != NULL; # endif #elif defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK) char *csp = (char *)*os_context_sp_addr(context); @@ -327,21 +361,19 @@ extern void thread_register_gc_trigger(); # ifdef LISP_FEATURE_SB_THRUPTION -int wake_thread(os_thread_t os_thread); -# ifdef LISP_FEATURE_WIN32 -void wake_thread_win32(struct thread *thread); -# else -int wake_thread_posix(os_thread_t os_thread); -# endif +void wake_thread(struct thread_instance*), + wake_thread_impl(struct thread_instance*); # endif +#define csp_around_foreign_call(thread) *(((lispobj*)thread) - 1) + static inline void push_gcing_safety(struct gcing_safety *into) { struct thread* th = arch_os_get_current_thread(); asm volatile (""); - into->csp_around_foreign_call = *th->csp_around_foreign_call; - *th->csp_around_foreign_call = 0; + into->csp_around_foreign_call = csp_around_foreign_call(th); + csp_around_foreign_call(th) = 0; asm volatile (""); } @@ -350,7 +382,7 @@ { struct thread* th = arch_os_get_current_thread(); asm volatile (""); - *th->csp_around_foreign_call = from->csp_around_foreign_call; + csp_around_foreign_call(th) = from->csp_around_foreign_call; asm volatile (""); } @@ -364,20 +396,33 @@ int check_pending_thruptions(os_context_t *ctx); -void attach_os_thread(init_thread_data *); -void detach_os_thread(init_thread_data *); - -# if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32) - -void signal_handler_callback(lispobj, int, void *, void *); -# endif - +#else +#define WITH_GC_AT_SAFEPOINTS_ONLY() #endif -extern void create_initial_thread(lispobj); +extern void create_main_lisp_thread(lispobj); -#ifdef LISP_FEATURE_SB_THREAD +#ifdef LISP_FEATURE_WIN32 +extern CRITICAL_SECTION all_threads_lock; +#elif defined LISP_FEATURE_SB_THREAD extern pthread_mutex_t all_threads_lock; #endif +#ifndef LISP_FEATURE_SB_THREAD +// Put in an empty conversion to avoid warning at the point of use: +// "warning: too many arguments for format [-Wformat-extra-args]" +# define THREAD_ID_LABEL "%s" +# define THREAD_ID_VALUE "" +#elif defined LISP_FEATURE_WIN32 +# define THREAD_ID_LABEL "%ld" +# define THREAD_ID_VALUE (GetCurrentThreadId()) +#elif defined __linux__ +extern int sb_GetTID(); +# define THREAD_ID_LABEL " tid %d" +# define THREAD_ID_VALUE (sb_GetTID()) +#else +# define THREAD_ID_LABEL " pthread %p" +# define THREAD_ID_VALUE ((void*)thread_self()) +#endif + #endif /* _INCLUDE_THREAD_H_ */ diff -Nru sbcl-2.0.6/src/runtime/time.c sbcl-2.1.1/src/runtime/time.c --- sbcl-2.0.6/src/runtime/time.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/time.c 2021-01-30 11:22:38.000000000 +0000 @@ -18,11 +18,6 @@ #include "sbcl.h" #include "runtime.h" -#ifdef LISP_FEATURE_HPUX -struct tm *gmtime_r(const time_t *timer, struct tm *result); -struct tm *localtime_r(const time_t *timer, struct tm *result); -#endif - int get_timezone(time_t when, boolean *dst) { struct tm ltm, gtm; diff -Nru sbcl-2.0.6/src/runtime/traceroot.c sbcl-2.1.1/src/runtime/traceroot.c --- sbcl-2.0.6/src/runtime/traceroot.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/traceroot.c 2021-01-30 11:22:38.000000000 +0000 @@ -18,6 +18,7 @@ #include "search.h" #include "genesis/avlnode.h" #include "genesis/sap.h" +#include "genesis/thread-instance.h" #include #include @@ -82,6 +83,7 @@ // A hashmap from object to list of objects pointing to it struct hopscotch_table* inverted_heap; struct scratchpad scratchpad; + lispobj ignored_objects; int keep_leaves; }; @@ -97,8 +99,8 @@ switch(lowtag_of(ptr)) { case INSTANCE_POINTER_LOWTAG: name = instance_classoid_name(native_pointer(ptr)); - if (widetag_of(name) == SIMPLE_BASE_STRING_WIDETAG) - return (char*)(name + 2); + if (widetag_of(name) == SIMPLE_BASE_STRING_WIDETAG) return (char*)(name + 2); + break; case LIST_POINTER_LOWTAG: return "cons"; case FUN_POINTER_LOWTAG: @@ -148,7 +150,7 @@ #define check_ptr(index,ptr) if(canonical_obj(ptr)==target) return index; static int find_ref(lispobj* source, lispobj target) { - lispobj layout, bitmap; + lispobj layout; int scan_limit, i; lispobj word = *source; @@ -161,18 +163,16 @@ scan_limit = sizetab[widetag](source); switch (widetag) { case INSTANCE_WIDETAG: -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER case FUNCALLABLE_INSTANCE_WIDETAG: -#endif - // mixed boxed/unboxed objects - // Unlike in scav_instance where the slot loop is unswitched for - // speed into three cases (no raw slots, fixnum bitmap, bignum bitmap), - // here we just go for clarity by abstracting out logbitp. - layout = instance_layout(source); + // Unlike in scav_instance where the slot loop is optimized for + // certain special cases, here we opt for simplicity. + layout = layout_of(source); check_ptr(0, layout); - bitmap = layout ? LAYOUT(layout)->bitmap : make_fixnum(-1); - for(i=1; ilisp_thread; end = (lispobj*)((char*)th + SymbolValue(FREE_TLS_INDEX,0)); for( ; where < end ; ++where) if (interestingp(*where, targets)) { @@ -359,7 +360,7 @@ break; } } - return pin; + if (*root_thread) return pin; } #endif *root_kind = HEAP; @@ -698,16 +699,30 @@ if (count_only) COUNT_POINTER(x) \ else if (is_lisp_pointer(x) && relevant_ptr_p(x)) record_ptr(where,x,ss); } +static boolean ignorep(lispobj* base_ptr, + lispobj ignored_objects) +{ + int i; + for (i = fixnum_value(VECTOR(ignored_objects)->length)-1; i >= 0; --i) + if (native_pointer(VECTOR(ignored_objects)->data[i]) == base_ptr) + return 1; + return 0; +} + static uword_t build_refs(lispobj* where, lispobj* end, struct scan_state* ss) { - lispobj layout, bitmap; + lispobj layout; sword_t nwords, scan_limit, i; uword_t n_objects = 0, n_scanned_words = 0, n_immediates = 0, n_pointers = 0; boolean count_only = !ss->record_ptrs; for ( ; where < end ; where += nwords ) { + if (ss->ignored_objects && ignorep(where, ss->ignored_objects)) { + nwords = OBJECT_SIZE(*where, where); + continue; + } ++n_objects; lispobj word = *where; if (!is_header(word)) { @@ -720,19 +735,17 @@ nwords = scan_limit = sizetab[widetag](where); switch (widetag) { case INSTANCE_WIDETAG: -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER case FUNCALLABLE_INSTANCE_WIDETAG: -#endif // mixed boxed/unboxed objects - layout = instance_layout(where); + layout = layout_of(where); check_ptr(layout); // Partially initialized instance can't have nonzero words yet - bitmap = layout ? LAYOUT(layout)->bitmap : make_fixnum(-1); - // If no raw slots, just scan without use of the bitmap. - // FIXME: check lockfree_list_node_p() also - if (bitmap == make_fixnum(-1)) break; - for(i=1; icar, - output = CONS(objects)->cdr, - paths = CONS(output)->cdr; + lispobj input = VECTOR(objects)->data[0], + ignore = VECTOR(objects)->data[1], + output = VECTOR(objects)->data[2], + paths = CONS(output)->cdr; lispobj list; for (list = input ; list != NIL && listp(list) ; list = CONS(list)->cdr) { ++n_watched; @@ -1038,7 +1052,7 @@ pins[i] = compute_lispobj((lispobj*)pins[i]); } } - n_paths = trace_paths(context_scanner, input, paths, + n_paths = trace_paths(context_scanner, input, paths, ignore, n_pins, (lispobj*)pins, criterion); CONS(output)->car = make_fixnum(n_paths); return n_paths; @@ -1053,38 +1067,3 @@ extern int gc_n_stack_pins; return gc_prove_liveness(0, objects, gc_n_stack_pins, pinned_objects.keys, criterion); } - -// These are slot offsets in (DEFSTRUCT THREAD), -// not the C structure defined in genesis/thread.h -#define LISP_THREAD_NAME_SLOT INSTANCE_DATA_START+0 -#define LISP_THREAD_OS_THREAD_SLOT INSTANCE_DATA_START+3 - -/* Perform exhaustive search on *ALL-THREADS* looking for a specific thread. - * Efficiency is not a concern. - */ -static struct instance* find_thread(os_thread_t os_thread, lispobj tree) -{ - if (tree == NIL) return 0; - struct avlnode* node = (struct avlnode*)native_pointer(tree); - struct instance* lisp_thread = (struct instance*)native_pointer(node->data); - if ((os_thread_t)lisp_thread->slots[LISP_THREAD_OS_THREAD_SLOT] == os_thread) - return lisp_thread; - if ((lisp_thread = find_thread(os_thread, node->left)) != NULL) - return lisp_thread; - if ((lisp_thread = find_thread(os_thread, node->right)) != NULL) - return lisp_thread; - return 0; -} - -struct vector* lisp_thread_name(os_thread_t os_thread) -{ - static unsigned int hint; - lispobj* sym = find_symbol("*ALL-THREADS*", find_package("SB-THREAD"), &hint); - if (sym) { - struct instance* lisp_thread = - find_thread(os_thread, ((struct symbol*)sym)->value); - if (lisp_thread) - return VECTOR(lisp_thread->slots[LISP_THREAD_NAME_SLOT]); - } - return 0; -} diff -Nru sbcl-2.0.6/src/runtime/validate.c sbcl-2.1.1/src/runtime/validate.c --- sbcl-2.0.6/src/runtime/validate.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/validate.c 2021-01-30 11:22:38.000000000 +0000 @@ -63,23 +63,26 @@ } os_vm_address_t undefined_alien_address = 0; +/* As contrasted with the useless os_vm_page_size which is identical to + * the constant BACKEND_PAGE_BYTES that we define for various other purposes + * such as core file loading and generational GC, + * this is the number the OS tells us */ +int os_reported_page_size; + +#ifdef LISP_FEATURE_WIN32 +#include +#endif static void ensure_undefined_alien(void) { - os_vm_address_t start = os_validate(MOVABLE|IS_GUARD_PAGE, NULL, -#ifndef LISP_FEATURE_WIN32 - /* We can/should disregard our 'os_vm_page_size' constant which tends to be - * larger than the granularity that the OS will allow you to manipulate via - * mprotect(). e.g. on x86-64-linux we use a page size of 32K but in reality - * the protection granularity is 4K. - * Moreover, since the memory protection is not changed after allocation, - * the granuarity that mprotect() operates on is immaterial. As such, it - * probably would work to put N_WORD_BYTES here since that's all we need. */ - getpagesize() -#else // Use the same value as does contrib/sb-posix/interface.lisp - 4096 +#ifdef LISP_FEATURE_WIN32 + SYSTEM_INFO info; + GetSystemInfo(&info); + os_reported_page_size = info.dwPageSize; +#else + os_reported_page_size = getpagesize(); #endif - ); + os_vm_address_t start = os_validate(MOVABLE|IS_GUARD_PAGE, NULL, os_reported_page_size); if (start) { undefined_alien_address = start; } else { diff -Nru sbcl-2.0.6/src/runtime/win32-os.c sbcl-2.1.1/src/runtime/win32-os.c --- sbcl-2.0.6/src/runtime/win32-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/win32-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -22,7 +22,7 @@ /* * This file was copied from the Linux version of the same, and - * likely still has some linuxisms in it have haven't been elimiated + * likely still has some linuxisms in it have haven't been eliminated * yet. */ @@ -60,11 +60,6 @@ #include "thread.h" #include "align.h" -#ifndef LISP_FEATURE_SB_THREAD -/* dummy definition to reduce ifdef clutter */ -#define WITH_GC_AT_SAFEPOINTS_ONLY() if (0) ; else -#endif - #include "gc.h" #include "gencgc-internal.h" #include @@ -213,20 +208,6 @@ sys_aver((booly)?0:-1, #booly, __FILE__, __LINE__, 0); \ me;}) -const char * t_nil_s(lispobj symbol); - -/* - * The following signal-mask-related alien routines are called from Lisp: - */ - -/* As of win32, deferrables _do_ matter. gc_signal doesn't. */ -unsigned long block_deferrables_and_return_mask() -{ - sigset_t sset; - block_deferrable_signals(&sset); - return (unsigned long)sset; -} - /* The exception handling function looks like this: */ EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *, struct lisp_exception_frame *, @@ -309,7 +290,6 @@ #endif -#if defined(LISP_FEATURE_LINKAGE_TABLE) /* This feature has already saved me more development time than it * took to implement. In its current state, ``dynamic RT<->core * linking'' is a protocol of initialization of C runtime and Lisp @@ -481,7 +461,7 @@ * Of course, this name-parsing trick lacks conceptual clarity; we're * going to get rid of it eventually. */ -u32 os_get_build_time_shared_libraries(u32 excl_maximum, +uint32_t os_get_build_time_shared_libraries(uint32_t excl_maximum, void* opt_root, void** opt_store_handles, const char *opt_store_names[]) @@ -497,7 +477,7 @@ void* check_duplicates[excl_maximum]; - if ((*(u32*)base_magic_location)!=0x4550) { + if ((*(uint32_t*)base_magic_location)!=0x4550) { /* We don't need this DLL thingie _that_ much. If the world * has changed to a degree where PE magic isn't found, let's * silently return `no libraries detected'. */ @@ -516,7 +496,7 @@ &image_optional_header->DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT]; IMAGE_IMPORT_DESCRIPTOR* image_import_descriptor = base + image_import_direntry->VirtualAddress; - u32 nlibrary, j; + uint32_t nlibrary, j; for (nlibrary=0u; nlibrary < excl_maximum && image_import_descriptor->FirstThunk; @@ -584,7 +564,7 @@ } } -static u32 buildTimeImageCount = 0; +static uint32_t buildTimeImageCount = 0; static void* buildTimeImages[16]; /* Resolve symbols against the executable and its build-time dependencies */ @@ -603,8 +583,6 @@ return result; } -#endif /* LINKAGE_TABLE */ - #if defined(LISP_FEATURE_SB_THREAD) /* We want to get a slot in TIB that (1) is available at constant offset, (2) is our private property, so libraries wouldn't legally @@ -645,8 +623,44 @@ started before _any_ TLS slot is allocated by libraries, and some C compiler vendors rely on this fact. */ +extern CRITICAL_SECTION code_allocator_lock, alloc_profiler_lock; +static CRITICAL_SECTION interrupt_io_lock; + +struct { + console_char buffer[MAX_CONSOLE_TCHARS]; + DWORD head, tail; + CRITICAL_SECTION lock; + CONDITION_VARIABLE cond_has_data; + CONDITION_VARIABLE cond_has_client; + HANDLE thread; + boolean initialized; + HANDLE handle; + boolean in_progress; +} ttyinput; + +#ifdef LISP_FEATURE_64_BIT +// 32-bit uses a hardwired value (63) as this index because codegen +// usese %FS:[a_constant] to get CURRENT-THREAD-SAP, etc. +DWORD sbcl_thread_tls_index; +#endif + int os_preinit(char *argv[], char *envp[]) { +#ifdef LISP_FEATURE_SB_FUTEX + if (GetModuleHandle("API-MS-Win-Core-Synch-l1-2-0") == NULL) { + // calling lose() here loses. Such irony. + fprintf(stderr, "This binary was compiled for Windows 8 or later but you appear to be" +" using 7 or earlier.\nRecompiling SBCL from source on the older release will" +" probably work. See also\n" + "https://support.microsoft.com/en-us/help/4057281/windows-7-support-ended-on-january-14-2020\n"); + fflush(stderr); + exit(1); + } +#endif + InitializeCriticalSection(&code_allocator_lock); + InitializeCriticalSection(&alloc_profiler_lock); + InitializeCriticalSection(&interrupt_io_lock); + InitializeCriticalSection(&ttyinput.lock); #ifdef LISP_FEATURE_X86 DWORD slots[TLS_MINIMUM_AVAILABLE]; DWORD key; @@ -672,8 +686,7 @@ "(last TlsAlloc() returned %u)",key); } #else - (void) argv; /* unused */ - (void) envp; /* unused */ + OUR_TLS_INDEX = TlsAlloc(); #endif return 0; } @@ -715,9 +728,25 @@ ? result : 0); } +static LARGE_INTEGER lisp_init_time; +static double qpcMultiplier; + void os_init(char __attribute__((__unused__)) *argv[], char __attribute__((__unused__)) *envp[]) { +#ifdef LISP_FEATURE_64_BIT + LARGE_INTEGER qpcFrequency; + if (!QueryPerformanceCounter(&lisp_init_time) || + !QueryPerformanceFrequency(&qpcFrequency)) + lose("Can't use monotonic realtime clock. Please report this as an SBCL bug"); + // Convert performance counter ticks per second into INTERNAL-TIME-UNITS-PER-SECOND + // (microseconds). In theory the performance counter can increment faster than + // or slower than I-T-U. Fwiw, on my machine the frequency is 10x I-T-U-P-S, + // so a single integer division by 10 would work, but I don't know in general + // what the ratio is. + qpcMultiplier = (double)1000000 / qpcFrequency.QuadPart; +#endif + SYSTEM_INFO system_info; GetSystemInfo(&system_info); os_vm_page_size = system_info.dwPageSize > BACKEND_PAGE_BYTES? @@ -733,81 +762,47 @@ runtime_module_handle = (HMODULE)win32_get_module_handle_by_address(&runtime_module_handle); } -static inline boolean local_thread_stack_address_p(os_vm_address_t address) +#ifdef LISP_FEATURE_64_BIT +uword_t get_monotonic_time() { - return this_thread && - (((((u64)address >= (u64)this_thread->os_address) && - ((u64)address < ((u64)this_thread)-THREAD_CSP_PAGE_SIZE))|| - (((u64)address >= (u64)this_thread->control_stack_start)&& - ((u64)address < (u64)this_thread->control_stack_end)))); + LARGE_INTEGER t; + QueryPerformanceCounter(&t); + t.QuadPart -= lisp_init_time.QuadPart; + return (uword_t)((double)t.QuadPart * qpcMultiplier); } - -/* - * So we have three fun scenarios here. - * - * First, we could be being called to reserve the memory areas - * during initialization (prior to loading the core file). - * - * Second, we could be being called by the GC to commit a page - * that has just been decommitted (for easy zero-fill). - * - * Third, we could be being called by create_thread_struct() - * in order to create the sundry and various stacks. - * - * The third case is easy to pick out because it passes an - * addr of 0. - * - * The second case is easy to pick out because it will be for - * a range of memory that is MEM_RESERVE rather than MEM_FREE. - * - * The second case is also an easy implement, because we leave - * the memory as reserved (since we do lazy commits). - */ +#endif os_vm_address_t os_validate(int attributes, os_vm_address_t addr, os_vm_size_t len) { - MEMORY_BASIC_INFORMATION mem_info; - if (!addr) { - /* the simple case first */ int protection = attributes & IS_GUARD_PAGE ? PAGE_NOACCESS : PAGE_EXECUTE_READWRITE; return AVERLAX(VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT, protection)); } - if (!AVERLAX(VirtualQuery(addr, &mem_info, sizeof mem_info))) - return 0; + os_vm_address_t actual = VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT, PAGE_EXECUTE_READWRITE); - if ((mem_info.State == MEM_RESERVE) && (mem_info.RegionSize >= len)) { - /* It would be correct to return here. However, support for Wine - * is beneficial, and Wine has a strange behavior in this - * department. It reports all memory below KERNEL32.DLL as - * reserved, but disallows MEM_COMMIT. - * - * Let's work around it: reserve the region we need for a second - * time. The second reservation is documented to fail on normal NT - * family, but it will succeed on Wine if this region is - * actually free. - */ - VirtualAlloc(addr, len, MEM_RESERVE, PAGE_EXECUTE_READWRITE); - /* If it is wine, the second call has succeeded, and now the region - * is really reserved. */ - return addr; - } + if (!actual) { + if (!(attributes & MOVABLE)) { + fprintf(stderr, + "VirtualAlloc: wanted %lu bytes at %p, actually mapped at %p\n", + (unsigned long) len, addr, actual); + fflush(stderr); + return 0; + } - DWORD mode; - if (mem_info.State == MEM_RESERVE) { - fprintf(stderr, "validation of reserved space too short.\n"); - fflush(stderr); - /* Oddly, we do not treat this assertion as fatal; hence also the - * provision for MEM_RESERVE in the following code, I suppose: */ - mode = MEM_COMMIT; - } else { - mode = MEM_RESERVE; + return AVERLAX(VirtualAlloc(NULL, len, MEM_RESERVE|MEM_COMMIT, PAGE_EXECUTE_READWRITE)); } - os_vm_address_t actual = VirtualAlloc(addr, len, mode, PAGE_EXECUTE_READWRITE); + return actual; +} + +/* Used to allocate the dynamic space, as it may be very large. Dynamically comitted by os_commit_memory in handle_access_violation */ +os_vm_address_t +os_validate_nocommit(int attributes, os_vm_address_t addr, os_vm_size_t len) +{ + os_vm_address_t actual = VirtualAlloc(addr, len, MEM_RESERVE, PAGE_EXECUTE_READWRITE); if (!actual) { if (!(attributes & MOVABLE)) { @@ -817,82 +812,28 @@ fflush(stderr); return 0; } - - return AVERLAX(VirtualAlloc(NULL, len, mode, PAGE_EXECUTE_READWRITE)); + return AVERLAX(VirtualAlloc(NULL, len, MEM_RESERVE, PAGE_EXECUTE_READWRITE)); } return actual; } -/* - * For os_invalidate(), we merely decommit the memory rather than - * freeing the address space. This loses when freeing per-thread - * data and related memory since it leaks address space. - * - * So far the original comment (author unknown). It used to continue as - * follows: - * - * It's not too lossy, however, since the two scenarios I'm aware of - * are fd-stream buffers, which are pooled rather than torched, and - * thread information, which I hope to pool (since windows creates - * threads at its own whim, and we probably want to be able to have - * them callback without funky magic on the part of the user, and - * full-on thread allocation is fairly heavyweight). - * - * But: As it turns out, we are no longer content with decommitting - * without freeing, and have now grown a second function - * os_invalidate_free(), sort of a really_os_invalidate(). - * - * As discussed on #lisp, this is not a satisfactory solution, and probably - * ought to be rectified in the following way: - * - * - Any cases currently going through the non-freeing version of - * os_invalidate() are ultimately meant for zero-filling applications. - * Replace those use cases with an os_revalidate_bzero() or similarly - * named function, which explicitly takes care of that aspect of - * the semantics. - * - * - The remaining uses of os_invalidate should actually free, and once - * the above is implemented, we can rename os_invalidate_free back to - * just os_invalidate(). - * - * So far the new plan, as yet unimplemented. -- DFL - */ - -void -os_invalidate(os_vm_address_t addr, os_vm_size_t len) +void* os_commit_memory(os_vm_address_t addr, os_vm_size_t len) { - AVERLAX(VirtualFree(addr, len, MEM_DECOMMIT)); + return + AVERLAX(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)); } -void -os_invalidate_free(os_vm_address_t addr, - os_vm_size_t __attribute__((__unused__)) len) -{ - AVERLAX(VirtualFree(addr, 0, MEM_RELEASE)); -} -void -os_invalidate_free_by_any_address(os_vm_address_t addr, - os_vm_size_t __attribute__((__unused__)) len) -{ - MEMORY_BASIC_INFORMATION minfo; - AVERLAX(VirtualQuery(addr, &minfo, sizeof minfo)); - AVERLAX(minfo.AllocationBase); - AVERLAX(VirtualFree(minfo.AllocationBase, 0, MEM_RELEASE)); +void os_revalidate_bzero(os_vm_address_t addr, os_vm_size_t len) { + AVERLAX(VirtualFree(addr, len, MEM_DECOMMIT)); + AVERLAX(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)); } -/* os_validate doesn't commit, i.e. doesn't actually "validate" in the - * sense that we could start using the space afterwards. Usually it's - * load_core_bytes or Lisp code that will run into that, in which case we recommit - * elsewhere in this file. For cases where C wants to write into newly - * os_validate()d memory, it needs to commit it explicitly first: - */ -os_vm_address_t -os_validate_recommit(os_vm_address_t addr, os_vm_size_t len) +void +os_invalidate(os_vm_address_t addr, os_vm_size_t len) { - return - AVERLAX(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)); + AVERLAX(VirtualFree(addr, 0, MEM_RELEASE)); } /* @@ -908,10 +849,7 @@ void* load_core_bytes(int fd, os_vm_offset_t offset, os_vm_address_t addr, os_vm_size_t len) { - - AVER(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)|| - VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT, - PAGE_EXECUTE_READWRITE)); + os_commit_memory(addr, len); #ifdef LISP_FEATURE_64_BIT CRT_AVER_NONNEGATIVE(_lseeki64(fd, offset, SEEK_SET)); #else @@ -926,7 +864,6 @@ len -= count; CRT_AVER(count == to_read); } - return (void*)0; } static DWORD os_protect_modes[8] = { @@ -954,75 +891,6 @@ address,length,prot,new_prot,old_prot); } -/* FIXME: Now that FOO_END, rather than FOO_SIZE, is the fundamental - * description of a space, we could probably punt this and just do - * (FOO_START <= x && x < FOO_END) everywhere it's called. */ -static boolean -in_range_p(lispobj a, lispobj sbeg, size_t slen) -{ - char* beg = (char*)((uword_t)sbeg); - char* end = (char*)((uword_t)sbeg) + slen; - char* adr = (char*)a; - return (adr >= beg && adr < end); -} - -boolean -is_linkage_table_addr(os_vm_address_t addr) -{ - return in_range_p((lispobj)addr, LINKAGE_TABLE_SPACE_START, LINKAGE_TABLE_SPACE_SIZE); -} - -static boolean is_some_thread_local_addr(os_vm_address_t addr); - -boolean -gc_managed_addr_p(lispobj addr) -{ - if(gc_managed_heap_space_p(addr) || - is_some_thread_local_addr((os_vm_address_t)addr)) - return 1; - return 0; -} - -/* test if an address is within thread-local space */ -static boolean -is_thread_local_addr(struct thread* th, os_vm_address_t addr) -{ - /* Assuming that this is correct, it would warrant further comment, - * I think. Based on what our call site is doing, we have been - * tasked to check for the address of a lisp object; not merely any - * foreign address within the thread's area. Indeed, this used to - * be a check for control and binding stack only, rather than the - * full thread "struct". So shouldn't the THREAD_STRUCT_SIZE rather - * be (thread_control_stack_size+BINDING_STACK_SIZE) instead? That - * would also do away with the LISP_FEATURE_SB_THREAD case. Or does - * it simply not matter? --DFL */ - ptrdiff_t diff = ((char*)th->os_address)-(char*)addr; - return diff > (ptrdiff_t)0 && diff < (ptrdiff_t)THREAD_STRUCT_SIZE -#ifdef LISP_FEATURE_SB_THREAD - && addr != (os_vm_address_t) th->csp_around_foreign_call -#endif - ; -} - -static boolean -is_some_thread_local_addr(os_vm_address_t addr) -{ - boolean result = 0; -#ifdef LISP_FEATURE_SB_THREAD - struct thread *th; - pthread_mutex_lock(&all_threads_lock); - for_each_thread(th) { - if(is_thread_local_addr(th,addr)) { - result = 1; - break; - } - } - pthread_mutex_unlock(&all_threads_lock); -#endif - return result; -} - - /* A tiny bit of interrupt.c state we want our paws on. */ extern boolean internal_errors_enabled; @@ -1157,14 +1025,6 @@ exception_record->ExceptionInformation[0]); #endif - /* Stack: This case takes care of our various stack exhaustion - * protect pages (with the notable exception of the control stack!). */ - if (self && local_thread_stack_address_p(fault_address)) { - if (handle_guard_page_triggered(ctx, fault_address)) - return 0; /* gc safety? */ - goto try_recommit; - } - /* Safepoint pages */ #ifdef LISP_FEATURE_SB_THREAD if (fault_address == (void *) GC_SAFEPOINT_TRAP_ADDR) { @@ -1172,72 +1032,38 @@ return 0; } - if ((((u64)fault_address) == ((u64)self->csp_around_foreign_call))){ + if (1+(lispobj*)fault_address == (lispobj*)self) { thread_in_safety_transition(ctx); return 0; } #endif /* dynamic space */ - page_index_t index = find_page_index(fault_address); - if (index != -1) { - /* - * Now, if the page is supposedly write-protected and this - * is a write, tell the gc that it's been hit. - */ - if (page_table[index].write_protected) { - gencgc_handle_wp_violation(fault_address); - } else { - AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size), - os_vm_page_size, - MEM_COMMIT, PAGE_EXECUTE_READWRITE)); + if (DYNAMIC_SPACE_START <= (lispobj)fault_address && + (lispobj)fault_address < (DYNAMIC_SPACE_START + dynamic_space_size)) { + MEMORY_BASIC_INFORMATION mem_info; + if (AVERLAX(VirtualQuery(fault_address, &mem_info, sizeof mem_info)) && + mem_info.State == MEM_RESERVE) { + os_commit_memory(PTR_ALIGN_DOWN(fault_address, os_vm_page_size), + os_vm_page_size); + return 0; } + } + if (gencgc_handle_wp_violation(fault_address)) { return 0; - } else { + } + #ifdef LISP_FEATURE_IMMOBILE_SPACE - extern int immobile_space_handle_wp_violation(void*); - if (immobile_space_handle_wp_violation(fault_address)) { - return 0; - } + extern int immobile_space_handle_wp_violation(void*); + if (immobile_space_handle_wp_violation(fault_address)) { + return 0; + } #endif + if (handle_guard_page_triggered(ctx, fault_address)) { + return 0; } - if (fault_address == undefined_alien_address) - return -1; - - /* linkage table or a "valid_lisp_addr" outside of dynamic space (?) */ - if (is_linkage_table_addr(fault_address) - || gc_managed_addr_p((lispobj)fault_address)) - goto try_recommit; - return -1; - -try_recommit: - /* First use of a new page, lets get some memory for it. */ - -#if defined(LISP_FEATURE_X86) - AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size), - os_vm_page_size, - MEM_COMMIT, PAGE_EXECUTE_READWRITE) - ||(fprintf(stderr,"Unable to recommit addr %p eip 0x%08lx\n", - fault_address, win32_context->Eip) && - (c_level_backtrace("BT",5), - fake_foreign_function_call(ctx), - lose("Lispy backtrace"), - 0))); -#else - AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size), - os_vm_page_size, - MEM_COMMIT, PAGE_EXECUTE_READWRITE) - ||(fprintf(stderr,"Unable to recommit addr %p eip %p\n", - fault_address, (void*)win32_context->Rip) && - (c_level_backtrace("BT",5), - fake_foreign_function_call(ctx), - lose("Lispy backtrace"), - 0))); -#endif - - return 0; } static void @@ -1354,14 +1180,12 @@ os_context_t context, *ctx = &context; context.win32_context = win32_context; -#if defined(LISP_FEATURE_SB_THREAD) - context.sigmask = self ? self->os_thread->blocked_signal_set : 0; -#endif + context.sigmask = self ? thread_extra_data(self)->blocked_signal_set : 0; os_context_register_t oldbp = 0; if (self) { - oldbp = self ? self->carried_base_pointer : 0; - self->carried_base_pointer + oldbp = self ? thread_extra_data(self)->carried_base_pointer : 0; + thread_extra_data(self)->carried_base_pointer = (os_context_register_t) voidreg(win32_context, bp); } @@ -1408,7 +1232,7 @@ signal_internal_error_or_lose(ctx, exception_record, fault_address); if (self) - self->carried_base_pointer = oldbp; + thread_extra_data(self)->carried_base_pointer = oldbp; errno = lastErrno; SetLastError(lastError); @@ -1427,7 +1251,7 @@ EXCEPTION_DISPOSITION disp; RESTORING_ERRNO() { - if (!pthread_self()) + if (!arch_os_get_current_thread()) return EXCEPTION_CONTINUE_SEARCH; } @@ -1450,7 +1274,7 @@ carry_frame_pointer(os_context_register_t default_value) { struct thread* self = arch_os_get_current_thread(); - os_context_register_t bp = self->carried_base_pointer; + os_context_register_t bp = thread_extra_data(self)->carried_base_pointer; return bp ? bp : default_value; } @@ -1519,19 +1343,32 @@ int socket_input_available(HANDLE socket) { - unsigned long count = 0, count_size = 0; + int count = 0; int wsaErrno = GetLastError(); - int err = WSAIoctl((SOCKET)socket, FIONREAD, NULL, 0, - &count, sizeof(count), &count_size, NULL, NULL); + TIMEVAL timeout = {0, 0}; + fd_set readfds, errfds; - int ret; + FD_ZERO(&readfds); + FD_ZERO(&errfds); + FD_SET(socket, &readfds); + FD_SET(socket, &errfds); - if (err == 0) { - ret = (count > 0) ? 1 : 2; - } else - ret = 0; + count = select(0, &readfds, NULL, &errfds, &timeout); SetLastError(wsaErrno); - return ret; + + if (count == SOCKET_ERROR) + /* This is an error in select() itself, not with the socket. */ + return 0; + else if (count == 0) + return 2; + /* True if there is data, or the socket has been closed (i.e. a read + * would retrieve an EOF error) */ + else if (FD_ISSET(socket, &readfds)) + return 1; + else + /* This is an error in the socket. The count was positive, and + * it wasn't in the read set, so it must be in the error set. */ + return 0; } #ifdef LISP_FEATURE_SB_THREAD @@ -1547,17 +1384,15 @@ if (!ptr_CancelIoEx) return 1; - if (!__sync_bool_compare_and_swap(&this_thread->synchronous_io_handle_and_flag, + if (!__sync_bool_compare_and_swap(&thread_extra_data(this_thread)->synchronous_io_handle_and_flag, 0, handle)) { - ResetEvent(this_thread->private_events.events[0]); - this_thread->synchronous_io_handle_and_flag = 0; + ResetEvent(thread_private_events(this_thread,0)); + thread_extra_data(this_thread)->synchronous_io_handle_and_flag = 0; return 0; } return 1; } -static pthread_mutex_t interrupt_io_lock = PTHREAD_MUTEX_INITIALIZER; - /* Unmark current thread as (probably) doing synchronous I/O; if an * I/O cancellation was requested, postpone it until next * io_begin_interruptible */ @@ -1566,10 +1401,10 @@ { if (!ptr_CancelIoEx) return; - pthread_mutex_lock(&interrupt_io_lock); - __sync_bool_compare_and_swap(&this_thread->synchronous_io_handle_and_flag, + thread_mutex_lock(&interrupt_io_lock); + __sync_bool_compare_and_swap(&thread_extra_data(this_thread)->synchronous_io_handle_and_flag, handle, 0); - pthread_mutex_unlock(&interrupt_io_lock); + thread_mutex_unlock(&interrupt_io_lock); } #define WITH_INTERRUPTIBLE_IO(handle) \ if (!io_begin_interruptible(handle)) { \ @@ -1647,30 +1482,17 @@ * entered. */ -struct { - console_char buffer[MAX_CONSOLE_TCHARS]; - DWORD head, tail; - pthread_mutex_t lock; - pthread_cond_t cond_has_data; - pthread_cond_t cond_has_client; - pthread_t thread; - boolean initialized; - HANDLE handle; - boolean in_progress; -} ttyinput = {.lock = PTHREAD_MUTEX_INITIALIZER}; - -static void* -tty_read_line_server() +static __stdcall unsigned int tty_read_line_server(LPVOID arg) { - pthread_mutex_lock(&ttyinput.lock); + thread_mutex_lock(&ttyinput.lock); while (ttyinput.handle) { DWORD nchars; BOOL ok; while (!ttyinput.in_progress) - pthread_cond_wait(&ttyinput.cond_has_client,&ttyinput.lock); + SleepConditionVariableCS(&ttyinput.cond_has_client,&ttyinput.lock,INFINITE); - pthread_mutex_unlock(&ttyinput.lock); + thread_mutex_unlock(&ttyinput.lock); #ifdef LISP_FEATURE_SB_UNICODE ok = ReadConsoleW(ttyinput.handle, &ttyinput.buffer[ttyinput.tail], @@ -1683,16 +1505,16 @@ &nchars,NULL); #endif - pthread_mutex_lock(&ttyinput.lock); + thread_mutex_lock(&ttyinput.lock); if (ok) { ttyinput.tail += nchars; - pthread_cond_broadcast(&ttyinput.cond_has_data); + WakeAllConditionVariable(&ttyinput.cond_has_data); } ttyinput.in_progress = 0; } - pthread_mutex_unlock(&ttyinput.lock); - return NULL; + thread_mutex_unlock(&ttyinput.lock); + return 0; } static boolean @@ -1704,9 +1526,13 @@ 0,FALSE,DUPLICATE_SAME_ACCESS)) { return 0; } - pthread_cond_init(&ttyinput.cond_has_data,NULL); - pthread_cond_init(&ttyinput.cond_has_client,NULL); - pthread_create(&ttyinput.thread,NULL,tty_read_line_server,NULL); + InitializeConditionVariable(&ttyinput.cond_has_data); + InitializeConditionVariable(&ttyinput.cond_has_client); + ttyinput.thread = + (HANDLE)_beginthreadex(NULL, + 0, // stack size = default + tty_read_line_server, 0, + 0, 0); ttyinput.initialized = 1; } return 1; @@ -1718,7 +1544,7 @@ boolean result = 0; INPUT_RECORD ir; DWORD nevents; - pthread_mutex_lock(&ttyinput.lock); + thread_mutex_lock(&ttyinput.lock); if (!tty_maybe_initialize_unlocked(handle)) result = 0; @@ -1730,11 +1556,11 @@ } else { if (PeekConsoleInput(ttyinput.handle,&ir,1,&nevents) && nevents) { ttyinput.in_progress = 1; - pthread_cond_broadcast(&ttyinput.cond_has_client); + WakeAllConditionVariable(&ttyinput.cond_has_client); } } } - pthread_mutex_unlock(&ttyinput.lock); + thread_mutex_unlock(&ttyinput.lock); return result; } @@ -1750,7 +1576,7 @@ count = nchars*sizeof(console_char); - pthread_mutex_lock(&ttyinput.lock); + thread_mutex_lock(&ttyinput.lock); if (!tty_maybe_initialize_unlocked(handle)) { result = -1; @@ -1770,9 +1596,9 @@ /* We are to wait */ ttyinput.in_progress=1; /* wake console reader */ - pthread_cond_broadcast(&ttyinput.cond_has_client); + WakeAllConditionVariable(&ttyinput.cond_has_client); } - pthread_cond_wait(&ttyinput.cond_has_data, &ttyinput.lock); + SleepConditionVariableCS(&ttyinput.cond_has_data, &ttyinput.lock, INFINITE); io_end_interruptible(ttyinput.handle); } } @@ -1807,7 +1633,7 @@ } } unlock: - pthread_mutex_unlock(&ttyinput.lock); + thread_mutex_unlock(&ttyinput.lock); return result; } @@ -1817,28 +1643,33 @@ struct thread *th = thread; boolean done = 0; +#ifdef LISP_FEATURE_SB_FUTEX + if (thread_extra_data(th)->waiting_on_address) + WakeByAddressAll(thread_extra_data(th)->waiting_on_address); +#endif + if (ptr_CancelIoEx) { - pthread_mutex_lock(&interrupt_io_lock); + thread_mutex_lock(&interrupt_io_lock); HANDLE h = (HANDLE) InterlockedExchangePointer((volatile LPVOID *) - &th->synchronous_io_handle_and_flag, + &thread_extra_data(th)->synchronous_io_handle_and_flag, (LPVOID)INVALID_HANDLE_VALUE); if (h && (h!=INVALID_HANDLE_VALUE)) { if (console_handle_p(h)) { - pthread_mutex_lock(&ttyinput.lock); - pthread_cond_broadcast(&ttyinput.cond_has_data); - pthread_mutex_unlock(&ttyinput.lock); + thread_mutex_lock(&ttyinput.lock); + WakeAllConditionVariable(&ttyinput.cond_has_data); + thread_mutex_unlock(&ttyinput.lock); done = 1; goto unlock; } if (ptr_CancelSynchronousIo) { - done = !!ptr_CancelSynchronousIo(th->os_thread->handle); + done = !!ptr_CancelSynchronousIo((HANDLE)th->os_thread); } done |= !!ptr_CancelIoEx(h,NULL); } unlock: - pthread_mutex_unlock(&interrupt_io_lock); + thread_mutex_unlock(&interrupt_io_lock); } return done; } @@ -1895,7 +1726,7 @@ return win32_write_console(handle,buf,count); } - overlapped.hEvent = self->private_events.events[0]; + overlapped.hEvent = thread_private_events(self,0); seekable = SetFilePointerEx(handle, zero_large_offset, &file_position, @@ -1926,7 +1757,7 @@ errno = errorCode; return -1; } else { - if(WaitForMultipleObjects(2,self->private_events.events, + if(WaitForMultipleObjects(2,thread_extra_data(self)->private_events, FALSE,INFINITE) != WAIT_OBJECT_0) { CancelIo(handle); waitInGOR = TRUE; @@ -1970,7 +1801,7 @@ return win32_read_console(handle, buf, count); } - overlapped.hEvent = self->private_events.events[0]; + overlapped.hEvent = thread_private_events(self,0); /* If it has a position, we won't try overlapped */ seekable = SetFilePointerEx(handle, zero_large_offset, @@ -2012,7 +1843,7 @@ return -1; } else { int ret; - if( (ret = WaitForMultipleObjects(2,self->private_events.events, + if( (ret = WaitForMultipleObjects(2,thread_extra_data(self)->private_events, FALSE,INFINITE)) != WAIT_OBJECT_0) { CancelIo(handle); waitInGOR = TRUE; @@ -2090,7 +1921,7 @@ { #ifdef LISP_FEATURE_SB_THREAD struct thread *self = arch_os_get_current_thread(); - HANDLE handles[] = {waitFor, self->private_events.events[1]}; + HANDLE handles[] = {waitFor, thread_private_events(self,1)}; return WaitForMultipleObjects(2,handles, FALSE, INFINITE); #else @@ -2103,7 +1934,7 @@ { #ifdef LISP_FEATURE_SB_THREAD struct thread *self = arch_os_get_current_thread(); - handles[count] = self->private_events.events[1]; + handles[count] = thread_private_events(self,1); return WaitForMultipleObjects(count + 1, handles, FALSE, INFINITE); #else @@ -2157,4 +1988,121 @@ } #endif +#ifdef LISP_FEATURE_SB_FUTEX +int +futex_wait(int *lock_word, int oldval, long sec, unsigned long usec) +{ + DWORD timeout = sec < 0 ? INFINITE : (sec * 1000) + (usec / 1000); + struct thread* th = arch_os_get_current_thread(); + thread_extra_data(th)->waiting_on_address = lock_word; + int result = WaitOnAddress(lock_word, &oldval, 4, timeout); + thread_extra_data(th)->waiting_on_address = 0; + if (result) + return 0; + if (GetLastError() == ERROR_TIMEOUT) + return 1; + return 0; +} + +int +futex_wake(PVOID lock_word, int n) +{ + if (n == 1) + WakeByAddressSingle(lock_word); + else + WakeByAddressAll(lock_word); + return 0; +} +#endif + +int sb_pthread_sigmask(int how, const sigset_t *set, sigset_t *oldset) +{ + struct extra_thread_data* self = thread_extra_data(arch_os_get_current_thread()); + if (oldset) + *oldset = self->blocked_signal_set; + if (set) { + switch (how) { + case SIG_BLOCK: + self->blocked_signal_set |= *set; + break; + case SIG_UNBLOCK: + self->blocked_signal_set &= ~(*set); + break; + case SIG_SETMASK: + self->blocked_signal_set = *set; + break; + } + } + return 0; +} + +int sb_pthr_kill(struct thread* thread, int signum) +{ + __sync_fetch_and_or(&thread_extra_data(thread)->pending_signal_set, 1<pending_signal_set, + 0, 0); + return 0; +} + +/* Signals */ +struct sigaction signal_handlers[NSIG]; + +/* Never called for now */ +int sigaction(int signum, const struct sigaction* act, struct sigaction* oldact) +{ + struct sigaction newact = *act; + if (oldact) + *oldact = signal_handlers[signum]; + if (!(newact.sa_flags & SA_SIGINFO)) { + newact.sa_sigaction = (typeof(newact.sa_sigaction))newact.sa_handler; + } + signal_handlers[signum] = newact; + return 0; +} + +int sched_yield() +{ + /* http://stackoverflow.com/questions/1383943/switchtothread-vs-sleep1 + SwitchToThread(); was here. Unsure what's better for us, just trying.. */ + + if(!SwitchToThread()) + Sleep(0); + return 0; +} + +int sigemptyset(sigset_t *set) +{ + *set = 0; + return 0; +} + +int sigfillset(sigset_t *set) +{ + *set = 0xfffffffful; + return 0; +} + +int sigaddset(sigset_t *set, int signum) +{ + *set |= 1 << signum; + return 0; +} + +int sigdelset(sigset_t *set, int signum) +{ + *set &= ~(1 << signum); + return 0; +} + +int sigismember(const sigset_t *set, int signum) +{ + return (*set & (1 << signum)) != 0; +} + /* EOF */ diff -Nru sbcl-2.0.6/src/runtime/win32-os.h sbcl-2.1.1/src/runtime/win32-os.h --- sbcl-2.0.6/src/runtime/win32-os.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/win32-os.h 2021-01-30 11:22:38.000000000 +0000 @@ -30,9 +30,6 @@ #ifdef LISP_FEATURE_SB_THREAD #include "pthreads_win32.h" -/* prevent inclusion of a mingw semaphore.h */ -#define CANNOT_USE_POSIX_SEM_T -typedef sem_t os_sem_t; #else typedef void *siginfo_t; typedef int sigset_t; @@ -60,7 +57,17 @@ extern int win32_open_for_mmap(const char* file); extern FILE* win32_fopen_runtime(); +// 64-bit uses whatever TLS index the kernels gives us which we store in +// 'sbcl_thread_tls_index' to hold our thread-local value of the pointer +// to struct thread. +// 32-bit uses a quasi-arbitrary fixed TLS index that we try to claim on startup. +// of the process. +#ifdef LISP_FEATURE_64_BIT +extern DWORD sbcl_thread_tls_index; +#define OUR_TLS_INDEX sbcl_thread_tls_index +#else #define OUR_TLS_INDEX 63 +#endif #define SIG_MEMORY_FAULT SIGSEGV #define SIG_STOP_FOR_GC (SIGRTMIN+1) @@ -76,12 +83,9 @@ void wos_install_interrupt_handlers(struct lisp_exception_frame *handler); char *dirname(char *path); -void os_invalidate_free(os_vm_address_t addr, os_vm_size_t len); - boolean win32_maybe_interrupt_io(void* thread); +void os_revalidate_bzero(os_vm_address_t addr, os_vm_size_t len); -struct thread; -void** os_get_csp(struct thread* th); - +int sb_pthread_sigmask(int how, const sigset_t *set, sigset_t *oldset); #endif /* SBCL_INCLUDED_WIN32_OS_H */ diff -Nru sbcl-2.0.6/src/runtime/win32-thread-private-events.h sbcl-2.1.1/src/runtime/win32-thread-private-events.h --- sbcl-2.0.6/src/runtime/win32-thread-private-events.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/win32-thread-private-events.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -#ifndef _WIN32_THREAD_PRIVATE_EVENTS_H_ -#define _WIN32_THREAD_PRIVATE_EVENTS_H_ - -#ifndef WIN32_LEAN_AND_MEAN -#define WIN32_LEAN_AND_MEAN -#endif -#include - -struct private_events { - HANDLE events[2]; -}; - -#endif /* _WIN32_THREAD_PRIVATE_EVENTS_H_ */ diff -Nru sbcl-2.0.6/src/runtime/wrap.c sbcl-2.1.1/src/runtime/wrap.c --- sbcl-2.0.6/src/runtime/wrap.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/wrap.c 2021-01-30 11:22:38.000000000 +0000 @@ -523,18 +523,13 @@ } #endif /* !LISP_FEATURE_WIN32 */ -#ifndef LISP_FEATURE_WIN32 -int sb_getrusage(int who, struct rusage *rusage) -{ - return getrusage(who, rusage); -} - -int sb_gettimeofday(struct timeval *tp) -{ - return gettimeofday(tp, NULL); -} - -#ifndef LISP_FEATURE_DARWIN /* reimplements nanosleep in darwin-os.c */ +#ifdef LISP_FEATURE_UNIX +#ifdef LISP_FEATURE_DARWIN +/* nanosleep() is not re-entrant on some versions of Darwin and is + * reimplemented using the underlying syscalls. + */ +int sb_nanosleep(time_t sec, int nsec); +#else void sb_nanosleep(time_t sec, int nsec) { struct timespec rqtp = {sec, nsec}; @@ -571,11 +566,6 @@ */ } } -#else -/* nanosleep() is not re-entrant on some versions of Darwin and is - * reimplemented it using the underlying syscalls. - */ -int sb_nanosleep(time_t sec, int nsec); #endif void sb_nanosleep_double(double seconds) { @@ -591,6 +581,20 @@ void sb_nanosleep_float(float seconds) { sb_nanosleep_double(seconds); } +#endif + +#ifdef LISP_FEATURE_NETBSD +/* These thin wrappers are needed due to "linker rewriting" + * acording to git revision 9304704f68 */ +int sb_getrusage(int who, struct rusage *rusage) +{ + return getrusage(who, rusage); +} + +int sb_gettimeofday(struct timeval *tp, void *tz) +{ + return gettimeofday(tp, tz); +} int sb_select(int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds, struct timeval *timeout) @@ -612,7 +616,18 @@ { return utimes(path, times); } -#else /* !LISP_FEATURE_WIN32 */ +#ifndef LISP_FEATURE_SB_THREAD +#include +int sb_sigprocmask(int how, const sigset_t *set, sigset_t *oldset) +{ + return sigprocmask(how, set, oldset); +} +#endif +#endif + +#ifdef LISP_FEATURE_WIN32 + +// These are used in src/code/irrat.lisp. Search for DEF-MATH-RTN #define SB_TRIG_WRAPPER(name) \ double sb_##name (double x) { \ return name(x); \ diff -Nru sbcl-2.0.6/src/runtime/wrap.h sbcl-2.1.1/src/runtime/wrap.h --- sbcl-2.0.6/src/runtime/wrap.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/wrap.h 2021-01-30 11:22:38.000000000 +0000 @@ -14,7 +14,7 @@ * * FIXME: But of course we should fix the FFI so that we can use the * actual 64-bit values instead. In fact, we probably have by now - * (2003-10-03) on all working platforms except MIPS and HPPA; if some + * (2003-10-03) on all working platforms except MIPS; if some * motivated spark would simply fix those, this hack could go away. * -- CSR, 2003-10-03 * diff -Nru sbcl-2.0.6/src/runtime/x86-64-arch.c sbcl-2.1.1/src/runtime/x86-64-arch.c --- sbcl-2.0.6/src/runtime/x86-64-arch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-64-arch.c 2021-01-30 11:22:38.000000000 +0000 @@ -40,7 +40,6 @@ #define UD2_INST 0x0b0f #define BREAKPOINT_WIDTH 1 -unsigned int cpuid_fn1_ecx; int avx_supported = 0, avx2_supported = 0; static void cpuid(unsigned info, unsigned subinfo, @@ -77,6 +76,7 @@ void tune_asm_routines_for_microarch(void) { unsigned int eax, ebx, ecx, edx; + unsigned int cpuid_fn1_ecx = 0; cpuid(0, 0, &eax, &ebx, &ecx, &edx); if (eax >= 1) { // see if we can execute basic id function 1 @@ -94,7 +94,13 @@ } } } - SetSymbolValue(CPUID_FN1_ECX, (lispobj)make_fixnum(cpuid_fn1_ecx), 0); + int our_cpu_feature_bits = 0; + // avx2_supported gets copied into bit 1 of *CPU-FEATURE-BITS* + if (avx2_supported) our_cpu_feature_bits |= 1; + // POPCNT = ECX bit 23, which gets copied into bit 2 in *CPU-FEATURE-BITS* + if (cpuid_fn1_ecx & (1<<23)) our_cpu_feature_bits |= 2; + SetSymbolValue(CPU_FEATURE_BITS, make_fixnum(our_cpu_feature_bits), 0); + // I don't know if this works on Windows #ifndef _MSC_VER cpuid(0, 0, &eax, &ebx, &ecx, &edx); @@ -113,6 +119,7 @@ void untune_asm_routines_for_microarch(void) { asm_routine_poke(VECTOR_FILL_T, 0x12, 0xEB); // Change JL to JMP + SetSymbolValue(CPU_FEATURE_BITS, 0, 0); } #ifndef _WIN64 @@ -406,6 +413,10 @@ #endif fake_foreign_function_call(context); +#ifdef LISP_FEATURE_LINUX + extern void sb_dump_mcontext(char*,void*); + sb_dump_mcontext("SIGILL received", context); +#endif lose("Unhandled SIGILL at %p.", pc); } @@ -478,12 +489,12 @@ * CL way, I hope there will at least be a comment to explain * why.. -- WHN 2001-06-07 */ #if !defined(LISP_FEATURE_MACH_EXCEPTION_HANDLER) && !defined(LISP_FEATURE_WIN32) - undoably_install_low_level_interrupt_handler(SIGILL , sigill_handler); - undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); + ll_install_handler(SIGILL , sigill_handler); + ll_install_handler(SIGTRAP, sigtrap_handler); #endif #if defined(X86_64_SIGFPE_FIXUP) && !defined(LISP_FEATURE_WIN32) - undoably_install_low_level_interrupt_handler(SIGFPE, sigfpe_handler); + ll_install_handler(SIGFPE, sigfpe_handler); #endif SHOW("returning from arch_install_interrupt_handlers()"); @@ -604,8 +615,12 @@ extern unsigned int alloc_profile_n_counters; extern unsigned int max_alloc_point_counters; #ifdef LISP_FEATURE_SB_THREAD +#ifdef LISP_FEATURE_WIN32 +extern CRITICAL_SECTION alloc_profiler_lock; +#else extern pthread_mutex_t alloc_profiler_lock; #endif +#endif static unsigned int claim_index(int qty) { @@ -621,7 +636,8 @@ return 0; // use the overflow bin(s) } -static boolean instrumentp(uword_t* sp, uword_t** pc, uword_t* old_word) +static boolean NO_SANITIZE_MEMORY +instrumentp(uword_t* sp, uword_t** pc, uword_t* old_word) { int __attribute__((unused)) ret = thread_mutex_lock(&alloc_profiler_lock); gc_assert(ret == 0); @@ -694,9 +710,10 @@ unsigned int index = claim_index(1); if (index == 0) index = 2; // reserved overflow counter for fixed-size alloc + uword_t disp = index * 8; // rewrite call into: LOCK INC QWORD PTR, [R11+n] ; opcode = 0xFF / 0 uword_t new_inst = - 0xF0 | (0x49 << 8) | (0xFF << 16) | (0x83L << 24) | ((index*8L) << 32); + 0xF0 | (0x49 << 8) | (0xFF << 16) | (0x83L << 24) | (disp << 32); // Ensure atomicity of the write. A plain store would probably do, // but since this is self-modifying code, the most stringent memory // order is prudent. @@ -728,14 +745,15 @@ } // rewrite call into: // LOCK INC QWORD PTR, [R11+n] ; opcode = 0xFF / 0 + uword_t disp = index * 8; uword_t new_inst1 = - 0xF0 | (0x49 << 8) | (0xFF << 16) | (0x83L << 24) | ((index * 8L) << 32); + 0xF0 | (0x49 << 8) | (0xFF << 16) | (0x83L << 24) | (disp << 32); // LOCK ADD [R11+n], Rxx ; opcode = 0x01 prefix = 0x49 | ((prefix & 1) << 2); // 'b' bit becomes 'r' bit modrm = 0x83 | (modrm & (7<<3)); // copy 'reg' into new modrm byte + disp = (1 + index) * 8; uword_t new_inst2 = - 0xF0 | (prefix << 8) | (0x01 << 16) | ((long)modrm << 24) - | (((1 + index) * 8L) << 32); + 0xF0 | (prefix << 8) | (0x01 << 16) | ((long)modrm << 24) | (disp << 32); // Overwrite the second instruction first, because as soon as the CALL // opcode is changed, fallthrough to the next instruction occurs. if (!__sync_bool_compare_and_swap(pc+1, word_after_pc, new_inst2) || diff -Nru sbcl-2.0.6/src/runtime/x86-64-assem.S sbcl-2.1.1/src/runtime/x86-64-assem.S --- sbcl-2.0.6/src/runtime/x86-64-assem.S 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-64-assem.S 2021-01-30 11:22:38.000000000 +0000 @@ -25,9 +25,6 @@ #include "genesis/fdefn.h" #include "genesis/static-symbols.h" #include "genesis/thread.h" -#ifdef MEMORY_SANITIZER -#include "genesis/symbol.h" -#endif #include "genesis/ratio.h" #include "genesis/complex.h" @@ -41,17 +38,12 @@ // Produce position-independent code. // macOS does not like the general way we do this, so do something different. -// I don't know about win32, so conservatively exclude that too. -#if !defined LISP_FEATURE_DARWIN && !defined LISP_FEATURE_WIN32 -#define PIC_CALL(x) x@PLT -#define LOAD_PIC_VAR(x,dest) mov GNAME(x)@GOTPCREL(%rip), dest ; mov (dest), dest -#else +#if defined(LISP_FEATURE_DARWIN) || defined(LISP_FEATURE_WIN32) #define PIC_CALL(x) x -#ifdef LISP_FEATURE_DARWIN #define LOAD_PIC_VAR(x,dest) mov GNAME(x)(%rip), dest #else -#define LOAD_PIC_VAR(x,dest) mov GNAME(x), dest -#endif +#define PIC_CALL(x) x@PLT +#define LOAD_PIC_VAR(x,dest) mov GNAME(x)@GOTPCREL(%rip), dest ; mov (dest), dest #endif /* Get the right type of alignment. Linux, FreeBSD and OpenBSD @@ -92,7 +84,17 @@ #define THREAD_BASE_REG %r13 -#ifdef OS_THREAD_STACK +#ifdef LISP_FEATURE_WIN32 +#define CARG1 %rcx +#define CARG2 %rdx +#define CARG3 %r8 +#else +#define CARG1 %rdi +#define CARG2 %rsi +#define CARG3 %rdx +#endif + +#ifdef LISP_FEATURE_OS_THREAD_STACK .text .globl GNAME(funcall1_switching_stack) TYPE(GNAME(funcall1_switching_stack)) @@ -104,8 +106,16 @@ push %rbp mov %rsp,%rbp - mov THREAD_CONTROL_STACK_END_OFFSET(%rdi),%rsp - call *%rsi + mov THREAD_CONTROL_STACK_END_OFFSET(CARG1),%rsp + +#ifdef LISP_FEATURE_WIN32 + /* _chkstk() is called at some unknown points and is + expecting that + */ + mov THREAD_CONTROL_STACK_START_OFFSET(CARG1), %rax + movq %rax, %gs:16 +#endif + call *CARG2 mov %rbp, %rsp pop %rbp @@ -127,13 +137,6 @@ GNAME(lspmain): # so much easier to type 'b lspmain' in gdb push %rbp # Save old frame pointer. mov %rsp,%rbp # Establish new frame. -#ifdef MEMORY_SANITIZER // Presumes GCC_TLS and SB_THREAD - movq GNAME(current_thread)@GOTTPOFF(%rip), %r8 // Clobberable - movq %fs:(%r8), %r8 - movq %fs:0, %rax - leaq __msan_param_tls@TPOFF(%rax), %rax - movq %rax, THREAD_MSAN_PARAM_TLS_OFFSET(%r8) -#endif LOAD_PIC_VAR(all_threads, %rax) mov THREAD_CONTROL_STACK_END_OFFSET(%rax) ,%rsp jmp Lstack @@ -180,6 +183,9 @@ #ifdef LISP_FEATURE_GCC_TLS movq GNAME(current_thread)@GOTTPOFF(%rip), THREAD_BASE_REG movq %fs:(THREAD_BASE_REG), THREAD_BASE_REG +#elif defined LISP_FEATURE_WIN32 + call PIC_CALL(GNAME(get_current_vm_thread)) + mov %rax, THREAD_BASE_REG #else LOAD_PIC_VAR(specials, %rdi) call PIC_CALL(GNAME(pthread_getspecific)) @@ -444,7 +450,8 @@ jae ascs_clear_loop cmp %rax, %rsi ja ascs_clear_loop - cmpq $(NIL), THREAD_CONTROL_STACK_GUARD_PAGE_PROTECTED_OFFSET(%rdi) + /* test state_word.control_stack_guard_page_protected */ + cmpb $0, THREAD_STATE_WORD_OFFSET(%rdi) jne ascs_finished /* Clear memory backwards to the start of the (4KiB) page */ diff -Nru sbcl-2.0.6/src/runtime/x86-64-bsd-os.c sbcl-2.1.1/src/runtime/x86-64-bsd-os.c --- sbcl-2.0.6/src/runtime/x86-64-bsd-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-64-bsd-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -149,14 +149,6 @@ } int arch_os_thread_init(struct thread *thread) { -#ifdef LISP_FEATURE_SB_THREAD -#ifdef LISP_FEATURE_GCC_TLS - current_thread = thread; -#else - pthread_setspecific(specials,thread); -#endif -#endif - #ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER mach_lisp_thread_init(thread); #elif defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK) diff -Nru sbcl-2.0.6/src/runtime/x86-64-darwin-os.c sbcl-2.1.1/src/runtime/x86-64-darwin-os.c --- sbcl-2.0.6/src/runtime/x86-64-darwin-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-64-darwin-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -108,7 +108,7 @@ } if(sp < (__uint64_t)(CONTROL_STACK_GUARD_PAGE(th) + os_vm_page_size) && - th->control_stack_guard_page_protected != NIL) { + th->state_word.control_stack_guard_page_protected) { /* We hit the end of the control stack: disable guard page * protection so the error handler has some headroom, protect the * previous page so that we can catch returns from the guard page @@ -121,9 +121,9 @@ } /* Modify a context to push new data on its stack. */ -void push_context(u64 data, x86_thread_state64_t *context) +void push_context(uint64_t data, x86_thread_state64_t *context) { - u64* stack_pointer = (u64*)context->rsp - 1; + uint64_t* stack_pointer = (uint64_t*)context->rsp - 1; context->rsp = (__uint64_t) stack_pointer; *stack_pointer = data; @@ -183,12 +183,12 @@ align_context_stack(context); push_context(context->rip, context); - context->rdi = (u64) mcontext; + context->rdi = (uint64_t) mcontext; context->rsi = signal; - context->rdx = (u64) addr; - context->rcx = (u64) handler; + context->rdx = (uint64_t) addr; + context->rcx = (uint64_t) handler; - context->rip = (u64) signal_emulation_wrapper; + context->rip = (uint64_t) signal_emulation_wrapper; } /* Call CONTROL_STACK_EXHAUSTED_ERROR directly, without emulating @@ -198,15 +198,15 @@ { align_context_stack(context); push_context(context->rip, context); - context->rdi = (u64) StaticSymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR); - context->rip = (u64) funcall0; + context->rdi = (uint64_t) StaticSymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR); + context->rip = (uint64_t) funcall0; } #if defined DUMP_CONTEXT void dump_context(x86_thread_state64_t *context) { int i; - u64 *stack_pointer; + uint64_t *stack_pointer; printf("rax: %08lx rcx: %08lx rdx: %08lx rbx: %08lx\n", context->rax, context->rcx, context->rdx, context->rbx); @@ -219,7 +219,7 @@ context->cs, context->ds, context->rs, context->ss, context->fs, context->gs); - stack_pointer = (u64 *)context->rsp; + stack_pointer = (uint64_t *)context->rsp; for (i = 0; i < 48; i+=4) { printf("%08x: %08x %08x %08x %08x\n", context->rsp + (i * 4), @@ -328,7 +328,7 @@ break; case EXC_BAD_INSTRUCTION: - if (*((u64 *)thread_state.rip) == 0xffffffffffff0b0f) { + if (*((uint64_t *)thread_state.rip) == 0xffffffffffff0b0f) { /* Fake sigreturn. See the end of signal_emulation_wrapper() */ /* Apply any modifications done to the context, */ diff -Nru sbcl-2.0.6/src/runtime/x86-64-linux-os.c sbcl-2.1.1/src/runtime/x86-64-linux-os.c --- sbcl-2.0.6/src/runtime/x86-64-linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-64-linux-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -34,8 +34,6 @@ #include "interr.h" #include "lispregs.h" #include "sbcl.h" -#include -#include #include #include @@ -52,13 +50,6 @@ int arch_os_thread_init(struct thread *thread) { stack_t sigstack; -#ifdef LISP_FEATURE_SB_THREAD -#ifdef LISP_FEATURE_GCC_TLS - current_thread = thread; -#else - pthread_setspecific(specials,thread); -#endif -#endif #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK /* Signal handlers are run on the control stack, so if it is exhausted * we had better use an alternate stack for whatever signal tells us @@ -71,8 +62,8 @@ } #endif #ifdef MEMORY_SANITIZER - asm("movq %%fs:0, %0\n\tleaq __msan_param_tls@TPOFF(%0), %0" - : "=r" (thread->msan_param_tls)); + extern __thread unsigned long __msan_param_tls[]; + thread->msan_param_tls = (uword_t)&__msan_param_tls[0]; #endif return 1; } @@ -85,14 +76,68 @@ return 1; } +// This array is indexed by the encoding of the register in an instruction. +static unsigned char regmap[16] = { + REG_RAX, REG_RCX, REG_RDX, REG_RBX, REG_RSP, REG_RBP, REG_RSI, REG_RDI, + REG_R8, REG_R9, REG_R10, REG_R11, REG_R12, REG_R13, REG_R14, REG_R15 +}; +// So is this one, to coincide with the one above +static char *gprnames[] = { + "rax","rcx","rdx","rbx","rsp","rbp","rsi","rdi", + "r8","r9","r10","r11","r12","r13","r14","r15" +}; +static char *fprnames[] = { + "xmm0","xmm1","xmm2","xmm3","xmm4","xmm5","xmm6","xmm7", + "xmm8","xmm9","xmm10","xmm11","xmm12","xmm13","xmm14","xmm15" +}; +static char *flagbits[] = {"CF",0,"PF",0,"AF",0,"ZF","SF","TF","IF","DF","OF"}; + +void sb_dump_mcontext(char *reason, ucontext_t* context) +{ + /* In case multiple threads receive SIGILL at the same time, + * we want to try to avoid interleaving their output. + * Using a single write() call usually does the trick */ + char obuf[2048], smallbuf[100]; + int bit, ptr = 0, i, j; + smallbuf[0] = smallbuf[1] = 0; + long unsigned int flags = context->uc_mcontext.gregs[REG_EFL]; + for (bit=11; bit>=0; --bit) + if (flagbits[bit] && (flags & (1<uc_mcontext.gregs[REG_RIP], + smallbuf+1); + // GPRs + for(i=0; i<2; ++i) { + for(j=0; j<8; ++j) ptr += snprintf(obuf+ptr, REMAINING, " %16s", gprnames[i*8+j]); + if (REMAINING) obuf[ptr++] = '\n'; + for(j=0; j<8; ++j) + ptr += snprintf(obuf+ptr, REMAINING, " %16lX", + (uword_t)context->uc_mcontext.gregs[regmap[i*8+j]]); + if (REMAINING) obuf[ptr++] = '\n'; + } + // FPRs + for(i=0; i<4; ++i) { + for(j=0; j<4; ++j) ptr += snprintf(obuf+ptr, REMAINING, " %32s", fprnames[i*4+j]); + if (REMAINING) obuf[ptr++] = '\n'; + for(j=0; j<4; ++j) { + uint32_t* e = context->uc_mcontext.fpregs->_xmm[i*4+j].element; + ptr += snprintf(obuf+ptr, REMAINING, " %08X%08X%08X%08X", e[3], e[2], e[1], e[0]); + } + if (REMAINING) obuf[ptr++] = '\n'; + } + sigset_tostring(&context->uc_sigmask, smallbuf, sizeof smallbuf); + ptr += snprintf(obuf+ptr, REMAINING, "sigmask=%s\n", smallbuf); + write(2, obuf, ptr); +} os_context_register_t * os_context_register_addr(os_context_t *context, int offset) { - static unsigned char regmap[16] = { - REG_RAX, REG_RCX, REG_RDX, REG_RBX, REG_RSP, REG_RBP, REG_RSI, REG_RDI, - REG_R8, REG_R9, REG_R10, REG_R11, REG_R12, REG_R13, REG_R14, REG_R15 - }; if (offset >= 0 && offset < 16) return (os_context_register_t*)&context->uc_mcontext.gregs[regmap[offset]]; return 0; @@ -135,7 +180,7 @@ return &context->uc_sigmask; } -void +void NO_SANITIZE_ADDRESS os_restore_fp_control(os_context_t *context) { if (context->uc_mcontext.fpregs) { diff -Nru sbcl-2.0.6/src/runtime/x86-64-sunos-os.c sbcl-2.1.1/src/runtime/x86-64-sunos-os.c --- sbcl-2.0.6/src/runtime/x86-64-sunos-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-64-sunos-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -22,14 +22,6 @@ int arch_os_thread_init(struct thread *thread) { -#ifdef LISP_FEATURE_SB_THREAD -#ifdef LISP_FEATURE_GCC_TLS - current_thread = thread; -#else - pthread_setspecific(specials,thread); -#endif -#endif - #if defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK) /* Signal handlers are run on the control stack, so if it is exhausted * we had better use an alternate stack for whatever signal tells us diff -Nru sbcl-2.0.6/src/runtime/x86-64-win32-os.c sbcl-2.1.1/src/runtime/x86-64-win32-os.c --- sbcl-2.0.6/src/runtime/x86-64-win32-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-64-win32-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -42,7 +42,7 @@ int arch_os_thread_init(struct thread *thread) { - +#ifndef LISP_FEATURE_OS_THREAD_STACK void *cur_stack_end; MEMORY_BASIC_INFORMATION stack_memory; @@ -75,8 +75,6 @@ #endif -#ifdef LISP_FEATURE_SB_THREAD - pthread_setspecific(specials,thread); #endif return 1; } diff -Nru sbcl-2.0.6/src/runtime/x86-arch.c sbcl-2.1.1/src/runtime/x86-arch.c --- sbcl-2.0.6/src/runtime/x86-arch.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-arch.c 2021-01-30 11:22:38.000000000 +0000 @@ -319,8 +319,8 @@ * CL way, I hope there will at least be a comment to explain * why.. -- WHN 2001-06-07 */ #if !defined(LISP_FEATURE_WIN32) && !defined(LISP_FEATURE_MACH_EXCEPTION_HANDLER) - undoably_install_low_level_interrupt_handler(SIGILL , sigill_handler); - undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); + ll_install_handler(SIGILL , sigill_handler); + ll_install_handler(SIGTRAP, sigtrap_handler); #endif SHOW("returning from arch_install_interrupt_handlers()"); } diff -Nru sbcl-2.0.6/src/runtime/x86-assem.S sbcl-2.1.1/src/runtime/x86-assem.S --- sbcl-2.0.6/src/runtime/x86-assem.S 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-assem.S 2021-01-30 11:22:38.000000000 +0000 @@ -19,10 +19,7 @@ #endif #include "sbcl.h" -#include "validate.h" #include "genesis/closure.h" -#include "genesis/funcallable-instance.h" -#include "genesis/fdefn.h" #include "genesis/static-symbols.h" #include "genesis/symbol.h" #include "genesis/thread.h" @@ -165,7 +162,11 @@ /* the CSP page sits right before the thread */ #define THREAD_SAVED_CSP_OFFSET (-N_WORD_BYTES) +#ifdef LISP_FEATURE_UD2_BREAKPOINTS +#define TRAP ud2 +#else #define TRAP int3 +#endif .text .globl GNAME(all_threads) @@ -322,7 +323,7 @@ SIZE(GNAME(call_into_c)) -#ifdef OS_THREAD_STACK +#ifdef LISP_FEATURE_OS_THREAD_STACK .text .globl GNAME(funcall1_switching_stack) TYPE(GNAME(funcall1_switching_stack)) @@ -688,6 +689,7 @@ SIZE(GNAME(post_signal_tramp)) +#ifndef LISP_FEATURE_LINUX /* fast_bzero implementations and code to detect which implementation * to use. */ @@ -823,6 +825,7 @@ pop %eax ret SIZE(GNAME(fast_bzero_base)) +#endif /* LISP_FEATURE_LINUX */ /* When LISP_FEATURE_C_STACK_IS_CONTROL_STACK, we cannot safely scrub @@ -847,7 +850,7 @@ * guard page upper bound in ECX, and our hard guard * page upper bound in EDX. */ lea -4(%esp), %eax - mov GNAME(os_vm_page_size),%edx + mov $BACKEND_PAGE_BYTES,%edx mov %edx, %ecx add 8(%esp), %ecx add 12(%esp), %edx @@ -873,7 +876,8 @@ jae ascs_clear_loop cmp 8(%esp), %eax jbe ascs_clear_loop - cmpl $(NIL), THREAD_CONTROL_STACK_GUARD_PAGE_PROTECTED_OFFSET(%ecx) + /* test state_word.control_stack_guard_page_protected */ + cmpb $0, THREAD_STATE_WORD_OFFSET(%ecx) jne ascs_finished /* Clear memory backwards to the start of the (4KiB) page */ diff -Nru sbcl-2.0.6/src/runtime/x86-bsd-os.c sbcl-2.1.1/src/runtime/x86-bsd-os.c --- sbcl-2.0.6/src/runtime/x86-bsd-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-bsd-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -196,15 +196,8 @@ FSHOW_SIGNAL((stderr, "/ TLS: Allocated LDT %x\n", n)); thread->tls_cookie=n; arch_os_load_ldt(thread); - -#ifdef LISP_FEATURE_GCC_TLS - current_thread = thread; -#else - pthread_setspecific(specials,thread); -#endif #endif - #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK stack_t sigstack; diff -Nru sbcl-2.0.6/src/runtime/x86-darwin-os.c sbcl-2.1.1/src/runtime/x86-darwin-os.c --- sbcl-2.0.6/src/runtime/x86-darwin-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-darwin-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -81,8 +81,6 @@ FSHOW_SIGNAL((stderr, "/ TLS: Allocated LDT %x\n", n)); thread->tls_cookie=n; arch_os_load_ldt(thread); - - pthread_setspecific(specials,thread); #endif #ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER mach_lisp_thread_init(thread); @@ -146,11 +144,11 @@ } /* Modify a context to push new data on its stack. */ -void push_context(u32 data, x86_thread_state32_t *thread_state) +void push_context(uint32_t data, x86_thread_state32_t *thread_state) { - u32 *stack_pointer; + uint32_t *stack_pointer; - stack_pointer = (u32*) thread_state->ESP; + stack_pointer = (uint32_t*) thread_state->ESP; *(--stack_pointer) = data; thread_state->ESP = (unsigned int) stack_pointer; } @@ -189,7 +187,7 @@ /* round up size to 16byte multiple */ size = (size + 15) & -16; - thread_state->ESP = ((u32)thread_state->ESP) - size; + thread_state->ESP = ((uint32_t)thread_state->ESP) - size; return (void *)thread_state->ESP; } @@ -206,7 +204,7 @@ { va_list ap; int i; - u32 *stack_pointer; + uint32_t *stack_pointer; /* Set up to restore stack on exit. */ open_stack_allocation(thread_state); @@ -216,13 +214,13 @@ push_context(0, thread_state); } - thread_state->ESP = ((u32)thread_state->ESP) - nargs * 4; - stack_pointer = (u32 *)thread_state->ESP; + thread_state->ESP = ((uint32_t)thread_state->ESP) - nargs * 4; + stack_pointer = (uint32_t *)thread_state->ESP; va_start(ap, nargs); for (i = 0; i < nargs; i++) { - //push_context(va_arg(ap, u32), thread_state); - stack_pointer[i] = va_arg(ap, u32); + //push_context(va_arg(ap, uint32_t), thread_state); + stack_pointer[i] = va_arg(ap, uint32_t); } va_end(ap); @@ -319,7 +317,7 @@ void dump_context(x86_thread_state32_t *thread_state) { int i; - u32 *stack_pointer; + uint32_t *stack_pointer; printf("eax: %08lx ecx: %08lx edx: %08lx ebx: %08lx\n", thread_state->EAX, thread_state->ECX, thread_state->EDX, thread_state->EAX); @@ -336,7 +334,7 @@ thread_state->FS, thread_state->GS); - stack_pointer = (u32 *)thread_state->ESP; + stack_pointer = (uint32_t *)thread_state->ESP; for (i = 0; i < 48; i+=4) { printf("%08x: %08x %08x %08x %08x\n", thread_state->ESP + (i * 4), diff -Nru sbcl-2.0.6/src/runtime/x86-linux-os.c sbcl-2.1.1/src/runtime/x86-linux-os.c --- sbcl-2.0.6/src/runtime/x86-linux-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-linux-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -30,8 +30,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include @@ -74,11 +72,6 @@ ((entry_number << 3) + 3)); if(entry_number < 0) return 0; -#ifdef LISP_FEATURE_GCC_TLS - current_thread = thread; -#else - pthread_setspecific(specials,thread); -#endif #endif #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK @@ -95,7 +88,7 @@ } struct thread *debug_get_fs() { - register u32 fs; + register uint32_t fs; __asm__ __volatile__ ("movl %%fs,%0" : "=r" (fs) : ); return (struct thread *)fs; } diff -Nru sbcl-2.0.6/src/runtime/x86-sunos-os.c sbcl-2.1.1/src/runtime/x86-sunos-os.c --- sbcl-2.0.6/src/runtime/x86-sunos-os.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/src/runtime/x86-sunos-os.c 2021-01-30 11:22:38.000000000 +0000 @@ -9,8 +9,6 @@ #include "interrupt.h" #include "interr.h" #include "lispregs.h" -#include -#include #include #include @@ -101,8 +99,6 @@ __asm__ __volatile__ ("mov %0, %%fs" : : "r"(sel)); thread->tls_cookie = sel; - pthread_setspecific(specials,thread); - #endif #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK diff -Nru sbcl-2.0.6/tests/alien.impure.lisp sbcl-2.1.1/tests/alien.impure.lisp --- sbcl-2.0.6/tests/alien.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/alien.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -375,8 +375,7 @@ ;;; Skip for MSAN. Instead of returning 0, the intercepted malloc is configured ;;; to cause process termination by default on failure to allocate memory. (with-test (:name :malloc-failure - :skipped-on :msan - :fails-on :alpha) ;; Alpha has address space to burn + :skipped-on :msan) (assert (eq :enomem (handler-case (loop repeat 128 diff -Nru sbcl-2.0.6/tests/ansi-tests.sh sbcl-2.1.1/tests/ansi-tests.sh --- sbcl-2.0.6/tests/ansi-tests.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/ansi-tests.sh 2021-01-30 11:22:38.000000000 +0000 @@ -39,7 +39,21 @@ "READTABLE-CASE.CASE-PRESERVE" "READTABLE-CASE.CASE-UPCASE" "SHIFTF.7" "SUBTYPEP-COMPLEX.8" "SUBTYPEP.CONS.38" "SUBTYPEP.CONS.41" "SUBTYPEP.CONS.43" "SUBTYPEP.EQL.1" "SUBTYPEP.EQL.2" "SUBTYPEP.MEMBER.17" "SUBTYPEP.MEMBER.18" - "SXHASH.17" "SXHASH.18" "SXHASH.19" "TYPE-OF.1" "PRINT-STRUCTURE.1" + "SXHASH.17" "SXHASH.18" "SXHASH.19" "PRINT-STRUCTURE.1" + "MAKE-SYMBOL.11" "EQUAL.13" "EQUAL.14" "SXHASH.8" "INTERN.3" + "PARSE-INTEGER.21" "STRING.8" "STRING.9" "STRING.10" "STRING.12" "STRING.13" + "SIMPLE-STRING.11" "SIMPLE-STRING.12" "SIMPLE-STRING.13" "SIMPLE-STRING-P.8" + "SIMPLE-STRING-P.9" "STRINGP.9" "STRINGP.10" "STRING-UPCASE.11" + "STRING-DOWNCASE.11" "STRING-CAPITALIZE.11" "NSTRING-CAPITALIZE.12" + "STRING-TRIM.20" "STRING-LEFT-TRIM.20" "STRING-RIGHT-TRIM.20" + "STRING=.NIL-ARRAY.1" "STRING/=.NIL-ARRAY.1" "STRING<.NIL-ARRAY.1" + "STRING<=.NIL-ARRAY.1" "STRING>.NIL-ARRAY.1" "STRING>=.NIL-ARRAY.1" + "STRING-EQUAL.NIL-ARRAY.1" "STRING-NOT-EQUAL.NIL-ARRAY.1" + "STRING-LESSP.NIL-ARRAY.1" "STRING-NOT-GREATERP.NIL-ARRAY.1" + "STRING-GREATERP.NIL-ARRAY.1" "STRING-NOT-LESSP.NIL-ARRAY.1" "WRITE-STRING.2" + "WRITE-LINE.2" "MAKE-STRING-INPUT-STREAM.10" "MAKE-STRING-OUTPUT-STREAM.12" + "WITH-INPUT-FROM-STRING.10" "PRINT.STRING.NIL.1" "PRINT.STRING.NIL.2" + "PPRINT-LOGICAL-BLOCK.7" #+x86 (list "ACOSH.3" "SQRT.4") #+win32 (list "ASINH.1" "ASINH.2" "ASINH.3" "ASINH.7" "ACOSH.3" "EXP.ERROR.7" "EXPT.ERROR.4" "EXPT.ERROR.5" "EXPT.ERROR.6" "EXPT.ERROR.7" diff -Nru sbcl-2.0.6/tests/aprof.impure.lisp sbcl-2.1.1/tests/aprof.impure.lisp --- sbcl-2.0.6/tests/aprof.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/aprof.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -11,19 +11,21 @@ #-(and x86-64 sb-thread) (sb-ext:exit :code 104) ;; not implemented elsewhere +(defstruct fruitbasket x y z) (with-test (:name :aprof-smoketest-struct + :skipped-on :darwin ;; reverse-engineering the allocation instructions fails but should not :fails-on (not :immobile-space)) (let ((nbytes (sb-aprof:aprof-run (checked-compile '(sb-int:named-lambda "test" () - (declare (inline sb-thread:make-mutex) + (declare (inline make-fruitbasket) (optimize sb-c::instrument-consing)) - (loop repeat 50 collect (sb-thread:make-mutex)))) + (loop repeat 50 collect (make-fruitbasket)))) :stream nil))) (assert (= nbytes - (* 50 (+ (sb-vm::primitive-object-size (sb-thread:make-mutex)) + (* 50 (+ (sb-ext:primitive-object-size (make-fruitbasket)) (* 2 sb-vm:n-word-bytes))))))) ; cons cells (with-test (:name :aprof-smoketest-non-constant-size-vector @@ -49,7 +51,7 @@ (declare (optimize sb-c::instrument-consing)) (make-array (* 128 16) :element-type 'bit))) :stream nil))) - (assert (= nbytes (sb-vm::primitive-object-size + (assert (= nbytes (sb-ext:primitive-object-size (make-array (* 128 16) :element-type 'bit)))))) (with-test (:name :aprof-smoketest-large-vector diff -Nru sbcl-2.0.6/tests/arith.pure.lisp sbcl-2.1.1/tests/arith.pure.lisp --- sbcl-2.0.6/tests/arith.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/arith.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -514,8 +514,10 @@ (with-test (:name (:integer-division-using-multiplication :correctness)) (let ((*random-state* (make-random-state t))) (dolist (dividend-type `((unsigned-byte ,sb-vm:n-word-bits) + (signed-byte ,sb-vm:n-word-bits) (and fixnum unsigned-byte) - (integer 10000 10100))) + (integer 10000 10100) + fixnum)) (dolist (divisor `(;; Some special cases from the paper 7 10 14 641 274177 ;; Range extremes @@ -527,7 +529,9 @@ for r = (random (expt 2 i)) ;; We don't want 0, 1 and powers of 2. when (not (zerop (logand r (1- r)))) - collect r))) + collect r + and + collect (- r)))) (dolist (fun '(truncate ceiling floor mod rem)) (let ((foo (checked-compile `(lambda (x) @@ -544,7 +548,8 @@ ,@(loop for i from 4 to sb-vm:n-word-bits for pow = (expt 2 (1- i)) for r = (+ pow (random pow)) - collect r))) + collect r + collect (- r)))) (when (typep dividend dividend-type) (multiple-value-bind (q1 r1) (funcall foo dividend) @@ -854,3 +859,21 @@ (let ((result (funcall f 0))) (assert (equal result '(#x9516A7 #x2531b4 0 0)))))) + +(with-test (:name :truncate-by-zero-derivation) + (assert + (not (equal (cadr + (cdaddr (sb-kernel:%simple-fun-type + (checked-compile + `(lambda () + (truncate 5 0)) + :allow-style-warnings t)))) + '(integer 0 0))))) + +(with-test (:name :truncate-by-zero-derivation.2) + (checked-compile + `(lambda (x y) + (declare (type (unsigned-byte 8) x y) + (optimize speed (safety 0))) + (mod x y)) + :allow-notes nil)) diff -Nru sbcl-2.0.6/tests/array.pure.lisp sbcl-2.1.1/tests/array.pure.lisp --- sbcl-2.0.6/tests/array.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/array.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -197,6 +197,12 @@ (checked-compile `(lambda () (make-array 0 :element-type 'string))) (checked-compile `(lambda () (make-array '(0 2) :element-type 'string)))) +(with-test (:name (make-array standard-char)) + ;; Maybe this is a kludge, but STANDARD-CHAR should just work, + ;; I don't care if #\nul is nonstandard. Because, seriously? + (checked-compile '(lambda () + (make-array 5 :fill-pointer 0 :element-type 'standard-char)))) + (with-test (:name :big-array) ;; we used to have leakage from cross-compilation hosts of the INDEX ;; type, which prevented us from actually using all the large array @@ -523,6 +529,24 @@ (assert (not (array-has-fill-pointer-p (funcall fun nil)))) (assert (= (length (funcall fun nil)) 3)))) +(with-test (:name (make-array :transform :non-constant-fill-pointer)) + ;; Known adjustable with any fill-pointer can be inlined + (let ((fun (checked-compile '(lambda (n fillp) + (make-array (the (mod 20) n) + :adjustable t :fill-pointer fillp))))) + (assert (not (ctu:find-named-callees fun :name 'sb-kernel:%make-array))) + (let ((a (funcall fun 10 3))) + (assert (= (length a) 3)) + (assert (= (array-dimension a 0) 10)))) + ;; Non-adjustable w/ non-constant numeric fill-pointer can be inlined + (let ((fun (checked-compile '(lambda (n) + (make-array (the (mod 20) n) + :fill-pointer (floor n 2)))))) + (assert (not (ctu:find-named-callees fun :name 'sb-kernel:%make-array))) + (let ((a (funcall fun 10))) + (assert (= (length a) 5)) + (assert (= (array-dimension a 0) 10))))) + (with-test (:name :check-bound-fixnum-check) (checked-compile-and-assert (:optimize :safe) `(lambda (x) (aref #100(a) x)) @@ -538,6 +562,10 @@ (with-test (:name (make-array :strange-type-specifiers)) (assert (stringp (make-array 10 :element-type (opaque-identity '(base-char))))) (assert (stringp (make-array 10 :element-type (opaque-identity '(standard-char))))) + ;; If there are no extended characters (as on #-sb-unicode), then EXTENDED-CHAR is + ;; the empty type. You'll get exactly what you ask for: an array which can hold + ;; nothing. It's not a string, which is the right answer. + #+sb-unicode (assert (stringp (make-array 10 :element-type (opaque-identity '(extended-char))))) (assert (bit-vector-p (make-array 10 :element-type (opaque-identity '(bit)))))) @@ -598,3 +626,19 @@ (unless (svref p 0) (svref p nil))) :allow-warnings t)))) + +(with-test (:name :array-has-fill-pointer-p-folding) + (assert (equal (sb-kernel:%simple-fun-type + (checked-compile `(lambda (x) + (declare ((array * (* *)) x)) + (array-has-fill-pointer-p x)))) + `(function ((array * (* *))) (values null &optional))))) + +(with-test (:name :array-has-fill-pointer-p-transform) + (checked-compile-and-assert + () + `(lambda (n) + (let ((a (make-array n))) + (declare (vector a)) + (map-into a #'identity a))) + ((0) #() :test #'equalp))) diff -Nru sbcl-2.0.6/tests/assembler.pure.lisp sbcl-2.1.1/tests/assembler.pure.lisp --- sbcl-2.0.6/tests/assembler.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/assembler.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -42,49 +42,59 @@ ;;; Create some special variables that are needed for tests ;;; since they no longer exist as part of the vm definition. #+x86-64 -(progn -(defvar al-tn (reg-in-size rax-tn :byte)) -(defvar bl-tn (reg-in-size rbx-tn :byte)) -(defvar cl-tn (reg-in-size rcx-tn :byte)) -(defvar dl-tn (reg-in-size rdx-tn :byte)) -(defvar dil-tn (reg-in-size rdi-tn :byte)) -(defvar r8b-tn (reg-in-size r8-tn :byte)) -(defvar ax-tn (reg-in-size rax-tn :word)) -(defvar bx-tn (reg-in-size rbx-tn :word)) -(defvar cx-tn (reg-in-size rcx-tn :word)) -(defvar r8w-tn (reg-in-size r8-tn :word)) -(defvar eax-tn (reg-in-size rax-tn :dword)) -(defvar ebx-tn (reg-in-size rbx-tn :dword)) -(defvar ecx-tn (reg-in-size rcx-tn :dword)) -(defvar edx-tn (reg-in-size rdx-tn :dword)) -(defvar edi-tn (reg-in-size rdi-tn :dword)) -(defvar r8d-tn (reg-in-size r8-tn :dword)) -(defvar r9d-tn (reg-in-size r9-tn :dword))) - -(test-util:with-test (:name :assemble-movti-instruction :skipped-on (not :x86-64)) +(macrolet ((define (name qword-tn size) + `(defvar ,name + (sb-x86-64-asm::sized-thing (sb-x86-64-asm::tn-reg ,qword-tn) + ,size)))) + (define al rax-tn :byte) + (define bl rbx-tn :byte) + (define cl rcx-tn :byte) + (define dl rdx-tn :byte) + (define dil rdi-tn :byte) + (define r8b r8-tn :byte) + + (define ax rax-tn :word) + (define bx rbx-tn :word) + (define cx rcx-tn :word) + (define r8w r8-tn :word) + + (define eax rax-tn :dword) + (define ebx rbx-tn :dword) + (define ecx rcx-tn :dword) + (define edx rdx-tn :dword) + (define edi rdi-tn :dword) + (define r8d r8-tn :dword) + (define r9d r9-tn :dword)) +#+x86 +(progn (defglobal al al-tn) (defglobal ax ax-tn) (defglobal eax eax-tn) + (defglobal bl bl-tn) (defglobal bx bx-tn) (defglobal ebx ebx-tn) + (defglobal cl cl-tn) (defglobal cx cx-tn) (defglobal ecx ecx-tn) + (defglobal dl dl-tn) + (defglobal edi edi-tn)) +(test-util:with-test (:name :assemble-movnti-instruction :skipped-on (not :x86-64)) (flet ((test-movnti (dst src expect) (test-assemble `(movnti ,dst ,src) expect))) - (test-movnti (ea 57 rdi-tn) eax-tn "0FC34739 MOVNTI [RDI+57], EAX") + (test-movnti (ea 57 rdi-tn) eax "0FC34739 MOVNTI [RDI+57], EAX") (test-movnti (ea rax-tn) r12-tn "4C0FC320 MOVNTI [RAX], R12"))) (test-util:with-test (:name :assemble-crc32 :skipped-on (not :x86-64)) ;; Destination size = :DWORD - (test-assemble `(crc32 :byte ,eax-tn ,(ea rbp-tn)) + (test-assemble `(crc32 :byte ,eax ,(ea rbp-tn)) "F20F38F04500 CRC32 EAX, BYTE PTR [RBP]") - (test-assemble `(crc32 :byte ,eax-tn (,rcx-tn . :high-byte)) + (test-assemble `(crc32 :byte ,eax (,rcx-tn . :high-byte)) "F20F38F0C5 CRC32 EAX, CH") - (test-assemble `(crc32 :byte ,eax-tn ,dil-tn) + (test-assemble `(crc32 :byte ,eax ,dil) "F2400F38F0C7 CRC32 EAX, DIL") - (test-assemble `(crc32 :word ,eax-tn ,(ea rbp-tn)) + (test-assemble `(crc32 :word ,eax ,(ea rbp-tn)) "66F20F38F14500 CRC32 EAX, WORD PTR [RBP]") - (test-assemble `(crc32 :dword ,eax-tn ,(ea rbp-tn)) + (test-assemble `(crc32 :dword ,eax ,(ea rbp-tn)) "F20F38F14500 CRC32 EAX, DWORD PTR [RBP]") ;; these check that the presence of REX does not per se change the width. - (test-assemble `(crc32 :byte ,r9d-tn ,(ea r14-tn r15-tn)) + (test-assemble `(crc32 :byte ,r9d ,(ea r14-tn r15-tn)) "F2470F38F00C3E CRC32 R9D, BYTE PTR [R14+R15]") - (test-assemble `(crc32 :word ,r9d-tn ,(ea r14-tn r15-tn)) + (test-assemble `(crc32 :word ,r9d ,(ea r14-tn r15-tn)) "66F2470F38F10C3E CRC32 R9D, WORD PTR [R14+R15]") - (test-assemble `(crc32 :dword ,r9d-tn ,(ea r14-tn r15-tn)) + (test-assemble `(crc32 :dword ,r9d ,(ea r14-tn r15-tn)) "F2470F38F10C3E CRC32 R9D, DWORD PTR [R14+R15]") ;; Destination size = :QWORD (test-assemble `(crc32 :byte ,rax-tn ,(ea rbp-tn)) @@ -113,31 +123,31 @@ ;; ADD/SUB/etc (test-assemble `(and ,rax-tn #xffffffffffffff8c) "4883E08C AND RAX, -116") - (test-assemble `(sub ,eax-tn #xfffffffc) "83E8FC SUB EAX, -4") + (test-assemble `(sub ,eax #xfffffffc) "83E8FC SUB EAX, -4") ;; Register AX could use the special 1-byte opcode and non-sign-extended ;; imm16 operand; the encoding length is the same either way. - (test-assemble `(or ,ax-tn #xfff7) "6683C8F7 OR AX, -9")) + (test-assemble `(or ,ax #xfff7) "6683C8F7 OR AX, -9")) (test-util:with-test (:name :assemble-movsx :skipped-on (not :x86-64)) ;; source = :BYTE, signed - (check-does-not-assemble `(movsx (:byte :byte) ,r8b-tn ,cl-tn)) - (test-assemble `(movsx (:byte :word) ,r8w-tn ,cl-tn) "66440FBEC1 MOVSX R8W, CL") - (test-assemble `(movsx (:byte :dword) ,r8d-tn ,cl-tn) "440FBEC1 MOVSX R8D, CL") - (test-assemble `(movsx (:byte :qword) ,r8-tn ,cl-tn) "4C0FBEC1 MOVSX R8, CL") + (check-does-not-assemble `(movsx (:byte :byte) ,r8b ,cl)) + (test-assemble `(movsx (:byte :word) ,r8w ,cl) "66440FBEC1 MOVSX R8W, CL") + (test-assemble `(movsx (:byte :dword) ,r8d ,cl) "440FBEC1 MOVSX R8D, CL") + (test-assemble `(movsx (:byte :qword) ,r8-tn ,cl) "4C0FBEC1 MOVSX R8, CL") ;; source = :BYTE, unsigned - (check-does-not-assemble `(movzx (:byte :byte) ,r8b-tn ,cl-tn)) - (test-assemble `(movzx (:byte :word) ,r8w-tn ,cl-tn) "66440FB6C1 MOVZX R8W, CL") - (test-assemble `(movzx (:byte :dword) ,r8d-tn ,cl-tn) "440FB6C1 MOVZX R8D, CL") - (test-assemble `(movzx (:byte :qword) ,r8-tn ,cl-tn) "440FB6C1 MOVZX R8D, CL") ; R8D, not R8 + (check-does-not-assemble `(movzx (:byte :byte) ,r8b ,cl)) + (test-assemble `(movzx (:byte :word) ,r8w ,cl) "66440FB6C1 MOVZX R8W, CL") + (test-assemble `(movzx (:byte :dword) ,r8d ,cl) "440FB6C1 MOVZX R8D, CL") + (test-assemble `(movzx (:byte :qword) ,r8-tn ,cl) "440FB6C1 MOVZX R8D, CL") ; R8D, not R8 ;; source = :WORD, signed - (test-assemble `(movsx (:word :dword) ,r8d-tn ,cx-tn) "440FBFC1 MOVSX R8D, CX") - (test-assemble `(movsx (:word :qword) ,r8-tn ,cx-tn) "4C0FBFC1 MOVSX R8, CX") + (test-assemble `(movsx (:word :dword) ,r8d ,cx) "440FBFC1 MOVSX R8D, CX") + (test-assemble `(movsx (:word :qword) ,r8-tn ,cx) "4C0FBFC1 MOVSX R8, CX") ;; source = :WORD, unsigned - (test-assemble `(movzx (:word :dword) ,r8d-tn ,cx-tn) "440FB7C1 MOVZX R8D, CX") - (test-assemble `(movzx (:word :qword) ,r8-tn ,cx-tn) "440FB7C1 MOVZX R8D, CX") ; R8D, not R8 + (test-assemble `(movzx (:word :dword) ,r8d ,cx) "440FB7C1 MOVZX R8D, CX") + (test-assemble `(movzx (:word :qword) ,r8-tn ,cx) "440FB7C1 MOVZX R8D, CX") ; R8D, not R8 ;; source = :DWORD, signed and unsigned - (test-assemble `(movsx (:dword :qword) ,r8-tn ,ecx-tn) "4C63C1 MOVSX R8, ECX") - (test-assemble `(movzx (:dword :qword) ,r8-tn ,ecx-tn) "448BC1 MOV R8D, ECX")) + (test-assemble `(movsx (:dword :qword) ,r8-tn ,ecx) "4C63C1 MOVSX R8, ECX") + (test-assemble `(movzx (:dword :qword) ,r8-tn ,ecx) "448BC1 MOV R8D, ECX")) (test-util:with-test (:name :disassemble-movabs-instruction :skipped-on (not :x86-64)) (let* ((bytes (coerce '(#x48 #xA1 8 7 6 5 4 3 2 1 @@ -167,57 +177,68 @@ (concatenate 'string (subseq expect 0 p) #+x86 "EBP" #+x86-64 "RBP" (subseq expect (+ p 3)))))) - (test-assemble inst expect)) - (memref (size) (make-ea size :base #+x86 ebp-tn #+x86-64 rbp-tn))) - (try `(bt ,(memref :word) ,ax-tn) "660FA34500 BT WORD PTR [$fp], AX") - (try `(bt ,(memref :dword) ,eax-tn) "0FA34500 BT DWORD PTR [$fp], EAX") - #+x86-64 - (try `(bt ,(memref :qword) ,rax-tn) "480FA34500 BT QWORD PTR [$fp], RAX") - (try `(bt ,(memref :word) 3) "660FBA650003 BT WORD PTR [$fp], 3") - (try `(bt ,(memref :dword) 3) "0FBA650003 BT DWORD PTR [$fp], 3") + (destructuring-bind (opcode operand1 operand2 . more) inst + (when (or (typep operand1 '(cons (eql memref))) + (typep operand2 '(cons (eql memref)))) + #+x86-64 + (let ((prefix (second (if (consp operand1) operand1 operand2)))) + (flet ((new-ea (operand) (if (consp operand) (ea rbp-tn) operand))) + (setf inst + (list* opcode prefix (new-ea operand1) (new-ea operand2) more)))) + #+x86 + (flet ((new-ea (operand) + (if (consp operand) (make-ea (second operand) :base ebp-tn) operand))) + (setf inst (list* opcode (new-ea operand1) (new-ea operand2) more))))) + (test-assemble inst expect))) + (try `(bt (memref :word) ,ax) "660FA34500 BT WORD PTR [$fp], AX") + (try `(bt (memref :dword) ,eax) "0FA34500 BT DWORD PTR [$fp], EAX") + #+x86-64 + (try `(bt (memref :qword) ,rax-tn) "480FA34500 BT QWORD PTR [$fp], RAX") + (try `(bt (memref :word) 3) "660FBA650003 BT WORD PTR [$fp], 3") + (try `(bt (memref :dword) 3) "0FBA650003 BT DWORD PTR [$fp], 3") #+x86-64 - (try `(bt ,(memref :qword) 3) "480FBA650003 BT QWORD PTR [$fp], 3") + (try `(bt (memref :qword) 3) "480FBA650003 BT QWORD PTR [$fp], 3") ;; - (try `(shld ,eax-tn ,ebx-tn :cl) "0FA5D8 SHLD EAX, EBX, CL") - (try `(shld ,(memref :word) ,bx-tn 6) "660FA45D0006 SHLD [$fp], BX, 6") - (try `(shld ,(memref :dword) ,ebx-tn 6) "0FA45D0006 SHLD [$fp], EBX, 6") + (try `(shld ,eax ,ebx :cl) "0FA5D8 SHLD EAX, EBX, CL") + (try `(shld (memref :word) ,bx 6) "660FA45D0006 SHLD [$fp], BX, 6") + (try `(shld (memref :dword) ,ebx 6) "0FA45D0006 SHLD [$fp], EBX, 6") #+x86-64 - (try `(shld ,(memref :qword) ,rbx-tn 6) "480FA45D0006 SHLD [$fp], RBX, 6") + (try `(shld (memref :qword) ,rbx-tn 6) "480FA45D0006 SHLD [$fp], RBX, 6") ;; - (try `(add ,al-tn #x7f) "047F ADD AL, 127") - (try `(add ,ax-tn #x7fff) "6605FF7F ADD AX, 32767") - (try `(add ,eax-tn #x7fffffff) "05FFFFFF7F ADD EAX, 2147483647") + (try `(add ,al #x7f) "047F ADD AL, 127") + (try `(add ,ax #x7fff) "6605FF7F ADD AX, 32767") + (try `(add ,eax #x7fffffff) "05FFFFFF7F ADD EAX, 2147483647") #+x86-64 (try `(add ,rax-tn #x7fffffff) "4805FFFFFF7F ADD RAX, 2147483647") ;; - (try `(add ,bl-tn #x7f) "80C37F ADD BL, 127") - (try `(add ,bx-tn #x7fff) "6681C3FF7F ADD BX, 32767") - (try `(add ,ebx-tn #x7fffffff) "81C3FFFFFF7F ADD EBX, 2147483647") + (try `(add ,bl #x7f) "80C37F ADD BL, 127") + (try `(add ,bx #x7fff) "6681C3FF7F ADD BX, 32767") + (try `(add ,ebx #x7fffffff) "81C3FFFFFF7F ADD EBX, 2147483647") #+x86-64 (try `(add ,rbx-tn #x7fffffff) "4881C3FFFFFF7F ADD RBX, 2147483647") ;; - (try `(add ,ax-tn #x7f) "6683C07F ADD AX, 127") - (try `(add ,eax-tn #x7f) "83C07F ADD EAX, 127") + (try `(add ,ax #x7f) "6683C07F ADD AX, 127") + (try `(add ,eax #x7f) "83C07F ADD EAX, 127") #+x86-64 (try `(add ,rax-tn #x7f) "4883C07F ADD RAX, 127") ;; - (try `(add ,(memref :byte) ,cl-tn) "004D00 ADD [$fp], CL") - (try `(add ,(memref :word) ,cx-tn) "66014D00 ADD [$fp], CX") - (try `(add ,(memref :dword) ,ecx-tn) "014D00 ADD [$fp], ECX") - #+x86-64 - (try `(add ,(memref :qword) ,rcx-tn) "48014D00 ADD [$fp], RCX") - (try `(add ,cl-tn ,(memref :byte)) "024D00 ADD CL, [$fp]") - (try `(add ,cx-tn ,(memref :word)) "66034D00 ADD CX, [$fp]") - (try `(add ,ecx-tn ,(memref :dword)) "034D00 ADD ECX, [$fp]") + (try `(add (memref :byte) ,cl) "004D00 ADD [$fp], CL") + (try `(add (memref :word) ,cx) "66014D00 ADD [$fp], CX") + (try `(add (memref :dword) ,ecx) "014D00 ADD [$fp], ECX") + #+x86-64 + (try `(add (memref :qword) ,rcx-tn) "48014D00 ADD [$fp], RCX") + (try `(add ,cl (memref :byte)) "024D00 ADD CL, [$fp]") + (try `(add ,cx (memref :word)) "66034D00 ADD CX, [$fp]") + (try `(add ,ecx (memref :dword)) "034D00 ADD ECX, [$fp]") #+x86-64 - (try `(add ,rcx-tn ,(memref :qword)) "48034D00 ADD RCX, [$fp]") + (try `(add ,rcx-tn (memref :qword)) "48034D00 ADD RCX, [$fp]") )) (test-util:with-test (:name :disassemble-imul :skipped-on (not (or :x86 :x86-64))) - (test-assemble `(imul ,dl-tn) "F6EA IMUL DL") - (test-assemble `(imul ,cx-tn) "66F7E9 IMUL CX") - (test-assemble `(imul ,ebx-tn) "F7EB IMUL EBX") - (test-assemble `(imul ,edi-tn 92) "6BFF5C IMUL EDI, EDI, 92")) + (test-assemble `(imul ,dl) "F6EA IMUL DL") + (test-assemble `(imul ,cx) "66F7E9 IMUL CX") + (test-assemble `(imul ,ebx) "F7EB IMUL EBX") + (test-assemble `(imul ,edi 92) "6BFF5C IMUL EDI, EDI, 92")) (test-util:with-test (:name :disassemble-fs-prefix :skipped-on (not (or :x86-64))) (let ((bytes (coerce '(#x64 #xF0 #x44 #x08 #x04 #x25 #x00 #x04 #x10 #x20) @@ -267,7 +288,7 @@ "40F6C60F TEST SIL, 15") (test-assemble `(movd ,float0-tn ,rax-tn) "660F6EC0 MOVD XMM0, EAX") - (test-assemble `(movq ,float0-tn ,eax-tn) + (test-assemble `(movq ,float0-tn ,eax) "66480F6EC0 MOVQ XMM0, RAX")) (test-util:with-test (:name :assemble-high-byte-regs :skipped-on (not :x86-64)) diff -Nru sbcl-2.0.6/tests/avltree.pure.lisp sbcl-2.1.1/tests/avltree.pure.lisp --- sbcl-2.0.6/tests/avltree.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/avltree.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -1,5 +1,10 @@ +(load "bbtree-test-util.lisp") (use-package "SB-INT") + +#-sb-thread (invoke-restart 'run-tests::skip-file) ;; some of the symbols below disappear + (import 'sb-thread::(avlnode-key avlnode-data avlnode-left avlnode-right + avl-find<= avl-find>= avl-insert avl-delete avl-find avl-balance-factor avl-count)) @@ -95,3 +100,9 @@ (test-util:with-test (:name :avltree-random-tester) (random-operations 10 10 nil) (random-operations 10 200 nil)) + +(defun test-avlfind-inexact (n-nodes n-iterations) + (bbtree-test:test-find-inexact-macro avl-insert avl-find<= avl-find>= avlnode-key)) + +(test-util:with-test (:name :avl-find-inexact) + (bbtree-test:exercise-find-inexact 'test-avlfind-inexact)) diff -Nru sbcl-2.0.6/tests/backq-const-fold.impure-cload.lisp sbcl-2.1.1/tests/backq-const-fold.impure-cload.lisp --- sbcl-2.0.6/tests/backq-const-fold.impure-cload.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/backq-const-fold.impure-cload.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,41 @@ + +;;; Example from Jan Moringen + +#| +I saw several ways to make this work: + + (1) treat backquote list constructors as foldable only if all list elements + are of type (OR list number character array symbol). + (1a) allow those types plus any instance type that has a MAKE-LOAD-FORM method. + (2) track the provenance of each element so that after folding we can reliably + detect which came from defconstants. (Is this even possible?) + (3) do as the old code did: assume that if a value is EQ to a defconstant, + that implies that we should use symbol-value on that constant. + +In the interest of simplicity, I choose (1), as it is maximally conservative +and therefore least likely to raise any kind of concerns as to applicability. +|# + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass foo () ())) + +(defconstant +foo+ + (if (boundp '+foo+) + +foo+ + (make-instance 'foo))) + +;;; The `(,+foo+) expression was being compile-time-folded to (#). +;;; Consequently it is unclear whether the # inside that list should +;;; require a load-form. On the one hand, it's EQ to the defconstant, so +;;; it shouldn't, but on the other hand, it's not "obvious" that the elements +;;; of a random anonymous list came from any particular place, +;;; and that that place should be assumed to contain the value that you want +;;; to stuff into a particular list cell, and that you should be indifferent +;;; to stuffing in the value at compile-time versus load-time. + +;;; Unfortunately, this definition of FOO now conses. +;;; As a further improvement, the transform could wrap the computed +;;; list in a LOAD-TIME-VALUE if the elements are constant +;;; but not satisfying TRIVIALLY-EXTERNALIZABLE-P. +(defun foo () + `(,+foo+)) diff -Nru sbcl-2.0.6/tests/backtrace.impure.lisp sbcl-2.1.1/tests/backtrace.impure.lisp --- sbcl-2.0.6/tests/backtrace.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/backtrace.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -189,7 +189,7 @@ (with-test (:name (:backtrace :undefined-function :bug-346) :skipped-on :interpreter - ;; Failures on SPARC, and probably HPPA are due to + ;; Failures on SPARC are due to ;; not having a full and valid stack frame for the ;; undefined function frame. See PPC ;; undefined_tramp for details. diff -Nru sbcl-2.0.6/tests/bad-code.pure.lisp sbcl-2.1.1/tests/bad-code.pure.lisp --- sbcl-2.0.6/tests/bad-code.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/bad-code.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -343,10 +343,9 @@ (with-test (:name :sequence-lvar-dimensions-dotted-list) - (assert (nth-value 3 + (assert (nth-value 1 (checked-compile '(lambda () (position 0 '(1 2 0 5 . 5))) - :allow-style-warnings t :allow-warnings t)))) (with-test (:name :source-form-context-dotted-list) @@ -430,19 +429,27 @@ (search '(a . b) x)) :allow-warnings t)))) +(with-test (:name :improper-list.3) + (assert (nth-value 1 + (checked-compile + '(lambda () + (let ((x '(1 2 . 3))) + (position c x))) + :allow-warnings t)))) + (with-test (:name :call-nil) (checked-compile-and-assert - () - `(lambda () - (funcall nil)) - (() (condition 'undefined-function))) + () + `(lambda () + (funcall nil)) + (() (condition 'undefined-function))) (checked-compile-and-assert - () - `(lambda (x) - (if x - 10 - (funcall x))) - ((nil) (condition 'undefined-function)))) + () + `(lambda (x) + (if x + 10 + (funcall x))) + ((nil) (condition 'undefined-function)))) (with-test (:name (:valid-callable-argument :toplevel-xep)) (assert (nth-value 2 (checked-compile `(lambda (l) (find-if (lambda ()) l)) @@ -522,7 +529,7 @@ (f))) :allow-style-warnings t)))) -(with-test (:name :inapprorate-declare) +(with-test (:name :inappropriate-declare) (assert (nth-value 5 (checked-compile @@ -538,3 +545,63 @@ (checked-compile `(lambda () (prog1 10 (declare (optimize)))) :allow-failure t)))) + +(with-test (:name :reduce-initial-value) + (assert + (nth-value 2 + (checked-compile + `(lambda () + (reduce (lambda (x y) + (declare (fixnum x)) + (+ x (char-code y))) + "abc")) + :allow-warnings t))) + (assert + (nth-value 2 + (checked-compile + `(lambda () + (reduce (lambda (x y) + (declare (fixnum x)) + (+ x (char-code y))) + "abc" + :initial-value #\a)) + :allow-warnings t))) + (checked-compile-and-assert + () + `(lambda (s) + (declare (string s)) + (reduce (lambda (x y) + (declare (fixnum x)) + (+ x (char-code y))) + s + :initial-value 0)) + (("abc") 294))) + +(with-test (:name :get-defined-fun-lambda-list-error) + (assert (nth-value 1 (checked-compile '(lambda () (defun x 10)) :allow-failure t)))) + +(with-test (:name :dolist-mismatch) + (assert (nth-value 2 + (checked-compile '(lambda (x) + (dolist (x (the integer x)))) + :allow-warnings 'sb-int:type-warning)))) + +(with-test (:name :loop-list-mismatch) + (assert (nth-value 2 + (checked-compile '(lambda (x) + (loop for y in (the integer x))) + :allow-warnings 'sb-int:type-warning))) + (assert (nth-value 2 + (checked-compile '(lambda (x) + (loop for y on (the integer x))) + :allow-warnings 'sb-int:type-warning)))) + +(with-test (:name :mapcar-list-mismatch) + (assert (nth-value 2 + (checked-compile '(lambda (z) + (mapl #'car (the integer z))) + :allow-warnings 'sb-int:type-warning))) + (assert (nth-value 2 + (checked-compile '(lambda (f z x) + (mapcar f (the integer z) (the integer x))) + :allow-warnings 'sb-int:type-warning)))) diff -Nru sbcl-2.0.6/tests/bbtree-test-util.lisp sbcl-2.1.1/tests/bbtree-test-util.lisp --- sbcl-2.0.6/tests/bbtree-test-util.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/bbtree-test-util.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,62 @@ + +(defpackage "BBTREE-TEST" + (:use :cl) + (:export #:test-find-inexact-macro + #:exercise-find-inexact)) + +;;;; Tests of two different kinds of balanced binary trees + +(defmacro bbtree-test:test-find-inexact-macro (insertion-fun find<=-fun find>=-fun node-key) + `(let (integers) + ;; Generate N random integers + (dotimes (i n-nodes) + (loop + (let ((val (+ 5 (random 1000)))) + (unless (member val integers) + (push val integers) + (return))))) + (setq integers (coerce integers 'vector)) + (dotimes (i n-iterations) + ;; Try many different shuffles of the insertion order because each + ;; potentially yields a different tree. + (test-util:shuffle integers) + ;; Convert a tree + (let ((tree nil)) + (dotimes (i (length integers)) + (setq tree (,insertion-fun tree (svref integers i) (svref integers i)))) + (setq integers (sort integers #'<)) + (dotimes (i (length integers)) + (let ((this (svref integers i)) + (pred (if (> i 0) (svref integers (1- i)))) + (succ (if (< i (1- (length integers))) (svref integers (1+ i))))) + ;; THIS should be found exactly + (let ((answer (,find<=-fun this tree))) + (assert (eql (,node-key answer) this))) + (let ((answer (,find>=-fun this tree))) + (assert (eql (,node-key answer) this))) + ;; find this node by a smaller key using FIND>= + (unless (eql pred (1- this)) + (assert (eql (,node-key (,find>=-fun (1- this) tree)) this))) + ;; find this node by a larger key using FIND<= + (unless (eql succ (1+ this)) + (assert (eql (,node-key (,find<=-fun (1+ this) tree)) this))) + ;; check the boundary case of FIND<= and/or find the predecessor + (let ((answer (,find<=-fun (1- this) tree))) + (if pred + (assert (eql (,node-key answer) pred)) + (assert (not answer)))) + ;; check the boundary case of FIND>= and/or find the successor + (let ((answer (,find>=-fun (1+ this) tree))) + (if succ + (assert (eql (,node-key answer) succ)) + (assert (not answer)))))))))) + +(defun bbtree-test:exercise-find-inexact (fun) + (loop for n-nodes from 1 to 20 + do (funcall fun n-nodes + (case n-nodes + (1 1) + (2 4) + (3 10) + (t 100))))) + diff -Nru sbcl-2.0.6/tests/bit-vector.impure.lisp sbcl-2.1.1/tests/bit-vector.impure.lisp --- sbcl-2.0.6/tests/bit-vector.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/bit-vector.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -126,12 +126,13 @@ (setf (sb-sys:sap-ref-word addr 0) sb-vm:simple-bit-vector-widetag) (setf (sb-sys:sap-ref-word addr sb-vm:n-word-bytes) (ash n-bits sb-vm:n-fixnum-tag-bits)) - (multiple-value-bind (object widetag size) - (sb-vm::reconstitute-object (sb-c::mask-signed-field + (let* ((object + (sb-vm::reconstitute-object + (sb-c::mask-signed-field sb-vm:n-fixnum-bits (ash (sb-sys:sap-int addr) - (- sb-vm:n-fixnum-tag-bits)))) - (declare (ignore widetag)) + (- sb-vm:n-fixnum-tag-bits))))) + (size (sb-ext:primitive-object-size object))) (assert (simple-bit-vector-p object)) (assert (= size n-bytes)) (assert (not (sb-kernel:%bit-position/1 object nil 0 n-bits))) diff -Nru sbcl-2.0.6/tests/bug-1072739.pure.lisp sbcl-2.1.1/tests/bug-1072739.pure.lisp --- sbcl-2.0.6/tests/bug-1072739.pure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/bug-1072739.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,51 @@ +;; win32 is very specific about the order in which catch blocks +;; must be allocated on the stack +;; +;; This test is extremely slow, so it deserves its own file. +(with-test (:name (compile :bug-1072739) :slow t) + (checked-compile-and-assert (:optimize :safe) + `(lambda () + (STRING= + (LET ((% 23)) + (WITH-OUTPUT-TO-STRING (G13908) + (PRINC + (LET () + (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3))) + (HANDLER-CASE + (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909) + (UNBOUND-VARIABLE NIL + (HANDLER-CASE + (WITH-OUTPUT-TO-STRING (G13914) + (PRINC %A%B% G13914) + (PRINC "" G13914) + G13914) + (UNBOUND-VARIABLE NIL + (HANDLER-CASE + (WITH-OUTPUT-TO-STRING (G13913) + (PRINC %A%B G13913) + (PRINC "%" G13913) + G13913) + (UNBOUND-VARIABLE NIL + (HANDLER-CASE + (WITH-OUTPUT-TO-STRING (G13912) + (PRINC %A% G13912) + (PRINC "b%" G13912) + G13912) + (UNBOUND-VARIABLE NIL + (HANDLER-CASE + (WITH-OUTPUT-TO-STRING (G13911) + (PRINC %A G13911) + (PRINC "%b%" G13911) + G13911) + (UNBOUND-VARIABLE NIL + (HANDLER-CASE + (WITH-OUTPUT-TO-STRING (G13910) + (PRINC % G13910) + (PRINC "a%b%" G13910) + G13910) + (UNBOUND-VARIABLE NIL + (ERROR "Interpolation error in \"%a%b%\" +")))))))))))))) + G13908))) + "23a%b%")) + (() t))) diff -Nru sbcl-2.0.6/tests/bug-1180102.impure.lisp sbcl-2.1.1/tests/bug-1180102.impure.lisp --- sbcl-2.0.6/tests/bug-1180102.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/bug-1180102.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -7,17 +7,30 @@ ;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the ;; interrupting code thus made a recursive lock attempt. +;; This test runs excruciatingly slowly on win32 without futexes. +;; Using n-threads = 100 with sb-futex, each trial took between .1 and .2 +;; seconds, so 200 trials took ~ 30 seconds. +;; Without sb-futex and that same number of threads, each trial took +;; between 1.5 and 2.5 seconds which would be 400 seconds total. +(defparameter *test-params* (or #+(and win32 (not sb-futex)) '(10 . 20) + '(100 . 100))) + (with-test (:name (:timer :dispatch-thread :make-thread :bug-1180102) :skipped-on (not :sb-thread)) (flet ((test (thread) (let ((timer (make-timer (lambda ()) :thread thread))) (schedule-timer timer .01 :repeat-interval 0.1) - (dotimes (i 100) - (let ((threads '())) - (dotimes (i 100) + (dotimes (i (car *test-params*)) + (let ((threads '()) + (start (get-internal-real-time))) + (declare (ignorable start)) + (dotimes (i (cdr *test-params*)) (push (sb-thread:make-thread (lambda () (sleep .01))) threads)) - (mapc #'sb-thread:join-thread threads))) + (mapc #'sb-thread:join-thread threads) + #+nil (format t "Trial ~d: ~f sec~%" i + (/ (- (get-internal-real-time) start) + internal-time-units-per-second)))) (unschedule-timer timer)))) (test t) (test sb-thread:*current-thread*))) diff -Nru sbcl-2.0.6/tests/call-into-lisp.impure.lisp sbcl-2.1.1/tests/call-into-lisp.impure.lisp --- sbcl-2.0.6/tests/call-into-lisp.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/call-into-lisp.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -61,9 +61,9 @@ ;; Making room for 3 args aligns the stack to a 16-byte boundary ;; presuming it was at CALL to me. Darwin requires the alignment, others don't care. `((sub ,rsp-tn 24) - (mov ,(make-ea :qword :base rsp-tn :disp 16) ,(get-lisp-obj-address T)) - (mov ,(make-ea :qword :base rsp-tn :disp 8) ,(fixnumize 311)) - (mov ,(make-ea :qword :base rsp-tn :disp 0) ,(get-lisp-obj-address #\A)) + (mov :qword ,(ea 16 rsp-tn) ,(get-lisp-obj-address T)) + (mov :qword ,(ea 8 rsp-tn) ,(fixnumize 311)) + (mov :qword ,(ea 0 rsp-tn) ,(get-lisp-obj-address #\A)) (mov ,rdi-tn ,(get-lisp-obj-address #'monkeybiz)) ; C arg 0 = Lisp function (mov ,rsi-tn ,rsp-tn) ; C arg 1 = argv (mov ,rdx-tn :ARGC) ; C arg 2 = argc diff -Nru sbcl-2.0.6/tests/clos-1.impure.lisp sbcl-2.1.1/tests/clos-1.impure.lisp --- sbcl-2.0.6/tests/clos-1.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/clos-1.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -231,10 +231,15 @@ (:arguments &whole))) program-error)) -(define-method-combination bug-309084-b/mc nil - ((all *)) - (:arguments x &optional (y 'a yp) &key (z 'b zp) &aux (w (list y z))) - `(list ,x ,y ,yp ,z ,zp ,w)) +(let (warnings) + (handler-bind ((warning (lambda (c) (push c warnings)))) + (eval '(define-method-combination bug-309084-b/mc nil + ((all *)) + (:arguments x &optional (y 'a yp) &key (z 'b zp) &aux (w (list y z))) + `(list ,x ,y ,yp ,z ,zp ,w))) + ;; Should not get any "assigned but never read" warnings. + (assert (= (length warnings) 1)) + (assert (search "&OPTIONAL and &KEY" (princ-to-string (car warnings)))))) (defgeneric bug-309084-b/gf (a &optional b &key &allow-other-keys) (:method-combination bug-309084-b/mc) @@ -268,3 +273,21 @@ (eval '(defclass bug-1840595w () ())) (assert-error (eval '(defclass bug-1840595w () ((z :writer bug-1840595-z))))) (eval '(defclass bug-1840595w () ()))) + +(with-test (:name :bug-1909659/reader) + (eval '(defclass bug-1909659r () ((name :initarg :name :reader bug-1909659r-name)))) + (let ((one (make-instance 'bug-1909659r :name 1)) + (two (make-instance 'bug-1909659r :name 2))) + (assert-error (bug-1909659r-name one two) program-error) + (assert (eql (bug-1909659r-name one) 1)) + (assert (eql (bug-1909659r-name two) 2)))) + +(with-test (:name :bug-1909659/writer) + (eval '(defclass bug-1909659w () ((name :initarg :name :writer bug-1909659w-set-name)))) + (let ((one (make-instance 'bug-1909659w :name 1)) + (two (make-instance 'bug-1909659w :name 2))) + (assert-error (bug-1909659w-set-name one) program-error) + (assert-error (bug-1909659w-set-name two) program-error) + (bug-1909659w-set-name one two) + (assert (eql (slot-value one 'name) 1)) + (assert (eql (slot-value two 'name) one)))) diff -Nru sbcl-2.0.6/tests/clos-call-next-method.impure.lisp sbcl-2.1.1/tests/clos-call-next-method.impure.lisp --- sbcl-2.0.6/tests/clos-call-next-method.impure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/clos-call-next-method.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -0,0 +1,134 @@ +;;;; Testing CALL-NEXT-METHOD. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; CALL-NEXT-METHOD arguments are only fully checked on high safety. +(declaim (optimize (safety 3))) + +;;; Utilities +;;; +;;; It makes sense to cover all permutations of arguments since the +;;; order of calls can affect the construction of the CALL-NEXT-METHOD +;;; argument checker. + +;;; Assumes unique elements in SEQUENCE. +(defun map-permutations (function sequence) + (labels ((rec (partial-permutation remainder) + (if (null remainder) + (funcall function partial-permutation) + (map nil (lambda (element) + (rec (list* element partial-permutation) + (remove element remainder))) + remainder)))) + (rec '() sequence))) + +;;; RESET-FUNCTION is used to reset the generic function between +;;; permutations so caches are built up from scratch according to the +;;; following call sequence. +(defun map-test-case-permutations (reset-function check-function test-cases) + (map-permutations + (lambda (permutation) + (funcall reset-function) + (map nil (lambda (arguments-and-expected) + (destructuring-bind (arguments expected) arguments-and-expected + (funcall check-function arguments expected))) + permutation)) + test-cases)) + +;;; Make sure CALL-NEXT-METHOD calls that result in different sets of +;;; applicable methods signal errors. + +(defgeneric different-applicable-methods (thing) + (:method ((thing t)) + (list 't thing)) + (:method ((thing null)) + (list 'null thing)) + (:method ((thing list)) + (list 'list (call-next-method (rest thing)))) + (:method ((thing cons)) + (list 'cons (call-next-method (rest thing))))) + +(with-test (:name (call-next-method :different-applicable-methods)) + (map-test-case-permutations + (lambda () + (sb-pcl::update-dfun #'different-applicable-methods )) + (lambda (arguments expected) + (flet ((do-it () + (apply #'different-applicable-methods arguments))) + (case expected + (error (assert-error (do-it))) + (t (assert (equal (do-it) expected)))))) + '((((1 2 3)) (cons (list (t (3))))) + (((1 2)) error) + (((1)) error) + ((nil) (null nil))))) + +;;; Test calling the next method with non-EQL arguments of the same +;;; class. + +(defgeneric non-eql-arguments (x) + (:method ((x t)) + (list 't x)) + (:method ((x number)) + (list 'number (call-next-method (1+ x)))) + (:method ((x real)) + (list 'real (call-next-method (1+ x)))) + (:method ((x integer)) + (list 'integer (call-next-method (1+ x))))) + +(with-test (:name (call-next-method :same-applicable-methods :non-eql-arguments)) + (map-test-case-permutations + (lambda () + (sb-pcl::update-dfun #'non-eql-arguments)) + (lambda (arguments expected) + (assert (equal (apply #'non-eql-arguments arguments) expected))) + '(((1) (integer (real (number (t 4))))) + ((1/2) (real (number (t 5/2)))) + ((#C(1 2)) (number (t #C(2 2))))))) + +;;; Test EQL specializers which always require a dedicated method in +;;; the CALL-NEXT-METHOD argument checker. + +(defgeneric eql-specializer (x) + (:method ((x t)) + (list 't x)) + (:method ((x number)) + (list 'number (call-next-method (1+ x)))) + (:method ((x real)) + (list 'real (call-next-method (1+ x)))) + (:method ((x integer)) + (list 'integer (call-next-method (1+ x)))) + (:method ((x (eql 4))) + (list 'eql 4 (call-next-method (1+ x)))) + (:method ((x (eql 5))) + (list 'eql 5 (call-next-method (1+ x))))) + +(with-test (:name (call-next-method :eql-specializer)) + (map-test-case-permutations + (lambda () + (sb-pcl::update-dfun #'eql-specializer)) + (lambda (arguments expected) + (flet ((do-it () + (apply #'eql-specializer arguments))) + (case expected + (error (assert-error (do-it))) + (t (assert (equal (do-it) expected)))))) + '(((0) (integer (real (number (t 3))))) + ((1) error) + ;; ((2) error) ; too slow otherwise (exponential scaling) + ((3) error) + ;; ((4) error) + ((5) error) + ((6) (integer (real (number (t 9))))) + ((1/2) (real (number (t 5/2)))) + ((#C(1 2)) (number (t #C(2 2)))) + ((:foo) (t :foo))))) diff -Nru sbcl-2.0.6/tests/clos.pure.lisp sbcl-2.1.1/tests/clos.pure.lisp --- sbcl-2.0.6/tests/clos.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/clos.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -39,6 +39,18 @@ (declare (ignore value)) (assert (not format-err))))) +(with-test (:name (defclass :initform type-error)) + (mapc (lambda (form) + (assert (nth-value 1 (checked-compile + `(lambda () ,form) :allow-warnings t)))) + '(;; Special-cased initforms + (defclass foo () ((%bar :type integer :initform t))) + (defclass foo () ((%bar :type integer :initform nil))) + (defclass foo () ((%bar :type boolean :initform 0))) + ;; Ordinary initforms + (defclass foo () ((%bar :type integer :initform (lisp-implementation-version)))) + (defclass foo () ((%bar :type boolean :initform (random 2))))))) + ;;; another not (user-)observable behaviour: make sure that ;;; sb-pcl::map-all-classes calls its function on each class once and ;;; exactly once. @@ -82,16 +94,26 @@ (setf (slot-value x z) (slot-value y z))) :allow-notes nil)) -(with-test (:name :slot-table-of-symbol-works) - (assert (eq :win - ;; the error that I want is about a missing slot, - ;; not a missing method, so don't let the compiler turn - ;; this into (funcall #'(SLOT-ACCESSOR :GLOBAL A READER)...) - (handler-case (eval '(slot-value 'a 'a)) - (simple-condition (c) - (and (search "slot ~S is missing" - (simple-condition-format-control c)) - :win)))))) +(defun assert-no-such-slot (obj slot-name) + (dolist (method '(slot-value slot-boundp)) + (assert (eq :win + ;; the error that I want is about a missing slot, + ;; not a missing method, so don't let the compiler turn + ;; this into (funcall #'(SLOT-ACCESSOR :GLOBAL A READER)...) + (handler-case (eval `(,method ',obj ',slot-name)) + (simple-condition (c) + (and (search "slot ~S is missing" + (simple-condition-format-control c)) + :win)))))) + ;; and of course SLOT-EXISTS-P should just return NIL + (assert (not (slot-exists-p obj slot-name)))) + +(with-test (:name :slot-table-of-builtin-classoids) + (assert-no-such-slot 'some-symbol 'some-slot) + (assert-no-such-slot #P"foo" 'some-slot) + (let ((lpn #p"sys:contrib;")) + (assert (typep lpn 'logical-pathname)) + (assert-no-such-slot lpn 'some-slot))) (with-test (:name :funcallable-instance-sxhash) (assert diff -Nru sbcl-2.0.6/tests/coerce.pure.lisp sbcl-2.1.1/tests/coerce.pure.lisp --- sbcl-2.0.6/tests/coerce.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/coerce.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -137,3 +137,10 @@ ((10) 10.0) ((1/2) 0.5) ((30d0) 30d0))) + +(with-test (:name :no-coerce-to-values-type) + (multiple-value-bind (fun warnp errorp) + (checked-compile '(lambda (x) (coerce (list x) '(values list))) + :allow-warnings t) + (assert (and warnp errorp)) + (assert-error (funcall fun 1)))) diff -Nru sbcl-2.0.6/tests/compiler-2.pure.lisp sbcl-2.1.1/tests/compiler-2.pure.lisp --- sbcl-2.0.6/tests/compiler-2.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/compiler-2.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -204,25 +204,6 @@ ;; Should not have a call to SET-SYMBOL-GLOBAL-VALUE> (assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn)))))) -(with-test (:name :layout-constants - :skipped-on (not (and :x86-64 :immobile-space))) - (let ((addr-of-pathname-layout - (write-to-string - (sb-kernel:get-lisp-obj-address - (sb-kernel:find-layout 'hash-table)) - :base 16 :radix t)) - (count 0)) - ;; The constant should appear in two CMP instructions - (dolist (line (split-string - (with-output-to-string (s) - (let ((sb-disassem:*disassem-location-column-width* 0)) - (disassemble 'hash-table-p :stream s))) - #\newline)) - (when (and (search "CMP" line) (search addr-of-pathname-layout line)) - (incf count))) - (assert (= count 2)))) - -;; Whoever deals with the Alpha and/or HPPA ports can make this test pass for them (with-test (:name :linkage-table-bogosity) (let ((strings (map 'list (lambda (x) (if (consp x) (car x) x)) sb-vm::+required-foreign-symbols+))) @@ -989,6 +970,39 @@ '(function ((complex rational)) (values null &optional)))) (assert (not (funcall fun2 #C(10 10)))))) +(with-test (:name (:numeric float rational :contagion)) + (flet ((check (operator type argument) + (let ((fun (checked-compile + `(lambda (x) + (declare (type ,type x)) + ,(ecase argument + (1 `(,operator x 1/2)) + (2 `(,operator 1/2 x))))))) + (assert (null (ctu:find-code-constants fun :type 'ratio)))))) + (dolist (operator '(+ * / - = < > <= >=)) + (dolist (type '(single-float double-float)) + (check operator type 1) + (check operator type 2) + (when (member operator '(+ * / - =)) + (check operator `(complex ,type) 1) + (check operator `(complex ,type) 2)))))) + +(with-test (:name (:numeric float float :contagion)) + (flet ((check (operator type argument) + (let ((fun (checked-compile + `(lambda (x) + (declare (type ,type x)) + ,(ecase argument + (1 `(,operator x 1.0f0)) + (2 `(,operator 1.0f0 x))))))) + (assert (null (ctu:find-code-constants fun :type 'single-float)))))) + (dolist (operator '(+ * / - = < > <= >=)) + (check operator 'double-float 1) + (check operator 'double-float 2) + (when (member operator '(+ * / - =)) + (check operator '(complex double-float) 1) + (check operator '(complex double-float) 2))))) + (with-test (:name :find-type-deriver) (checked-compile-and-assert () @@ -2913,4 +2927,161 @@ `(lambda (x) (inline-recursive x) (inline-recursive x)) - ((5) 0))) + ((5) 0))) + +(with-test (:name :split-let-unused-vars) + (checked-compile-and-assert + () + `(lambda (x y) + (let ((a + (if x y)) + (b) + (c + (if y + x))) + (declare (ignore b)) + (if c (if a a c)))) + ((t t) t) + ((t nil) nil) + ((nil t) nil) + ((nil nil) nil))) + +(with-test (:name :sequence-lvar-dimensions-on-arrays) + (checked-compile-and-assert + () + `(lambda (x a) + (count a (make-string x :initial-element a))) + ((10 #\a) 10))) + +(with-test (:name :length-transform-on-arrays) + (checked-compile-and-assert + () + `(lambda () (length (make-sequence '(string *) 10 :initial-element #\a))) + (() 10))) + +(with-test (:name :constant-fold-unknown-types) + (checked-compile-and-assert + (:allow-style-warnings t) + `(lambda () + (oddp (the (or a b) -1))))) + +(with-test (:name :dead-code-no-constant-fold-errors) + (assert + (typep (nth-value 4 + (checked-compile + `(lambda (z) + (when (and (eq z 0) + (not (eq z 0))) + (/ 10 0))))) + '(cons sb-ext:code-deletion-note null)))) + +(with-test (:name :unused-assignment) + (flet ((try (expr &aux (warned 0)) + (handler-bind ((style-warning + (lambda (c) + (if (search "assigned but never read" (princ-to-string c)) + (incf warned) + (error "That's unexpected"))))) + (multiple-value-bind (fun warn error) + (let ((*error-output* (make-broadcast-stream))) (compile nil expr)) + (declare (ignore fun)) + (assert (and warn (not error) (eql warned 1))))))) + (try '(lambda (x) (let* ((a (+ x 5)) (b a)) (setq b 3) (eval ''z)))) + ;; Even if the initializer is necessary to call, it's still warning-worthy. + (try '(lambda (x) (let* ((a (+ x 5)) + (b (opaque-identity a))) + (setq b 3) + (eval ''z)))) + (try '(lambda (x) (let* ((a (+ x 5)) (b a)) + (setq b (opaque-identity 3)) + (eval ''z))))) + ;; This one uses the value of B + (checked-compile '(lambda (x) (let* ((a (+ x 5)) (b a)) + (setq b (opaque-identity 3)))))) + +(with-test (:name :unconvert-tail-calls-terminate-block) + (checked-compile-and-assert + () + `(lambda (x y) + (flet ((f () + (labels ((a () + (error "~a" x)) + (b () + (a))) + (if nil + (b) + (if y + (a) + (b)))))) + (block nil + (return (f))))) + ((t t) (condition 'error)))) + +(with-test (:name :unconvert-tail-calls-terminate-block.2) + (checked-compile-and-assert + () + `(lambda (x) + (flet ((f () + (labels ((a () + (error "foo ~a" x)) + (b () + (let (*) + (a)))) + (if nil + (b) + (if nil + (a) + (if x + (a) + (b))))))) + (f) + 10)) + ((t t) (condition 'error)))) + + +(with-test (:name :fixnum-checking-boxing + :skipped-on (not :x86-64)) + (checked-compile + `(lambda (x y) + (declare (optimize speed) + (fixnum x y)) + (the fixnum (+ x y))) + :allow-notes nil)) + +(with-test (:name :ltn-analyze-mv-bind) + (checked-compile-and-assert + () + `(lambda () + (multiple-value-call #'list + 10 (apply #'values '(44 33d0)))) + (() '(10 44 33d0) :test #'equal))) + + +(with-test (:name :lp719585) + ;; Iteration variables are always "used" + (checked-compile '(lambda () (do (var) (t)))) + (checked-compile '(lambda () (do* (var) (t)))) + (checked-compile '(lambda () (do-all-symbols (var)))) + (checked-compile '(lambda () (do-external-symbols (var)))) + (checked-compile '(lambda () (do-symbols (var)))) + (checked-compile '(lambda () (dolist (var '(1 2 3)))))) + +(with-test (:name :key-default-type) + (let ((name (gensym))) + (proclaim `(ftype (function (double-float &key (:y double-float))) ,name)) + (checked-compile-and-assert + (:optimize :default) + `(sb-int:named-lambda ,name (x &key (y x)) + (values x y)) + ((1d0 :y nil) (condition 'error))))) + +(with-test (:name :deleting-unreachable-floats) + (let ((name (gensym))) + (proclaim `(inline ,name)) + (eval `(defun ,name (&key (k (eval 0f0))) + k)) + (checked-compile-and-assert + (:allow-notes nil) + `(lambda () + (,name :k 0f0)) + (() 0f0)))) diff -Nru sbcl-2.0.6/tests/compiler.impure.lisp sbcl-2.1.1/tests/compiler.impure.lisp --- sbcl-2.0.6/tests/compiler.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/compiler.impure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -955,7 +955,7 @@ ;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual) ; FIXME: make a better test! -(with-test (:name muffle-conditions :skipped-on (or :alpha :ppc64 :x86-64)) +(with-test (:name muffle-conditions :skipped-on (or :ppc64 :x86-64)) (multiple-value-bind (fun failure-p warnings style-warnings notes) (checked-compile '(lambda (x) @@ -2260,6 +2260,8 @@ ;;; check that non-trivial constants are EQ across different files: this is ;;; not something ANSI either guarantees or requires, but we want to do it ;;; anyways. +(when (find-symbol "SORT-INLINE-CONSTANTS" "SB-VM") + (push :inline-constants *features*)) (defconstant +share-me-1+ #-inline-constants 123.456d0 #+inline-constants nil) (defconstant +share-me-2+ "a string to share") (defconstant +share-me-3+ (vector 1 2 3)) @@ -3005,7 +3007,7 @@ (assert (eql (foo1 10 1) 3628800)) (let ((code (sb-kernel::fun-code-header #'foo1))) (assert (= (sb-kernel::code-n-entries code) 1)) - (assert (eq (aref (sb-kernel::code-entry-points code) 0) + (assert (eq (sb-kernel:%code-entry-point code 0) #'foo1))))) (with-test (:name (:block-compile :inline)) @@ -3066,3 +3068,8 @@ (with-test (:name :fopcompile-specials) (ctu:file-compile "(locally (declare (special foo)) (print foo))")) + +(with-test (:name :local-call-context) + (ctu:file-compile + "(lambda (&optional b) (declare (type integer b)) b)" + :load t)) diff -Nru sbcl-2.0.6/tests/compiler.pure.lisp sbcl-2.1.1/tests/compiler.pure.lisp --- sbcl-2.0.6/tests/compiler.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/compiler.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -3281,6 +3281,7 @@ (with-test (:name :float-division-using-exact-reciprocal) (flet ((test (lambda-form arg res &key (check-insts t)) + (declare (ignorable check-insts)) (let* ((fun (checked-compile lambda-form)) (disassembly (with-output-to-string (s) (disassemble fun :stream s)))) @@ -3329,6 +3330,7 @@ (disassemble fun1 :stream s))) (disassembly2 (with-output-to-string (s) (disassemble fun2 :stream s)))) + (declare (ignorable disassembly1 disassembly2)) ;; Multiplication at runtime should be eliminated only with ;; FLOAT-ACCURACY=0. (To catch SNaNs.) #+(or x86 x86-64) @@ -3359,6 +3361,7 @@ (disassemble fun1 :stream s))) (disassembly2 (with-output-to-string (s) (disassemble fun2 :stream s)))) + (declare (ignorable disassembly1 disassembly2)) ;; Let's make sure there is no addition at runtime: for x86 and ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so ;; look for the ADDs in the disassembly. It's a terrible KLUDGE, @@ -3382,7 +3385,7 @@ (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0) (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0))) -(with-test (:name :float-substraction-of-zero) +(with-test (:name :float-subtraction-of-zero) (flet ((test (lambda-form arg &optional (result arg)) (let* ((fun1 (checked-compile lambda-form)) (fun2 (funcall (checked-compile @@ -3393,6 +3396,7 @@ (disassemble fun1 :stream s))) (disassembly2 (with-output-to-string (s) (disassemble fun2 :stream s)))) + (declare (ignorable disassembly1 disassembly2)) ;; Let's make sure there is no substraction at runtime: for x86 ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction, ;; so look for SUB in the disassembly. It's a terrible KLUDGE, @@ -3426,6 +3430,7 @@ (disassemble fun1 :stream s))) (disassembly2 (with-output-to-string (s) (disassemble fun2 :stream s)))) + (declare (ignorable disassembly1 disassembly2)) ;; Let's make sure there is no multiplication at runtime: for x86 ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction, ;; so look for MUL in the disassembly. It's a terrible KLUDGE, @@ -3919,7 +3924,9 @@ finally (return result)) (loop for result = (checked-compile lambda) do (incf iterations) - until (> (get-internal-run-time) (+ start 10)) + until (> (get-internal-run-time) (+ start (* 10 + (/ internal-time-units-per-second + 1000)))) finally (return result)))) (end (get-internal-run-time)) (got (funcall fun))) @@ -4575,8 +4582,8 @@ (with-test (:name (:bug-1050768 :cause)) (let ((types `((string string) - ((or (simple-array character 24) (vector t 24)) - (or (simple-array character 24) (vector t)))))) + ((or (simple-array character 9) (vector t 9)) + (or (simple-array character 9) (vector t)))))) (dolist (pair types) (destructuring-bind (orig conservative) pair (assert (sb-kernel:type= (sb-kernel:specifier-type conservative) @@ -4945,59 +4952,6 @@ (logand (lognand a -6) (* b -502823994))) ((-1491588365 -3745511761) 1084329992))) -;; win32 is very specific about the order in which catch blocks -;; must be allocated on the stack -;; -;; This test is on the critical path. When started as the very first test, -;; it finishes as the last. -(with-test (:name (compile :bug-1072739) :slow t) - (checked-compile-and-assert (:optimize :safe) - `(lambda () - (STRING= - (LET ((% 23)) - (WITH-OUTPUT-TO-STRING (G13908) - (PRINC - (LET () - (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3))) - (HANDLER-CASE - (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909) - (UNBOUND-VARIABLE NIL - (HANDLER-CASE - (WITH-OUTPUT-TO-STRING (G13914) - (PRINC %A%B% G13914) - (PRINC "" G13914) - G13914) - (UNBOUND-VARIABLE NIL - (HANDLER-CASE - (WITH-OUTPUT-TO-STRING (G13913) - (PRINC %A%B G13913) - (PRINC "%" G13913) - G13913) - (UNBOUND-VARIABLE NIL - (HANDLER-CASE - (WITH-OUTPUT-TO-STRING (G13912) - (PRINC %A% G13912) - (PRINC "b%" G13912) - G13912) - (UNBOUND-VARIABLE NIL - (HANDLER-CASE - (WITH-OUTPUT-TO-STRING (G13911) - (PRINC %A G13911) - (PRINC "%b%" G13911) - G13911) - (UNBOUND-VARIABLE NIL - (HANDLER-CASE - (WITH-OUTPUT-TO-STRING (G13910) - (PRINC % G13910) - (PRINC "a%b%" G13910) - G13910) - (UNBOUND-VARIABLE NIL - (ERROR "Interpolation error in \"%a%b%\" -")))))))))))))) - G13908))) - "23a%b%")) - (() t))) - (with-test (:name (compile equal equalp :transforms)) (let* ((s "foo") (bit-vector #*11001100) @@ -5041,7 +4995,7 @@ x)))) (with-test (:name (compile :copy-more-arg) - :fails-on (or :alpha :hppa :mips :sparc)) + :fails-on (or :mips :sparc)) ;; copy-more-arg might not copy in the right direction ;; when there are more fixed args than stack frame slots, ;; and thus end up splatting a single argument everywhere. @@ -5724,7 +5678,7 @@ (let ((f (checked-compile '(lambda (x) (oddp x))))) (ctu:assert-no-consing (funcall f most-positive-fixnum)))) (with-test (:name (oddp bignum :no-consing) - :serial t :skipped-on :interpreter) + :serial t :skipped-on :interpreter :fails-on :ppc) (let ((f (checked-compile '(lambda (x) (oddp x)))) (x (* most-positive-fixnum most-positive-fixnum 3))) (ctu:assert-no-consing (funcall f x)))) @@ -5733,7 +5687,7 @@ (let ((f (checked-compile '(lambda (x) (logtest x most-positive-fixnum))))) (ctu:assert-no-consing (funcall f 1)))) (with-test (:name (logtest bignum :no-consing) - :serial t :skipped-on :interpreter) + :serial t :skipped-on :interpreter :fails-on :ppc) (let ((f (checked-compile '(lambda (x) (logtest x 1)))) (x (* most-positive-fixnum most-positive-fixnum 3))) (ctu:assert-no-consing (funcall f x)))) diff -Nru sbcl-2.0.6/tests/constantp.pure.lisp sbcl-2.1.1/tests/constantp.pure.lisp --- sbcl-2.0.6/tests/constantp.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/constantp.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -13,6 +13,7 @@ :allow-failure t))) (assert (not (constantp '(block 1 10))))) +(sb-ext:defglobal *some-global-var* nil) (with-test (:name (constantp progv)) (assert (not (constantp '(progv '(*s*) nil *s*)))) @@ -31,8 +32,9 @@ (assert (not (constantp '(progv '(pi) '(10) 10)))) (assert - (not (constantp '(progv '(sb-c::**world-lock**) '(10) 10))))) + (not (constantp '(progv '(*some-global-var*) '(10) 10))))) +(declaim (muffle-conditions style-warning)) ; unknown type ABC (with-test (:name (constantp the)) (assert (not (constantp '(the (satisfies eval) 10)))) diff -Nru sbcl-2.0.6/tests/constraint.pure.lisp sbcl-2.1.1/tests/constraint.pure.lisp --- sbcl-2.0.6/tests/constraint.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/constraint.pure.lisp 2021-01-30 11:22:38.000000000 +0000 @@ -98,3 +98,17 @@ ((= i 1) 3) (t i)))))) '(values (integer 2) &optional)))) + +(with-test (:name :ir1-phases-delay) + (assert + (equal (third (sb-kernel:%simple-fun-type + (checked-compile + '(lambda (n z) + (when (typep n 'fixnum) + (let ((ar (if (integerp n) + (make-array n) + z))) + (declare (type vector ar)) + (print ar) + (array-has-fill-pointer-p ar))))))) + '(values null &optional)))) diff -Nru sbcl-2.0.6/tests/deadline.impure.lisp sbcl-2.1.1/tests/deadline.impure.lisp --- sbcl-2.0.6/tests/deadline.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/deadline.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -190,3 +190,209 @@ (sb-sys:cancel-deadline condition)))) (sb-sys:with-deadline (:seconds .1) (sleep 1))) sb-sys:deadline-timeout)) + +(defmacro timestamp (string &optional mutex) + (declare (ignorable string mutex)) + #+nil + `(let ((s ,string)) + (sb-sys:with-pinned-objects (s) + ,(if mutex + `(alien-funcall (extern-alien "lisp_mutex_event1" (function void system-area-pointer system-area-pointer)) + (sb-sys:vector-sap s) + (sb-sys:vector-sap (or (mutex-name ,mutex) "unnamed"))) + `(alien-funcall (extern-alien "lisp_mutex_event" (function void system-area-pointer)) + (sb-sys:vector-sap s)))))) + +;;; I observed (at least) four different ways this next test can flake: +;;; +;;; 1. one of the first CONDITION-WAITs at the initial deadline can be spuriously woken. +;;; This is easy to see: +;;; Thread A Thread B +;;; -------- -------- +;;; mutex.acquire +;;; cv.wait +;;; set wakeup token +;;; mutex.release +;;; mutex.acquire +;;; cv.wait +;;; set wakeup token +;;; mutex.release +;;; sys_futex +;;; sys_futex +;;; (* no waiting - "wrong" token *) +;;; So this causes the (:UNKNOWN :UNKNOWN) result for one thread, +;;; because it never enters its deadline handler and because the customary +;;; ("obligatory" one might say) loop around condition-wait is absent. +;;; This is so common that it is no longer considered a failure. +;;; +;;; 2. one of the threads could be scheduled entirely before the other- +;;; that is, it runs from start to finish before the other thread does anything. +;;; This causes them both to conclude they acquired the mutex, +;;; though the deadline handlers were completely nonoverlapping. +;;; +;;; 3. one of the calls to SYS_futex with a timeout can wait significantly more than +;;; requested. This essentially reduces to case 2 but in a more convoluted way, +;;; which I've somewhat mitigated this by scaling up the timeouts so that we're +;;; not skating at the edge of the granularity the system is willing to give you. +;;; This mode of flakiness is likely to happen on a cloud compute environment. +;;; +;;; 4. the deadline handler can be invoked twice in one thread because +;;; - I don't know why. +;;; +;;; Here's an example with MUTEX_EVENTRECORDING #defined that was +;;; considered a "failure": +;;; [0.000000000] main thread: try-mutex: acquired 'Make-Thread Lock' +;;; [0.000038478] main thread: released 'Make-Thread Lock' +;;; [0.000053675] main thread: try-mutex: acquired 'Make-Thread Lock' +;;; [0.000068255] main thread: released 'Make-Thread Lock' +;;; [0.000069415] main thread: try-mutex: acquired 'gate sem mutex' +;;; [0.000069781] main thread: released 'gate sem mutex' +;;; [0.000071536] main thread: start futex wait 'thread result lock' +;;; [0.000094761] B: try-mutex: acquired 'gate sem mutex' +;;; [0.000095494] B: released 'gate sem mutex' +;;; [0.000096646] B: deadline established +;;; [0.000097026] B: try-mutex: acquired 'testmut' +;;; [0.000097931] B: released 'testmut' +;;; [0.000098251] B: start futex timedwait 'testcv' timeout 300000 +;;; [0.300161614] B: back from sys_futex 'testcv' +;;; [0.300163763] B: try-mutex: acquired 'testmut' +;;; [0.300172833] B: enter deadline handler +;;; [0.300173184] B: start sleep +;;; [0.601937423] A: try-mutex: acquired 'gate sem mutex' +;;; [0.601940795] A: released 'gate sem mutex' +;;; [0.601945635] A: deadline established +;;; [0.601952083] A: start futex timedwait 'testmut' timeout 300000 +;;; [0.900264670] B: end sleep +;;; [0.900266124] B: waking futex 'testcv' +;;; [0.900280645] B: waking futex 'testmut' +;;; [0.900285623] B: released 'testmut' +;;; [0.900290563] B: try-mutex: acquired 'thread interruptions lock' +;;; [0.900290777] B: released 'thread interruptions lock' +;;; [0.900292127] B: try-mutex: acquired 'session lock' +;;; [0.900293214] B: released 'session lock' +;;; [0.900293703] B: released 'thread result lock' +;;; [0.900294381] A: back from sys_futex 'testmut' +;;; [0.900296267] A: %wait-for-mutex: acquired 'testmut' +;;; [0.900299208] A: waking futex 'testmut' +;;; [0.900300544] A: released 'testmut' +;;; [0.900301101] A: start futex timedwait 'testcv' timeout 1000 +;;; [0.901358710] A: back from sys_futex 'testcv' +;;; [0.901359680] A: try-mutex: acquired 'testmut' +;;; [0.901369935] A: enter deadline handler +;;; [0.901370203] A: start sleep +;;; [1.501418757] A: end sleep +;;; [1.501419570] A: waking futex 'testcv' +;;; [1.501456896] A: released 'testmut' +;;; [1.501460896] A: try-mutex: acquired 'thread interruptions lock' +;;; [1.501461171] A: released 'thread interruptions lock' +;;; [1.501462039] A: try-mutex: acquired 'session lock' +;;; [1.501463001] A: released 'session lock' +;;; [1.501463544] A: waking futex 'thread result lock' +;;; [1.501465881] A: released 'thread result lock' +;;; [1.501474477] main thread: back from sys_futex 'thread result lock' +;;; [1.501476447] main thread: %wait-for-mutex: acquired 'thread result lock' +;;; [1.501477283] main thread: waking futex 'thread result lock' +;;; [1.501478429] main thread: released 'thread result lock' +;;; [1.501479467] main thread: try-mutex: acquired 'thread result lock' +;;; [1.501479600] main thread: released 'thread result lock' +;;; +;;; Basically I give up trying to fix this test any more. +(defun signal-dealine-check-interrupt-enablement () + (let ((mutex (sb-thread:make-mutex :name "testmut")) + (waitq (sb-thread:make-waitqueue :name "testcv")) + (A-holds? :unknown) + (B-holds? :unknown) + (A-interrupts-enabled? :unknown) + (B-interrupts-enabled? :unknown) + (gate (sb-thread:make-semaphore :name "testsem")) + (initial-deadline .3) + (sleep-amount .6) + (A) + (B)) + ;; The gate semaphore is just a half-assed attempt to trigger both worker threads + ;; to start running their bodies at the exact same time. If they don't do that, + ;; then it's entirely possible that one thread gets run start to finish before + ;; the other thread does anything at all. So obviously the test will fail. + (let ((m (sb-thread::semaphore-mutex gate))) + (setf (sb-thread:mutex-name m) "gate sem mutex")) + (let ((cv (sb-thread::semaphore-queue gate))) + (setf (sb-thread:waitqueue-name cv) "gate sem cv")) + #+nil (alien-funcall (extern-alien "lisp_mutex_start_eventrecording" (function void))) + (setq A (sb-thread:make-thread + (lambda () + (sb-thread:wait-on-semaphore gate) + (handler-bind + ((sb-sys:deadline-timeout + (lambda (c) + (timestamp "enter deadline handler") + ;; We came here through the call to DECODE-TIMEOUT + ;; in CONDITION-WAIT; hence both here are supposed + ;; to evaluate to T. + (setq A-holds? (sb-thread:holding-mutex-p mutex)) + (setq A-interrupts-enabled? + sb-sys:*interrupts-enabled*) + (timestamp "start sleep") + (sleep sleep-amount) + (timestamp "end sleep") + (sb-thread:condition-broadcast waitq) + (sb-sys:defer-deadline 10.0 c) + (timestamp "leave deadline handler")))) + (sb-sys:with-deadline (:seconds initial-deadline) + (timestamp "deadline established") + (sb-thread:with-mutex (mutex) + (sb-thread:condition-wait waitq mutex))))) + :name "A")) + (setq B (sb-thread:make-thread + (lambda () + (sb-thread:wait-on-semaphore gate) + (handler-bind + ((sb-sys:deadline-timeout + (lambda (c) + (timestamp "enter deadline handler") + ;; We came here through the call to DECODE-TIMEOUT + ;; in CONDITION-WAIT (contended case of + ;; reaquiring the mutex) - so the former will + ;; be NIL, but interrupts should still be enabled. + (setq B-holds? (sb-thread:holding-mutex-p mutex)) + (setq B-interrupts-enabled? + sb-sys:*interrupts-enabled*) + (timestamp "start sleep") + (sleep sleep-amount) + (timestamp "end sleep") + (sb-thread:condition-broadcast waitq) + (sb-sys:defer-deadline 10.0 c) + (timestamp "leave deadline handler")))) + (sb-sys:with-deadline (:seconds initial-deadline) + (timestamp "deadline established") + (sb-thread:with-mutex (mutex) + (sb-thread:condition-wait waitq mutex))))) + :name "B")) + (sb-thread:signal-semaphore gate 3) + (sb-thread:join-thread A) + (sb-thread:join-thread B) + #+nil (alien-funcall (extern-alien "lisp_mutex_done_eventrecording" (function void))) + (let ((A-result (list A-holds? A-interrupts-enabled?)) + (B-result (list B-holds? B-interrupts-enabled?))) + ;; We also check some subtle behaviour w.r.t. whether a deadline + ;; handler in CONDITION-WAIT got the mutex, or not. This is most + ;; probably very internal behaviour (so user should not depend + ;; on it) -- I added the testing here just to manifest current + ;; behaviour. + (cond ((equal A-result '(t t)) + (or (equal B-result '(nil t)) + (equal B-result '(:unknown :unknown)) + (error "thread B result: ~s" B-result))) + ((equal B-result '(t t)) + (or (equal A-result '(nil t)) + (equal A-result '(:unknown :unknown)) + (error "thread A result: ~s" A-result))) + (t + (error "Failure: fell through with A: ~S, B: ~S" + A-result + B-result)))))) + +;;; Test from git rev 5e55f426de8fa579a0d6cfbfb3ac5433d530d3c9 formerly in threads.impure +(test-util:with-test (:name (:deadline :interrupts-enabled) :skipped-on (:not :sb-thread)) + ;; I cranked this up to 1000 (and ran it on lots of machines) to get examples of failure, + ;; but that's more than a reasonable amount of time to spend in the test. + (loop repeat 2 do (signal-dealine-check-interrupt-enablement))) diff -Nru sbcl-2.0.6/tests/deadlock.impure.lisp sbcl-2.1.1/tests/deadlock.impure.lisp --- sbcl-2.0.6/tests/deadlock.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/deadlock.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -1,5 +1,142 @@ #-sb-thread (sb-ext:exit :code 104) +(import '(sb-thread:join-thread + sb-thread:make-mutex + sb-thread:make-semaphore + sb-thread:make-thread + sb-thread:signal-semaphore + sb-thread:thread-deadlock + sb-thread:wait-on-semaphore + sb-thread:with-mutex)) + +(with-test (:name :deadlock-detection.1) + (loop + repeat 1000 + do (flet ((test (ma mb sa sb) + (lambda () + (handler-case + (with-mutex (ma) + (signal-semaphore sa) + (wait-on-semaphore sb) + (with-mutex (mb) + :ok)) + (thread-deadlock (e) + ;; (assert (plusp (length ...))) prevents + ;; flushing. + (assert (plusp (length (princ-to-string e)))) + :deadlock))))) + (let* ((m1 (make-mutex :name "M1")) + (m2 (make-mutex :name "M2")) + (s1 (make-semaphore :name "S1")) + (s2 (make-semaphore :name "S2")) + (t1 (make-thread (test m1 m2 s1 s2) :name "T1")) + (t2 (make-thread (test m2 m1 s2 s1) :name "T2"))) + ;; One will deadlock, and the other will then complete normally. + (let ((res (list (join-thread t1) + (join-thread t2)))) + (assert (or (equal '(:deadlock :ok) res) + (equal '(:ok :deadlock) res)))))))) + +(with-test (:name :deadlock-detection.2) + (let* ((m1 (make-mutex :name "M1")) + (m2 (make-mutex :name "M2")) + (s1 (make-semaphore :name "S1")) + (s2 (make-semaphore :name "S2")) + (t1 (make-thread + (lambda () + (with-mutex (m1) + (signal-semaphore s1) + (wait-on-semaphore s2) + (with-mutex (m2) + :ok))) + :name "T1"))) + (prog (err) + :retry + (handler-bind ((thread-deadlock + (lambda (e) + (unless err + ;; Make sure we can print the condition + ;; while it's active + (let ((*print-circle* nil)) + (setf err (princ-to-string e))) + (go :retry))))) + (when err + (sleep 1)) + (assert (eq :ok (with-mutex (m2) + (unless err + (signal-semaphore s2) + (wait-on-semaphore s1) + (sleep 1)) + (with-mutex (m1) + :ok))))) + (assert (stringp err))) + (assert (eq :ok (join-thread t1))))) + +(with-test (:name :deadlock-detection.3) + (let* ((m1 (make-mutex :name "M1")) + (m2 (make-mutex :name "M2")) + (s1 (make-semaphore :name "S1")) + (s2 (make-semaphore :name "S2")) + (t1 (make-thread + (lambda () + (with-mutex (m1) + (signal-semaphore s1) + (wait-on-semaphore s2) + (with-mutex (m2) + :ok))) + :name "T1"))) + ;; Currently we don't consider it a deadlock + ;; if there is a timeout in the chain. + (assert (eq :deadline + (handler-case + (with-mutex (m2) + (signal-semaphore s2) + (wait-on-semaphore s1) + (sleep 1) + (sb-sys:with-deadline (:seconds 0.1) + (with-mutex (m1) + :ok))) + (sb-sys:deadline-timeout () + :deadline) + (thread-deadlock () + :deadlock)))) + (assert (eq :ok (join-thread t1))))) + +(with-test (:name (:deadlock-detection :interrupts) + :broken-on :win32) + (let* ((m1 (sb-thread:make-mutex :name "M1")) + (m2 (sb-thread:make-mutex :name "M2")) + (t1-can-go (sb-thread:make-semaphore :name "T1 can go")) + (t2-can-go (sb-thread:make-semaphore :name "T2 can go")) + (t1 (sb-thread:make-thread + (lambda () + (sb-thread:with-mutex (m1) + (sb-thread:wait-on-semaphore t1-can-go) + :ok1)) + :name "T1")) + (t2 (sb-thread:make-thread + (lambda () + (sb-ext:wait-for (eq t1 (sb-thread:mutex-owner m1))) + (sb-thread:with-mutex (m1 :wait-p t) + (sb-thread:wait-on-semaphore t2-can-go) + :ok2)) + :name "T2"))) + (sb-ext:wait-for (eq m1 (sb-thread::thread-waiting-for t2))) + (sb-thread:interrupt-thread t2 (lambda () + (sb-thread:with-mutex (m2 :wait-p t) + (sb-ext:wait-for + (eq m2 (sb-thread::thread-waiting-for t1))) + (sb-thread:signal-semaphore t2-can-go)))) + (sb-ext:wait-for (eq t2 (sb-thread:mutex-owner m2))) + (sb-thread:interrupt-thread t1 (lambda () + (sb-thread:with-mutex (m2 :wait-p t) + (sb-thread:signal-semaphore t1-can-go)))) + ;; both threads should finish without a deadlock or deadlock + ;; detection error + (let ((res (list (sb-thread:join-thread t1) + (sb-thread:join-thread t2)))) + (assert (equal '(:ok1 :ok2) res))))) + (with-test (:name (:deadlock-detection :gc)) ;; To semi-reliably trigger the error (in SBCL's where) ;; it was present you had to run this for > 30 seconds, @@ -22,39 +159,213 @@ (sb-thread:join-thread t2)))) (assert (equal '(:ok :ok) res))))) +(defun clock-gettime () + (sb-int:dx-let ((a (make-array 2 :element-type 'sb-ext:word))) + (alien-funcall (extern-alien "clock_gettime" (function void int system-area-pointer)) + 0 (sb-sys:vector-sap a)) + (values (aref a 0) (aref a 1)))) + +(defun seconds-since (start_sec start_nsec) + (sb-int:dx-let ((a (make-array 2 :element-type 'sb-ext:word))) + (alien-funcall (extern-alien "clock_gettime" (function void int system-area-pointer)) + 0 (sb-sys:vector-sap a)) + (+ (/ (coerce (- (aref a 1) start_nsec) 'double-float) 1000000000) + (- (aref a 0) start_sec)))) + +(defglobal *max-avl-tree-total* 0) +(defglobal *max-avl-tree-born* 0) +(defglobal *max-avl-tree-running* 0) +(defglobal *max-avl-tree-died* 0) + +(defun avl-maptree (fun tree) + (sb-int:named-let recurse ((node tree)) + (when node + (funcall fun node) + (recurse (sb-thread::avlnode-left node)) + (recurse (sb-thread::avlnode-right node))))) + +(defun thread-count (&optional (tree sb-thread::*all-threads*)) + (let ((born 0) + (running 0) + (died 0)) + #-pauseless-thread-start (setq running (sb-thread::avl-count tree)) + #+pauseless-thread-start + (sb-int:dx-flet ((mapfun (node) + (ecase (sb-thread::thread-%visible (sb-thread::avlnode-data node)) + (0 (incf born)) ; "can't happen" ? + (1 (incf running)) + (-1 (incf died))))) + (avl-maptree #'mapfun tree)) + (let ((total (+ born running died))) + (macrolet ((max-into (global mine) + `(let ((old ,global)) + (loop + (when (<= ,mine old) (return)) + (let ((actual (cas ,global old ,mine))) + (if (>= actual old) (return)) (setq old actual)))))) + (max-into *max-avl-tree-total* total) + (max-into *max-avl-tree-born* born) + (max-into *max-avl-tree-running* running) + (max-into *max-avl-tree-died* died)) + (list total born running died)))) + +;;; I would optimistically guess that this test can no longer fail, +;;; even for :win32, since there is no lisp mutex around *all-threads*. +;;; (There is still the C one) +;;; +;;; With the sesion lock acquisition as part of thread startup, +;;; but with a patch that allows the thread creator to run while +;;; the child is waiting, all this test managed to do was create thousands +;;; of threads all blocked on the *SESSION-LOCK*, because MAKE-THREAD could +;;; return the created thread did anything at all. +;;; The way that happens is as follows: +;;; thread 0: grab session lock, initiate GC +;;; ... return from GC but not release session lock yet +;;; thread 1: start sleeping +;;; thread 2: try to grab session lock, enter a wait +;;; thread 3: start sleeping +;;; thread 4: try to grab session lock, enter a wait +;;; thread 5: start sleeping +;;; ... +;;; So the number of threads running simultaneously depends entirely on when +;;; the even numbered threads get CPU time to release the session lock. +;;; +;;; That said, I was curious why this test complete _so_ much slowly +;;; with faster thread start, and more quickly with slower thread start. +;;; Enabling the :deadlock-test-timing feature shows: +;;; +;;; Maxima attained: 2923 1 2923 2916 current=(2923 0 1 2922) +;;; ---- ---- +;;; tree node count ^ ^ nunber of threads in "run" state +;;; +;;; The answer is obvious: the time spent in each GC is proportional to +;;; the number of threads, and with faster thread start, we can actually +;;; achieve *nearly* 3000 threads running at the same time. +;;; With each thread allocating slightly over 4MiB of memory, that's +;;; about 12GiB of additional memory for the OS to manage which has +;;; a 2nd-order effect on our runtime as well. +;;; Contrast this with the "old way" where we were essentially +;;; firing off two threads at a time and letting them finish +;;; before getting to the next two. + +;; (pushnew :deadlock-test-timing *features*) + +(defglobal *message-in-counter* 0) +(defglobal *message-out-counter* 0) +(declaim (fixnum *message-in-counter* *message-out-counter*)) +(defparameter *huge-n-threads* 3000) +(defglobal *messages* (make-array (* 2 *huge-n-threads*))) +(declaim (simple-vector *messages*)) + +(defun show-queued-messages () + (loop while (< *message-out-counter* *message-in-counter*) + do (let ((args (aref *messages* *message-out-counter*))) + ;; If a store did not get into the array yet, bail out + ;; and hope it shows up by the next time we're here. + (when (eql args 0) + (return-from show-queued-messages)) + (apply #'format t (concatenate 'string "~4d " (car args)) (cdr args)) + (terpri)) + (incf *message-out-counter*))) + +;;; Atomically log a message for output by the main thread (to avoid interleaving) +(defun message (control &rest args) + (let* ((data (cons control args)) + (index (atomic-incf *message-in-counter*))) + (setf (aref *messages* index) data))) + +;;; This encounters the "backing off for retry" error if attempting +;;; to start too many threads. +(defparameter *max-runnable-threads* #+x86-64 100 #-x86-64 5) (with-test (:name :gc-deadlock :broken-on :win32) - (write-line "WARNING: THIS TEST WILL HANG ON FAILURE!") + #+nil (write-line "WARNING: THIS TEST WILL HANG ON FAILURE!") ;; Prior to 0.9.16.46 thread exit potentially deadlocked the ;; GC due to *all-threads-lock* and session lock. On earlier ;; versions and at least on one specific box this test is good enough ;; to catch that typically well before the 1500th iteration. (loop with i = 0 - with n = 3000 + with n = *huge-n-threads* + with running = nil while (< i n) do + (show-queued-messages) (incf i) + #-deadlock-test-timing (when (zerop (mod i 100)) (write-char #\.) (force-output)) + (when (> (length running) *max-runnable-threads*) + (let ((last (car (last running)))) + (sb-thread:join-thread last) + (setq running (nbutlast running)))) (handler-case + (push (if (oddp i) (make-join-thread - (lambda () - (sleep (random 0.001))) + (lambda (i &aux (rand (random 0.001))) + (declare (ignorable i)) + #-deadlock-test-timing + (sleep rand) + #+deadlock-test-timing + (multiple-value-bind (t0_sec t0_nsec) (clock-gettime) + (message "Sleep ~f, threads=~d" i rand (thread-count)) + (sleep rand) + (message "Done (~f sec)" i (seconds-since t0_sec t0_nsec)))) + :arguments i :name (format nil "SLEEP-~D" i)) (make-join-thread - (lambda () + (lambda (i) + (declare (ignorable i)) ;; KLUDGE: what we are doing here is explicit, ;; but the same can happen because of a regular ;; MAKE-THREAD or LIST-ALL-THREADS, and various ;; session functions. - (sb-thread::with-all-threads-lock + #-deadlock-test-timing + (progn + (sb-thread::with-session-lock (sb-thread::*session*) + (sb-ext:gc))) + #+deadlock-test-timing + (sb-int:binding* (((t0_sec t0_nsec) (clock-gettime)) + ((t1_sec t1_nsec wait-time) (values nil nil nil))) + (message "GC, threads=~d" i (thread-count)) (sb-thread::with-session-lock (sb-thread::*session*) - (sb-ext:gc)))) + (setq wait-time (seconds-since t0_sec t0_nsec)) + (multiple-value-setq (t1_sec t1_nsec) (clock-gettime)) + (sb-ext:gc)) + (let ((gc-time (seconds-since t1_sec t1_nsec))) + (message "GC Done (~f wait + ~f gc)~A" + i wait-time gc-time + (if (> gc-time .5) "***" ""))))) + :arguments i :name (format nil "GC-~D" i))) + running) (error (e) + ;; Not sure why this needs to back off - at most it was running 2 threads. (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e) (sleep 0.1) - (incf i))))) + (incf i)))) + #+deadlock-test-timing + (progn + (format t "~&Main thread: draining messages~%") (force-output) + (loop while (< (cas *message-out-counter* 0 0) (length *messages*)) + do (show-queued-messages) + (sleep .05)) + (format t "Maxima attained: ~d ~d ~d ~d current=~d~%" + *max-avl-tree-total* + *max-avl-tree-born* + *max-avl-tree-running* + *max-avl-tree-died* + (thread-count)) + (sb-thread:make-thread #'list :name "list") + (format t "After another make-thread: current=~d~%" (thread-count)) + (let (gc-times) + (sb-int:dovector (x *messages*) + (when (string= (first x) "GC Done" :end1 7) + (push (fourth x) gc-times))) + (let ((min (reduce #'min gc-times)) + (max (reduce #'max gc-times)) + (sum (reduce #'+ gc-times))) + (format t "~&GC time: min=~f max=~f avg=~f sum=~f~%" + min max (/ sum (length gc-times)) sum))))) diff -Nru sbcl-2.0.6/tests/debug.impure.lisp sbcl-2.1.1/tests/debug.impure.lisp --- sbcl-2.0.6/tests/debug.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/debug.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -99,7 +99,7 @@ ;;; bug 379 (with-test (:name (trace :encapsulate nil) :fails-on (or (and :ppc (not :linux)) :sparc :arm64) - :broken-on (or :hppa :freebsd)) + :broken-on (or :freebsd)) (let ((output (with-traced-function (trace-this :encapsulate nil) (assert (eq 'ok (trace-this)))))) (assert (search "TRACE-THIS" output)) @@ -107,7 +107,7 @@ (with-test (:name (trace :encapsulate nil :recursive) :fails-on (or (and :ppc (not :linux)) :sparc :arm64) - :broken-on (or :hppa :freebsd)) + :broken-on (or :freebsd)) (let ((output (with-traced-function (trace-fact :encapsulate nil) (assert (= 120 (trace-fact 5)))))) (assert (search "TRACE-FACT" output)) @@ -661,7 +661,7 @@ (sb-sys:with-pinned-objects (code) (let* ((base (logandc2 (sb-kernel:get-lisp-obj-address code) sb-vm:lowtag-mask)) - (limit (+ base (sb-vm::primitive-object-size code)))) + (limit (+ base (sb-ext:primitive-object-size code)))) (flet ((properly-tagged-p (ptr) (eql (alien-funcall (extern-alien "properly_tagged_p_internal" (function int unsigned unsigned)) diff -Nru sbcl-2.0.6/tests/defstruct.impure-cload.lisp sbcl-2.1.1/tests/defstruct.impure-cload.lisp --- sbcl-2.0.6/tests/defstruct.impure-cload.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/defstruct.impure-cload.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -12,6 +12,11 @@ (eval-when (:compile-toplevel) (load "compiler-test-util.lisp")) +;;; This test asserts that each constructor for a defstruct involved in a +;;; mutually referential cycle with other defstructs inlines the test of the +;;; as-yet-unseen type when the DEFSTRUCT form is first read. +;;; We can tell that they're inlined because they use layout-IDs, so the only +;;; boxed constant is for the constructor to deposit a layout. (with-test (:name (:block-compile :defstruct-slot-type-circularity)) (with-scratch-file (fasl "fasl") (compile-file "block-compile-defstruct-test.lisp" :output-file fasl :block-compile t) @@ -20,29 +25,18 @@ (let ((constants (ctu:find-code-constants (symbol-function symbol) :type 'sb-kernel:layout))) - (assert (= (length constants) 3))))) - -;;; Check an organic (not contrived) use of mutually referential types. -;;; NEWLINE is defined after SECTION-START, because it is a subtype. -;;; One of SECTION-START's slot setters refers to type NEWLINE. -(with-test (:name :pretty-stream-structs) - (let ((layouts - (ctu:find-code-constants #'(setf sb-pretty::section-start-section-end) - :type 'sb-kernel:layout))) - ;; expect 3 layouts: one for SECTION-START to check the instance itself, - ;; one for NEWLINE and one for BLOCK-END. - ;; It's entirely coincidental that the above test also has 3. - (assert (= (length layouts) 3)) - (assert (find (sb-kernel:find-layout 'sb-pretty::newline) - layouts)))) + (assert (= (length constants) 1))))) (with-test (:name :mutex-owner-typecheck) (let ((layouts (ctu:find-code-constants #'(setf sb-thread::mutex-%owner) :type 'sb-kernel:layout))) - ;; expect 3 layouts: one for THREAD, one for MUTEX, and one for FOREIGN-THREAD - (assert (= (length layouts) 3)) - (assert (find (sb-kernel:find-layout 'sb-thread:thread) + ;; expect exactly 1 layout, that of MUTEX, for signaling OBJECT-NOT-TYPE. + ;; To be really pedantic we'd want to assert that in the source file + ;; the defstruct of MUTEX appears prior to the defstruct of THREAD, + ;; proving without a doubt that block compilation worked. + (assert (= (length layouts) 1)) + (assert (find (sb-kernel:find-layout 'sb-thread:mutex) layouts)))) (defstruct (parent) diff -Nru sbcl-2.0.6/tests/defstruct.impure.lisp sbcl-2.1.1/tests/defstruct.impure.lisp --- sbcl-2.0.6/tests/defstruct.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/defstruct.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -11,6 +11,53 @@ (load "compiler-test-util.lisp") +;;;; Better ensure nothing in messed up in the ID space +;;;; or else everything is suspect. +(defun layout-id-vector-sap (layout) + (sb-sys:sap+ (sb-sys:int-sap (sb-kernel:get-lisp-obj-address layout)) + (- (ash (+ sb-vm:instance-slots-offset + (sb-kernel:get-dsd-index + sb-kernel:layout sb-kernel::id-word0)) + sb-vm:word-shift) + sb-vm:instance-pointer-lowtag))) + +(let ((hash (make-hash-table))) + ;; assert that all layout IDs are unique + (let ((all-layouts + (delete-if + ;; temporary layouts (created for parsing DEFSTRUCT) + ;; must be be culled out. + (lambda (x) + (and (typep (sb-kernel:layout-classoid x) + 'sb-kernel:structure-classoid) + (eq (sb-kernel::layout-equalp-impl x) + #'sb-kernel::equalp-err))) + (sb-vm::list-allocated-objects :all + :type sb-vm:instance-widetag + :test #'sb-kernel::layout-p)))) + (dolist (layout all-layouts) + (let ((id (sb-kernel:layout-id layout))) + (sb-int:awhen (gethash id hash) + (error "ID ~D is ~A and ~A" id sb-int:it layout)) + (setf (gethash id hash) layout))) + ;; assert that all inherited ID vectors match the layout-inherits vector + (let ((structure-object + (sb-kernel:find-layout 'structure-object))) + (dolist (layout all-layouts) + (when (find structure-object (sb-kernel:layout-inherits layout)) + (let ((ids + (sb-sys:with-pinned-objects (layout) + (let ((sap (layout-id-vector-sap layout))) + (loop for depthoid from 2 to (sb-kernel:layout-depthoid layout) + collect (sb-sys:signed-sap-ref-32 sap (ash (- depthoid 2) 2)))))) + (expect + (map 'list 'sb-kernel:layout-id + (sb-kernel:layout-inherits layout)))) + (unless (equal (append '(1 2) ids) + (append expect (list (sb-kernel:layout-id layout)))) + (error "Wrong IDs for ~A: expect ~D actual ~D~%" + layout expect ids)))))))) + ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec ;;; Type mismatch of slot default init value isn't an error until the @@ -34,19 +81,15 @@ (defstruct (boa-kid (:include boa-saux))) (defstruct (boa-grandkid (:include boa-kid))) (with-test (:name :defstruct-boa-typecheck) - (flet ((dsd-always-boundp (dsd) - ;; A copy of sb-kernel::dsd-always-boundp, which may not - ;; survive make-target-2's shake-packages. - (logbitp 3 (sb-kernel::dsd-bits dsd)))) (dolist (dsd (sb-kernel:dd-slots (sb-kernel:find-defstruct-description 'boa-saux))) (let ((name (sb-kernel:dsd-name dsd)) - (always-boundp (dsd-always-boundp dsd))) + (always-boundp (sb-kernel:dsd-always-boundp dsd))) (ecase name ((a c) (assert (not always-boundp))) (b (assert always-boundp))))) (let ((dd (sb-kernel:find-defstruct-description 'boa-grandkid))) - (assert (not (dsd-always-boundp (car (sb-kernel:dd-slots dd)))))) + (assert (not (sb-kernel:dsd-always-boundp (car (sb-kernel:dd-slots dd)))))) (let ((s (make-boa-saux))) (locally (declare (optimize (safety 3)) (inline boa-saux-a)) @@ -55,7 +98,7 @@ (setf (boa-saux-c s) 5) (assert (eql (boa-saux-a s) 1)) (assert (eql (boa-saux-b s) 3)) - (assert (eql (boa-saux-c s) 5))))) + (assert (eql (boa-saux-c s) 5)))) (with-test (:name :defstruct-boa-nice-error :skipped-on :interpreter) (let ((err (nth-value 1 (ignore-errors (boa-saux-a (make-boa-saux)))))) @@ -252,9 +295,10 @@ (declaim (optimize (debug 2))) +(declaim (muffle-conditions style-warning)) ; &OPTIONAL and &KEY + (defmacro test-variant (defstructname &key colontype boa-constructor-p) `(locally - (declare (muffle-conditions style-warning)) ; &OPTIONAL and &KEY #+nil(format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype) (defstruct (,defstructname ,@(when colontype `((:type ,colontype))) @@ -764,33 +808,19 @@ (aref (vector x) (incf i))) (bug-348-x x))))) -;;; obsolete instance trapping -;;; -;;; FIXME: Both error conditions below should possibly be instances -;;; of the same class. (Putting this FIXME here, since this is the only -;;; place where they appear together.) - (with-test (:name :obsolete-defstruct/print-object) (eval '(defstruct born-to-change)) (let ((x (make-born-to-change))) (handler-bind ((error 'continue)) (eval '(defstruct born-to-change slot))) - (assert (eq :error - (handler-case - (princ-to-string x) - (sb-pcl::obsolete-structure () - :error)))))) + (assert (search "UNPRINTABLE instance" (princ-to-string x))))) (with-test (:name :obsolete-defstruct/typep) (eval '(defstruct born-to-change-2)) (let ((x (make-born-to-change-2))) (handler-bind ((error 'continue)) (eval '(defstruct born-to-change-2 slot))) - (assert (eq :error2 - (handler-case - (typep x (find-class 'standard-class)) - (sb-kernel:layout-invalid () - :error2)))))) + (assert (not (typep x (find-class 'standard-class)))))) ;; EQUALP didn't work for structures with float slots (reported by ;; Vjacheslav Fyodorov). @@ -911,13 +941,8 @@ (defun assert-is (predicate instance) (assert (funcall predicate instance))) -;;; It used to call the predicate function, but out-of-line predicate -;;; functions now don't signal layout-invalid, just like inlined -;;; predicates didn't signal it. (defun assert-invalid (instance) - (declare (notinline typep)) - (assert (typep (nth-value 1 (ignore-errors (typep instance 'structure-object))) - 'sb-kernel::layout-invalid))) + (assert (sb-kernel:layout-invalid (sb-kernel:%instance-layout instance)))) ;; Don't try to understand this macro; just look at its expansion. (defmacro with-defstruct-redefinition-test (name diff -Nru sbcl-2.0.6/tests/describe.impure.lisp sbcl-2.1.1/tests/describe.impure.lisp --- sbcl-2.0.6/tests/describe.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/describe.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -154,3 +154,10 @@ (with-output-to-string (stream) (describe (make-array 1 :displaced-to (make-array 1)) stream))))) + +(with-test (:name :bad-second-arg) + (assert-error + (describe 'describe + (opaque-identity + (make-array 256 :element-type 'character :fill-pointer 0))) + type-error)) diff -Nru sbcl-2.0.6/tests/do-refs.impure.lisp sbcl-2.1.1/tests/do-refs.impure.lisp --- sbcl-2.0.6/tests/do-refs.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/do-refs.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absoluely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -64,18 +64,21 @@ :key 'widetag-of :test #'/=))))))) (test-util:with-test (:name :walk-slots-fdefn) - (walk-slots-test* - (sb-kernel::find-fdefn 'constantly-t) - (lambda (slots) - #+immobile-code - (and (= (length slots) 3) - (symbolp (first slots)) - (closurep (second slots)) - (code-component-p (third slots))) - #-immobile-code - (and (= (length slots) 2) - (symbolp (first slots)) - (closurep (second slots)))))) + (let* ((closure (funcall (compile nil '(lambda (x) (lambda () x))) t)) + (symbol (gensym))) + (setf (fdefinition symbol) closure) + (walk-slots-test* + (sb-kernel::find-fdefn symbol) + (lambda (slots) + #+immobile-code + (and (= (length slots) 3) + (symbolp (first slots)) + (closurep (second slots)) + (code-component-p (third slots))) + #-immobile-code + (and (= (length slots) 2) + (symbolp (first slots)) + (closurep (second slots))))))) (defclass mystdinst () ((a :initform 1) (b :initform 2) @@ -97,13 +100,27 @@ (c c format-control nil) :a ay :b bee :format-arguments "wat")))) +(defun make-random-funinstance (&rest values) + (let* ((ctor (apply #'sb-pcl::%make-ctor values)) + (layout (sb-kernel:%fun-layout ctor))) + ;; If the number of payload words is even, then there's a padding word + ;; because adding the header makes the unaligned total an odd number. + ;; Fill that padding word with something - it should not be visible. + ;; Whether GC should trace the word is a different question, + ;; on whose correct answer I waver back and forth. + (when (evenp (sb-kernel:get-closure-length ctor)) ; payload length + (let ((max (reduce #'max (sb-kernel:dd-slots (sb-kernel:layout-info layout)) + :key 'sb-kernel:dsd-index))) + (setf (sb-kernel:%funcallable-instance-info ctor (1+ max)) + (elt sb-vm:+static-symbols+ 0)))) + ;; stuff in a random function as the implementation + (setf (sb-kernel:%funcallable-instance-fun ctor) #'error) + ctor)) +(compile 'make-random-funinstance) + (test-util:with-test (:name :walk-slots-pcl-ctor) (let* ((slot-vals '("A" "B" "C" "D" "E" "F")) - (f (apply (compile nil '(lambda (&rest args) - (let ((ctor (apply #'sb-pcl::%make-ctor args))) - (setf (%funcallable-instance-fun ctor) #'error) - ctor))) - slot-vals))) + (f (apply #'make-random-funinstance slot-vals))) (walk-slots-test f `(,(find-layout 'sb-pcl::ctor) ,#'error ,@slot-vals)))) #+sb-fasteval diff -Nru sbcl-2.0.6/tests/dump.impure-cload.lisp sbcl-2.1.1/tests/dump.impure-cload.lisp --- sbcl-2.0.6/tests/dump.impure-cload.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/dump.impure-cload.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -246,7 +246,7 @@ (assert-canonical '(y x))) ;; specifying only one slot is not canonical (assert (equal (let ((*foo-save-slots* '(x))) (sb-c::%make-load-form foo)) - '(sb-kernel::new-instance foo))))) + '(sb-kernel::new-struct foo))))) ;; A huge constant vector. This took 9 seconds to compile (on a MacBook Pro) ;; prior to the optimization for using fops to dump. @@ -472,3 +472,45 @@ (let ((z (eval `(test-constant-identity ,(intern "+CONSY-CONSTANT+"))))) (assert (equal (car z) +consy-constant+)) (assert (cadr z)))) + +(macrolet ((expand () + `(progn + ,@(loop for i from 0 below sb-vm:n-word-bits + collect + `(sb-int:defconstant-eqx ,(intern (format nil "MYSAP~d" i)) + ,(sb-sys:int-sap (ash 1 i)) + #'sb-sys:sap=))))) + (expand)) +(with-test (:name :dump-sap) + (dotimes (i sb-vm:n-word-bits) + (let ((s (intern (format nil "MYSAP~d" i)))) + (assert (= (sb-sys:sap-int (symbol-value s)) + (ash 1 i)))))) + +(eval-when (:compile-toplevel :load-toplevel) + (defstruct monkey + (x t) + (y 1 :type fixnum) + (data (cons 1 2)) + (str "hi")) + + (defmethod make-load-form ((self monkey) &optional e) + (make-load-form-saving-slots self :slot-names '(data) :environment e))) + +(defvar *amonkey* #.(make-monkey :x nil :y 3 :data '(ok))) +(eval-when (:compile-toplevel) (makunbound '*amonkey*)) +(with-test (:name :dump-monkey) + (let ((a *amonkey*)) + (assert (sb-kernel::unbound-marker-p (monkey-x a))) + (assert (sb-kernel::unbound-marker-p (monkey-y a))) + (assert (sb-kernel::unbound-marker-p (monkey-str a))) + (assert (equal (monkey-data a) '(ok))))) + +(defun use-numeric-vector-a () + #.(make-array 5 :element-type '(signed-byte 8) :initial-contents '(90 100 5 -2 3))) + +(defun use-numeric-vector-b () + #.(make-array 5 :element-type '(signed-byte 8) :initial-contents '(90 100 5 -2 3))) + +(with-test (:name :coalesce-numeric-arrays) + (assert (eq (use-numeric-vector-a) (use-numeric-vector-b)))) diff -Nru sbcl-2.0.6/tests/dynamic-extent.impure.lisp sbcl-2.1.1/tests/dynamic-extent.impure.lisp --- sbcl-2.0.6/tests/dynamic-extent.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/dynamic-extent.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -174,7 +174,7 @@ (defun-with-dx dx-value-cell (x) ;; Not implemented everywhere, yet. - #+(or x86 x86-64 mips hppa) + #+(or x86 x86-64 mips) (let ((cell x)) (declare (sb-int:truly-dynamic-extent cell)) (flet ((f () @@ -873,7 +873,7 @@ (assert (every (lambda (x) (eql x 0)) a)))) (with-test (:name (:dx-bug-misc :bdowning-2005-iv-16)) - #+(or hppa mips x86 x86-64) + #+(or mips x86 x86-64) (assert-no-consing (bdowning-2005-iv-16)) (bdowning-2005-iv-16)) @@ -928,7 +928,7 @@ (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos) (assert (equalp f2 y)) (assert (equalp f3 (read-from-string res nil nil :start pos2)))))) - #+(or hppa mips x86 x86-64) + #+(or mips x86 x86-64) (assert-no-consing (assert (eql n (funcall fun nil)))) (assert (eql n (funcall fun nil)))) @@ -1587,3 +1587,15 @@ (assert-no-consing (with-output-to-string (*standard-output* s) (write-char #\x))))) + +(with-test (:name :cycles-without-dx-lvars) + (checked-compile-and-assert + () + `(lambda (f x z) + (let ((l (if x + (loop while z) + (list (list 1))))) + (declare (dynamic-extent l)) + (funcall f l))) + (((lambda (l) (equal l '((1)))) nil nil) t) + (((lambda (l) (equal l nil)) t nil) t))) diff -Nru sbcl-2.0.6/tests/elfcore.test.sh sbcl-2.1.1/tests/elfcore.test.sh --- sbcl-2.0.6/tests/elfcore.test.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/elfcore.test.sh 2021-01-30 11:22:39.000000000 +0000 @@ -33,11 +33,32 @@ # Ensure that we're not running a stale shrinkwrap-sbcl (cd $SBCL_PWD/../src/runtime ; rm -f shrinkwrap-sbcl ; make shrinkwrap-sbcl) +# Prevent style-warnings in the editcore script, but don't assume that it +# can be compiled in the first place unless actually doing the ELFcore tests. +run_sbcl --noinform < (sb-kernel:code-n-entries obj) 0)) + (assert (/= (sb-kernel:%code-serialno obj) 0)))) + :all) ;; This just needs any function that when ELFinated has its packed fixups rewritten. ;; If the packed value is a bignum, it goes into a C data section. -(let* ((code (sb-kernel:fun-code-header #'sb-impl::schedule-timer)) +(let* ((code (sb-kernel:fun-code-header #'compile-file)) (fixups (sb-vm::%code-fixups code))) (assert (typep fixups 'bignum)) (assert (not (heap-allocated-p fixups)))) diff -Nru sbcl-2.0.6/tests/exit-hang.impure.lisp sbcl-2.1.1/tests/exit-hang.impure.lisp --- sbcl-2.0.6/tests/exit-hang.impure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/exit-hang.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,77 @@ +#+(or (not sb-thread) win32) (sb-ext:exit :code 104) + +;;; Not an exactly an "exit hang" test, but there was a different hang +;;; regarding concurrent JOIN-THREAD on 1 thread. +;;; Even though POSIX threads would consider this to be undefined behavior with +;;; its thread abstraction, it's not undefined behavior in SBCL (for now) +;;; though I do think it's slightly suspicious to depend on this. +(with-test (:name :concurrent-join-thread) + (let* ((other-guy (sb-thread:make-thread #'sleep :arguments .2 :name "sleepyhead")) + (joiners + (loop repeat 4 + collect (sb-thread:make-thread #'sb-thread:join-thread + :arguments other-guy)))) + ;; The joiners should all return + (mapc 'sb-thread:join-thread joiners))) + +;;; This uses the same C source file as fcb-threads. +;;; This is OK in the parallel test runner because WITH-SCRATCH-FILE +;;; includes the PID in the temp file name. +(if (probe-file "fcb-threads.so") + ;; Assume the test automator built this for us + (load-shared-object (truename "fcb-threads.so")) + ;; Otherwise, write into /tmp so that we never fail to rebuild + ;; the '.so' if it gets changed, and assume that it's OK to + ;; delete a mapped file (which it is for *nix). + (with-scratch-file (solib "so") + (sb-ext:run-program "/bin/sh" + `("run-compiler.sh" "-sbcl-pic" "-sbcl-shared" + "-o" ,solib "fcb-threads.c")) + (sb-alien:load-shared-object solib))) + +;;; Final test: EXIT does not lock up due to (simulated) C++ destructors +;;; or free() or most anything else involved in stopping the main thread. +;;; The point of the test is to mock a Lisp thread that uses foreign code +;;; that uses malloc and free or equivalent from C++. +;;; The behavior being tested is the effect of SB-THREAD:ABORT-THREAD on +;;; a thread that happened to be just at that moment in the foreign code. +;;; We can't - or don't need to - exactly replicate the behavior +;;; of doing a lot of memory allocation. All we need to demonstrate is +;;; that we won't interrupt a malloc() or free(). +(defglobal *should-i-keep-going* t) +(defun mess-around-with-foreign-calls () + ;; In reality the thread would not permanently own the lock, but this is the + ;; simplest way to simulate the random occurrence that it does own the lock + ;; exactly when terminated. + ;; So make it own the lock forever unless politely (i.e. not forcibly) terminated. + (alien-funcall (extern-alien "acquire_a_global_lock" (function void))) + (loop (sb-thread:barrier (:read)) + (unless *should-i-keep-going* (return)) + (sleep .75)) + (format *error-output* "~&Worker thread politely exiting~%") + (alien-funcall (extern-alien "release_a_global_lock" (function void)))) + +(sb-thread:make-thread #'mess-around-with-foreign-calls) + +(push (compile nil + '(lambda () + (format t "~&Invoked exit hook~%") + (setq *should-i-keep-going* nil))) + *exit-hooks*) + +;;; The actual code under test involved C++ destructors that are +;;; interposed between our call to OS-EXIT and the OS call per se. +;;; Acquiring a globally shared mutex in OS-EXIT simulates that. +(sb-int:encapsulate + 'sb-sys:os-exit + 'simulate-c++-destructors + (lambda (realfun code &key abort) + (format t "~&Enter OS-EXIT ~s ~s~%" code abort) + (alien-funcall (extern-alien "acquire_a_global_lock" (function void))) + (alien-funcall (extern-alien "release_a_global_lock" (function void))) + (funcall realfun code :abort abort))) + +;;; Give ourselves 3 seconds to exit. +(alien-funcall (extern-alien "prepare_exit_test" (function void int)) 3) +(setq sb-ext:*forcibly-terminate-threads-on-exit* nil) +(exit :code 104) diff -Nru sbcl-2.0.6/tests/extended-sequences.impure.lisp sbcl-2.1.1/tests/extended-sequences.impure.lisp --- sbcl-2.0.6/tests/extended-sequences.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/extended-sequences.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -95,3 +95,44 @@ (x :from-end t) (loop until (stop) collect (value) do (next)))) (('(a b c d)) '(d c b a) :test #'equal))) + +(defclass my-list (sequence standard-object) + ((%nilp :initarg :nilp :initform nil :accessor nilp) + (%kar :initarg :kar :accessor kar) + (%kdr :initarg :kdr :accessor kdr))) + +(defun my-list (&rest elems) + (if (null elems) + (load-time-value (make-instance 'my-list :nilp t) t) + (make-instance 'my-list + :kar (first elems) :kdr (apply #'my-list (rest elems))))) + +(defmethod sequence:length ((sequence my-list)) + (if (nilp sequence) + 0 + (1+ (length (kdr sequence))))) + +(defmethod sequence:make-sequence-iterator + ((sequence my-list) &key from-end start end) + (declare (ignore from-end start end)) + (values sequence (my-list) nil + (lambda (sequence iterator from-end) + (declare (ignore sequence from-end)) + (kdr iterator)) + (lambda (sequence iterator limit from-end) + (declare (ignore sequence from-end)) + (eq iterator limit)) + (lambda (sequence iterator) + (declare (ignore sequence)) + (kar iterator)) + (lambda (new sequence iterator) + (declare (ignore sequence)) + (setf (kar iterator) new)) + (constantly 0) + (lambda (sequence iterator) + (declare (ignore sequence)) + iterator))) + +(with-test (:name :map-into) + (assert (equal (coerce (map-into (my-list 1 2 3) #'identity '(4 5 6)) 'list) + '(4 5 6)))) diff -Nru sbcl-2.0.6/tests/external-format.impure.lisp sbcl-2.1.1/tests/external-format.impure.lisp --- sbcl-2.0.6/tests/external-format.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/external-format.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -1014,7 +1014,7 @@ (with-open-file (s *test-path* :external-format :utf-32be) (assert (string= " ???? " (read-line s)))))) -(with-test (:name :invalid-external-format :fails-on :win32) +(with-test (:name :invalid-external-format) (labels ((test-error (e) (assert (typep e 'error)) (unless (equal "Undefined external-format: :BAD-FORMAT" @@ -1023,7 +1023,7 @@ (test (direction) (test-error (handler-case - (open "/dev/null" :direction direction :external-format :bad-format + (open #-win32 "/dev/null" #+win32 "nul" :direction direction :external-format :bad-format :if-exists :overwrite) (error (e) e))))) (test :input) diff -Nru sbcl-2.0.6/tests/fast-eval.impure.lisp sbcl-2.1.1/tests/fast-eval.impure.lisp --- sbcl-2.0.6/tests/fast-eval.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/fast-eval.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -325,3 +325,16 @@ (assert (nth-value 1 (function-lambda-expression (sb-int:info :type :expander 'thingz)))) ;; and make sure the expander actually works (assert (typep "hey" '(thingz 3)))) + +(defpackage fancypkg (:use "CL" "SB-EXT") (:export make-mystruct mystruct-x)) +(in-package fancypkg) +(defstruct mystruct (x 3) y) +(in-package "CL-USER") +(lock-package "FANCYPKG") + +(defun f () + (fancypkg:mystruct-x (fancypkg:make-mystruct))) +(test-util:with-test (:name :jit-compiled-struct-accessor-locked-pkg) + (assert (eql (f) 3)) + (assert (not (compiled-function-p #'f))) + (assert (compiled-function-p #'fancypkg:mystruct-x))) diff -Nru sbcl-2.0.6/tests/fcb-threads.c sbcl-2.1.1/tests/fcb-threads.c --- sbcl-2.0.6/tests/fcb-threads.c 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/fcb-threads.c 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,162 @@ +/* In as much as this file simulates "foreign" code, + * we don't include "sbcl.h" and we use the native thread API + * for the platform */ + +#ifdef _WIN32 +# include +# include +# include +# include // for WaitForSingleObject +#else +# include +#endif +#include +#include +#include + +struct thread_arg { void * funkyfun; int index; int n_calls; }; + +char *salutations[8] = { + "Hello", "Hi there!", "Hey", "Hi!", "Ahoy there", "What's up!", "Hola", + "That's a winner" +}; +int sharedvar; + +#ifdef _WIN32 +__stdcall unsigned int perftest_thread(LPVOID void_arg) +#else +void* perftest_thread(void* void_arg) +#endif +{ + struct thread_arg* arg = void_arg; + int (*lispfun)() = arg->funkyfun; + int ncalls = arg->n_calls; + int i; + for (i=0; ifunkyfun; + int i; + // fprintf(stderr, "enter doThatThing %p\n", void_arg); fflush(stderr); + for(i=0; in_calls; ++i) { + int index = __sync_fetch_and_add(&sharedvar,1); + char *salutation = salutations[index % 8]; + int answer = lispfun(salutation, arg->index + i); + if (answer != (arg->index + i) * strlen(salutation)) thread_result = 0; + } + return (void*)(uintptr_t)thread_result; +} + +int call_thing_from_threads(void* ptr, int n_threads, int n_calls) +{ + struct { +#ifdef _WIN32 + HANDLE handle; + DWORD result; +#else + pthread_t pthread_id; + void* result; +#endif + struct thread_arg arg; + } threads[50]; + if (n_threads>50) { + fprintf(stderr, "pick a smaller number\n"); + return -1; + } + int i; + for(i=0; i +#include +#include + +static pthread_mutex_t some_global_lock = PTHREAD_MUTEX_INITIALIZER; + +void acquire_a_global_lock() { + pthread_mutex_lock(&some_global_lock); +} +void release_a_global_lock() { + pthread_mutex_unlock(&some_global_lock); +} +static void alarmclock_expired(int sig) +{ + char msg[] = "timed out\n"; + write(2, msg, sizeof msg-1); + _exit(1); +} + +/// Exit with failure if we can't exit within a set time. +void prepare_exit_test(int seconds) +{ + struct sigaction sa; + sa.sa_handler = alarmclock_expired; + sigemptyset(&sa.sa_mask); + sa.sa_flags = 0; + sigaction(SIGALRM, &sa, 0); + struct itimerval it; + it.it_value.tv_sec = seconds; + it.it_value.tv_usec = 0; + it.it_interval.tv_sec = it.it_interval.tv_usec = 0; + setitimer(ITIMER_REAL, &it, 0); +} +#endif diff -Nru sbcl-2.0.6/tests/fcb-threads.impure.lisp sbcl-2.1.1/tests/fcb-threads.impure.lisp --- sbcl-2.0.6/tests/fcb-threads.impure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/fcb-threads.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,196 @@ +;;;; callback tests + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; This reliably fails with two crashes (both in the same run) on FreeBSD: +;;; - garbage_collect: no SP known for thread 0x802bea000 (OS 34367133952) +;;; - failed AVER: (NOT (SB-THREAD::AVL-FIND ADDR SB-THREAD::OLD)) + +#+(or (not sb-thread) freebsd) (sb-ext:exit :code 104) + +#+win32 +(with-scratch-file (solib "dll") + (sb-ext:run-program "gcc" + `("-shared" "-o" ,solib "fcb-threads.c") + :search t) + (sb-alien:load-shared-object solib)) + +#-win32 +(if (probe-file "fcb-threads.so") + ;; Assume the test automator built this for us + (load-shared-object (truename "fcb-threads.so")) + ;; Otherwise, write into /tmp so that we never fail to rebuild + ;; the '.so' if it gets changed, and assume that it's OK to + ;; delete a mapped file (which it is for *nix). + (with-scratch-file (solib "so") + (sb-ext:run-program "/bin/sh" + `("run-compiler.sh" "-sbcl-pic" "-sbcl-shared" + "-o" ,solib "fcb-threads.c") + :output t :error :output) + (sb-alien:load-shared-object solib))) + +;;;; Just exercise a ton of calls from 1 thread +(sb-alien::define-alien-callback perftestcb int () 0) +(defun trivial-call-test (n) + (with-alien ((testfun (function int system-area-pointer int) :extern "minimal_perftest")) + (alien-funcall testfun (alien-sap perftestcb) n))) +(time (trivial-call-test 200000)) + +;;;; +(defglobal *counter* 0) +(declaim (fixnum *counter*)) +(defglobal *ok* (list t)) + +(defglobal *seen-threads* nil) + +;;; A variable commissioned by the department of needless and unnecessary redundancy department +(defglobal *print-greetings-and-salutations* (or #+linux t)) + +(defglobal *semaphore* nil) +(sb-alien::define-alien-callback testcb int ((arg1 c-string) (arg2 double)) + (when *semaphore* (sb-thread:signal-semaphore *semaphore*)) + (let ((cell (assoc sb-thread:*current-thread* *seen-threads*)) + (result (floor (* (length arg1) arg2)))) + (unless cell + (let* ((thr sb-thread:*current-thread*) + (string + (format nil "~s,~f from [~@[TID ~d ~]C-thread ~x] ~s => ~x~%" + arg1 arg2 + (or #+linux (sb-thread::thread-os-tid thr)) + (sb-thread::thread-primitive-thread thr) + thr result))) + ;; This WRITE kind of has to stay here for timing purposes - + ;; With it, we get >100 GCs, without it only 3 or 4, + ;; and the intent of the test is to exercise GC and foreign + ;; calbacks together, which was formerly bug prone. + (when *print-greetings-and-salutations* + #+win32 (progn (write-string string) (force-output)) + #-win32 (sb-sys:with-pinned-objects (string) ; avoid interleaved output this way + (sb-unix:unix-write 1 (sb-sys:vector-sap string) 0 (length string)))) + (setq cell (cons thr (1- (floor arg2)))) + (atomic-push cell *seen-threads*))) + (assert (eql (coerce (incf (cdr cell)) 'double-float) + arg2)) + result)) + +(defglobal *keepon* t) +(defglobal *n-gcs* 0) + +(defun f (n-trials n-threads n-calls enable-gcing) + (dotimes (trialno n-trials) + (setq *n-gcs* 0) + (setq *semaphore* (sb-thread:make-semaphore)) + (let ((watchdog-thread + (sb-thread:make-thread + (lambda () + ;; Each trial, when it works, takes between .01 to .4 sec + ;; (which is a tremendous spread), + ;; so after 20 seconds (50x more than needed), say it failed. + (let ((result + (sb-thread:wait-on-semaphore *semaphore* + :n (* n-threads n-calls) + ;; :timeout 20 + ))) + (if result + (format t "OK!~%") + (sb-sys:os-exit 1)))))) + (gc-thr + (when enable-gcing + (sb-thread:make-thread + (lambda() + (loop + (gc) + (incf *n-gcs*) + (sleep .0001) + (sb-thread:barrier (:read)) + (if (not *keepon*) (return))))))) + (start (get-internal-real-time))) + (setq *keepon* t) + (with-alien ((testfun (function int system-area-pointer int int) + :extern "call_thing_from_threads")) + (assert (eql (alien-funcall testfun (alien-sap testcb) n-threads n-calls) + 1))) + (setq *keepon* nil) + (sb-thread:barrier (:write)) + (let ((stop (get-internal-real-time))) + #+darwin + (with-alien ((count int :extern "sigwait_bug_mitigation_count")) + (when (plusp count) + (format t "Bug mitigation strategy applied ~D time~:P~%" count) + (setf count 0))) + (sb-thread:join-thread watchdog-thread) + (when gc-thr + (sb-thread:join-thread gc-thr) + (format t "Trial ~d: GC'd ~d times (Elapsed=~f sec)~%" + (1+ trialno) *n-gcs* + (/ (- stop start) internal-time-units-per-second))))))) + +(with-test (:name :call-me-from-1-thread-no-gc + :skipped-on (or :interpreter)) + ;; smoke test and no GCing + (setq *print-greetings-and-salutations* t) + (f 1 1 1 nil) + (setq *print-greetings-and-salutations* nil)) + +(with-test (:name :call-me-from-many-threads-and-gc + :skipped-on (or :interpreter (and :x86 :win32))) + ;; two trials, 5 threads, 40 calls each + (f 2 5 40 t) + ;; one trial, 10 threads, 10 calls + (f 1 10 10 t) + ;; Crank the number of trials up if you're trying to investigate + ;; flakes in this test. The larger number of calls is usually + ;; what gets it to fail. + ;; 5 trials, 5 threads, 200 calls each + (f 5 5 200 t)) + +;;; The next test hasn't been made to run on windows, but should. +#+win32 (exit :code 104) + +;;; Check that you get an error trying to join a foreign thread +(defglobal *my-foreign-thread* nil) +(sb-alien::define-alien-callback tryjointhis int () + (setq *my-foreign-thread* sb-thread:*current-thread*) + (dotimes (i 10) + (write-char #\.) (force-output) + (sleep .01)) + 0) + +(defun tryjoiner () + (setq *my-foreign-thread* nil) + (sb-int:dx-let ((pthread (make-array 1 :element-type 'sb-vm:word))) + (alien-funcall + (extern-alien "pthread_create" + (function int system-area-pointer unsigned + system-area-pointer unsigned)) + (sb-sys:vector-sap pthread) 0 (alien-sap tryjointhis) 0) + (format t "Alien pthread is ~x~%" (aref pthread 0)) + (let (found) + (loop + (setq found *my-foreign-thread*) + (when found (return)) + (sleep .05)) + (format t "Got ~s~%" found) + (let ((result (handler-case (sb-thread:join-thread found) + (sb-thread:join-thread-error () 'ok)))) + (when (eq result 'ok) + ;; actually join it to avoid resource leak + (alien-funcall + (extern-alien "pthread_join" (function int unsigned unsigned)) + (aref pthread 0) + 0)) + (format t "Pthread joined ~s~%" found) + result)))) + +(with-test (:name :try-join-foreign-thread) + (assert (eq (tryjoiner) 'ok))) + diff -Nru sbcl-2.0.6/tests/finalize.impure.lisp sbcl-2.1.1/tests/finalize.impure.lisp --- sbcl-2.0.6/tests/finalize.impure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/finalize.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,131 @@ +#+interpreter (sb-ext:exit :code 104) +#+sb-safepoint (sb-ext:exit :code 104) ; tends to hang + +(defvar *tmp* 0.0) ; don't remove - used by the setq below +(defglobal *count* 0) +(declaim (fixnum *count*)) + +(defun foo (_) + (declare (ignore _)) + nil) + +(defglobal *maxdepth* 0) +;; Be gentler on 32-bit platforms +(defglobal *n-finalized-things* (or #+(and 64-bit (not sb-safepoint)) 20000 10000)) +(defglobal *weak-pointers* nil) + +(defun makejunk (_) + (declare (ignore _)) + (let ((x (gensym))) + (push (make-weak-pointer x) *weak-pointers*) + (finalize x (lambda () + (setq *maxdepth* + (max sb-kernel:*free-interrupt-context-index* + *maxdepth*)) + ;; cons 320K in the finalizer for #+64-bit, + ;; or 80K for #-64-bit + (setf *tmp* (make-list *n-finalized-things*)) + (sb-ext:atomic-incf *count*))) + x)) +(compile 'makejunk) + +(defun scrubstack () + (sb-int:dx-let ((b (make-array 20))) (eval b)) + (sb-sys:scrub-control-stack)) + +(defun run-consy-thing () + (dotimes (iter 10) + (let ((junk (mapcar #'makejunk + (make-list (/ *n-finalized-things* 10))))) + (setf junk (foo junk)) + (foo junk)) + (scrubstack) + (gc :full t))) + +; no threads - hope for the best with respect to conservative root retention +#-sb-thread (run-consy-thing) + +#+sb-thread +(progn + (sb-thread:join-thread (sb-thread:make-thread #'run-consy-thing)) + (gc :full t)) ; one more time to clean everything up + +;;; Verify that the thread was started. +#+sb-thread +(with-test (:name :finalizer-thread-started) + (assert (typep sb-impl::*finalizer-thread* 'sb-thread::thread)) + ;; We're going to assert on an approximate count of finalizers that ran, + ;; which is a bit sketchy. + ;; So call RUN-PENDING-FINALIZERS which actually does the work of helping out + ;; the finalizer thread. + ;; This also shows that it works to run finalization actions in two threads - + ;; the finalizer thread and this. Hence the need for ATOMIC-INCF on *count*. + (sb-impl::run-pending-finalizers) + + ;; Make sure the thread is done. + ;; This JOIN-THREADs it, so we know it's not executing. + (sb-impl::finalizer-thread-stop)) + +;;; This was failing with something like: +;;; The assertion (<= *MAXDEPTH* 1) failed with *MAXDEPTH* = 232. +;;; The test parameters for 64-bit are quite severe, but should not exhaust the heap. +(with-test (:name :finalizers-dont-nest-garbage-collections) + (assert (<= *maxdepth* 1))) + +;;; Regardless of anything else, check representational invariants. +;;; - each ID in the id-recycle-list is not a value in the hash-table +;;; - each value in the hash-table is not in the id-recycle-list +(with-test (:name :finalizer-id-uniqueness) + (let* ((hash-table (elt sb-impl::**finalizer-store** 1)) + (used-ids (loop for v being each hash-value of hash-table + collect v)) + (available-ids (cdr (elt sb-impl::**finalizer-store** 0)))) + (assert (null (intersection used-ids available-ids))))) + +(with-test (:name :finalizers-ran) + ;; expect that 97% of the finalizers ran + (assert (>= *count* (* *n-finalized-things* 97/100))) + (unless (= *count* *n-finalized-things*) + ;; show how the junk was reachable + (search-roots *weak-pointers* :print :verbose))) + +;;; For finalizers that didn't run (if any), we had better find +;;; that the object still exists in *weak-pointers*. +;;; Conversely, for each intact weak pointer, there had better be +;;; a finalizer for that object. +(with-test (:name :finalizer-state) + (setq *weak-pointers* + (delete-if (lambda (x) (null (weak-pointer-value x))) + *weak-pointers*)) + (let ((hash-table (elt sb-impl::**finalizer-store** 1))) + (loop for k being each hash-key of hash-table + when (and (symbolp k) (not (symbol-package k))) + do (assert (find k *weak-pointers* :key #'weak-pointer-value))) + (dolist (wp *weak-pointers*) + (assert (gethash (weak-pointer-value wp) hash-table))))) + +;;; A super-smart GC and/or compiler might prove that the object passed to +;;; FINALIZE is instantly garbage. Like maybe (FINALIZE (CONS 1 2) 'somefun) +;;; with the object otherwise unreachable. And so the system might reasonably +;;; call #'SOMEFUN right away. Hence it had better be a function so that the +;;; error isn't just shoved over to the finalizer thread. +;;; Also, as a special case caught by the general case, I'd rather not see NILs +;;; in the finalizer table, because NIL could never be defined as a function. +(with-test (:name :finalizer-funarg) + ;; The :no-function-conversion option in fndb was removed, for two reasons: + ;; - unlike with SET-MACRO-CHARACTER there is no "inquiry" function that you + ;; could use to determine what symbol was given as the funarg. + ;; Whereas I prefer lazy resolution in readtables because GET-MACRO-CHARACTER + ;; should return 'FUN if that's what you had set, and not #'FUN. + ;; - I can't particularly see anyone making the claim that a weird use such as + ;; (FINALIZE (CONS 1 2) 'STRING=))) should not emit e a warning about #'STRING= + ;; being funcalled with zero args when it should receive two. + (assert (nth-value 1 (compile nil '(lambda () (finalize (cons 1 2) 'string=))))) + ;; I make this mistake sometimes in GC testing - forgetting to wrap + ;; a FORMAT in a LAMBDA. So this had better fail early and often. + (assert-error (finalize (cons 'a 'b) (format t "The object died~%"))) + ;; This too, even if you think this is a little different, because + ;; you _could_ define this function. But it's not different. + ;; The attempted call to #'no-function-for-you may arbitrarily occur + ;; (in theory) as soon as the system is able to detect garbage. + (assert-error (finalize (cons 1 2) 'no-function-for-you))) diff -Nru sbcl-2.0.6/tests/finalize.test.sh sbcl-2.1.1/tests/finalize.test.sh --- sbcl-2.0.6/tests/finalize.test.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/finalize.test.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -#!/bin/sh -# -# This test is as convoluted as it is to avoid having failing tests -# hang the test-suite, as the typical failure mode used to be SBCL -# hanging uninterruptible in GC. - -. ./subr.sh - -use_test_subdirectory - -echo //entering finalize.test.sh - -# $! is not set correctly when calling run_sbcl, do it directly -"$SBCL_RUNTIME" --core "$SBCL_CORE" $SBCL_ARGS < /dev/null & -(defvar *tmp* 0.0) -(defvar *count* 0) - -(defun foo (_) - (declare (ignore _)) - nil) - -(let ((junk (mapcar (compile nil '(lambda (_) - (declare (ignore _)) - (let ((x (gensym))) - (finalize x (lambda () - ;; cons in finalizer - (setf *tmp* (make-list 10000)) - (incf *count*))) - x))) - (make-list 10000)))) - (setf junk (foo junk)) - (foo junk)) - -(gc :full t) -(gc :full t) -;; Stopping the finalizer thread ensures that queued finalizers execute. -;; [I don't think it's possible for it to stop before draining the queue, -;; but that isn't part of the contract with stopping. If this test fails, -;; try inserting a call to RUN-PENDING-FINALIZERS after this line] -#+sb-thread (sb-impl::finalizer-thread-stop) -;; FIXME: turns out, it does fail: -(sb-kernel:run-pending-finalizers) - -(if (= *count* 10000) - (with-open-file (f "finalize-test-passed" :direction :output) - (write-line "OK" f)) - (with-open-file (f "finalize-test-failed" :direction :output) - (format f "OOPS: ~A~%" *count*) - (sb-kernel:run-pending-finalizers) - (format f "After sb-kernel:run-pending-finalizers: ~A~%" *count*))) - -(sb-ext:quit) -EOF - -SBCL_PID=$! -WAITED=x - -echo "Waiting for SBCL to finish stress-testing finalizers" -while true; do - if [ -f finalize-test-passed ]; then - echo "OK" - rm finalize-test-passed - exit $EXIT_TEST_WIN - elif [ -f finalize-test-failed ]; then - wait - cat finalize-test-failed - rm finalize-test-failed - exit $EXIT_LOSE - fi - sleep 1 - WAITED="x$WAITED" - if [ $WAITED = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ]; then - echo - echo "timeout, killing SBCL" - kill -9 $SBCL_PID - exit $EXIT_LOSE # Failure, SBCL probably hanging in GC - fi -done - diff -Nru sbcl-2.0.6/tests/fin-threadsafety.impure.lisp sbcl-2.1.1/tests/fin-threadsafety.impure.lisp --- sbcl-2.0.6/tests/fin-threadsafety.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/fin-threadsafety.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -32,35 +32,33 @@ ;;; fruitful to concentrate their efforts around this test... (with-test (:name (:funcallable-instances) - :broken-on (or :win32 - (and :sb-safepoint - (not :c-stack-is-control-stack)))) + :broken-on (and :sb-safepoint (not :c-stack-is-control-stack))) ;; the funcallable-instance implementation used not to be threadsafe ;; against setting the funcallable-instance function to a closure ;; (because the code and lexenv were set separately). (let ((fun (sb-kernel:%make-funcallable-instance 0)) + (stop nil) (condition nil)) (setf (sb-kernel:%funcallable-instance-fun fun) #'closure-one) (flet ((changer () - (loop (setf (sb-kernel:%funcallable-instance-fun fun) #'closure-one) + (loop (sb-thread:barrier (:read)) + (when stop (return)) + (setf (sb-kernel:%funcallable-instance-fun fun) #'closure-one) (setf (sb-kernel:%funcallable-instance-fun fun) #'closure-two))) (test () - (handler-case (loop (funcall fun)) + (handler-case (loop (sb-thread:barrier (:read)) + (when stop (return)) + (funcall fun)) (serious-condition (c) (setf condition c))))) - (let ((changer (make-thread #'changer)) - (test (make-thread #'test))) - (handler-case - (progn + (let ((changer (make-thread #'changer :name "changer")) + (test (make-thread #'test :name "test"))) ;; The two closures above are fairly carefully crafted ;; so that if given the wrong lexenv they will tend to ;; do some serious damage, but it is of course difficult ;; to predict where the various bits and pieces will be ;; allocated. Five seconds failed fairly reliably on ;; both my x86 and x86-64 systems. -- CSR, 2006-09-27. - (sb-ext:with-timeout 5 - (wait-for-threads (list test))) - (error "~@" condition)) - (sb-ext:timeout () - (terminate-thread changer) - (terminate-thread test) - (wait-for-threads (list changer test)))))))) + (sleep 5) + (setq stop t) + (sb-thread:barrier (:write)) + (wait-for-threads (list changer test)))))) diff -Nru sbcl-2.0.6/tests/float.impure.lisp sbcl-2.1.1/tests/float.impure.lisp --- sbcl-2.0.6/tests/float.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/float.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -356,7 +356,13 @@ (dolist (op '(sin cos tan)) (dolist (val `(,(coerce most-positive-fixnum 'double-float) ,@(loop for v = most-positive-double-float - then (expt v 4/5) + ;; EXPT calls %POW which directly calls the libm pow() function. + ;; Some libm's might internally cause an *expected* overflow on + ;; certain inputs. So instead of computing an answer for + ;; (EXPT 1.7976931348623157d308 4/5) it would trap. + ;; I'll bet that's why we disabled the test on openbsd, + ;; but I don't care to find out. + then (sb-int:with-float-traps-masked (:overflow) (expt v 4/5)) while (> v (expt 2 50)) collect v) ;; The following values cover all eight combinations diff -Nru sbcl-2.0.6/tests/float.pure.lisp sbcl-2.1.1/tests/float.pure.lisp --- sbcl-2.0.6/tests/float.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/float.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -544,3 +544,55 @@ (the single-float (labels ((%f () (the real p1))) (%f))))) ((-96088.234) -1.0))) + +(with-test (:name :inline-signum) + (assert (ctu:find-named-callees ; should be a full call + (compile nil '(lambda (x) + (signum (truly-the number x)))))) + ;; should not be a full call + (dolist (type '(integer + (or (integer 1 10) (integer 50 90)) + rational + single-float + (or (single-float -10f0 0f0) (single-float 1f0 20f0)) + double-float + (or (double-float -10d0 0d0) (double-float 1d0 20d0)))) + (assert (null (ctu:find-named-callees + (compile nil `(lambda (x) + (signum (truly-the ,type x)))))))) + ;; check signed zero + (let ((f (compile nil '(lambda (x) (signum (the single-float x)))))) + (assert (eql (funcall f -0f0) -0f0)) + (assert (eql (funcall f +0f0) +0f0))) + (let ((f (compile nil '(lambda (x) (signum (the double-float x)))))) + (assert (eql (funcall f -0d0) -0d0)) + (assert (eql (funcall f +0d0) +0d0)))) + + +(with-test (:name :expt-double-no-complex) + (checked-compile-and-assert + (:allow-notes nil) + `(lambda (x y) + (> (expt (the double-float x) 4d0) + (the double-float y))) + ((1d0 0d0) t)) + (checked-compile-and-assert + (:allow-notes nil) + `(lambda (x y) + (> (expt (the (double-float 0d0) x) (the double-float y)) + y)) + ((1d0 0d0) t))) + +(with-test (:name :ftruncate-inline + :skipped-on (not :64-bit)) + (checked-compile + `(lambda (v d) + (declare (optimize speed) + (double-float d) + ((simple-array double-float (2)) v)) + (setf (aref v 0) (ffloor (aref v 0) d)) + v) + :allow-notes nil)) + +(with-test (:name :ctype-of-nan) + (checked-compile '(lambda () #.(sb-kernel:make-single-float -1)))) diff -Nru sbcl-2.0.6/tests/foreign-stack-alignment.impure.lisp sbcl-2.1.1/tests/foreign-stack-alignment.impure.lisp --- sbcl-2.0.6/tests/foreign-stack-alignment.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/foreign-stack-alignment.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -18,16 +18,18 @@ (import 'sb-alien::alien-lambda) (defun run (program &rest arguments) - (let* ((proc nil) - (output - (with-output-to-string (s) - (setf proc (run-program program arguments - :output s))))) + (let* ((stringstream (make-string-output-stream)) + (proc (run-program program arguments + :output stringstream :error sb-sys:*tty* + :search (or #+win32 t))) + (output (get-output-stream-string stringstream))) (unless (zerop (process-exit-code proc)) (error "Bad exit code: ~S~%Output:~% ~S" (process-exit-code proc) output)) output)) +(defun cc (&rest arguments) + (apply #'run #+unix "./run-compiler.sh" #+win32 "gcc" arguments)) (defvar *required-alignment* (or #+arm 8 @@ -36,29 +38,28 @@ #+(and ppc (not darwin)) 8 #+(or arm64 x86 x86-64 riscv ppc64) 16 #+sparc 8 - #+alpha 16 - #+hppa 64 (error "Unknown platform"))) ;;;; Build the offset-tool as regular excutable, and run it with ;;;; fork/exec, so that no lisp is on the stack. This is our known-good ;;;; number. -#-win32 +(defvar *exename* (format nil "stackalign-test~a" (or #+win32 ".exe" ""))) +(defvar *soname* (format nil "stackalign-test~a" (or #+win32 ".dll" ".so"))) + (progn - (run "/bin/sh" "run-compiler.sh" "-sbcl-pic" - "stack-alignment-offset.c" "-o" "stack-alignment-offset") + (cc #+unix "-sbcl-pic" "-o" *exename* "stack-alignment-offset.c") (defparameter *good-offset* - (parse-integer (run "./stack-alignment-offset" + (parse-integer (run (format nil "./~a" *exename*) (princ-to-string *required-alignment*)))) - + (format t "~s is ~d~%" '*good-offset* *good-offset*) ;; Build the tool again, this time as a shared object, and load it - (run "/bin/sh" "run-compiler.sh" "-sbcl-pic" "-sbcl-shared" - "stack-alignment-offset.c" "-o" "stack-alignment-offset.so") + #+unix (cc "-sbcl-shared" "-sbcl-pic" "-o" *soname* "stack-alignment-offset.c") + #+win32 (cc "-shared" "-o" *soname* "stack-alignment-offset.c") - (load-shared-object (truename "stack-alignment-offset.so")) + (load-shared-object (truename *soname*)) (define-alien-routine stack-alignment-offset int (alignment int)) #+alien-callbacks @@ -67,17 +68,16 @@ ;;;; Now get the offset by calling from lisp, first with a regular foreign function ;;;; call, then with an intervening callback. -(with-test (:name :regular :fails-on :win32) +(with-test (:name :regular) (assert (= *good-offset* (stack-alignment-offset *required-alignment*)))) #+alien-callbacks -(with-test (:name :callback :fails-on :win32) +(with-test (:name :callback) (assert (= *good-offset* (trampoline (alien-lambda int () (stack-alignment-offset *required-alignment*)))))) -(when (probe-file "stack-alignment-offset.so") - (delete-file "stack-alignment-offset") - (delete-file "stack-alignment-offset.so")) +(ignore-errors (delete-file *exename*)) +(ignore-errors (delete-file *soname*)) ;;;; success! diff -Nru sbcl-2.0.6/tests/foreign.test.sh sbcl-2.1.1/tests/foreign.test.sh --- sbcl-2.0.6/tests/foreign.test.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/foreign.test.sh 2021-01-30 11:22:39.000000000 +0000 @@ -137,6 +137,7 @@ # some constants in the functions), so that the test will fail if we accidentally # call the new bar() at the old address - as might happen if the OS maps both '.so' # files at the same place - as a consequence of failing to update the linkage table. +echo 'int bar(void);' >> $TEST_FILESTEM-b2.c echo 'int somerandomfun(int x) { return x?-x:bar(); }' >> $TEST_FILESTEM-b2.c echo 'int bar() { return 13; }' >> $TEST_FILESTEM-b2.c build_so $TEST_FILESTEM-b2 diff -Nru sbcl-2.0.6/tests/fun-names.pure.lisp sbcl-2.1.1/tests/fun-names.pure.lisp --- sbcl-2.0.6/tests/fun-names.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/fun-names.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -57,3 +57,15 @@ (assert (eq stored-doc doc))) (assert (string= (documentation closure t) (if (eq doc sb-pcl:+slot-unbound+) "doc" doc))))))) + +(with-test (:name :no-funcall-of-extended-name) + (multiple-value-bind (fun warnp errorp) + (checked-compile '(lambda (x y) (funcall '(setf foo) x y)) + :allow-warnings t) + (assert (and warnp errorp)) + (assert-error (funcall fun nil 1) type-error)) + (multiple-value-bind (fun warnp errorp) + (checked-compile '(lambda (x y) (multiple-value-call '(setf foo) x (floor y 2))) + :allow-warnings t) + (assert (and warnp errorp)) + (assert-error (funcall fun nil 1) type-error))) diff -Nru sbcl-2.0.6/tests/futex-wait.test.sh sbcl-2.1.1/tests/futex-wait.test.sh --- sbcl-2.0.6/tests/futex-wait.test.sh 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/futex-wait.test.sh 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,151 @@ +#!/bin/sh + +. ./subr.sh + +run_sbcl --noinform < /dev/null && ! strace ls > /dev/null 2>&1 ; then + exit $EXIT_TEST_WIN +fi + +set -e + +tracelog=`mktemp ${TMPDIR:-/tmp}/$TEST_FILESTEM.XXXXXX` + +strace -f -e futex -e signal=\!sigsegv -o $tracelog \ + $SBCL_RUNTIME --core "$SBCL_CORE" $SBCL_ARGS <1500 calls to futex_wait due to the bug +echo N was $n +exit 0 + +# SBCL had a bug in %%WAIT-FOR-MUTEX. This is an examination of why one should not +# endeavor to make the slightest alteration to researched and published code, +# potentially even so far as eschewing gratuitious abtractions such as introduction +# of symbolic constants that if anything make it difficult to compare against +# the reference algorithm. +# +# value of C as-is STATE value +# from top of PROG after futex-wait outcome +# ================ ================ ======= +# +# 1 1 same as reference algorithm +# after wait: cmpxchg(val,0,2) fails +# reference algorithm assigns C := 1 here. SBCL did not assign, +# but the value of C is that anyway. +# at retry : cmpxchg(val,1,2) suceeds +# +# ---------------------------------------------------------------------------- +# +# 2 1 extra futex_wait/wake cycles +# after wait: cmpxchg(val,0,2) fails +# reference algorithm assigns C := 1 here +# SBCL incorrectly omits the next cmpxchg, which was needed. +# at retry : cmpxchg(val,1,2) succeeds ; SBCL omits by mistake +# +# by omitting a required cmpxchg, the state is perceived as 2 when it isn't. +# futex_wait() returns EWOULDBLOCK. This cycle continues forever +# until the mutex is released. +# +# ---------------------------------------------------------------------------- +# +# 1 2 one extra cmpxchg +# after wait: cmpxchg(val,0,2) fails +# reference algorithm assigns C := 2 here but SBCL algorithm did not, +# therefore the reference algorithm does not attempt next cmpxchg. +# at retry : cmpxchg(val,1,2) fails ; this cmpxchg is not needed. +# +# ---------------------------------------------------------------------------- +# +# 2 2 +# after wait: cmpxchg(val,0,2) fails +# reference algorithm assigns C := 2 here. SBCL did not assign, +# but the value of C is that anyway. +# diff -Nru sbcl-2.0.6/tests/gc.impure-cload.lisp sbcl-2.1.1/tests/gc.impure-cload.lisp --- sbcl-2.0.6/tests/gc.impure-cload.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/gc.impure-cload.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -29,7 +29,7 @@ ;;; point of failure, in conservative_root_p() (with-test (:name :gc-region-pickup :skipped-on (not (or :x86 :x86-64)) ;; (and apparently can also fail on linux with larger card size) - :fails-on :win32) + :fails-on (and :win32 :x86)) (flet ((allocate-code-bytes (nbytes) ;; Make a code component occupying exactly NBYTES bytes in total. (assert (zerop (mod nbytes (* 2 sb-vm:n-word-bytes)))) @@ -168,6 +168,9 @@ (gc :gen 1) (assert (= (sb-kernel:generation-of *junk*) 1)) +;;; These aren't defined anywhere, just "implied" by gencgc-internal.h +(defconstant page-write-protect-bit #+big-endian 2 #+little-endian 5) + ;;; This test is very contrived, but this bug was observed in real life, ;;; having something to do with SB-PCL::CHECK-WRAPPER-VALIDITY. (with-test (:name :gc-anonymous-layout) @@ -177,7 +180,7 @@ (page (sb-vm::find-page-index (sb-kernel:get-lisp-obj-address foo))) (gen (slot (deref sb-vm::page-table page) 'sb-vm::gen)) (flags (slot (deref sb-vm::page-table page) 'sb-vm::flags)) - (wp (logbitp 3 flags)) + (wp (logbitp page-write-protect-bit flags)) (page-addr (+ sb-vm:dynamic-space-start (* sb-vm:gencgc-card-bytes page))) (aok t)) @@ -200,7 +203,8 @@ (assert (= (sb-kernel:generation-of (sb-kernel:%instance-layout foo)) 0)) ;; And the page with FOO must have gotten touched - (assert (not (logbitp 3 (slot (deref sb-vm::page-table page) 'sb-vm::flags)))) + (assert (not (logbitp page-write-protect-bit + (slot (deref sb-vm::page-table page) 'sb-vm::flags)))) ;; It requires *two* GCs, not one, to cause this bug. ;; The first GC sees that the page with the FOO on it was touched, @@ -213,7 +217,8 @@ #+nil (format t "~&page ~d: wp=~a~%" page - (logbitp 3 (slot (deref sb-vm::page-table page) 'sb-vm::flags))) + (logbitp page-write-protect-bit + (slot (deref sb-vm::page-table page) 'sb-vm::flags))) ;; This GC would fail in the verify step because it trashes the apparently ;; orphaned layout, which actually does have a referer. diff -Nru sbcl-2.0.6/tests/gc.impure.lisp sbcl-2.1.1/tests/gc.impure.lisp --- sbcl-2.0.6/tests/gc.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/gc.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -139,6 +139,31 @@ (let ((thread (sb-thread:make-thread (lambda () (sb-ext:gc))))) (loop while (sb-thread:thread-alive-p thread))))) +(defglobal *some-object-handles* nil) +(defun make-some-objects () + (declare (notinline format)) + (let* ((string-one (format nil "~a~a~a" "pot" "ayt" "o")) + (string-two (concatenate 'string "two " string-one)) + (afunction + (let (#+immobile-space (sb-c::*compile-to-memory-space* :dynamic)) + (compile nil `(sb-int:named-lambda ,string-two (x) (coerce x 'float)))))) + (setq *some-object-handles* + (list (sb-kernel:get-lisp-obj-address afunction) + (sb-kernel:get-lisp-obj-address string-one) + (sb-kernel:get-lisp-obj-address string-two))))) +#+gencgc +(with-test (:name :pin-all-code-with-gc-enabled) + #+sb-thread (sb-thread:join-thread (sb-thread:make-thread #'make-some-objects)) + #-sb-thread (progn (make-some-objects) (sb-sys:scrub-control-stack)) + (sb-sys:with-code-pages-pinned (:dynamic) (gc)) + ;; this should not fail to find FUN at its old address + (let ((fun (sb-kernel:make-lisp-obj (first *some-object-handles*)))) + ;; this should fail to find a string at its old address + (assert (not (nth-value 1 (sb-kernel:make-lisp-obj (second *some-object-handles*) nil)))) + ;; this should similarly fail- STRING-TWO was transitively reachable but movable + (assert (not (nth-value 1 (sb-kernel:make-lisp-obj (third *some-object-handles*) nil)))) + (assert (string= (sb-kernel:%simple-fun-name fun) "two potayto")))) + (with-test (:name :without-gcing) (let ((gc-happend nil)) (push (lambda () (setq gc-happend t)) sb-ext:*after-gc-hooks*) @@ -219,12 +244,13 @@ :skipped-on :cheneygc) ;; The interpreters (both sb-eval and sb-fasteval) special-case ;; WITH-PINNED-OBJECTS as a "special form", because the x86oid - ;; version of WITH-PINNED-OBJECTS uses black magic that isn't - ;; supportable outside of the compiler. The non-x86oid versions of - ;; WITH-PINNED-OBJECTS don't use black magic, but are overridden - ;; anyway. But the special-case logic was, historically broken, and - ;; this affects all gencgc targets (cheneygc isn't affected because - ;; cheneygc WITH-PINNED-OBJECTS devolves to WITHOUT-GC>ING). + ;; version of WITH-PINNED-OBJECTS uses special functionality that + ;; isn't supportable outside of the compiler. The non-x86oid + ;; versions of WITH-PINNED-OBJECTS don't use this special + ;; functionality, but are overridden anyway. But the special-case + ;; logic was, historically broken, and this affects all gencgc + ;; targets (cheneygc isn't affected because cheneygc + ;; WITH-PINNED-OBJECTS devolves to WITHOUT-GCING). ;; ;; Our basic approach is to allocate some kind of object and stuff ;; it where it doesn't need to be on the control stack. We then pin @@ -313,7 +339,7 @@ (sb-vm:map-allocated-objects (lambda (obj type size) (declare (ignore type size)) - (when (>= (sb-vm::primitive-object-size obj) (* 4 sb-vm:gencgc-card-bytes)) + (when (>= (sb-ext:primitive-object-size obj) (* 4 sb-vm:gencgc-card-bytes)) (let* ((addr (sb-kernel:get-lisp-obj-address obj)) (pte (deref sb-vm:page-table (sb-vm:find-page-index addr)))) (when (eq (slot pte 'sb-vm::gen) sb-vm:+pseudo-static-generation+) @@ -322,7 +348,7 @@ (assert (logbitp 4 type))))))) :all)) -(with-test (:name :unique-code-serialno) +(with-test (:name :unique-code-serialno :skipped-on :interpreter) (let ((a (make-array 100000 :element-type 'bit :initial-element 0))) (sb-vm:map-allocated-objects (lambda (obj type size) @@ -361,6 +387,24 @@ (return))) (sb-thread:join-thread gc-thread))) +(defun parse-address-range (line) + ;; I hope nothing preceding the match of "00-" could be a false positive. + ;; If there is, I suspect we should parse the legend that contains + ;; "REGION TYPE START - END" to determine the column + ;; with a #\- which appears consistently in the same place on each following line. + (let ((pos (search "00-" line))) + (assert pos) + (let* ((separator (+ pos 2)) ; position of the #\- + (start separator)) + (loop (if (digit-char-p (char line (1- start)) 16) (decf start) (return))) + (values (parse-integer line :start start :end separator :radix 16) + (multiple-value-bind (value end) + (parse-integer line :start (1+ separator) :radix 16 :junk-allowed t) + (assert (and (> end (+ separator 3)) + (or (= end (length line)) + (char= (char line end) #\space)))) + value))))) + (defun get-shared-library-maps () (let (result) #+linux @@ -383,14 +427,11 @@ (assert (search "REGION TYPE" (read-line s))) (loop (let ((line (read-line s))) (when (zerop (length line)) (return)) + ;; Look for lines that look like + ;; "{mumble} 7fff646c8000-7fff646ca000 {mumble}.dylib" (when (search ".dylib" line) - (let ((c (search "00-00" line))) - (assert c) - (let ((start (parse-integer line :start (+ c 2 (- 16)) :radix 16 - :junk-allowed t)) - (end (parse-integer line :start (+ c 3) :radix 16 - :junk-allowed t))) - (push `(,start . ,end) result))))))) + (multiple-value-bind (start end) (parse-address-range line) + (push `(,start . ,end) result)))))) (process-wait p)) result)) @@ -399,7 +440,8 @@ ;;; Verify that it works fine while invoking GC in another thread ;;; despite removal of the mysterious WITHOUT-GCING. #+sb-thread -(with-test (:name :sap-foreign-symbol-no-deadlock) +(with-test (:name :sap-foreign-symbol-no-deadlock + :skipped-on :interpreter) ;; needlessly slow when interpreted (let* ((worker-thread (sb-thread:make-thread (lambda (ranges) @@ -419,7 +461,7 @@ (gc-thread (sb-thread:make-thread (lambda () - (loop while working do (gc) (sleep .001)))))) + (loop while working do (gc) (sleep .01)))))) (sb-thread:join-thread worker-thread) (setq working nil) (sb-thread:join-thread gc-thread))) @@ -427,10 +469,85 @@ (with-test (:name :no-conses-on-large-object-pages) (let* ((fun (checked-compile '(lambda (&rest params) params))) (list (make-list #+gencgc (/ sb-vm:large-object-size - (sb-vm::primitive-object-size '(1)) + (sb-ext:primitive-object-size '(1)) 1/2) #-gencgc 16384)) (rest (apply fun list))) (sb-sys:with-pinned-objects (rest) (sb-ext:gc :full t) (assert (and (equal list rest) t))))) + +(defun use-up-thread-region () + ;; cons until the thread-local allocation buffer uses up a page + (loop + (let* ((c (cons 1 2)) + (end (+ (sb-kernel:get-lisp-obj-address c) + (- sb-vm:list-pointer-lowtag) + (* 2 sb-vm:n-word-bytes)))) + (when (zerop (logand end (1- sb-vm:gencgc-card-bytes))) + (return))))) +(defglobal *go* nil) + +#+sb-thread +(with-test (:name :c-call-save-p :skipped-on :interpreter) + (let* ((fun (compile nil '(lambda (a b c d e f g h i j k l m) + (declare (optimize (sb-c::alien-funcall-saves-fp-and-pc 0))) + (setq *go* t) + #+win32 + (alien-funcall (extern-alien "Sleep" (function void int)) 300) + #-win32 + (alien-funcall (extern-alien "sb_nanosleep" (function void int int)) 0 300000000) + (values a b c d e f g h i j k l m)))) + (thr (sb-thread:make-thread (lambda () + (let ((args #1=(list (LIST 'A) (LIST 'B) (LIST 'C) + (LIST 'D) (LIST 'E) (LIST 'F) (LIST 'G) + (LIST 'H) (LIST 'I) (LIST 'J) (LIST 'K) + (LIST 'L) (LIST 'M)))) + (use-up-thread-region) + (apply fun + args)))))) + (loop (sb-thread:barrier (:read)) + (if *go* (return)) + (sleep .1)) + (gc) + (assert (equal (multiple-value-list (sb-thread:join-thread thr)) #1#)))) + +#+gencgc +(progn +(defun code-iterator (how) + (let ((n 0) (tot-bytes 0)) + (sb-int:dx-flet ((visit (obj type size) + (declare (ignore obj)) + (when (= type sb-vm:code-header-widetag) + (incf n) + (incf tot-bytes size)))) + (ecase how + (:slow (sb-vm:map-allocated-objects #'visit :dynamic)) + (:fast (sb-vm::walk-dynamic-space #'visit #x7f 3 3))) + (values n tot-bytes)))) +(compile 'code-iterator) + +(with-test (:name :code-iteration-fast) + (sb-int:binding* (((slow-n slow-bytes) (code-iterator :slow)) + ((fast-n fast-bytes) (code-iterator :fast))) + ;; Fast should be 20x to 50x faster than slow, but that's kinda sensitive + ;; to the machine and can't be reliably asserted. + (assert (= slow-n fast-n)) + (assert (= slow-bytes fast-bytes))))) + +(defglobal *wp-for-signal-handler-gc-test* nil) +#+(and gencgc unix sb-thread) +(with-test (:name :signal-handler-gc-test) + (sb-thread:join-thread + (sb-thread:make-thread + (lambda () + (let ((foo (make-symbol "hey"))) + (setf *wp-for-signal-handler-gc-test* (make-weak-pointer foo)) + (sb-sys:enable-interrupt + 23 + (lambda (&rest x) (declare (ignore x)) (constantly foo))))))) + (sb-ext:gc :gen 7) + ;; If fullcgc fails to see the closure that is installed as a signal handler + ;; (actually a closure around a closure) then the weak pointer won't survive. + ;; Was broken in https://sourceforge.net/p/sbcl/sbcl/ci/04296434 + (assert (weak-pointer-value *wp-for-signal-handler-gc-test*))) diff -Nru sbcl-2.0.6/tests/genmakefile.lisp sbcl-2.1.1/tests/genmakefile.lisp --- sbcl-2.0.6/tests/genmakefile.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/genmakefile.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,15 @@ +;;; +;;; invocation: "$SBCL --script genmakefile.lisp >Makefile" +;;; +(let ((files (append (directory "*.test.sh") + (directory "*.*pure*.lisp")))) + (format t "~%all:") + (dolist (file (mapcar 'pathname-name files)) + (format t " \\~% $(LOGDIR)/~a.log" file)) + (terpri) + (terpri) + (dolist (file files) + (let ((in (format nil "~a.~a" (pathname-name file) (pathname-type file))) + (out (format nil "$(LOGDIR)/~a.log" (pathname-name file)))) + (format t "~a: ~a~%~a./run-tests.sh ~a >~a 2>&1~%" + out in #\tab in out)))) diff -Nru sbcl-2.0.6/tests/hash-cache.impure.lisp sbcl-2.1.1/tests/hash-cache.impure.lisp --- sbcl-2.0.6/tests/hash-cache.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/hash-cache.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -1,6 +1,7 @@ ;;; FIXME: Since timeouts do not work on Windows this would loop ;;; forever. -(with-test (:name (:hash-cache :interrupt) :skipped-on :win32) +(with-test (:name (:hash-cache :interrupt) + :skipped-on (or :win32 (:and :darwin :sb-safepoint))) (let* ((type1 (random-type 500)) (type2 (random-type 500)) (wanted (subtypep type1 type2))) diff -Nru sbcl-2.0.6/tests/hash.impure.lisp sbcl-2.1.1/tests/hash.impure.lisp --- sbcl-2.0.6/tests/hash.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/hash.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -524,4 +524,28 @@ (assert (= empty (psxhash (make-rslotty :cdf #c(0d0 -0d0))))) (assert (= empty (psxhash (make-rslotty :cdf #c(-0d0 0d0))))))) +(defun my= (a b) (= a b)) +(defun fixnum-hash (x) (sxhash (the fixnum x))) +(defun fixnum-hash-worse (x) (logand (sxhash (the fixnum x)) 7)) +(define-hash-table-test my= fixnum-hash) + +(with-test (:name :hash-fun-is-function-designator) + ;; Users shouldn't write this baroque expression to make an EQL table. + (assert-error (make-hash-table :hash-function nil)) + ;; nor this + (assert-error (make-hash-table :test #'eql :hash-function nil)) + ;; :TEST, if unknown, does not imply a hash function + ;; even when it looks like it could. + (assert-error (make-hash-table :test #'=)) + ;; and of course this doesn't work either because the preceding doesn't + (assert-error (make-hash-table :test #'= :hash-function nil)) + ;; Try user functions + (let ((h (make-hash-table :test 'my=))) + (assert (eq (sb-impl::hash-table-hash-fun h) #'fixnum-hash))) + (let ((h (make-hash-table :test 'my= :hash-function 'fixnum-hash-worse))) + (assert (eq (sb-impl::hash-table-hash-fun h) #'fixnum-hash-worse))) + (let ((h (make-hash-table :test 'my= :hash-function #'fixnum-hash-worse))) + (assert (eq (sb-impl::hash-table-hash-fun h) #'fixnum-hash-worse))) + (assert-error (make-hash-table :test 'my= :hash-function nil))) ; no good + ;;; success diff -Nru sbcl-2.0.6/tests/hash.pure.lisp sbcl-2.1.1/tests/hash.pure.lisp --- sbcl-2.0.6/tests/hash.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/hash.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -211,7 +211,7 @@ (setf (gethash #\a tbl) 1) #+64-bit (setf (gethash 1.0f0 tbl) 1) ; single-float is a nonpointer (let ((data (sb-kernel:get-header-data (sb-impl::hash-table-pairs tbl)))) - (assert (not (logtest data sb-vm:vector-addr-hashing-subtype)))))) + (assert (not (logtest data sb-vm:vector-addr-hashing-flag)))))) (with-test (:name (hash-table :small-rehash-size)) (let ((ht (make-hash-table :rehash-size 2))) @@ -227,10 +227,10 @@ ;; verify that EQ hashing on symbols is address-sensitive (let ((h (make-hash-table :test 'eq))) (setf (gethash 'foo h) 1) - (assert (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-subtype))) + (assert (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-flag))) (let ((h (make-hash-table :test 'eq :hash-function 'sb-kernel:symbol-hash))) (setf (gethash 'foo h) 1) - (assert (not (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-subtype)))) + (assert (not (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-flag)))) ;; Verify that any standard hash-function on a function is address-sensitive, ;; but a custom hash function makes it not so. @@ -240,13 +240,13 @@ (dolist (test '(eq eql equal equalp)) (let ((h (make-hash-table :test test))) (setf (gethash #'car h) 1) - (assert (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-subtype))) + (assert (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-flag))) (let ((h (make-hash-table :test test :hash-function (lambda (x) (sb-kernel:%code-serialno (sb-kernel:fun-code-header x)))))) (setf (gethash #'car h) 1) - (assert (not (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-subtype))))))) + (assert (not (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-flag))))))) (defun hash-table-freelist (tbl) (sb-int:named-let chain ((index (sb-impl::hash-table-next-free-kv tbl))) @@ -271,6 +271,7 @@ ;; Ensure the values remain outside of the stack pointer for scrub-control-stack to work (declare (notinline f)) (f)) + (eval nil) (sb-sys:scrub-control-stack) (gc) ;; There were 20 items REMHASHed plus the freelist contains a pointer diff -Nru sbcl-2.0.6/tests/hash-table.impure.lisp sbcl-2.1.1/tests/hash-table.impure.lisp --- sbcl-2.0.6/tests/hash-table.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/hash-table.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -30,7 +30,7 @@ (defun is-address-sensitive (tbl) (let ((data (sb-kernel:get-header-data (sb-impl::hash-table-pairs tbl)))) - (logtest data sb-vm:vector-addr-hashing-subtype))) + (logtest data sb-vm:vector-addr-hashing-flag))) (with-test (:name (hash-table :eql-hash-symbol-not-eq-based)) ;; If you ask for #'EQ as the test, then everything is address-sensitive, @@ -105,7 +105,7 @@ (dotimes (i 100) (setf (gethash i h) (- i))) (assert (= (sb-kernel:get-header-data (sb-impl::hash-table-pairs h)) - sb-vm:vector-hashing-subtype)))) + sb-vm:vector-hashing-flag)))) (defmacro kv-vector-needs-rehash (x) `(svref ,x 1)) ;;; EQL tables no longer get a hash vector, so the GC has to decide @@ -121,14 +121,14 @@ (let ((key (make-symbol (make-string (1+ i) :initial-element #\a)))) (setf (gethash key tbl) (sb-kernel:get-lisp-obj-address key)))) (assert (= (sb-kernel:get-header-data (sb-impl::hash-table-pairs tbl)) - sb-vm:vector-hashing-subtype)) ; noo address-based key + sb-vm:vector-hashing-flag)) ; noo address-based key (let ((foo (cons 0 0))) (setf (gethash foo tbl) foo) (remhash foo tbl)) ;; now we've added an address-based key (but removed it) (assert (= (sb-kernel:get-header-data (sb-impl::hash-table-pairs tbl)) - (+ sb-vm:vector-addr-hashing-subtype - sb-vm:vector-hashing-subtype))) + (+ sb-vm:vector-addr-hashing-flag + sb-vm:vector-hashing-flag))) (gc) (let ((n-keys-moved 0)) (maphash (lambda (key value) @@ -142,8 +142,8 @@ (sb-impl::hash-table-pairs tbl))))) ;; the vector type is unchanged (assert (= (sb-kernel:get-header-data (sb-impl::hash-table-pairs tbl)) - (+ sb-vm:vector-addr-hashing-subtype - sb-vm:vector-hashing-subtype))) + (+ sb-vm:vector-addr-hashing-flag + sb-vm:vector-hashing-flag))) (setf (gethash (cons 1 2) tbl) 'one) (setf (gethash (cons 3 4) tbl) 'two) (setf (gethash (cons 5 6) tbl) 'three) @@ -171,7 +171,7 @@ (assert (not (gethash '(foo) tbl))) (assert (= (sb-kernel:get-header-data (sb-impl::hash-table-pairs tbl)) ;; Table is no longer address-sensitive - sb-vm:vector-hashing-subtype)))) + sb-vm:vector-hashing-flag)))) (defun actually-address-sensitive-p (ht) (let* ((hashfun (sb-impl::hash-table-hash-fun ht)) @@ -202,3 +202,32 @@ (with-test (:name :weak-hash-table-with-explicit-lock) (let ((h (make-hash-table :weakness :key))) (with-locked-hash-table (h) (setf (gethash 'foo h) 1)))) + +(with-test (:name :hash-table-iterator-no-notes) + (let ((f + (checked-compile + '(lambda (h) + (declare (optimize speed)) + (let ((n 0)) + (declare (fixnum n)) + ;; Silly test - count items, unrolling by 2 + (with-hash-table-iterator (iter h) + (loop + (let ((a (iter))) + (unless a (return))) + (let ((a (iter))) + (unless a + (incf n) + (return))) + (incf n 2))) + n)) + :allow-notes nil))) + ;; Test F + (maphash (lambda (classoid layout) + (declare (ignore layout)) + (let ((subclasses + (sb-kernel:classoid-subclasses classoid))) + (when (hash-table-p subclasses) + (assert (= (hash-table-count subclasses) + (funcall f subclasses)))))) + (sb-kernel:classoid-subclasses (sb-kernel:find-classoid 't))))) diff -Nru sbcl-2.0.6/tests/heap-reloc/embiggen.lisp sbcl-2.1.1/tests/heap-reloc/embiggen.lisp --- sbcl-2.0.6/tests/heap-reloc/embiggen.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/heap-reloc/embiggen.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -;;; Arrange so that all layouts have bignums as their bitmap, -;;; for exercising the C instance scavenging code. -;;; -;;; The use of a hashtable here was supposed end up with some layouts -;;; whose bitmap is at a lower address than the layout itself. -;;; This should randomize scavenging such that it sometimes sees -;;; a layout-bitmap that was already forwarded. -;;; However it doesn't work as desired; something else will have -;;; to be done to force that to happen. -;;; -;;; This test can't be run with immobile space enabled -;;; due simply to the assertion that instances in immobile space -;;; (which all happen to be layouts at the moment) -;;; do not have bignum bitmaps, which is true because a LAYOUT -;;; does not have enough slots to warrant a bignum bitmap. -;;; -;;; But the test's entire purpose is to assign noncanonical bignums -;;; (that are equivalent to fixnums) into every layout. -;;; -#-(or immobile-space (and));; FIXME: it's breaking something -(let ((ht (make-hash-table :test 'eql))) - (flet ((bignumify (int) - (or (gethash int ht) - (setf (gethash int ht) - (if (typep int 'fixnum) - (sb-bignum:make-small-bignum int) - int))))) - (sb-vm:map-allocated-objects - (lambda (obj type size) - (declare (ignore type size)) - (when (and (typep obj 'sb-kernel:layout) - (typep (sb-kernel:layout-bitmap obj) 'fixnum)) - (let ((flags (sb-kernel:layout-flags obj))) - (setf (sb-kernel:layout-bitmap obj) - (if (logtest (logior sb-kernel:+condition-layout-flag+ - sb-kernel:+pcl-object-layout-flag+) - flags) - ;; *** this is bogus, since conditions have an arbitrary - ;; number of slots, and need the special case of "all 1s" - ;; But it's ok as a test. - (1- (ash 1 99)) - (bignumify - (let ((bitmap (sb-kernel:layout-bitmap obj))) - (if (/= bitmap -1) - bitmap - (let ((len (sb-kernel:layout-length obj))) - ;; force the 0th bit to 1, for the layout - ;; (Shouldn't LENGTH be right? Doesn't seem to be) - (logior #-compact-instance-header 1 - (1- (ash 1 len))))))))) - (unless (plusp (length (sb-kernel:layout-equalp-tests obj))) - (let ((n (- (sb-kernel:layout-length obj) sb-vm:instance-data-start))) - (when (>= n 0) - (setf (sb-kernel:layout-equalp-tests obj) - (make-array n :initial-element 0)))))))) - :all))) diff -Nru sbcl-2.0.6/tests/hide-packages.test.sh sbcl-2.1.1/tests/hide-packages.test.sh --- sbcl-2.0.6/tests/hide-packages.test.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/hide-packages.test.sh 2021-01-30 11:22:39.000000000 +0000 @@ -60,7 +60,6 @@ ;;; That it doesn't pass doesn't mean the packages aren't hidden correctly. ;;; It just means the test is inadequate. #-(or x86 x86-64) (exit) -#-sb-thread (exit) ;; doesn't pass for some reason #+sb-devel (exit) ;;; Does not pass with interpreter @@ -88,7 +87,8 @@ (let ((name (package-name package))) (rename-package name (concatenate 'string "HIDDEN-" name))))) ;; The package hashtable lazily removes keys. Force it do to do so now. - (sb-impl::%rebuild-package-names sb-kernel::*package-names*)) + (sb-impl::%rebuild-package-names sb-kernel::*package-names*) + (sb-sys:scrub-control-stack)) ;;; Place all the strings we want to search for onto the stack. ;;; This little rearrangement here is a hack which causes the last item in diff -Nru sbcl-2.0.6/tests/icf-smoketest.impure-cload.lisp sbcl-2.1.1/tests/icf-smoketest.impure-cload.lisp --- sbcl-2.0.6/tests/icf-smoketest.impure-cload.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/icf-smoketest.impure-cload.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,7 @@ +(eval '(defun hhh () 92)) +(defvar f #'hhh) +(unintern 'hhh) +(eval '(defun hhh () 92)) +;;; Ensure no crash on (FIND-PACKAGE (SYMBOL-PACKAGE NIL)) if two functions +;;; are identical and one is named by an uninterned symbol. +(fold-identical-code :aggressive t) diff -Nru sbcl-2.0.6/tests/immobile-space.impure.lisp sbcl-2.1.1/tests/immobile-space.impure.lisp --- sbcl-2.0.6/tests/immobile-space.impure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/immobile-space.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,46 @@ + +#-immobile-space (sb-ext:exit :code 104) + +(defstruct trythis a) + +;;; Assign a bitmap that is not the special case for "all tagged" +;;; but does correctly indicate 1 tagged slot. +(let* ((l (sb-kernel:find-layout 'trythis)) + (slot (1- (sb-kernel:%instance-length l)))) + (assert (eql (sb-kernel:%raw-instance-ref/signed-word l slot) + sb-kernel:+layout-all-tagged+)) + (setf (sb-kernel:%raw-instance-ref/word l slot) 1)) + +(defun ll-alloc () + ;; This must be in its own function because the vop preserves no registers + ;; when calling to C. + (values(sb-sys:%primitive + sb-vm::alloc-immobile-fixedobj + 8 ; an unused sized class + 2 ; physical words + (logior (ash 1 sb-vm:instance-length-shift) + sb-vm:instance-widetag)))) +(compile 'll-alloc) ; low level allocator +(defun make () + (let ((inst (ll-alloc))) + (setf (sb-kernel:%instance-layout (truly-the trythis inst)) + (sb-kernel:find-layout 'trythis)) + (setf (trythis-a inst) (copy-seq "Hello")) + inst)) + +(setf (extern-alien "verify_gens" char) 0) +(compile 'make) +(defglobal things (loop repeat 5 collect (make))) +;;; promote THINGS to gen 1 so that we can make them +;;; point to something younger. +(gc :gen 1) +(assert (eql (sb-kernel:generation-of (car things)) 1)) +(setf (trythis-a (car things)) "wat") + +;;; This next GC doesn't incur a bug (though that's maybe surprising), +;;; but the final one would if this one leaves a page protection bit +;;; in a wrong state such that an old->young pointer is missed next time. +(gc :gen 2) +(print things) +(setf (trythis-a (car things)) "anewstring") +(gc) diff -Nru sbcl-2.0.6/tests/info.before-xc.lisp sbcl-2.1.1/tests/info.before-xc.lisp --- sbcl-2.0.6/tests/info.before-xc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/info.before-xc.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -19,7 +19,7 @@ ;;; It's possible in general for a constant to have the value NIL, but ;;; not for vector-data-offset, which must be a number: -(assert (constantp 'sb-vm:vector-data-offset)) +(assert (cl:constantp 'sb-vm:vector-data-offset)) (assert (integerp (symbol-value 'sb-vm:vector-data-offset))) (in-package "SB-IMPL") diff -Nru sbcl-2.0.6/tests/input-manifest.lisp-expr sbcl-2.1.1/tests/input-manifest.lisp-expr --- sbcl-2.0.6/tests/input-manifest.lisp-expr 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/input-manifest.lisp-expr 2021-01-30 11:22:39.000000000 +0000 @@ -1,6 +1,10 @@ +;;; This comment might make sourceforge stop thinking that the file +;;; is binary its diff view. +;;; Or not. (("aprof.impure.lisp" "src/code/aprof.lisp" "src/code/shaketree.lisp") + ("avltree.pure.lisp" "tests/bbtree-test-util.lisp") ("bit-vector.impure.lisp" "contrib/sb-posix.fasl") ("case.pure.lisp" "tests/case-test.lisp") ("chill.test.sh" @@ -37,6 +41,8 @@ ("debug.impure.lisp" "tests/bug-414.lisp") ("defstruct.impure-cload.lisp" "tests/block-compile-defstruct-test.lisp") ("elfcore.test.sh" "src/runtime/shrinkwrap-sbcl") + ("exit-hang.impure.lisp" "tests/fcb-threads.so") + ("fcb-threads.impure.lisp" "tests/fcb-threads.so") ("init.test.sh" "contrib/sb-introspect.fasl" "tests/custom-sysinit.lisp" @@ -52,6 +58,7 @@ ("octets.pure.lisp" "tests/data/compile-file-pos.lisp" "tests/data/compile-file-pos-utf16be.lisp") + ("redblack.pure.lisp" "tests/bbtree-test-util.lisp") ("run-program.impure.lisp" "contrib/sb-posix.fasl") ("signals.impure.lisp" "contrib/sb-posix.fasl") ("stream.impure.lisp" "contrib/sb-posix.fasl") @@ -83,4 +90,6 @@ "tests/data/SentenceBreakProperty.txt") ("undefined-classoid-bug.test.sh" "tests/undefined-classoid-bug-1.lisp" - "tests/undefined-classoid-bug-2.lisp")) + "tests/undefined-classoid-bug-2.lisp") + ("x86-64-codegen.impure.lisp" + "tests/typep-golden-data.txt")) diff -Nru sbcl-2.0.6/tests/interface.pure.lisp sbcl-2.1.1/tests/interface.pure.lisp --- sbcl-2.0.6/tests/interface.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/interface.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -53,6 +53,13 @@ (length (apropos-list "" "SB-VM" t)) (length (apropos-list "" "SB-VM"))))) +(with-test (:name :apropos-symbol-values) + (let ((string + (with-output-to-string (*standard-output*) + (apropos "*print-")))) + (assert (search "=" string)) + (assert (search "PPRINT-DISPATCH" string)))) + ;;; TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE and ;;; UPGRADED-COMPLEX-PART-TYPE should be able to deal with NIL as an ;;; environment argument @@ -108,7 +115,8 @@ :timeout))))) ;;; SLEEP should work with large integers as well -(with-test (:name (sleep :pretty-much-forever)) +(with-test (:name (sleep :pretty-much-forever) + :skipped-on (:and :darwin :sb-safepoint)) ; hangs (assert (eq :timeout (handler-case (sb-ext:with-timeout 1 diff -Nru sbcl-2.0.6/tests/join-thread-timeout.impure.lisp sbcl-2.1.1/tests/join-thread-timeout.impure.lisp --- sbcl-2.0.6/tests/join-thread-timeout.impure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/join-thread-timeout.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,23 @@ +(use-package "SB-THREAD") + +(with-test (:name (:join-thread :timeout) + :broken-on :sb-safepoint + :skipped-on (not :sb-thread)) + (macrolet ((delta-t () '(/ (- (get-internal-real-time) begin) + internal-time-units-per-second))) + (let ((thr (sb-thread:make-thread (lambda () (sleep 10)) :name "thr1")) + (begin (get-internal-real-time))) + (assert-error(join-thread thr :timeout 0.01) join-thread-error) + ;; should not have taken more than 1/10th sec. (and that's being generous) + (assert (< (delta-t) 1/10)) + (sb-thread:terminate-thread thr)) + (let ((cookie (cons t t)) + (thr (sb-thread:make-thread (lambda () (sleep 10)) :name "thr2")) + (begin (get-internal-real-time))) + (assert (eq cookie (join-thread thr :timeout 0.01 :default cookie))) + (assert (< (delta-t) 1/10)) + (sb-thread:terminate-thread thr))) + ;; KLUDGE: JOIN-THREAD would signal an error if the victim threads already indicated + ;; "aborted" status (by failing to store a list of values), so just give them time + ;; to relax and unwind and remove themselves from *ALL-THREADS* + (sleep .25)) diff -Nru sbcl-2.0.6/tests/join-thread-timeout.pure.lisp sbcl-2.1.1/tests/join-thread-timeout.pure.lisp --- sbcl-2.0.6/tests/join-thread-timeout.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/join-thread-timeout.pure.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -(use-package "SB-THREAD") - -(with-test (:name (:join-thread :timeout) - :skipped-on (not :sb-thread)) - (assert-error - (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01) - join-thread-error) - (let ((cookie (cons t t))) - (assert (eq cookie - (join-thread (make-join-thread (lambda () (sleep 10))) - :timeout 0.01 - :default cookie))))) diff -Nru sbcl-2.0.6/tests/kill-non-lisp-thread.c sbcl-2.1.1/tests/kill-non-lisp-thread.c --- sbcl-2.0.6/tests/kill-non-lisp-thread.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/kill-non-lisp-thread.c 2021-01-30 11:22:39.000000000 +0000 @@ -18,5 +18,5 @@ perror("pthread_create"); exit(1); } - pthread_kill(kid, SIGPIPE); + pthread_kill(kid, SIGURG); } diff -Nru sbcl-2.0.6/tests/kill-non-lisp-thread.impure.lisp sbcl-2.1.1/tests/kill-non-lisp-thread.impure.lisp --- sbcl-2.0.6/tests/kill-non-lisp-thread.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/kill-non-lisp-thread.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -45,7 +45,7 @@ (setq receivedp t)) (sb-thread::thread-interruptions sb-thread:*current-thread*)) #+sb-thruption - ;; On sb-thruption builds, the usual resignalling of SIGPIPE will + ;; On sb-thruption builds, the usual resignalling of SIGURG will ;; work without problems, but the signal handler won't ordinarily ;; think that there's anything to be done. Since we're poking at ;; INTERRUPT-THREAD internals anyway, let's help it along. diff -Nru sbcl-2.0.6/tests/lambda-list.pure.lisp sbcl-2.1.1/tests/lambda-list.pure.lisp --- sbcl-2.0.6/tests/lambda-list.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/lambda-list.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -47,6 +47,15 @@ (error-p (&rest foo &rest bar)) (error-p (&rest foo &optional bar)))) +(with-test (:name :lp1738638) + ;; I really don't like that the name of the keyword to *expect* a failure + ;; is ":allow-failure". It sounds like it's a permission, not a requirement. + (checked-compile '(lambda (&key ((x) 1)) x) :allow-failure t)) + +(with-test (:name :lp1740756) + (checked-compile '(lambda () (declare (special 1))) :allow-failure t) + (checked-compile '(lambda () (declare (special (foo)))) :allow-failure t)) + (with-test (:name (:lambda-list :supplied-p-order 1)) (let ((* 10)) (assert (eql ((lambda (&key (x * *)) () x)) 10)) diff -Nru sbcl-2.0.6/tests/make-thread.impure.lisp sbcl-2.1.1/tests/make-thread.impure.lisp --- sbcl-2.0.6/tests/make-thread.impure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/make-thread.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,165 @@ +(in-package "SB-THREAD") + +#+cheneygc (sb-ext:exit :code 104) + +;;; Test out-of-memory (or something) that goes wrong in pthread_create +#+pauseless-threadstart ; no SB-THREAD::PTHREAD-CREATE symbol if not +(test-util:with-test (:name :failed-thread-creation) + (let ((encapsulation + (compile nil + '(lambda (realfun thread stack-base) + (if (string= (sb-thread:thread-name thread) "finalizer") + (funcall realfun thread stack-base) + nil)))) + (success)) + ;; This test checks that if pthread_create fails, nothing is added to *STARTING-THREADS*. + ;; If there were an entry spuriously added, it would remain forever, as the thread we're + ;; attempting to create would not consume and clear out its startup data. + ;; So as a precondition to the test, *STARTING-THREADS* must be NIL. If it isn't, then + ;; there must have been a finalizer thread started, and it would have left a 0 in the list, + ;; which is the telltale mark of a thread that smashed its startup data. + ;; So if the list is not NIL right now, assert that there is a finalizer thread, + ;; and then set the list to NIL. + ;; [The rationale for the 0 is that responsibility for deletion from the list falls to the + ;; next MAKE-THREAD so that new threads need not synchronize with creators for exclusive + ;; access to the list. But threads can safely RPLACA their own cell in *STARTING-THREADS* + ;; allowing it to be GC'd even if nothing subsequently prunes out un-needed cons cells] + (when sb-thread::*starting-threads* + (assert (sb-thread::thread-p sb-impl::*finalizer-thread*)) + (assert (equal sb-thread::*starting-threads* '(0))) + (setq sb-thread::*starting-threads* nil)) + + (unwind-protect + (progn (sb-int:encapsulate 'sb-thread::pthread-create 'test encapsulation) + (handler-case (sb-thread:make-thread #'list :name "thisfails") + (error (e) + (setq success (string= (write-to-string e) + "Could not create new OS thread."))))) + (sb-int:unencapsulate 'sb-thread::pthread-create 'test)) + (assert (null sb-thread::*starting-threads*)) + (assert (equal (remove sb-impl::*finalizer-thread* + (sb-thread::avltree-list sb-thread::*all-threads*)) + (list sb-thread::*initial-thread*))))) + +(defun actually-get-stack-roots (current-sp + &key allwords (print t) + &aux (current-sp (descriptor-sap current-sp)) + (roots)) + (declare (type (member nil t :everything) allwords)) + (without-gcing + (binding* ((stack-low (get-lisp-obj-address sb-vm:*control-stack-start*)) + (stack-high (get-lisp-obj-address sb-vm:*control-stack-end*)) + ((nwords copy-from direction base) + #+c-stack-is-control-stack ; growth direction is always down + (values (ash (- stack-high (sap-int current-sp)) (- sb-vm:word-shift)) + current-sp #\- "sp") + #-c-stack-is-control-stack ; growth direction is always up + (values (ash (- (sap-int current-sp) stack-low) (- sb-vm:word-shift)) + (int-sap stack-low) #\+ "base")) + (array (make-array nwords :element-type 'sb-ext:word))) + (when print + (format t "SP=~a~dw (range = ~x..~x)~%" direction nwords stack-low stack-high)) + (alien-funcall (extern-alien "memcpy" (function void system-area-pointer + system-area-pointer unsigned)) + (vector-sap array) copy-from (* nwords sb-vm:n-word-bytes)) + (loop for i downfrom (1- nwords) to 0 by 1 do + (let ((word (aref array i))) + (when (or (/= word sb-vm:nil-value) allwords) + (let ((baseptr (alien-funcall (extern-alien "search_all_gc_spaces" (function unsigned unsigned)) + word))) + (cond ((/= baseptr 0) ; an object reference + (let ((obj (sb-vm::reconstitute-object (%make-lisp-obj baseptr)))) + (when (code-component-p obj) + (cond + #+c-stack-is-control-stack + ((= (logand word sb-vm:lowtag-mask) sb-vm:fun-pointer-lowtag) + (dotimes (i (code-n-entries obj)) + (when (= (get-lisp-obj-address (%code-entry-point obj i)) word) + (return (setq obj (%code-entry-point obj i)))))) + #-c-stack-is-control-stack ; i.e. does this backend have LRAs + ((= (logand (sap-ref-word (int-sap (logandc2 word sb-vm:lowtag-mask)) 0) + sb-vm:widetag-mask) sb-vm:return-pc-widetag) + (setq obj (%make-lisp-obj word))))) + ;; interior pointers to objects that contain instructions are OK, + ;; otherwise only correctly tagged pointers. + (when (or (typep obj '(or fdefn code-component funcallable-instance)) + (= (get-lisp-obj-address obj) word)) + (push obj roots) + (when print + (format t "~x = ~a[~5d] = ~16x (~A) " + (sap-int (sap+ copy-from (ash i sb-vm:word-shift))) + base i word + (or (generation-of obj) #\S)) ; S is for static + (let ((*print-pretty* nil)) + (cond ((consp obj) (format t "a cons")) + #+sb-fasteval + ((typep obj 'sb-interpreter::sexpr) (format t "a sexpr")) + ((arrayp obj) (format t "a ~s" (type-of obj))) + #+c-stack-is-control-stack + ((and (code-component-p obj) + (>= word (sap-int (code-instructions obj)))) + (format t "PC in ~a" obj)) + (t (format t "~a" obj)))) + (terpri))))) + ((and print + (or (eq allwords :everything) (and allwords (/= word 0)))) + (format t "~x = ~a[~5d] = ~16x~%" + (sap-int (sap+ copy-from (ash i sb-vm:word-shift))) + base i word))))))))) + (if print + (format t "~D roots~%" (length roots)) + roots)) +(defun get-stack-roots (&rest rest) + (apply #'actually-get-stack-roots (%make-lisp-obj (sap-int (current-sp))) rest)) + +(defstruct big-structure x) +(defstruct other-big-structure x) +(defun make-a-closure (arg options) + (lambda (&optional (z 0) y) + (declare (ignore y)) + (test-util:opaque-identity + (format nil "Ahoy-hoy! ~d~%" (+ (big-structure-x arg) z))) + (apply #'get-stack-roots options))) +(defun tryit (&rest options) + (let ((thread + (make-thread (make-a-closure (make-big-structure :x 0) options) + :arguments (list 1 (make-other-big-structure))))) + ;; Sometimes the THREAD instance shows up in the list of objects + ;; on the stack, sometimes it doesn't. This is annoying, but work around it. + (remove thread (join-thread thread)))) + +(defun make-a-closure-nontail (arg) + (lambda (&optional (z 0) y) + (declare (ignore y)) + (get-stack-roots) + (test-util:opaque-identity + (format nil "Ahoy-hoy! ~d~%" (+ (big-structure-x arg) z))) + 1)) +(defun tryit-nontail () + (join-thread + (make-thread (make-a-closure-nontail (make-big-structure :x 0)) + :arguments (list 1 (make-other-big-structure))))) + +;;; Test that reusing memory from an exited thread does not point to junk. +;;; In fact, assert something stronger: there are no young objects +;;; between the current SP and end of stack. +(test-util:with-test (:name :expected-gc-roots + :skipped-on (or :interpreter (not :pauseless-threadstart))) + (let ((list (tryit :print nil))) + ;; should be not many things pointed to by the stack + (assert (< (length list) #+x86 38 ; more junk, I don't know why + #+x86-64 30 ; less junk, I don't know why + #-(or x86 x86-64) 44)) ; even more junk + ;; Either no objects are in GC generation 0, or all are, depending on + ;; whether CORE_PAGE_GENERATION has been set to 0 for testing. + (let ((n-objects-in-g0 (count 0 list :key #'sb-kernel:generation-of))) + (assert (or (= n-objects-in-g0 0) + (= n-objects-in-g0 (length list))))))) + +;; lp#1595699 +(test-util:with-test (:name :start-thread-in-without-gcing + :skipped-on (not :pauseless-threadstart)) + (assert (eq (sb-thread:join-thread + (sb-sys:without-gcing + (sb-thread:make-thread (lambda () 'hi)))) + 'hi))) diff -Nru sbcl-2.0.6/tests/map-tests.impure.lisp sbcl-2.1.1/tests/map-tests.impure.lisp --- sbcl-2.0.6/tests/map-tests.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/map-tests.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -223,3 +223,9 @@ (test 'mapcar (list #'list '(1 2 3) '(4 5 6) '(7 8 9)) '((1 4 7) (2 5 8) (3 6 9))) (test 'mapcan (list #'identity '(1)) 1))) + +(with-test (:name (map :initial-element-style-warnin)) + (checked-compile-and-assert + () + `(lambda (x) + (map '(vector hash-table) #'identity x)))) diff -Nru sbcl-2.0.6/tests/mutex.impure.lisp sbcl-2.1.1/tests/mutex.impure.lisp --- sbcl-2.0.6/tests/mutex.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/mutex.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -11,8 +11,8 @@ (dotimes (i 100) (with-mutex (mutex) (sleep .03) - (assert (eql (mutex-value mutex) me))) - (assert (not (eql (mutex-value mutex) me)))) + (assert (eql (mutex-owner mutex) me))) + (assert (not (eql (mutex-owner mutex) me)))) (format t "done ~A~%" *current-thread*)))) (let ((kid1 (make-thread #'run)) (kid2 (make-thread #'run))) @@ -27,12 +27,12 @@ (setf child (test-interrupt (lambda () (with-mutex (lock) - (assert (eql (mutex-value lock) *current-thread*))) - (assert (not (eql (mutex-value lock) *current-thread*))) + (assert (eql (mutex-owner lock) *current-thread*))) + (assert (not (eql (mutex-owner lock) *current-thread*))) (sleep 10)))) ;;hold onto lock for long enough that child can't get it immediately (sleep 5) - (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock)))) + (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-owner lock)))) (format t "parent releasing lock~%")) (process-all-interrupts child) (terminate-thread child) diff -Nru sbcl-2.0.6/tests/octets.pure.lisp sbcl-2.1.1/tests/octets.pure.lisp --- sbcl-2.0.6/tests/octets.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/octets.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -243,13 +243,12 @@ ;;; START argument. (assert (equalp #(50) (string-to-octets "42" :start 1 :external-format :utf-8))) -;;; STRING->UTF8 should cope with NIL strings if a null range is required (assert (equalp #() (string-to-octets "" :external-format :utf-8))) -(assert (equalp #() (string-to-octets (make-array 0 :element-type nil) +(assert (equalp #() (string-to-octets (make-string 0) :external-format :utf-8))) -(assert (equalp #() (string-to-octets (make-array 5 :element-type nil) +(assert (equalp #() (string-to-octets (make-string 5) :start 3 :end 3 :external-format :utf-8))) -(assert (equalp #(0) (string-to-octets (make-array 5 :element-type nil) +(assert (equalp #(0) (string-to-octets (make-string 5) :start 3 :end 3 :null-terminate t :external-format :utf-8))) diff -Nru sbcl-2.0.6/tests/packages.impure.lisp sbcl-2.1.1/tests/packages.impure.lisp --- sbcl-2.0.6/tests/packages.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/packages.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -36,7 +36,7 @@ (make-package "FOO") (defvar *foo* (find-package (coerce "FOO" 'base-string))) -(rename-package "FOO" (make-array 0 :element-type nil)) +(rename-package "FOO" (make-array 0 :element-type 'character)) (assert (eq *foo* (find-package ""))) (assert (delete-package "")) diff -Nru sbcl-2.0.6/tests/parallel-exec.sh sbcl-2.1.1/tests/parallel-exec.sh --- sbcl-2.0.6/tests/parallel-exec.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/parallel-exec.sh 2021-01-30 11:22:39.000000000 +0000 @@ -5,9 +5,25 @@ junkdir=${SBCL_PAREXEC_TMP:-/tmp}/junk mkdir -p $junkdir $logdir +case `uname` in + CYGWIN* | WindowsNT | MINGW* | MSYS*) + if [ $# -ne 1 ] + then + echo $0: Need arg + exit 1 + fi + echo ";; Using -j$1" + echo "LOGDIR=$logdir" >$logdir/Makefile + ../run-sbcl.sh --script genmakefile.lisp >>$logdir/Makefile + exec $GNUMAKE -k -j $1 -f $logdir/Makefile + ;; +esac + export TEST_DIRECTORY SBCL_HOME TEST_DIRECTORY=$junkdir SBCL_HOME=../obj/sbcl-home exec ../src/runtime/sbcl \ - --noinform --core ../output/sbcl.core --no-userinit --no-sysinit --noprint --disable-debugger << EOF + --noinform --core ../output/sbcl.core \ + --no-userinit --no-sysinit --noprint --disable-debugger $* << EOF +(pop *posix-argv*) (require :sb-posix) (let ((*evaluator-mode* :compile)) (with-compilation-unit () (load"run-tests"))) @@ -15,20 +31,34 @@ (import '(sb-alien:alien-funcall sb-alien:extern-alien sb-alien:int sb-alien:c-string sb-alien:unsigned)) (setq *summarize-test-times* t) -(defun parallel-execute-tests (max-jobs) +;;; Ordered approximately in descending order by running time +(defvar *slow-tests* '("threads.impure" + "seq.impure" + "threads.pure" + "compiler.pure" + "timer.impure" + "bug-1180102.impure" + "gethash-concurrency.impure" + "arith.pure")) +(defun choose-order (tests) + (sort tests + (lambda (a b) + (let ((posn-a (or (position a *slow-tests* :test #'string=) + most-positive-fixnum)) + (posn-b (or (position b *slow-tests* :test #'string=) + most-positive-fixnum))) + (cond ((< posn-a posn-b) t) + ((> posn-a posn-b) nil) + (t (string< a b))))))) +(defun parallel-execute-tests (files max-jobs vop-summary-stats-p) (format t "Using ~D processes~%" max-jobs) ;; Interleave the order in which all tests are launched rather than ;; starting them in the batches that filtering places them in. - (let ((files (sort (mapcar #'pathname-name - (append (pure-load-files) - (pure-cload-files) - (impure-load-files) - (impure-cload-files) - (sh-files))) - #'string<)) - (subprocess-count 0) + (let ((subprocess-count 0) (subprocess-list nil) (aggregate-vop-usage (make-hash-table)) + ;; Start timing only after all the DIRECTORY calls are done (above) + (start-time (get-internal-real-time)) (missing-usage) (losing)) (labels ((wait () @@ -37,18 +67,28 @@ #+nil (format t "Runner is waiting on: ~S~%" subprocess-list) (multiple-value-bind (pid status) (sb-posix:wait) (decf subprocess-count) - (let ((process (assoc pid subprocess-list))) + (let ((process (assoc pid subprocess-list)) + (code (ash status -8)) + (et)) + (unless process + (warn "Whoa! Process ~D is an unexpected child" pid) + (return-from wait (wait))) (setq subprocess-list (delete process subprocess-list)) - (let* ((code (ash status -8)) - (filename (cdr process))) - (unless (sum-vop-usage (format nil "$logdir/~a.vop-usage" filename) t) - (when (or (search ".pure" filename) (search ".impure" filename)) - (push filename missing-usage))) + (destructuring-bind ((filename . iteration) start-time) (cdr process) + (setq et (elapsed-time-from start-time)) + (when vop-summary-stats-p + (unless (sum-vop-usage (format nil "$logdir/~a.vop-usage" filename) t) + (when (or (search ".pure" filename) (search ".impure" filename)) + (push filename missing-usage)))) (cond ((eq code 104) - (format t "~A: success~%" filename)) + (format t "~A: success (~d msec)~%" filename et)) (t - (format t "~A: status ~D~%" filename code) - (push filename losing))))))) + (format t "~A~@[[~d]~]: status ~D (~d msec)~%" + filename iteration code et) + (push (list filename iteration pid) losing))))))) + (elapsed-time-from (when) ; return value in milliseconds + (round (- (get-internal-real-time) when) + (/ internal-time-units-per-second 1000))) (sum-vop-usage (input deletep) (with-open-file (f input :if-does-not-exist nil) ;; No vop coverage file from shell script tests or any test @@ -65,11 +105,13 @@ (wait)) (let ((pid (sb-posix:fork))) (when (zerop pid) - (with-open-file (stream (format nil "$logdir/~a" file) + ;; FILE is (filename . test-iteration) + (with-open-file (stream (format nil "$logdir/~a~@[-~d~]" (car file) (cdr file)) :direction :output :if-exists :supersede) (alien-funcall (extern-alien "dup2" (function int int int)) (sb-sys:fd-stream-fd stream) 1) (alien-funcall (extern-alien "dup2" (function int int int)) 1 2)) + (setq file (car file)) ;; Send this to the log file, not the terminal (setq *debug-io* (make-two-way-stream (make-concatenated-stream) *error-output*)) @@ -88,31 +130,34 @@ (pure-runner (list (concatenate 'string file ".lisp")) (if (search "-cload" file) 'cload-test 'load-test) (make-broadcast-stream))) - (with-open-file (output (format nil "$logdir/~a.vop-usage" file) - :direction :output) - ;; There's an impure test that screws with the default pprint dispatch - ;; table such that integers don't print normally (and can't be parsed). - (let ((*print-pretty* nil)) - (sb-int:dohash ((name count) sb-c::*static-vop-usage-counts*) - (format output "~7d ~s~%" count name)))) + (when vop-summary-stats-p + (with-open-file (output (format nil "$logdir/~a.vop-usage" file) + :direction :output) + ;; There's an impure test that screws with the default pprint dispatch + ;; table such that integers don't print normally (and can't be parsed). + (let ((*print-pretty* nil)) + (sb-int:dohash ((name count) sb-c::*static-vop-usage-counts*) + (format output "~7d ~s~%" count name))))) (exit :code (if (unexpected-failures) 1 104))))) - (format t "~A: pid ~d~%" file pid) + (format t "~A: pid ~d~@[ (trial ~d)~]~%" (car file) pid (cdr file)) (incf subprocess-count) - (push (cons pid file) subprocess-list))) + (push (list pid file (get-internal-real-time)) subprocess-list))) (loop (if (plusp subprocess-count) (wait) (return))) - (dolist (result '("vop-usage.txt" "vop-usage-combined.txt")) - (let (list) - (sb-int:dohash ((name vop) sb-c::*backend-template-names*) - (declare (ignore vop)) - (push (cons (gethash name aggregate-vop-usage 0) name) list)) - (with-open-file (output (format nil "$logdir/~a" result) - :direction :output - :if-exists :supersede) - (dolist (cell (sort list #'> :key #'car)) - (format output "~7d ~s~%" (car cell) (cdr cell))))) - (sum-vop-usage "../output/warm-vop-usage.txt" nil)) + (when vop-summary-stats-p + (dolist (result '("vop-usage.txt" "vop-usage-combined.txt")) + (let (list) + (sb-int:dohash ((name vop) sb-c::*backend-template-names*) + (declare (ignore vop)) + (push (cons (gethash name aggregate-vop-usage 0) name) list)) + (with-open-file (output (format nil "$logdir/~a" result) + :direction :output + :if-exists :supersede) + (dolist (cell (sort list #'> :key #'car)) + (format output "~7d ~s~%" (car cell) (cdr cell))))) + (sum-vop-usage "../output/warm-vop-usage.txt" nil))) + (format t "~&Total realtime: ~d msec~%" (elapsed-time-from start-time)) (when missing-usage (format t "~&Missing vop-usage:~{ ~a~}~%" missing-usage)) @@ -120,6 +165,44 @@ (format t "~&Failing files:~%") (dolist (filename losing) (format t "~A~%" filename)) + (format t "==== Logs are in $logdir ====~%") (exit :code 1))))) -(parallel-execute-tests $1) +(if (= (length *posix-argv*) 1) + ;; short form - all files, argument N is the number of parallel tasks + (let ((jobs (parse-integer (car *posix-argv*)))) + (parallel-execute-tests + (mapcar #'list + (choose-order + (mapcar #'pathname-name + (append (pure-load-files) + (pure-cload-files) + (impure-load-files) + (impure-cload-files) + (sh-files))))) + jobs + t)) + ;; long form + (let ((jobs 4) + (runs-per-test 1) + (argv *posix-argv*)) + (loop (cond ((string= (car argv) "-j") + (setq jobs (parse-integer (cadr argv)) + argv (cddr argv))) + ((string= (car argv) "--runs_per_test") + (setq runs-per-test (parse-integer (cadr argv)) + argv (cddr argv))) + (t + (return)))) + (setq argv + (mapcar (lambda (file) + (probe-file file) ; for effect + (pathname-name file)) argv)) + (parallel-execute-tests + (loop for trial-number from 1 to runs-per-test + nconc (mapcar (lambda (file) + (cons file + (when (> runs-per-test 1) trial-number))) + argv)) + jobs + nil))) EOF diff -Nru sbcl-2.0.6/tests/pathnames.impure.lisp sbcl-2.1.1/tests/pathnames.impure.lisp --- sbcl-2.0.6/tests/pathnames.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/pathnames.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -733,7 +733,8 @@ (defun scratch-dir-truename () (with-scratch-file (name) - (truename (make-pathname :directory (pathname-directory name))))) + (truename (make-pathname :directory (pathname-directory name) + :device (pathname-device name))))) (with-test (:name (delete-file logical-pathname)) (setf (logical-pathname-translations "SB-TEST") @@ -879,3 +880,35 @@ :displaced-to string :displaced-index-offset 1))) (assert (equal (parse-namestring disp) #p"SYS:ABC.LISP")))) + +;;; LOGICAL-PATHAME was missing the specialized pathname comparator +;;; function in SB_KERNEL::LAYOUT-EQUALP-IMPL +(with-test (:name :logical-pathname-equalp-method) + ;; PATHNAME is not a structure-object but uses the instance EQUALP case. + (checked-compile-and-assert + () + `(lambda (x y) + (equalp x y)) + (((make-pathname) (make-pathname :version :newest)) t)) + (let ((s "#p\"sys:contrib/f[1-9].txt\"")) + (let ((a (read-from-string s))) + ;; result shouldn't depend on the pathnames being EQ + (clrhash sb-impl::*pathnames*) + (let ((b (read-from-string s))) + (assert (not (eq a b))) + (equalp a b))))) + +;;; After the change which added address-based hashing to all INSTANCE types, +;;; someone forgot to ensure that address-based hashes were not used on +;;; PATTERN instances which can comprise the subcomponents of a pathname. +;;; So make sure the hash is based on the string contents of the pattern. +;;; Read pathnames from strings to guarantee that some magic effect of reading +;;; pathnames doesn't coalesce them. To be especially certain, clear the +;;; SB-IMPL::*PATHNAMES* table between the read-from-string calls. +(with-test (:name :wild-pathnames-string-based-hash) + (let ((string "#p\"file[0-9].txt\"")) + (let ((a (read-from-string string))) + (clrhash (clrhash sb-impl::*pathnames*)) + (let ((b (read-from-string string))) + (assert (not (eq a b))) + (assert (eql (sxhash a) (sxhash b))))))) diff -Nru sbcl-2.0.6/tests/raw-slots-interleaved.impure.lisp sbcl-2.1.1/tests/raw-slots-interleaved.impure.lisp --- sbcl-2.0.6/tests/raw-slots-interleaved.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/raw-slots-interleaved.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -66,37 +66,42 @@ (princ 'did-pass-2) (terpri) (force-output) -;; Test the C bignum bit extractor. -;; Surprisingly, there was a bug in it, unrelated to forwarding -;; pointers that remained dormant until the randomized -;; HUGE-MANYRAW test in 'defstruct.impure.lisp' found it. -(defun c-bignum-logbitp (index bignum) - (assert (typep bignum 'bignum)) - (sb-sys:with-pinned-objects (bignum) - (alien-funcall (extern-alien "positive_bignum_logbitp" - (function boolean int system-area-pointer)) - index - (sb-sys:int-sap - (- (sb-kernel:get-lisp-obj-address bignum) - sb-vm:other-pointer-lowtag))))) +;; Test the C bitmap bit extractor. +(defun c-bitmap-logbitp (index layout) + (eql (sb-sys:with-pinned-objects (layout) + (alien-funcall (extern-alien "test_bitmap_logbitp" + (function int int unsigned)) + index + (logandc2 (sb-kernel:get-lisp-obj-address layout) + sb-vm:lowtag-mask))) + 1)) -(with-test (:name :c-bignum-logbitp) +(with-test (:name :bitmap-logbitp) ;; walking 1 bit (dotimes (i 256) - (let ((num (ash 1 i))) - (when (typep num 'bignum) - (dotimes (j 257) - (assert (eq (c-bignum-logbitp j num) - (logbitp j num))))))) + (let* ((num (ash 1 i)) + (layout (sb-kernel:make-layout 0 (sb-kernel:find-classoid 'structure-object) + :bitmap num))) + (dotimes (j 257) + (assert (eq (c-bitmap-logbitp j layout) (logbitp j num)))))) + ;; walking 0 bit + (dotimes (i 256) + (let* ((num (lognot (ash 1 i))) + (layout (sb-kernel:make-layout 0 (sb-kernel:find-classoid 'structure-object) + :bitmap num))) + (dotimes (j 257) + (assert (eq (c-bitmap-logbitp j layout) (logbitp j num)))))) ;; random bits (let ((max (ash 1 768))) (dotimes (i 100) - (let ((num (random max))) - (when (typep num 'bignum) - (dotimes (j (* (sb-bignum:%bignum-length num) - sb-vm:n-word-bits)) - (assert (eq (c-bignum-logbitp j num) - (logbitp j num))))))))) + (let* ((num (- (random max) (floor max 20))) ; test both + and - + (layout + (sb-kernel:make-layout 0 (sb-kernel:find-classoid 'structure-object) + :bitmap num))) + (dotimes (j (if (typep num 'bignum) + (* (sb-bignum:%bignum-length num) sb-vm:n-word-bits) + sb-vm:n-word-bits)) + (assert (eq (c-bitmap-logbitp j layout) (logbitp j num)))))))) ;; for testing the comparator (defstruct foo1 diff -Nru sbcl-2.0.6/tests/reader.pure.lisp sbcl-2.1.1/tests/reader.pure.lisp --- sbcl-2.0.6/tests/reader.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/reader.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -11,203 +11,206 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(assert (equal (symbol-name '#:|fd\sA|) "fdsA")) +(with-test (:name (:reader symbol :escape)) + (assert (equal (symbol-name '#:|fd\sA|) "fdsA"))) -;;; Prior to sbcl-0.7.2.10, SBCL disobeyed the ANSI requirements on -;;; returning NIL for unset dispatch-macro-character functions. (bug -;;; 151, fixed by Alexey Dejenka sbcl-devel "bug 151" 2002-04-12) -(assert (not (get-dispatch-macro-character #\# #\{))) -(assert (not (get-dispatch-macro-character #\# #\0))) -;;; And we might as well test that we don't have any cross-compilation -;;; shebang residues left... -(assert (not (get-dispatch-macro-character #\# #\!))) -;;; Also test that all the illegal sharp macro characters are -;;; recognized as being illegal. -(loop for char in '(#\Backspace #\Tab #\Newline #\Linefeed - #\Page #\Return #\Space #\) #\<) - do (assert (get-dispatch-macro-character #\# char))) - -(assert (not (ignore-errors (get-dispatch-macro-character #\! #\0) - t))) - -;;; In sbcl-0.7.3, GET-MACRO-CHARACTER and SET-MACRO-CHARACTER didn't -;;; use NIL to represent the no-macro-attached-to-this-character case -;;; as ANSI says they should. (This problem is parallel to the -;;; GET-DISPATCH-MACRO misbehavior fixed in sbcl-0.7.2.10, but -;;; was fixed a little later.) -(dolist (customizable-char - ;; According to ANSI "2.1.4 Character Syntax Types", these - ;; characters are reserved for the programmer. - '(#\? #\! #\[ #\] #\{ #\})) - ;; So they should have no macro-characterness. - (multiple-value-bind (macro-fun non-terminating-p) - (get-macro-character customizable-char) - (assert (null macro-fun)) - ;; Also, in a bit of ANSI weirdness, NON-TERMINATING-P can be - ;; true only when MACRO-FUN is true. (When the character - ;; is not a macro character, it can be embedded in a token, - ;; so it'd be more logical for NON-TERMINATING-P to be T in - ;; this case; but ANSI says it's NIL in this case. - (assert (null non-terminating-p)))) - -;;; rudimentary test of SET-SYNTAX-FROM-CHAR, just to verify that it -;;; wasn't totally broken by the GET-MACRO-CHARACTER/SET-MACRO-CHARACTER -;;; fixes in 0.7.3.16 -(assert (= 123579 (read-from-string "123579"))) -(let ((*readtable* (copy-readtable))) - (set-syntax-from-char #\7 #\;) - (assert (= 1235 (read-from-string "123579")))) +(with-test (:name (get-dispatch-macro-character :return-value)) + ;; Prior to sbcl-0.7.2.10, SBCL disobeyed the ANSI requirements on + ;; returning NIL for unset dispatch-macro-character functions. (bug + ;; 151, fixed by Alexey Dejenka sbcl-devel "bug 151" 2002-04-12) + (assert (not (get-dispatch-macro-character #\# #\{))) + (assert (not (get-dispatch-macro-character #\# #\0))) + ;; And we might as well test that we don't have any cross-compilation + ;; shebang residues left... + (assert (not (get-dispatch-macro-character #\# #\!))) + ;; Also test that all the illegal sharp macro characters are + ;; recognized as being illegal. + (loop for char in '(#\Backspace #\Tab #\Newline #\Linefeed + #\Page #\Return #\Space #\) #\<) + do (assert (get-dispatch-macro-character #\# char))) + + (assert-error (get-dispatch-macro-character #\! #\0))) + +(with-test (:name (get-macro-character :return-value)) + ;; In sbcl-0.7.3, GET-MACRO-CHARACTER and SET-MACRO-CHARACTER didn't + ;; use NIL to represent the no-macro-attached-to-this-character case + ;; as ANSI says they should. (This problem is parallel to the + ;; GET-DISPATCH-MACRO misbehavior fixed in sbcl-0.7.2.10, but was + ;; fixed a little later.) + (dolist (customizable-char + ;; According to ANSI "2.1.4 Character Syntax Types", these + ;; characters are reserved for the programmer. + '(#\? #\! #\[ #\] #\{ #\})) + ;; So they should have no macro-characterness. + (multiple-value-bind (macro-fun non-terminating-p) + (get-macro-character customizable-char) + (assert (null macro-fun)) + ;; Also, in a bit of ANSI weirdness, NON-TERMINATING-P can be + ;; true only when MACRO-FUN is true. (When the character is not + ;; a macro character, it can be embedded in a token, so it'd be + ;; more logical for NON-TERMINATING-P to be T in this case; but + ;; ANSI says it's NIL in this case. + (assert (null non-terminating-p))))) + +(with-test (:name (set-syntax-from-char :smoke)) + ;; rudimentary test of SET-SYNTAX-FROM-CHAR, just to verify that it + ;; wasn't totally broken by the GET-MACRO-CHARACTER/SET-MACRO-CHARACTER + ;; fixes in 0.7.3.16 + (assert (= 123579 (read-from-string "123579"))) + (let ((*readtable* (copy-readtable))) + (set-syntax-from-char #\7 #\;) + (assert (= 1235 (read-from-string "123579"))))) ;;; PARSE-INTEGER must signal an error of type PARSE-ERROR if it is ;;; unable to parse an integer and :JUNK-ALLOWED is NIL. -(macrolet ((assert-parse-error (form) - `(multiple-value-bind (val cond) - (ignore-errors ,form) - (assert (null val)) - (assert (typep cond 'parse-error))))) - (assert-parse-error (parse-integer " ")) - (assert-parse-error (parse-integer "12 a")) - (assert-parse-error (parse-integer "12a")) - (assert-parse-error (parse-integer "a")) - (assert (= (parse-integer "12") 12)) - (assert (= (parse-integer " 12 ") 12)) - (assert (= (parse-integer " 12asdb" :junk-allowed t) 12))) +(with-test (:name (parse-integer :smoke)) + (macrolet ((assert-parse-error (form) + `(assert-error ,form parse-error))) + (assert-parse-error (parse-integer " ")) + (assert-parse-error (parse-integer "12 a")) + (assert-parse-error (parse-integer "12a")) + (assert-parse-error (parse-integer "a")) + (assert (= (parse-integer "12") 12)) + (assert (= (parse-integer " 12 ") 12)) + (assert (= (parse-integer " 12asdb" :junk-allowed t) 12)))) ;;; #A notation enforces that once one 0 dimension has been found, all ;;; subsequent ones are also 0. -(assert (equal (array-dimensions (read-from-string "#3A()")) - '(0 0 0))) -(assert (equal (array-dimensions (read-from-string "#3A(())")) - '(1 0 0))) -(assert (equal (array-dimensions (read-from-string "#3A((() ()))")) - '(1 2 0))) +(with-test (:name (:sharpsign-a-reader-macro :initial-elements)) + (assert (equal (array-dimensions (read-from-string "#3A()")) + '(0 0 0))) + (assert (equal (array-dimensions (read-from-string "#3A(())")) + '(1 0 0))) + (assert (equal (array-dimensions (read-from-string "#3A((() ()))")) + '(1 2 0)))) ;;; Bug reported by Nikodemus Siivola on sbcl-devel 2003-07-21: ;;; package misconfiguration -(assert (eq - (handler-case (with-input-from-string (s "cl:") (read s)) - (end-of-file (c) - (declare (ignore c)) - 'good)) - 'good)) +(with-test (:name (with-input-from-string :package-misconfiguration)) + (assert-error (with-input-from-string (s "cl:") (read s)) end-of-file)) ;;; Bugs found by Paul Dietz -(assert (equal (multiple-value-list - (parse-integer " 123 ")) - '(123 12))) - -(let* ((base "xxx 123 yyy") - (intermediate (make-array 8 :element-type (array-element-type base) - :displaced-to base - :displaced-index-offset 2)) - (string (make-array 6 :element-type (array-element-type base) - :displaced-to intermediate - :displaced-index-offset 1))) +(with-test (:name (parse-integer 1)) (assert (equal (multiple-value-list - (parse-integer string)) - '(123 6)))) + (parse-integer " 123 ")) + '(123 12)))) -(let ((*read-base* *read-base*)) - (dolist (float-string '(".9" ".9e9" ".9e+9" ".9e-9" - "-.9" "-.9e9" "-.9e+9" "-.9e-9" - "+.9" "+.9e9" "+.9e+9" "+.9e-9" - "0.9" "0.9e9" "0.9e+9" "0.9e-9" - "9.09" "9.09e9" "9.09e+9" "9.09e-9" - #|"9e9" could be integer|# "9e+9" "9e-9")) - (loop for i from 2 to 36 - do (setq *read-base* i) - do (assert (typep (read-from-string float-string) - *read-default-float-format*)) - do (assert (typep - (read-from-string (substitute #\E #\e float-string)) - *read-default-float-format*)) - if (position #\e float-string) - do (assert (typep - (read-from-string (substitute #\s #\e float-string)) - 'short-float)) - and do (assert (typep - (read-from-string (substitute #\S #\e float-string)) - 'short-float)) - and do (assert (typep - (read-from-string (substitute #\f #\e float-string)) - 'single-float)) - and do (assert (typep - (read-from-string (substitute #\F #\e float-string)) - 'single-float)) - and do (assert (typep - (read-from-string (substitute #\d #\e float-string)) - 'double-float)) - and do (assert (typep - (read-from-string (substitute #\D #\e float-string)) - 'double-float)) - and do (assert (typep - (read-from-string (substitute #\l #\e float-string)) - 'long-float)) - and do (assert (typep - (read-from-string (substitute #\L #\e float-string)) - 'long-float))))) - -(let ((*read-base* *read-base*)) - (dolist (integer-string '("1." "2." "3." "4." "5." "6." "7." "8." "9." "0.")) - (loop for i from 2 to 36 - do (setq *read-base* i) - do (assert (typep (read-from-string integer-string) 'integer))))) - -(let ((*read-base* *read-base*)) - (dolist (symbol-string '("A." "a." "Z." "z." - - "+.9eA" "+.9ea" - - "0.A" "0.a" "0.Z" "0.z" - - #|"9eA" "9ea"|# "9e+A" "9e+a" "9e-A" "9e-a" - #|"Ae9" "ae9"|# "Ae+9" "ae+9" "Ae-9" "ae-9" - - "ee+9" "Ee+9" "eE+9" "EE+9" - "ee-9" "Ee-9" "eE-9" "EE-9" - - "A.0" "A.0e10" "a.0" "a.0e10" - - "1e1e+9")) - (loop for i from 2 to 36 - do (setq *read-base* i) - do (assert (typep (read-from-string symbol-string) 'symbol))))) +(with-test (:name (parse-integer 2)) + (let* ((base "xxx 123 yyy") + (intermediate (make-array 8 :element-type (array-element-type base) + :displaced-to base + :displaced-index-offset 2)) + (string (make-array 6 :element-type (array-element-type base) + :displaced-to intermediate + :displaced-index-offset 1))) + (assert (equal (multiple-value-list + (parse-integer string)) + '(123 6))))) + +(with-test (:name (*read-base* 1)) + (let ((*read-base* *read-base*)) + (dolist (float-string '(".9" ".9e9" ".9e+9" ".9e-9" + "-.9" "-.9e9" "-.9e+9" "-.9e-9" + "+.9" "+.9e9" "+.9e+9" "+.9e-9" + "0.9" "0.9e9" "0.9e+9" "0.9e-9" + "9.09" "9.09e9" "9.09e+9" "9.09e-9" + #|"9e9" could be integer|# "9e+9" "9e-9")) + (loop for i from 2 to 36 + do (setq *read-base* i) + do (assert (typep (read-from-string float-string) + *read-default-float-format*)) + do (assert (typep + (read-from-string (substitute #\E #\e float-string)) + *read-default-float-format*)) + if (position #\e float-string) + do (assert (typep + (read-from-string (substitute #\s #\e float-string)) + 'short-float)) + and do (assert (typep + (read-from-string (substitute #\S #\e float-string)) + 'short-float)) + and do (assert (typep + (read-from-string (substitute #\f #\e float-string)) + 'single-float)) + and do (assert (typep + (read-from-string (substitute #\F #\e float-string)) + 'single-float)) + and do (assert (typep + (read-from-string (substitute #\d #\e float-string)) + 'double-float)) + and do (assert (typep + (read-from-string (substitute #\D #\e float-string)) + 'double-float)) + and do (assert (typep + (read-from-string (substitute #\l #\e float-string)) + 'long-float)) + and do (assert (typep + (read-from-string (substitute #\L #\e float-string)) + 'long-float)))))) + +(with-test (:name (*read-base* 2)) + (let ((*read-base* *read-base*)) + (dolist (integer-string '("1." "2." "3." "4." "5." "6." "7." "8." "9." "0.")) + (loop for i from 2 to 36 + do (setq *read-base* i) + do (assert (typep (read-from-string integer-string) 'integer)))))) + +(with-test (:name (*read-base* 3)) + (let ((*read-base* *read-base*)) + (dolist (symbol-string '("A." "a." "Z." "z." + + "+.9eA" "+.9ea" + + "0.A" "0.a" "0.Z" "0.z" + + #|"9eA" "9ea"|# "9e+A" "9e+a" "9e-A" "9e-a" + #|"Ae9" "ae9"|# "Ae+9" "ae+9" "Ae-9" "ae-9" + + "ee+9" "Ee+9" "eE+9" "EE+9" + "ee-9" "Ee-9" "eE-9" "EE-9" + + "A.0" "A.0e10" "a.0" "a.0e10" + + "1e1e+9")) + (loop for i from 2 to 36 + do (setq *read-base* i) + do (assert (typep (read-from-string symbol-string) 'symbol)))))) -(let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ +(with-test (:name (readtable :specified-macro-characters)) + (let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ ") - (standard-terminating-macro-chars "\"'(),;`") - (standard-nonterminating-macro-chars "#")) - (flet ((frob (char) - (multiple-value-bind (fun non-terminating-p) - (get-macro-character char) - (cond - ((find char standard-terminating-macro-chars) - (unless (and fun (not non-terminating-p)) - (list char))) - ((find char standard-nonterminating-macro-chars) - (unless (and fun non-terminating-p) - (list char))) - (t (unless (and (not fun) (not non-terminating-p)) - (list char))))))) - (let ((*readtable* (copy-readtable nil))) - (assert (null (loop for c across standard-chars append (frob c))))))) + (standard-terminating-macro-chars "\"'(),;`") + (standard-nonterminating-macro-chars "#")) + (flet ((frob (char) + (multiple-value-bind (fun non-terminating-p) + (get-macro-character char) + (cond ((find char standard-terminating-macro-chars) + (unless (and fun (not non-terminating-p)) + (list char))) + ((find char standard-nonterminating-macro-chars) + (unless (and fun non-terminating-p) + (list char))) + (t (unless (and (not fun) (not non-terminating-p)) + (list char))))))) + (let ((*readtable* (copy-readtable nil))) + (assert (null (loop for c across standard-chars append (frob c)))))))) -(let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ +(with-test (:name (readtable :specified-dispatch-macro-characters)) + (let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ ") - (undefined-chars "!\"$%&,;>?@[]^_`~{}/dDeEfFgGhHiIjJkKlLmMnNqQtTuUvVwWyYzZ")) - (flet ((frob (char) - (let ((fun (get-dispatch-macro-character #\# char))) - (cond - ((find char undefined-chars) - (when fun (list char))) - ((digit-char-p char 10) - (when fun (list char))) - (t - (unless fun (list char))))))) - (let ((*readtable* (copy-readtable nil))) - (assert (null (loop for c across standard-chars append (frob c))))))) + (undefined-chars "!\"$%&,;>?@[]^_`~{}/dDeEfFgGhHiIjJkKlLmMnNqQtTuUvVwWyYzZ")) + (flet ((frob (char) + (let ((fun (get-dispatch-macro-character #\# char))) + (cond ((find char undefined-chars) + (when fun (list char))) + ((digit-char-p char 10) + (when fun (list char))) + (t + (unless fun (list char))))))) + (let ((*readtable* (copy-readtable nil))) + (assert (null (loop for c across standard-chars append (frob c)))))))) -(with-test (:name :copy-readtable-with-unicode-macro +(with-test (:name (copy-readtable :with-unicode-macro) :skipped-on (not :sb-unicode)) (let ((rt (copy-readtable))) (set-macro-character (code-char #x100fa) #'error nil rt) @@ -217,7 +220,7 @@ ;;; All these must return a primary value of NIL when *read-suppress* is T ;;; Reported by Bruno Haible on cmucl-imp 2004-10-25. -(with-test (:name :read-suppress-char-macros) +(with-test (:name (*read-suppress* :char-macros)) (let ((*read-suppress* t)) (assert (null (read-from-string "(1 2 3)"))) (assert (null (with-input-from-string (s "abc xyz)") @@ -235,7 +238,7 @@ ;;; System code that asks whether %READ-PRESERVING-WHITESPACE hit EOF ;;; mistook NIL as an object returned normally for NIL the default eof mark. -(with-test (:name :read-preserving-whitespace-file-position) +(with-test (:name (read-preserving-whitespace file-position)) (multiple-value-bind (obj pos1) (read-from-string "NIL A") (declare (ignore obj)) (multiple-value-bind (obj pos2) (read-from-string "NNN A") @@ -272,23 +275,27 @@ ;;; EOF-ERROR-P defaults to true. Reported by Bruno Haible on ;;; cmucl-imp 2004-10-18. -(multiple-value-bind (res err) (ignore-errors (read-from-string "")) - (assert (not res)) - (assert (typep err 'end-of-file))) - -(assert (equal '((0 . "A") (1 . "B")) - (coerce (read-from-string "#((0 . \"A\") (1 . \"B\"))") - 'list))) +(with-test (:name (read-from-string :eof-error)) + (assert-error (read-from-string "") end-of-file) + (assert (equal '((0 . "A") (1 . "B")) + (coerce (read-from-string "#((0 . \"A\") (1 . \"B\"))") + 'list)))) + +(with-test (:name (read-delimited-list :non-recursive :circularity)) + (let* ((stream (make-string-input-stream "#1=(nil) #1#)")) + (result (read-delimited-list #\) stream))) + (assert (eq (first result) (second result))))) ;;; parse-integer uses whitespace[1] not whitespace[2] as its ;;; definition of whitespace to skip. -(let ((*readtable* (copy-readtable))) - (set-syntax-from-char #\7 #\Space) - (assert (= 710 (parse-integer "710")))) - -(let ((*readtable* (copy-readtable))) - (set-syntax-from-char #\7 #\Space) - (assert (string= (format nil "~7D" 1) " 1"))) +(with-test (:name (parse-integer :whitespace-handling)) + (let ((*readtable* (copy-readtable))) + (set-syntax-from-char #\7 #\Space) + (assert (= 710 (parse-integer "710")))) + + (let ((*readtable* (copy-readtable))) + (set-syntax-from-char #\7 #\Space) + (assert (string= (format nil "~7D" 1) " 1")))) (with-test (:name :report-reader-error) ;; Apparently this wants to test the printing of the error string @@ -302,12 +309,13 @@ ;;; The GET-MACRO-CHARACTER in SBCL <= "1.0.34.2" bogusly computed its ;;; second return value relative to *READTABLE* rather than the passed ;;; readtable. -(let* ((*readtable* (copy-readtable nil))) - (set-syntax-from-char #\" #\A) - (multiple-value-bind (reader-fn non-terminating-p) - (get-macro-character #\" (copy-readtable nil)) - (declare (ignore reader-fn)) - (assert (not non-terminating-p)))) +(with-test (:name (get-macro-character :argument)) + (let* ((*readtable* (copy-readtable nil))) + (set-syntax-from-char #\" #\A) + (multiple-value-bind (reader-fn non-terminating-p) + (get-macro-character #\" (copy-readtable nil)) + (declare (ignore reader-fn)) + (assert (not non-terminating-p))))) (with-test (:name :bug-309093) (assert (eq :error @@ -316,7 +324,7 @@ (reader-error () :error))))) -(with-test (:name :set-syntax-from-char-dispatch-macro-char) +(with-test (:name (set-syntax-from-char :dispatch-macro-char)) (let ((rt (copy-readtable))) (make-dispatch-macro-character #\! nil rt) (set-dispatch-macro-character #\! #\! (constantly 'bang^2) rt) diff -Nru sbcl-2.0.6/tests/redblack.pure.lisp sbcl-2.1.1/tests/redblack.pure.lisp --- sbcl-2.0.6/tests/redblack.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/redblack.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -6,6 +6,7 @@ color-of left right node-key node-value data find= find<=)) +(load "bbtree-test-util.lisp") (defun verify-invariants (root print) (unless root @@ -211,3 +212,10 @@ (dotimes (i n-items) (setq tree (redblack:insert tree i i))) tree) + +(defun test-rb-find-inexact (n-nodes n-iterations) + (bbtree-test:test-find-inexact-macro redblack:insert + find<= redblack:find>= node-key)) + +(test-util:with-test (:name :rb-find-inexact) + (bbtree-test:exercise-find-inexact 'test-rb-find-inexact)) diff -Nru sbcl-2.0.6/tests/run-compiler.sh sbcl-2.1.1/tests/run-compiler.sh --- sbcl-2.0.6/tests/run-compiler.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/run-compiler.sh 2021-01-30 11:22:39.000000000 +0000 @@ -2,7 +2,7 @@ platform="${SBCL_SOFTWARE_TYPE}-${SBCL_MACHINE_TYPE}" -if [ -z $CC ]; then +if [ -z "$CC" ]; then if [ -x "`command -v cc`" ]; then CC=cc else diff -Nru sbcl-2.0.6/tests/run-program.impure.lisp sbcl-2.1.1/tests/run-program.impure.lisp --- sbcl-2.0.6/tests/run-program.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/run-program.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -333,7 +333,9 @@ #-win32 (with-test (:name (run-program :if-input-does-not-exist)) (let ((file (pathname (sb-posix:mktemp "rpXXXXXX")))) - (when (boundp 'run-tests::*allowed-inputs*) + (when (and (boundp 'run-tests::*allowed-inputs*) + ;; If the permitted inputs are :ANY then leave it be + (listp (symbol-value 'run-tests::*allowed-inputs*))) (push (namestring file) (symbol-value 'run-tests::*allowed-inputs*))) (assert (null (run-program "/bin/cat" '() :input file))) (assert (null (run-program "/bin/cat" '() :output #.(or *compile-file-truename* @@ -417,11 +419,24 @@ :broken-on :sb-safepoint :skipped-on (or (not :sb-thread) :win32)) (let* (stop + (delay-between-gc + (or #+freebsd + (let* ((p (run-program "sysctl" '("hw.model") :search t :output :stream)) + (output (process-output p)) + (result (read-line output))) + (close output) + ;; With the default delay of 0 using FreeBSD on QEMU this test never + ;; finished because the RUN-PROGRAM thread would never get scheduled + ;; after its first entry into the loop. + ;; It wasn't hung, it just wasn't getting CPU time. For me anyway. + (when (search "QEMU" result) + .00000001)) ; 10 nanoseconds + 0)) (threads (list* (sb-thread:make-thread (lambda () (loop until stop do - (sleep 0) + (sleep delay-between-gc) (gc :full t)))) (loop repeat 3 collect diff -Nru sbcl-2.0.6/tests/run-tests.lisp sbcl-2.1.1/tests/run-tests.lisp --- sbcl-2.0.6/tests/run-tests.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/run-tests.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -162,8 +162,8 @@ (= (mismatch string "/dev/") 5) ; dev/null and dev/random (= (mismatch string "/tmp/") 5) (= (mismatch string "/var/tmp/") 9) + (= (mismatch string "/proc/self") 10) (eql (search "/private/var/folders/" string) 0) - (string= string "/proc/self/maps") (string= string "exists") (member (stem-of filename) '("compiler-test-util.lisp" "a.txt" "b.lisp" diff -Nru sbcl-2.0.6/tests/save4.test.sh sbcl-2.1.1/tests/save4.test.sh --- sbcl-2.0.6/tests/save4.test.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/save4.test.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -export TEST_BASEDIR=${TMPDIR:-/tmp} -. ./subr.sh - -sourcefile=`pwd -P`/heap-reloc/embiggen.lisp -use_test_subdirectory - -tmpcore=$TEST_FILESTEM.core - -# Expose potential failure that could happen in save-lisp-and-die in an image -# that was restarted from one that underwent number coalescing during a -# previous save-lisp-and-die: A bignum as a layout bitmap can be forwarded -# while using that bignum as the bitmap to decide what to scan in that selfsame -# instance. Aside from random failure, this could be detected by enabling -# 'verify_gens' which printed "Ptr sees free page" after GC failed to scavenge -# all pointer slots. I believe that it was a coincidence that my test croaked -# specifically while scanning layout-of-layout. It could have been any -# structure having a slot holding a bignum EQ to its own layout-bitmap. -run_sbcl --load ${sourcefile} <: -;;; Cannot save core with multiple threads running. -;;; -;;; Interactive thread (of current session): -;;; # -;;; -;;; Other thread: -;;; # - -;;; The test below is sufficient to show that it has been fixed. - -#-sb-thread (exit :code 104) - -(sb-int:encapsulate - 'sb-thread::new-lisp-thread-trampoline - 'finalizer-bug - (lambda (f thread semaphore userfun args) - (funcall f thread semaphore - (lambda (&rest args) - (sleep .1) - (apply userfun args)) - args))) - -(finalize (cons 1 'foo) - (lambda () (format t "~&finalizer1~%"))) -(finalize (cons 2 'foo) - (lambda () (format t "~&finalizer2~%"))) - -(setq sb-ext:*save-hooks* (list #'gc)) - -;;; DEINIT will invoke the save hooks which should cause post-GC -;;; to start the finalizer thread. The finalizer thread has a brief -;;; delay purposely induced before its main body. Therefore it won't -;;; have assigned *CURRENT-THREAD* into *FINALIZER-THREAD* until after -;;; FINALIZER-THREAD-STOP has returned. Therefore the test in DEINIT -;;; will see that thread in all threads, and will have to deal with it. -(let (sb-impl::*streams-closed-by-slad*) - (sb-impl::deinit) - (sb-impl::restore-fd-streams) - (sb-impl::reinit)) diff -Nru sbcl-2.0.6/tests/seq.pure.lisp sbcl-2.1.1/tests/seq.pure.lisp --- sbcl-2.0.6/tests/seq.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/seq.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -534,3 +534,12 @@ `(lambda (x) (make-array 3 :element-type 'fixnum :initial-element x)) ((1) #(1 1 1) :test #'equalp)))) + + +(with-test (:name (search :type-derivation)) + (checked-compile-and-assert + () + `(lambda (s) + (search '(a) s :end1 nil)) + (('(b a)) 1) + ((#(1)) nil))) diff -Nru sbcl-2.0.6/tests/session.impure.lisp sbcl-2.1.1/tests/session.impure.lisp --- sbcl-2.0.6/tests/session.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/session.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -28,6 +28,23 @@ (with-test (:name (:no-session-deadlock)) (make-join-thread (lambda () (sb-ext:gc)))) +(with-test (:name (:make-thread-while-holding-session-lock)) + (let ((thr1 nil) + (thr2 nil) + (sem1 (sb-thread:make-semaphore)) + (sem2 (sb-thread:make-semaphore))) + (sb-thread::with-session-lock (sb-thread::*session*) + (setq thr1 (sb-thread:make-thread + #'sb-thread:signal-semaphore :arguments sem1) + thr2 (sb-thread:make-thread + #'sb-thread:signal-semaphore :arguments sem2)) + ;; This used to hang right here because threads could not make progress + ;; in their lisp-side trampoline. + (sb-thread:wait-on-semaphore sem1) + (sb-thread:wait-on-semaphore sem2)) + (sb-thread:join-thread thr1) + (sb-thread:join-thread thr2))) + (with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted) :broken-on :win32) (sb-debug::enable-debugger) diff -Nru sbcl-2.0.6/tests/signals.impure.lisp sbcl-2.1.1/tests/signals.impure.lisp --- sbcl-2.0.6/tests/signals.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/signals.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -13,6 +13,7 @@ (use-package :test-util) +(sb-ext:finalize (list 1) (lambda ())) (with-test (:name (:async-unwind :specials)) (let ((*x0* nil) (*x1* nil) (*x2* nil) (*x3* nil) (*x4* nil)) (declare (special *x0* *x1* *x2* *x3* *x4*)) @@ -45,7 +46,8 @@ ;; (namely SLEEP) to produce known-good arguments, and ;; even if we wanted to check argument validity, ;; integration with `errno' is not to be expected. - :skipped-on :win32) + ;; And this hangs on darwin + safepoint. + :skipped-on (or :win32 (:and :darwin :sb-safepoint))) (let* (saved-errno (returning nil) (timer (make-timer (lambda () @@ -62,16 +64,20 @@ ;; we get EINTR. (loop until returning) (assert (= saved-errno (sb-unix::get-errno))))) + ;; It is desirable to support C-c on Windows, but SIGINT ;; is not the mechanism to use on this platform. +;; This test used to call kill_safely() in the C runtime if using safepoints, +;; and perhaps at some point kill_safely() interacted with the safepoint state +;; for POSIX (i.e. not win32), but it doesn't, at least not now. +;; The special case in kill_safely() for the current thread is pthread_kill() +;; and not a thing more, unless on win32, which skips this test. #-win32 (with-test (:name :handle-interactive-interrupt) (assert (eq :condition (handler-case (progn - (sb-thread::kill-safely - (sb-thread::thread-os-thread sb-thread::*current-thread*) - sb-unix:sigint) + (sb-thread::raise sb-unix:sigint) #+sb-safepoint-strictly ;; In this case, the signals handler gets invoked ;; indirectly through an INTERRUPT-THREAD. Give it @@ -95,3 +101,16 @@ (sb-ext:with-timeout 0.1 (sleep 1) t)))) (sb-ext:timeout () nil)))) + +#+unix +(with-test (:name :ignore-sigpipe) + (multiple-value-bind (read-side write-side) (sb-unix:unix-pipe) + (sb-unix:unix-close read-side) + (sb-sys:enable-interrupt sb-unix:sigpipe :ignore) + (let ((buffer "x")) + (sb-sys:with-pinned-objects (buffer) + (multiple-value-bind (nbytes errno) + (sb-unix:unix-write write-side buffer 0 1) + (assert (and (null nbytes) + (= errno sb-unix:epipe)))))) + (sb-unix:unix-close write-side))) diff -Nru sbcl-2.0.6/tests/simd-pack-256.impure.lisp sbcl-2.1.1/tests/simd-pack-256.impure.lisp --- sbcl-2.0.6/tests/simd-pack-256.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/simd-pack-256.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -173,3 +173,16 @@ '(1d0 2d0 3d0 4d0))))) (when tmp-fasl (delete-file tmp-fasl)) (delete-file *tmp-filename*)))) + + +(with-test (:name :spilling) + (checked-compile-and-assert + () + `(lambda (x y) + (declare ((sb-ext:simd-pack-256 (unsigned-byte 64)) x)) + (eval y) + (list (sb-kernel:%simd-pack-256-0 x) + (sb-kernel:%simd-pack-256-1 x) + (sb-kernel:%simd-pack-256-2 x) + (sb-kernel:%simd-pack-256-3 x) y)) + (((sb-ext:%make-simd-pack-256-ub64 1 2 3 4) 0) '(1 2 3 4 0) :test #'equal))) diff -Nru sbcl-2.0.6/tests/static-garbage.impure.lisp sbcl-2.1.1/tests/static-garbage.impure.lisp --- sbcl-2.0.6/tests/static-garbage.impure.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/static-garbage.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,10 @@ +;;; Ideally we want to assert that there are no pseudostatic unreachable objects +;;; at all, but that's not simple to do from lisp. +;;; Perform this by itself to remain unaffected by anything else. +#-cheneygc +(with-test (:name :pseudostatic-garbage :skipped-on (:not :sb-thread)) + (flet ((check-not-static (list) + (dolist (x list) + (assert (< (sb-kernel:generation-of x) sb-vm:+pseudo-static-generation+))))) + (check-not-static (sb-vm:list-allocated-objects :all :test #'sb-thread::thread-p)) + (check-not-static (sb-vm:list-allocated-objects :all :test #'sb-thread::semaphore-p)))) diff -Nru sbcl-2.0.6/tests/stream.impure.lisp sbcl-2.1.1/tests/stream.impure.lisp --- sbcl-2.0.6/tests/stream.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/stream.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -23,7 +23,7 @@ #P"/tmp/"))) (require :sb-posix) -;;; Believe it or not the x86-64-specific trap routine for UPDATE-OBJECT-LAYOUT-OR-INVALID +;;; Believe it or not the x86-64-specific trap routine for UPDATE-OBJECT-LAYOUT ;;; could fail to return the correct layout after calling from assembly code into lisp, ;;; back to assembly code, back to the vop, and not a single regression test failed. (defclass astream (fundamental-output-stream) ()) @@ -670,7 +670,8 @@ (assert (< (- (get-universal-time) time) 2))))) #-win32 -(with-test (:name (open :interrupt) :skipped-on :win32) +(with-test (:name (open :interrupt) + :skipped-on (or :win32 (:and :darwin :sb-safepoint))) (let ((to 0)) (with-scratch-file (fifo) ;; Make a FIFO @@ -853,4 +854,20 @@ (sb-impl::ansi-stream-read-string-from-frc-buffer string s 0 nil))) (assert (= endpos 0))))) -;;; success +(with-test (:name :named-pipe-wait-eof) + (let* ((process (run-program "cat" '() :search t + :wait nil :input nil :output :stream)) + (out (process-output process))) + (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd out) :input) + (assert (null (read-byte (process-output process) nil nil))) + (process-close process))) + +(with-test (:name :concatenated-stream-listen) + (let ((file (scratch-file-name))) + (with-open-file (stream file :direction :output :if-exists :supersede) + (write-line "abc" stream)) + (with-open-file (stream file) + (let ((cs (make-concatenated-stream stream))) + (read-char-no-hang cs) + (assert (listen cs)))) + (delete-file file))) diff -Nru sbcl-2.0.6/tests/stream.pure.lisp sbcl-2.1.1/tests/stream.pure.lisp --- sbcl-2.0.6/tests/stream.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/stream.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -136,6 +136,11 @@ ;;; Ideas? #+nil (assert (eq (interactive-stream-p *terminal-io*) t)) +;;; FILE-POSITION should not accept NIL +(with-test (:name :file-position-smoke-test) + (let ((s (make-broadcast-stream))) + (assert-error (file-position s (opaque-identity nil)) type-error))) + ;;; MAKE-STRING-INPUT-STREAM ;;; ;;; * Observe FILE-POSITION :START and :END, and allow setting of @@ -280,8 +285,7 @@ (let ((s (with-output-to-string (s nil ,@(when element-type-form `(:element-type ,element-type-form)))))) - (assert (typep s '(simple-array ,(if element-type-form - (eval element-type-form) + (assert (typep s '(simple-array ,(or (eval element-type-form) 'character) (0))))) (get-output-stream-string @@ -290,19 +294,7 @@ `(:element-type ,element-type-form))))))) ;; If you pass NIL as element-type, note that there seems to be no requirement ;; to produce a stream that can *accept* only characters of that type. - ;; We produce a BASE-STRING-OUTPUT-STREAM if you do something so pointless, - ;; and accept base characters written to that stream. - ;; However, we'll always return a (simple-array nil (0)) from such stream. - ;; For comparison - - ;; CCL: (type-of (get-output-stream-string (make-string-output-stream :element-type nil))) - ;; => (SIMPLE-BASE-STRING 0) - ;; ABCL: - ;; (let ((s (make-string-output-stream :element-type nil))) - ;; (write-string "Hi" s) - ;; (get-output-stream-string s)) => "" - ;; CLISP is more pedantic, refusing to accept characters and returning a NIL vector: - ;; (type-of (get-output-stream-string (make-string-output-stream :element-type nil))) - ;; => (VECTOR NIL 0) + ;; We produce a CHARACTER-STRING-OUTPUT-STREAM if you do something so pointless. (frob nil) (frob 'character) (frob 'base-char) @@ -372,7 +364,7 @@ ;;; immediately be completely filled for normal files, and that the ;;; buffer-fill routine is responsible for figuring out when we've ;;; reached EOF. -(with-test (:name (stream :listen-vs-select) :fails-on :win32) +(with-test (:name (stream :listen-vs-select)) (let ((listen-testfile-name (scratch-file-name)) ;; If non-NIL, size (in bytes) of the file that will exercise ;; the LISTEN problem. @@ -502,3 +494,20 @@ (compile 'input-from-dynamic-extent-stream) (with-test (:name :with-input-from-string-signal-stream-error) (assert (search "unavailable" (input-from-dynamic-extent-stream)))) + +(with-test (:name :closeable-broadcast-stream) + (let ((b (make-broadcast-stream))) + (close b) + (assert (not (open-stream-p b))) + (assert-error (write-string "test" b)))) + +(defvar *some-stream*) +(with-test (:name :closeable-synonym-stream) + (let ((*some-stream* (make-string-input-stream "hola"))) + (let ((syn (make-synonym-stream '*some-stream*))) + (assert (eql (read-char syn) #\h)) + (close syn) + (assert (not (open-stream-p syn))) + (assert-error (read-char syn)) + (close syn) ; no error + (assert (eql (read-char *some-stream*) #\o))))) diff -Nru sbcl-2.0.6/tests/string.pure.lisp sbcl-2.1.1/tests/string.pure.lisp --- sbcl-2.0.6/tests/string.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/string.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -48,34 +48,76 @@ (nstring-capitalize nstring) (assert (string= nstring "Cat")))) -;;; (VECTOR NIL)s are strings. Tests for that and issues uncovered in -;;; the process. +#| +(VECTOR NIL)s are strings only if you believe that the definition involving union +types prevails over the ample amount of exposition in the spec, as well as utility +of the resulting strings, and common sense. + +I tested 9 other implementations, and 7 of them agree that: + (SUBTYPEP '(SIMPLE-ARRAY NIL (*)) 'STRING) => NIL and T + +They have differing behaviors as to effect of make-string and make-array as follows: + +Allegro (10.1 Free Express Edition): + (SIMPLE-ARRAY NIL (*)) exists but does not satisfy STRINGP + (make-string 1 :element-type NIL) returns a (SIMPLE-ARRAY CHARACTER (1)) + +Clasp (built from git rev 6b8047c2 @ 2020-10-22): + (make-array 1 :element-type NIL) signals error + (make-string 1 :element-type NIL) returns a (SIMPLE-ARRAY CHARACTER (1)) + +Clozure (v1.12): + (make-array 1 :element-type NIL) returns (SIMPLE-VECTOR 1) + (make-string 1 :element-type NIL) returns a (SIMPLE-BASE-STRING 1) + +CMUCL (version 20d Unicode): + (make-array 1 :element-type nil) returns (SIMPLE-BASE-STRING 1) + as does MAKE-STRING. + +ECL (version 20.4.24): + (make-array 1 :element-type NIL) says + "ECL does not support arrays with element type NIL" + (make-string 1 :element-type NIL) returns a (SIMPLE-ARRAY BASE-CHAR (1)) + +GCL (version 2.6.12 CLtL1): + (type-of (make-array 1 :element-type nil)) => VECTOR + (array-element-type (make-string 1 :element-type nil)) => STRING-CHAR + +MKCL (version 1.1.11): + (make-array 1 :element-type NIL) returns a (VECTOR NIL 1) + (make-string 1 :element-type NIL) returns a (SIMPLE-BASE-STRING 1) + +Of the dissenters, they return T and T from the subtypep expression above +though their behavioral differences from MAKE-ARRAY to MAKE-STRING +present compelling evidence that at least in their API they disfavor considering +an object a string if it has element type NIL, hence MAKE-STRING upgrades NIL +to a nonempty type. +ABCL (version 1.7.1): + (type-of (make-array 1 :element-type nil)) => (NIL-VECTOR 1) + (type-of (make-string 1 :element-type nil)) => (SIMPLE-BASE-STRING 1) + Also: (make-string 1 :element-type 'ratio) => "^@" ; the type is just ignored +CLISP (version 2.49.92): + (type-of (make-array 1 :element-type nil)) => (SIMPLE-ARRAY NIL (1)) + (type-of (make-string 1 :element-type nil)) => (SIMPLE-BASE-STRING 1) + +And one more Lisp implementation which matches none of the above- +Lispworks personal edition 7.1: + (make-array 1 :element-type nil) signals + ERROR: (ARRAY NIL) is an illegal type specifier. + (make-string 1 :element-type nil) signals + ERROR: (ARRAY NIL) is an illegal type specifier. + (subtypep '(vector nil) 'string) signals + ERROR: (ARRAY NIL (*)) is an illegal type specifier. + +Hence (SIMPLE-ARRAY NIL (*)) is most plausibly not regarded as a string, +the ANSI compliance test suite notwithstanding. +And the range of implementation choices suggest that users can not reasonably +claim that any particular result from these edge cases constitutes a bug. +|# (with-test (:name (vector nil)) - (assert (typep (make-array 1 :element-type nil) 'string)) - (assert (not (typep (make-array 2 :element-type nil) 'base-string))) - (assert (typep (make-string 3 :element-type nil) 'simple-string)) - (assert (not (typep (make-string 4 :element-type nil) 'simple-base-string))) - - (assert (subtypep (class-of (make-array 1 :element-type nil)) - (find-class 'string))) - (assert (subtypep (class-of (make-array 2 :element-type nil :fill-pointer 1)) - (find-class 'string))) - - (assert (string= "" (make-array 0 :element-type nil))) - (assert (string/= "a" (make-array 0 :element-type nil))) - (assert (string= "" (make-array 5 :element-type nil :fill-pointer 0))) - - (assert (= (sxhash "") - (sxhash (make-array 0 :element-type nil)) - (sxhash (make-array 5 :element-type nil :fill-pointer 0)) - (sxhash (make-string 0 :element-type nil)))) - (assert (subtypep (type-of (make-array 2 :element-type nil)) 'simple-string)) - (assert (subtypep (type-of (make-array 4 :element-type nil :fill-pointer t)) - 'string)) - - (assert (eq (intern "") (intern (make-array 0 :element-type nil)))) - (assert (eq (intern "") - (intern (make-array 5 :element-type nil :fill-pointer 0))))) + (assert (not (stringp (make-array 0 :element-type nil)))) + (assert (not (subtypep (class-of (make-array 1 :element-type nil)) + (find-class 'string))))) (with-test (:name (make-string :element-type t type-error)) (multiple-value-bind (fun failure-p warnings) @@ -159,8 +201,11 @@ (with-test (:name :nil-vector-access) (let ((nil-vector (make-array 10 :element-type nil))) - (assert-error (write-to-string nil-vector) - sb-kernel:nil-array-accessed-error) + ;; Nowhere is it specified that PRINT-OBJECT on a VECTOR-NIL must + ;; access the contents and signal an error. So WRITE works fine. + (assert (write-to-string nil-vector)) + (let ((*read-eval* nil)) + (assert-error (write-to-string nil-vector :readably t))) (flet ((test (accessor) (assert-error (funcall (checked-compile @@ -172,14 +217,15 @@ nil-vector) sb-kernel:nil-array-accessed-error))) (test 'aref) - (test 'char) - (test 'schar) + ;; (test 'char) ; you'll get a TYPE-ERROR instead. + ;; (test 'schar) ; ditto (test 'row-major-aref)))) (with-test (:name :nil-array-access) (let ((nil-array (make-array '(10 10) :element-type nil))) - (assert-error (write-to-string nil-array) - sb-kernel:nil-array-accessed-error) + (assert (write-to-string nil-array)) + (let ((*read-eval* nil)) + (assert-error (write-to-string nil-array :readably t))) (flet ((test (accessor args) (assert-error (funcall (checked-compile diff -Nru sbcl-2.0.6/tests/test-util.lisp sbcl-2.1.1/tests/test-util.lisp --- sbcl-2.0.6/tests/test-util.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/test-util.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -120,7 +120,25 @@ (sb-ext:wait-for (null (sb-thread::thread-interruptions thread)))) (defun test-interrupt (function-to-interrupt &optional quit-p) - (let ((child (make-kill-thread function-to-interrupt))) + ;; Tests of interrupting a newly created thread can fail if the creator runs + ;; so quickly that it bypasses execution of the created thread. So the creator + ;; needs to wait, to have a facsimile of the situation prior to implementation + ;; of the so-called pauseless thread start feature. + ;; Wouldn't you know, it's just reintroducing a startup semaphore. + ;; And interruption tests are even more likely to fail with sb-thruption + ;; because sb-thruption is flawed: it presumes that there is enough synchronization + ;; between sender/receiver that checking the INVOKED variable (shared via a closure) + ;; makes any sense at all, which it doesn't. (In addition, it supposes that merely + ;; by polling at safepoints, interrupts somehow become safe, which is not true + ;; in general - it is only true of the GC "interrupt" delivered by the kernel + ;; when the safepoint page trap is hit.) + ;; Noneless, this tries to be robust enough to pass. + (let* ((sem (sb-thread:make-semaphore)) + (child (make-kill-thread + (lambda () + (sb-thread:signal-semaphore sem) + (funcall function-to-interrupt))))) + (sb-thread:wait-on-semaphore sem) (format t "interrupting child ~A~%" child) (sb-thread:interrupt-thread child (lambda () @@ -192,7 +210,7 @@ ;;; Like RUN-TEST but do not perform any of the automated thread management. ;;; Since multiple threads are executing tests, there is no reason to kill ;;; unrecognized threads. -(sb-ext:define-load-time-global *output-mutex* (sb-thread:make-mutex)) +(sb-ext:define-load-time-global *output-mutex* (sb-thread:make-mutex :name "run-tests output")) (defun run-test-concurrently (test-spec) (destructuring-bind (test-body . name) test-spec (sb-thread:with-mutex (*output-mutex*) @@ -815,7 +833,8 @@ finally (return (/ min-internal-time-units-per-call (float internal-time-units-per-second))))) -(defmacro runtime (form &key (repetitions 5) (precision 30)) +(defmacro runtime (form &key (repetitions 5) (precision (* 30 + (/ internal-time-units-per-second 1000)))) `(runtime* (lambda () ,form) ,repetitions ,precision)) (declaim (notinline opaque-identity)) @@ -850,17 +869,15 @@ (let ((a (make-array 10 :element-type 'character))) (dotimes (i 10) (setf (aref a i) (code-char (+ (char-code #\a) (random 26))))) - ;; not sure where to write files on win32. this is no worse than what it was - #+win32 (format nil "~a~@[.~a~]" a extension) - #-win32 (let ((dir (posix-getenv "TMPDIR")) - (file (format nil "sbcl~d~a~@[.~a~]" - (sb-unix:unix-getpid) a extension))) - (if dir - (namestring - (merge-pathnames - file (truename (parse-native-namestring dir nil *default-pathname-defaults* - :as-directory t)))) - (concatenate 'string "/tmp/" file))))) + (let ((dir (posix-getenv #+win32 "TMP" #+unix "TMPDIR")) + (file (format nil "sbcl~d~a~@[.~a~]" + (sb-unix:unix-getpid) a extension))) + (if dir + (namestring + (merge-pathnames + file (truename (parse-native-namestring dir nil *default-pathname-defaults* + :as-directory t)))) + (concatenate 'string "/tmp/" file))))) (defmacro with-scratch-file ((var &optional extension) &body forms) (sb-int:with-unique-names (tempname) diff -Nru sbcl-2.0.6/tests/threads.impure.lisp sbcl-2.1.1/tests/threads.impure.lisp --- sbcl-2.0.6/tests/threads.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/threads.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -12,7 +12,7 @@ ;;;; more information. -;;;; WHITE-BOX TESTS +;;;; STRUCTURAL TESTS (shadowing-import 'assertoid:assert-error) (use-package "SB-THREAD") @@ -21,8 +21,6 @@ (setf sb-unix::*on-dangerous-wait* :error) (with-test (:name (:threads :trivia)) - (assert (eql 1 (length (list-all-threads)))) - (assert (eq *current-thread* (find (thread-name *current-thread*) (list-all-threads) :key #'thread-name :test #'equal))) @@ -140,8 +138,10 @@ (let ((old-threads (list-all-threads)) (thread (make-thread (lambda () + ;; I honestly have no idea what this is testing. + ;; It seems to be nothing more than an implementation change detector test. (assert (sb-thread::avl-find - (sb-kernel:get-lisp-obj-address sb-vm:*control-stack-start*) + (sb-thread::thread-primitive-thread sb-thread:*current-thread*) sb-thread::*all-threads*)) (sleep 2)))) (new-threads (list-all-threads))) @@ -213,23 +213,23 @@ (with-test (:name (:mutex :basics)) (let ((l (make-mutex :name "foo")) (p *current-thread*)) - (assert (eql (mutex-value l) nil) nil "1") + (assert (eql (mutex-owner l) nil) nil "1") (grab-mutex l) - (assert (eql (mutex-value l) p) nil "3") + (assert (eql (mutex-owner l) p) nil "3") (release-mutex l) - (assert (eql (mutex-value l) nil) nil "5"))) + (assert (eql (mutex-owner l) nil) nil "5"))) (with-test (:name (with-recursive-lock :basics)) (labels ((ours-p (value) (eq *current-thread* value))) (let ((l (make-mutex :name "rec"))) - (assert (eql (mutex-value l) nil) nil "1") + (assert (eql (mutex-owner l) nil) nil "1") (with-recursive-lock (l) - (assert (ours-p (mutex-value l)) nil "3") + (assert (ours-p (mutex-owner l)) nil "3") (with-recursive-lock (l) - (assert (ours-p (mutex-value l)) nil "4")) - (assert (ours-p (mutex-value l)) nil "5")) - (assert (eql (mutex-value l) nil) nil "6")))) + (assert (ours-p (mutex-owner l)) nil "4")) + (assert (ours-p (mutex-owner l)) nil "5")) + (assert (eql (mutex-owner l) nil) nil "6")))) (with-test (:name (with-recursive-lock :wait-p)) (let ((m (make-mutex))) @@ -282,19 +282,19 @@ (n 0)) (labels ((in-new-thread () (with-mutex (lock) - (assert (eql (mutex-value lock) *current-thread*)) + (assert (eql (mutex-owner lock) *current-thread*)) (format t "~A got mutex~%" *current-thread*) ;; now drop it and sleep (condition-wait queue lock) ;; after waking we should have the lock again - (assert (eql (mutex-value lock) *current-thread*)) + (assert (eql (mutex-owner lock) *current-thread*)) (assert (eql n 1)) (decf n)))) (make-join-thread #'in-new-thread) (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) - (assert (eql (mutex-value lock) nil)) + (assert (eql (mutex-owner lock) nil)) (with-mutex (lock) (incf n) (condition-notify queue)) @@ -307,18 +307,18 @@ (eq *current-thread* value)) (in-new-thread () (with-recursive-lock (lock) - (assert (ours-p (mutex-value lock))) - (format t "~A got mutex~%" (mutex-value lock)) + (assert (ours-p (mutex-owner lock))) + (format t "~A got mutex~%" (mutex-owner lock)) ;; now drop it and sleep (condition-wait queue lock) ;; after waking we should have the lock again - (format t "woken, ~A got mutex~%" (mutex-value lock)) - (assert (ours-p (mutex-value lock)))))) + (format t "woken, ~A got mutex~%" (mutex-owner lock)) + (assert (ours-p (mutex-owner lock)))))) (make-join-thread #'in-new-thread) (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) - (assert (eql (mutex-value lock) nil)) + (assert (eql (mutex-owner lock) nil)) (with-recursive-lock (lock) (condition-notify queue)) (sleep 1)))) @@ -616,11 +616,17 @@ (with-test (:name :all-threads-have-abort-restart :broken-on :win32) - (loop repeat 100 do - (let ((thread (make-kill-thread (lambda () (sleep 100000000))))) - (interrupt-thread thread (lambda () - (assert (find-restart 'abort)))) - (process-all-interrupts thread)))) + ;; This test can fail with without the extra semaphore. + ;; See also TEST-INTERRUPT in test-util for further explanation. + (let* ((sem (make-semaphore)) + (thread (make-kill-thread + (lambda () + (signal-semaphore sem) + (sleep 100000000))))) + (wait-on-semaphore sem) + (interrupt-thread thread (lambda () + (assert (find-restart 'abort)))) + (process-all-interrupts thread))) (sb-ext:gc :full t) @@ -767,70 +773,6 @@ (mapc #'join-thread threads) (assert (not deadline-handler-run-twice?)))) -(with-test (:name (condition-wait :signal-deadline-with-interrupts-enabled)) - (let ((mutex (make-mutex)) - (waitq (make-waitqueue)) - (A-holds? :unknown) - (B-holds? :unknown) - (A-interrupts-enabled? :unknown) - (B-interrupts-enabled? :unknown) - (A) - (B)) - ;; W.L.O.G., we assume that A is executed first... - (setq A (make-thread - (lambda () - (handler-bind - ((sb-sys:deadline-timeout - (lambda (c) - ;; We came here through the call to DECODE-TIMEOUT - ;; in CONDITION-WAIT; hence both here are supposed - ;; to evaluate to T. - (setq A-holds? (holding-mutex-p mutex)) - (setq A-interrupts-enabled? - sb-sys:*interrupts-enabled*) - (sleep 0.2) - (condition-broadcast waitq) - (sb-sys:defer-deadline 10.0 c)))) - (sb-sys:with-deadline (:seconds 0.1) - (with-mutex (mutex) - (condition-wait waitq mutex))))) - :name "A")) - (setq B (make-thread - (lambda () - (thread-yield) - (handler-bind - ((sb-sys:deadline-timeout - (lambda (c) - ;; We came here through the call to DECODE-TIMEOUT - ;; in CONDITION-WAIT (contended case of - ;; reaquiring the mutex) - so the former will - ;; be NIL, but interrupts should still be enabled. - (setq B-holds? (holding-mutex-p mutex)) - (setq B-interrupts-enabled? - sb-sys:*interrupts-enabled*) - (sleep 0.2) - (condition-broadcast waitq) - (sb-sys:defer-deadline 10.0 c)))) - (sb-sys:with-deadline (:seconds 0.1) - (with-mutex (mutex) - (condition-wait waitq mutex))))) - :name "B")) - (join-thread A) - (join-thread B) - (let ((A-result (list A-holds? A-interrupts-enabled?)) - (B-result (list B-holds? B-interrupts-enabled?))) - ;; We also check some subtle behaviour w.r.t. whether a deadline - ;; handler in CONDITION-WAIT got the mutex, or not. This is most - ;; probably very internal behaviour (so user should not depend - ;; on it) -- I added the testing here just to manifest current - ;; behaviour. - (cond ((equal A-result '(t t)) (assert (equal B-result '(nil t)))) - ((equal B-result '(t t)) (assert (equal A-result '(nil t)))) - (t - (error "Failure: fell through wit A: ~S, B: ~S" - A-result - B-result)))))) - (with-test (:name (:mutex :finalization)) (let ((a nil)) (dotimes (i 500000) @@ -878,7 +820,7 @@ collect (make-thread #'subtypep-hash-cache-test))) (terpri)) -;;;; BLACK BOX TESTS +;;;; FUNCTIONAL TESTS (with-test (:name (:parallel defclass)) (write-line "WARNING, WILL HANG ON FAILURE!") @@ -891,22 +833,23 @@ ;; cheating, and might be hiding the underlying bug that the test is ;; exposing. Let's review this later. (let* ((run t) + (output nil) (d1 (sb-thread:make-thread (lambda () (loop while run do (defclass test-1 () ((a :initform :new-a))) - (write-char #\1) + (when output (write-char #\1)) #-win32 (force-output))) :name "d1")) (d2 (sb-thread:make-thread (lambda () (loop while run do (defclass test-2 () ((b :initform :new-b))) - (write-char #\2) + (when output (write-char #\2)) #-win32 (force-output))) :name "d2")) (d3 (sb-thread:make-thread (lambda () (loop while run do (defclass test-3 (test-1 test-2) ((c :initform :new-c))) - (write-char #\3) + (when output (write-char #\3)) #-win32 (force-output))) :name "d3")) (i (sb-thread:make-thread (lambda () @@ -915,7 +858,7 @@ (assert (member (slot-value i 'a) '(:orig-a :new-a))) (assert (member (slot-value i 'b) '(:orig-b :new-b))) (assert (member (slot-value i 'c) '(:orig-c :new-c)))) - (write-char #\i) + (when output (write-char #\i)) #-win32 (force-output))) :name "i"))) (format t "~%sleeping!~%") @@ -924,45 +867,10 @@ (setf run nil) (mapc (lambda (th) (sb-thread:join-thread th) - (format t "~%joined ~S~%" (sb-thread:thread-name th))) + (format t "~&joined ~S~%" (sb-thread:thread-name th))) (list d1 d2 d3 i)) (force-output))) -(with-test (:name (:deadlock-detection :interrupts) - :broken-on :win32) - (let* ((m1 (sb-thread:make-mutex :name "M1")) - (m2 (sb-thread:make-mutex :name "M2")) - (t1-can-go (sb-thread:make-semaphore :name "T1 can go")) - (t2-can-go (sb-thread:make-semaphore :name "T2 can go")) - (t1 (sb-thread:make-thread - (lambda () - (sb-thread:with-mutex (m1) - (sb-thread:wait-on-semaphore t1-can-go) - :ok1)) - :name "T1")) - (t2 (sb-thread:make-thread - (lambda () - (sb-ext:wait-for (eq t1 (sb-thread:mutex-owner m1))) - (sb-thread:with-mutex (m1 :wait-p t) - (sb-thread:wait-on-semaphore t2-can-go) - :ok2)) - :name "T2"))) - (sb-ext:wait-for (eq m1 (sb-thread::thread-waiting-for t2))) - (sb-thread:interrupt-thread t2 (lambda () - (sb-thread:with-mutex (m2 :wait-p t) - (sb-ext:wait-for - (eq m2 (sb-thread::thread-waiting-for t1))) - (sb-thread:signal-semaphore t2-can-go)))) - (sb-ext:wait-for (eq t2 (sb-thread:mutex-owner m2))) - (sb-thread:interrupt-thread t1 (lambda () - (sb-thread:with-mutex (m2 :wait-p t) - (sb-thread:signal-semaphore t1-can-go)))) - ;; both threads should finish without a deadlock or deadlock - ;; detection error - (let ((res (list (sb-thread:join-thread t1) - (sb-thread:join-thread t2)))) - (assert (equal '(:ok1 :ok2) res))))) - (with-test (:name :spinlock-api) (handler-bind ((warning #'error)) (destructuring-bind (with make get release) diff -Nru sbcl-2.0.6/tests/threads.pure.lisp sbcl-2.1.1/tests/threads.pure.lisp --- sbcl-2.0.6/tests/threads.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/threads.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -29,10 +29,10 @@ ;; Make sure basics are sane on unithreaded ports as well (let ((mutex (make-mutex))) (grab-mutex mutex) - (assert (eq *current-thread* (mutex-value mutex))) + (assert (eq *current-thread* (mutex-owner mutex))) (handler-bind ((warning #'error)) (release-mutex mutex)) - (assert (not (mutex-value mutex))))) + (assert (not (mutex-owner mutex))))) ;;; Terminating a thread that's waiting for the terminal. @@ -48,23 +48,34 @@ (assert (not (thread-alive-p thread))))) ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS +;;; BUT: Such a claim is without much merit. Even if a wait is not "interrupted", +;;; the very definition of spurious wakeup is that return from the wait happens +;;; for ANY reason - users of condition variables must ALWAYS anticipate needing +;;; to loop over a condition-wait. (with-test (:name :without-interrupts+condition-wait :skipped-on (not :sb-thread) :broken-on :win32) (let* ((lock (make-mutex)) (queue (make-waitqueue)) + (actually-wakeup nil) (thread (make-thread (lambda () (sb-sys:without-interrupts (with-mutex (lock) - (condition-wait queue lock))))))) - (sleep 1) + (loop + (condition-wait queue lock) + (if actually-wakeup (return))))))))) + (sleep .25) (assert (thread-alive-p thread)) + ;; this is the supposed "interrupt that doesn't interrupt", + ;; but it _is_ permitted to wake the condition variable. (terminate-thread thread) - (sleep 1) + (sleep .5) (assert (thread-alive-p thread)) + (setq actually-wakeup t) + (sb-thread:barrier (:write)) (condition-notify queue) - (sleep 1) + (sleep .25) (assert (not (thread-alive-p thread))))) ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS @@ -288,99 +299,6 @@ (sb-thread::symbol-value-in-thread-error-info e))))) (assert error-occurred))) -(with-test (:name :deadlock-detection.1 :skipped-on (not :sb-thread)) - (loop - repeat 1000 - do (flet ((test (ma mb sa sb) - (lambda () - (handler-case - (with-mutex (ma) - (signal-semaphore sa) - (wait-on-semaphore sb) - (with-mutex (mb) - :ok)) - (thread-deadlock (e) - ;; (assert (plusp (length ...))) prevents - ;; flushing. - (assert (plusp (length (princ-to-string e)))) - :deadlock))))) - (let* ((m1 (make-mutex :name "M1")) - (m2 (make-mutex :name "M2")) - (s1 (make-semaphore :name "S1")) - (s2 (make-semaphore :name "S2")) - (t1 (make-thread (test m1 m2 s1 s2) :name "T1")) - (t2 (make-thread (test m2 m1 s2 s1) :name "T2"))) - ;; One will deadlock, and the other will then complete normally. - (let ((res (list (join-thread t1) - (join-thread t2)))) - (assert (or (equal '(:deadlock :ok) res) - (equal '(:ok :deadlock) res)))))))) - -(with-test (:name :deadlock-detection.2 :skipped-on (not :sb-thread)) - (let* ((m1 (make-mutex :name "M1")) - (m2 (make-mutex :name "M2")) - (s1 (make-semaphore :name "S1")) - (s2 (make-semaphore :name "S2")) - (t1 (make-thread - (lambda () - (with-mutex (m1) - (signal-semaphore s1) - (wait-on-semaphore s2) - (with-mutex (m2) - :ok))) - :name "T1"))) - (prog (err) - :retry - (handler-bind ((thread-deadlock - (lambda (e) - (unless err - ;; Make sure we can print the condition - ;; while it's active - (let ((*print-circle* nil)) - (setf err (princ-to-string e))) - (go :retry))))) - (when err - (sleep 1)) - (assert (eq :ok (with-mutex (m2) - (unless err - (signal-semaphore s2) - (wait-on-semaphore s1) - (sleep 1)) - (with-mutex (m1) - :ok))))) - (assert (stringp err))) - (assert (eq :ok (join-thread t1))))) - -(with-test (:name :deadlock-detection.3 :skipped-on (not :sb-thread)) - (let* ((m1 (make-mutex :name "M1")) - (m2 (make-mutex :name "M2")) - (s1 (make-semaphore :name "S1")) - (s2 (make-semaphore :name "S2")) - (t1 (make-thread - (lambda () - (with-mutex (m1) - (signal-semaphore s1) - (wait-on-semaphore s2) - (with-mutex (m2) - :ok))) - :name "T1"))) - ;; Currently we don't consider it a deadlock - ;; if there is a timeout in the chain. - (assert (eq :deadline - (handler-case - (with-mutex (m2) - (signal-semaphore s2) - (wait-on-semaphore s1) - (sleep 1) - (sb-sys:with-deadline (:seconds 0.1) - (with-mutex (m1) - :ok))) - (sb-sys:deadline-timeout () - :deadline) - (thread-deadlock () - :deadlock)))) - (assert (eq :ok (join-thread t1))))) - #+sb-thread (with-test (:name :pass-arguments-to-thread) (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2)))))) @@ -490,10 +408,7 @@ (with-test (:name (wait-on-semaphore semaphore-notification :lp-1038034) :skipped-on (not :sb-thread) - ;; Maybe because they don't use futexes? - :fails-on (and :sb-thread - (not (or :darwin :openbsd :sunos))) - :broken-on :win32) + :broken-on :sb-safepoint) ;; Test robustness of semaphore acquisition and notification with ;; asynchronous thread termination... Which we know is currently ;; fragile. @@ -531,8 +446,8 @@ :timeout timeout :default :timeout)) (error "Hang in (join-thread ~A) ?" thread)))) - (safe-join-thread t1 :timeout 10) - (safe-join-thread t3 :timeout 10))))) + (safe-join-thread t1 :timeout 60) + (safe-join-thread t3 :timeout 60))))) (when (zerop (mod run 60)) (fresh-line) (write-string "; ")) @@ -577,3 +492,22 @@ (with-test (:name (abort-thread :main-thread)) (assert (main-thread-p)) (assert-error (abort-thread) thread-error)) + +;;; The OSes vary in how pthread_setname works. +;;; According to https://stackoverflow.com/questions/2369738/how-to-set-the-name-of-a-thread-in-linux-pthreads +;;; // NetBSD: name + arg work like printf(name, arg) +;;; int pthread_setname_np(pthread_t thread, const char *name, void *arg); +;;; // FreeBSD & OpenBSD: function name is slightly different, and has no return value +;;; void pthread_set_name_np(pthread_t tid, const char *name); +;;; // Mac OS X: must be set from within the thread (can't specify thread ID) +;;; int pthread_setname_np(const char*); +;;; Only Linux is implemented for now. +(with-test (:name :os-thread-name :skipped-on (:not (and :linux :sb-thread))) + (let ((thr + (make-thread + (lambda () + (with-open-file (stream (format nil "/proc/self/task/~d/comm" + (thread-os-tid *current-thread*))) + (read-line stream))) + :name "testme"))) + (assert (string= (join-thread thr) "testme")))) diff -Nru sbcl-2.0.6/tests/timer.impure.lisp sbcl-2.1.1/tests/timer.impure.lisp --- sbcl-2.0.6/tests/timer.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/timer.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -59,20 +59,31 @@ time) (loop until finishedp))) -(with-test (:name (:timer :deferrables-blocked) :skipped-on :win32) +;;; This test has to be skipped darwin + thruption because if those features +;;; are present, then sb-wtimer should be too, but it can't be, because the +;;; code in 'darwin-os.c' says: +;;; # error Completely untested. Go ahead! Remove this line, try your luck! +;;; and of course it doesn't work. +;;; But win32 has wtimer so the skipped test is more than just +;;; (:and :sb-thruption (:not :sb-wtimer)) because that wouldn't +;;; explain why win32 doesn't pass. +(with-test (:name (:timer :deferrables-blocked) + :skipped-on (or :win32 (:and :darwin :sb-safepoint))) (make-and-schedule-and-wait (lambda () (check-deferrables-blocked-or-lose 0)) (random 0.1)) (check-deferrables-unblocked-or-lose 0)) -(with-test (:name (:timer :deferrables-unblocked) :skipped-on :win32) +(with-test (:name (:timer :deferrables-unblocked) + :skipped-on (or :win32 (:and :darwin :sb-safepoint))) (make-and-schedule-and-wait (lambda () (sb-sys:with-interrupts (check-deferrables-unblocked-or-lose 0))) (random 0.1)) (check-deferrables-unblocked-or-lose 0)) -(with-test (:name (:timer :deferrables-unblocked :unwind) :skipped-on :win32) +(with-test (:name (:timer :deferrables-unblocked :unwind) + :skipped-on (or :win32 (:and :darwin :sb-safepoint))) (catch 'xxx (make-and-schedule-and-wait (lambda () (check-deferrables-blocked-or-lose 0) @@ -212,22 +223,6 @@ (mapc #'sb-thread:join-thread threads))))) (assert ok)))) -;;; FIXME: Since timeouts do not work on Windows this would loop -;;; forever. -(with-test (:name (:hash-cache :interrupt) :skipped-on :win32) - (let* ((type1 (random-type 500)) - (type2 (random-type 500)) - (wanted (subtypep type1 type2))) - (dotimes (i 100) - (block foo - (sb-ext:schedule-timer (sb-ext:make-timer - (lambda () - (assert (eq wanted (subtypep type1 type2))) - (return-from foo))) - 0.05) - (loop - (assert (eq wanted (subtypep type1 type2)))))))) - ;;; Used to hang occasionally at least on x86. Two bugs caused it: ;;; running out of stack (due to repeating timers being rescheduled ;;; before they ran) and dying threads were open interrupts. @@ -314,7 +309,7 @@ (dolist (thread threads) (sched thread))) (loop for thread in threads - do (sb-thread:join-thread thread :timeout 20)))))) + do (sb-thread:join-thread thread :timeout 40)))))) ;; A timer with a repeat interval can be configured to "catch up" in ;; case of missed calls. diff -Nru sbcl-2.0.6/tests/traceroot.impure.lisp sbcl-2.1.1/tests/traceroot.impure.lisp --- sbcl-2.0.6/tests/traceroot.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/traceroot.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -15,7 +15,8 @@ ;;;; and I don't care too much why, since the functionality still works. ;;;; It's just that sometimes we get :PINNED as a root instead of ;;;; the expected reference to the one and only thread. -#-(and gencgc sb-thread (or ppc64 x86-64)) (sb-ext:exit :code 104) +;;;; And also sb-safepoint gets a crash in C. +#-(and gencgc sb-thread (not sb-safepoint) (or ppc64 x86-64)) (sb-ext:exit :code 104) (setq sb-ext:*evaluator-mode* :compile) (defvar *fred*) @@ -104,3 +105,13 @@ (assert (loop for line in lines thereis (search "[ 3] a cons = (A B C ...)" line))))) + +(defun something () + (let ((a (make-symbol "x"))) + (gc) ; cause the symbol to be pinned + (make-weak-pointer a))) + +(with-test (:name :traceroot-old-pin-no-crash) + (let ((wp (something))) + (search-roots wp) + (something))) diff -Nru sbcl-2.0.6/tests/type.before-xc.lisp sbcl-2.1.1/tests/type.before-xc.lisp --- sbcl-2.0.6/tests/type.before-xc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/type.before-xc.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -417,6 +417,15 @@ (assert (= (sb-vm::immediate-constant-sc (complex $0.0d0 $0.0d0)) sb-vm::fp-complex-double-zero-sc-number))) -;;; Unparse a union of (up to) 4 things depending on :sb-unicode as 2 things. +;;; Unparse a union of (up to) 3 things depending on :sb-unicode as 2 things. (assert (equal (type-specifier (specifier-type '(or string null))) - '(or string null))) + '(or #+sb-unicode string #-sb-unicode base-string null))) + +(multiple-value-bind (result exactp) + (sb-vm::primitive-type (specifier-type 'list)) + (assert (and (eq result (sb-vm::primitive-type-or-lose 'list)) + exactp))) +(multiple-value-bind (result exactp) + (sb-vm::primitive-type (specifier-type 'cons)) + (assert (and (eq result (sb-vm::primitive-type-or-lose 'list)) + (not exactp)))) diff -Nru sbcl-2.0.6/tests/type.impure.lisp sbcl-2.1.1/tests/type.impure.lisp --- sbcl-2.0.6/tests/type.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/type.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -1002,3 +1002,15 @@ (assert (handler-case (not (sb-kernel:specifier-type class)) (sb-kernel:parse-unknown-type () t))))) + +;;; Try depthoid in excess of sb-kernel::layout-id-vector-fixed-capacity +(defstruct d2) ; depthoid = 2 +(defstruct (d3(:include d2))) ; = 3 +(defstruct (d4(:include d3))) ; and so on +(defstruct (d5(:include d4))) +(defstruct (d6(:include d5))) +(defstruct (d7(:include d6))) +(defstruct (d8(:include d7))) +(compile 'd8-p) +(with-test (:name :deep-structure-is-a) + (assert (d8-p (opaque-identity (make-d8))))) diff -Nru sbcl-2.0.6/tests/typep-golden-data.txt sbcl-2.1.1/tests/typep-golden-data.txt --- sbcl-2.0.6/tests/typep-golden-data.txt 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tests/typep-golden-data.txt 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,738 @@ + 15 (ALIEN SB-UNIX:UNIX-OFFSET) + 39 (AND (NOT SINGLE-FLOAT) (REAL 0 1152921504606)) +! 22 (AND (VECTOR T) (NOT SIMPLE-ARRAY)) + 26 (AND ARRAY (NOT (ARRAY T))) + 26 (AND ARRAY (NOT (OR STRING BIT-VECTOR))) + 26 (AND ARRAY (NOT (VECTOR CHARACTER)) (NOT BASE-STRING) (NOT BIT-VECTOR)) +! 22 (AND CONS (SATISFIES LEGAL-FUN-NAME-P)) + 9 (AND FIXNUM UNSIGNED-BYTE) + 15 (AND FUNCTION (NOT FUNCALLABLE-INSTANCE)) + 32 (AND INTEGER (NOT (SIGNED-BYTE 31))) + 32 (AND INTEGER (NOT (SIGNED-BYTE 32))) + 16 (AND FUNCALLABLE-INSTANCE (NOT INTERPRETED-FUNCTION)) + 15 (AND STRING (NOT SIMPLE-ARRAY)) + 17 (AND SYMBOL (NOT (EQL T))) + 20 (AND SYMBOL (NOT KEYWORD) (NOT NULL)) + 13 (AND SYMBOL (NOT NULL)) +! 23 (AND SYMBOL (SATISFIES FBOUNDP)) +! 23 (AND SYMBOL (SATISFIES MACRO-FUNCTION)) + 23 (AND VECTOR (NOT STRING)) + 27 (ARRAY BIT) + 15 (ARRAY CHARACTER (*)) +! 5 (ARRAY NIL (*)) + 27 (ARRAY T *) + 27 (ARRAY T) + 13 (COMPLEX DOUBLE-FLOAT) + 13 (COMPLEX RATIONAL) + 13 (COMPLEX SINGLE-FLOAT) + 21 (CONS (MEMBER FUNCTION FUNCTION-DESIGNATOR SB-C::MODIFYING SB-C::INHIBIT-FLUSHING) T) + 37 (CONS (AND SYMBOL (NOT NULL)) (OR NULL (CONS STRING NULL))) +! 30 (CONS (AND SYMBOL (SATISFIES FBOUNDP))) +! 30 (CONS (AND SYMBOL (SATISFIES MACRO-FUNCTION))) + 21 (CONS (CONS (MEMBER LAMBDA) T) NULL) + 38 (CONS (CONS (MEMBER QUOTE) (CONS SYMBOL NULL)) NULL) + 21 (CONS (CONS * (MOD 65536)) NULL) + 64 (CONS (CONS SYMBOL (CONS SYMBOL NULL)) (CONS (EQL &OPTIONAL) (CONS SYMBOL NULL))) + 57 (CONS (CONS SYMBOL (CONS SYMBOL NULL)) (CONS SYMBOL NULL)) + 17 (CONS (EQL *) NULL) + 21 (CONS (EQL :ABSOLUTE) (CONS (EQL :HOME))) + 14 (CONS (EQL :CHARACTER-SET)) + 14 (CONS (EQL :CONDITIONAL)) + 14 (CONS (EQL :CONTEXT)) + 20 (CONS (EQL :GRAPH) CONS) + 29 (CONS (EQL :HOME) (CONS STRING NULL)) + 23 (CONS (EQL :INITIAL-ELEMENT) (CONS T NULL)) + 14 (CONS (EQL :LOAD-TIME-VALUE)) + 14 (CONS (EQL :LOAD-TIME-VALUE-FIXUP)) + 14 (CONS (EQL :NAMED-CALL)) + 14 (CONS (EQL :STRUCT-READ)) + 23 (CONS (EQL :TEST) (CONS T NULL)) + 64 (CONS (EQL BYTE) (AND (NOT (CONS INTEGER (CONS INTEGER))) (CONS T (CONS T NULL)))) + 23 (CONS (EQL CLASS) (CONS T NULL)) + 14 (CONS (EQL DEFSTRUCT)) + 23 (CONS (EQL EQL) (CONS T NULL)) + 14 (CONS (EQL EQL)) + 45 (CONS (EQL FIND-CLASS) (CONS (CONS (EQL QUOTE) (CONS SYMBOL NULL)) NULL)) + 29 (CONS (EQL FIND-PACKAGE) (CONS STRING NULL)) + 28 (CONS (EQL FUNCTION) (CONS (CONS (EQL LAMBDA)) NULL)) +! 35 (CONS (EQL FUNCTION) (CONS (SATISFIES LEGAL-FUN-NAME-P) NULL)) + 23 (CONS (EQL FUNCTION) (CONS * NULL)) + 31 (CONS (EQL FUNCTION) (CONS SYMBOL NULL)) + 23 (CONS (EQL FUNCTION) (CONS T NULL)) + 14 (CONS (EQL FUNCTION)) + 23 (CONS (EQL GO) (CONS T NULL)) + 33 (CONS (EQL IF) (CONS T (CONS T (OR NULL (CONS T NULL))))) + 24 (CONS (EQL LAMBDA) (CONS LIST)) + 14 (CONS (EQL LAMBDA)) + 14 (CONS (EQL LIST)) + 20 (CONS (EQL LIST*) CONS) + 18 (CONS (EQL LIST*) LIST) + 14 (CONS (EQL LOAD-TIME-VALUE)) + 23 (CONS (EQL MULTIPLE-VALUE-LIST) (CONS T NULL)) + 16 (CONS (EQL NIL)) + 14 (CONS (EQL NOT)) + 14 (CONS (EQL OR)) + 23 (CONS (EQL QUOTE) (CONS T NULL)) + 14 (CONS (EQL QUOTE)) + 18 (CONS (EQL RETURN-FROM) LIST) + 23 (CONS (EQL SATISFIES) (CONS T NULL)) + 14 (CONS (EQL SATISFIES)) + 14 (CONS (EQL SB-C::COVERAGE-MAP)) + 23 (CONS (EQL SB-C::LAMBDA-LIST) (CONS T NULL)) + 14 (CONS (EQL SB-C::SOURCE-FORM)) + 14 (CONS (EQL SB-C::VOP-OPTIMIZE)) + 14 (CONS (EQL SB-C:LAMBDA-WITH-LEXENV)) + 14 (CONS (EQL EXPLICIT-CHECK)) + 23 (CONS (EQL QUASIQUOTE) (CONS T NULL)) + 31 (CONS (EQL NEW-INSTANCE) (CONS SYMBOL NULL)) + 14 (CONS (EQL SB-PCL::.PV.)) + 23 (CONS (EQL SB-PCL::CLASS-EQ) (CONS T NULL)) + 14 (CONS (EQL SB-PCL::FAST-METHOD)) + 23 (CONS (EQL SB-PCL::PROTOTYPE) (CONS T NULL)) + 24 (CONS (EQL SB-PCL::SET-SLOTS) (CONS INSTANCE)) + 14 (CONS (EQL SB-PCL::SLOT-ACCESSOR)) + 14 (CONS (EQL MACRO)) + 31 (CONS (EQL SETF) (CONS SYMBOL NULL)) + 20 (CONS (EQL SETF) CONS) + 14 (CONS (EQL SETF)) + 35 (CONS (EQL SETQ) (CONS SYMBOL (CONS T NULL))) + 14 (CONS (EQL TERPRI)) + 27 (CONS (EQL THE) (CONS T (CONS T NULL))) + 28 (CONS (EQL VALUES) (CONS T (CONS (EQL &OPTIONAL) NULL))) + 14 (CONS (EQL VALUES)) + 31 (CONS (MEMBER &OPTIONAL) (CONS SYMBOL NULL)) + 17 (CONS (MEMBER &OPTIONAL) NULL) + 22 (CONS (MEMBER :CHARACTER-SET) STRING) + 14 (CONS (MEMBER :HOME) T) + 17 (CONS (MEMBER :NO-CONSTANT-VARIANT) NULL) + 17 (CONS (MEMBER AND INTERSECTION)) + 26 (CONS (MEMBER AND OR) (CONS T NULL)) + 34 (CONS (MEMBER FUNCTION QUOTE) (CONS SYMBOL NULL)) + 26 (CONS (MEMBER FUNCTION QUOTE) (CONS T NULL)) + 26 (CONS (MEMBER FUNCTION SB-C::GLOBAL-FUNCTION) (CONS T NULL)) +! 35 (CONS (MEMBER FUNCTION) (CONS (SATISFIES LEGAL-FUN-NAME-P) NULL)) + 14 (CONS (MEMBER FUNCTION) T) + 19 (CONS (MEMBER LAMBDA NAMED-LAMBDA SB-C:LAMBDA-WITH-LEXENV)) + 19 (CONS (MEMBER LAMBDA NAMED-LAMBDA SB-IMPL::LAMBDA-WITH-LEXENV)) + 17 (CONS (MEMBER LAMBDA NAMED-LAMBDA) T) + 14 (CONS (MEMBER LAMBDA) T) + 17 (CONS (MEMBER LIST VECTOR)) + 17 (CONS (MEMBER OR UNION)) + 31 (CONS (MEMBER QUOTE) (CONS SYMBOL NULL)) + 17 (CONS (MEMBER SB-C::XEP SB-C::TL-XEP)) + 17 (CONS (MEMBER SB-PCL::SLOW-METHOD SB-PCL::FAST-METHOD)) + 17 (CONS (MEMBER STRING SIMPLE-STRING)) + 17 (CONS (MEMBER WHEN UNLESS)) + 32 (CONS (MEMBER WRITE-STRING WRITE-CHAR) (CONS (OR STRING CHARACTER))) + 28 (CONS (NOT INTEGER) (CONS T NULL)) + 24 (CONS (NOT INTEGER) NULL) + 22 (CONS (OR (VECTOR CHARACTER) BASE-STRING CHARACTER) T) + 24 (CONS (OR STRING NULL) T) +! 27 (CONS (SATISFIES LEGAL-FUN-NAME-P) NULL) + 20 (CONS (UNSIGNED-BYTE 21) SIMPLE-VECTOR) + 25 (CONS ATOM ATOM) + 17 (CONS CONS) + 36 (CONS INTEGER (CONS (NOT INTEGER) NULL)) + 23 (CONS INTEGER FUNCTION) + 22 (CONS INTEGER NULL) + 19 (CONS INTEGER) +! 14 (CONS KEYWORD T) +! 14 (CONS KEYWORD) + 25 (CONS LIST (CONS LIST)) + 17 (CONS LIST T) + 24 (CONS REAL NULL) + 21 (CONS SB-ALIEN::CALLING-CONVENTION *) + 17 (CONS INSTANCE T) + 23 (CONS SIMPLE-VECTOR SIMPLE-VECTOR) + 34 (CONS STRING (CONS STRING NULL)) + 22 (CONS STRING NULL) + 21 (CONS T (CONS (MEMBER &OPTIONAL) NULL)) + 24 (CONS T (CONS T (CONS T NULL))) + 18 (CONS T (CONS T (EQL DEFINE-COMPILER-MACRO))) + 26 (CONS T (CONS T (OR NULL (CONS T NULL)))) + 20 (CONS T (CONS T NULL)) + 14 (CONS T (EQL :DEFAULT)) + 14 (CONS T (MEMBER DEFINE-COMPILER-MACRO)) + 22 (CONS T (OR NULL (CONS T NULL))) + 26 (CONS T (OR STRING NULL (SATISFIES UNBOUND-MARKER-P))) + 24 (CONS T (OR STRING NULL)) + 14 (CONS T (UNSIGNED-BYTE 16)) + 17 (CONS T CONS) + 16 (CONS T NULL) + 17 (CONS T SIMPLE-VECTOR) + 19 (CONS T STRING) + 18 (DOUBLE-FLOAT (0.0d0)) + 17 (DOUBLE-FLOAT (1.0d0)) + 22 (DOUBLE-FLOAT 0.0d0 1.0d0) + 22 (DOUBLE-FLOAT 0.0d0 1.152921504606d12) + 22 (DOUBLE-FLOAT 0.0d0 4.611686018427388d18) + 18 (DOUBLE-FLOAT 0.0d0) + 9 (EQL 0) + 9 (EQL :AREF) + 9 (EQL :BPT-LRA) + 9 (EQL :FTYPE) + 9 (EQL :GOOD) + 9 (EQL :KNOWN-FUN) + 9 (EQL :LONG-NOP) + 9 (EQL :MULTI-CHAR-WILD) + 9 (EQL :SINGLE-CHAR-WILD) + 9 (EQL :WILD) + 9 (EQL :WILD-INFERIORS) + 9 (EQL T) + 18 (INTEGER (0) *) + 9 (INTEGER (63) 64) + 18 (INTEGER * -1) + 18 (INTEGER * -1000000) + 18 (INTEGER * -1073741825) + 18 (INTEGER * -12) + 18 (INTEGER * -14) + 18 (INTEGER * -2) + 18 (INTEGER * -2147483649) + 18 (INTEGER * -4611686018427387900) + 18 (INTEGER * -4611686018427387901) + 18 (INTEGER * -4611686018427387904) + 18 (INTEGER * -4611686018427387905) + 18 (INTEGER * -49) + 18 (INTEGER * -5) + 18 (INTEGER * -541073411) + 18 (INTEGER * -576460752303423489) + 18 (INTEGER * -6) + 18 (INTEGER * -9) + 18 (INTEGER * -9223372036854775809) + 25 (INTEGER * 0) + 18 (INTEGER * 18446744073709551615) + 18 (INTEGER * 20) + 18 (INTEGER * 2147483647) + 18 (INTEGER * 4611686018427387900) + 18 (INTEGER * 576460752303423487) + 18 (INTEGER * 9223372036854775807) + 18 (INTEGER -1) + 15 (INTEGER -128 255) + 15 (INTEGER -2147483648 4294967295) + 23 (INTEGER 0 *) + 9 (INTEGER 0 0) + 12 (INTEGER 0 100000) + 12 (INTEGER 0 2305843009213) + 23 (INTEGER 0) + 12 (INTEGER 1 15) + 12 (INTEGER 1 2) + 14 (INTEGER 1 4611686018427387900) + 12 (INTEGER 1 63) + 18 (INTEGER 1) + 18 (INTEGER 1073741824) + 18 (INTEGER 1114064) + 18 (INTEGER 1152921504606846961) + 18 (INTEGER 1171368248680556526601) + 18 (INTEGER 13835058055282163708) + 9 (INTEGER 16 16) + 31 (INTEGER 18446744071562067968 18446744073709551615) + 18 (INTEGER 18446744073709551617) + 18 (INTEGER 18446744073709551621) + 18 (INTEGER 1899) + 18 (INTEGER 2) + 18 (INTEGER 2147483648) + 18 (INTEGER 23058430092136939456) + 18 (INTEGER 2305843009214) + 18 (INTEGER 27670116110564327423) + 18 (INTEGER 295147905179352825856) + 18 (INTEGER 36893488147419103201) + 18 (INTEGER 36893488147419103217) + 18 (INTEGER 36893488147419103231) + 9 (INTEGER 4 4) + 15 (INTEGER 4294967168 4294967295) + 18 (INTEGER 4611686018427387901) + 18 (INTEGER 4611686018427387902) + 18 (INTEGER 4611686018427387903) + 18 (INTEGER 4611686018427387904) + 15 (INTEGER 5 14) + 18 (INTEGER 63) + 15 (INTEGER 65408 65535) + 15 (INTEGER 8 10) + 9 (INTEGER 8 8) + 18 (INTEGER 85070591730234615856620279821087277057) + 9 (MEMBER &OPTIONAL) + 9 (MEMBER *) + 12 (MEMBER 3 4) + 9 (MEMBER :ABSOLUTE) + 14 (MEMBER :ALWAYS-THREAD-LOCAL T NIL) + 9 (MEMBER :ALWAYS-THREAD-LOCAL) + 9 (MEMBER :BACK) + 14 (MEMBER :CDECL :STDCALL NIL) + 9 (MEMBER :CHARACTER-SET) + 9 (MEMBER :CL) + 9 (MEMBER :CONDITIONAL) + 9 (MEMBER :CONSTRUCTOR) + 9 (MEMBER :CONTEXT) + 12 (MEMBER :DEFAULT :IGNORE) + 9 (MEMBER :DEFAULT) + 9 (MEMBER :GENERIC-FUNCTION) + 9 (MEMBER :GRAPH) + 9 (MEMBER :HIGH-BYTE) + 9 (MEMBER :HOME) + 9 (MEMBER :INITIAL-ELEMENT) + 12 (MEMBER :LISP :STREAM) + 9 (MEMBER :LISP) + 9 (MEMBER :LOAD-TIME-VALUE) + 9 (MEMBER :LOAD-TIME-VALUE-FIXUP) + 9 (MEMBER :LONG-NOP) + 12 (MEMBER :MULTI-CHAR-WILD :SINGLE-CHAR-WILD) + 9 (MEMBER :MULTI-CHAR-WILD) + 12 (MEMBER :NAMED-CALL :FDEFINITION) + 9 (MEMBER :NAMED-CALL) + 18 (MEMBER :NEWEST :UNC :WILD :UNSPECIFIC NIL) + 9 (MEMBER :NEWEST) + 9 (MEMBER :NO-CONSTANT-VARIANT) + 12 (MEMBER :NONE NIL) + 9 (MEMBER :SINGLE-CHAR-WILD) + 9 (MEMBER :STRUCT-READ) + 9 (MEMBER :TEST) + 9 (MEMBER :UNC) + 9 (MEMBER :UNKNOWN) + 12 (MEMBER :UNPARSED NIL) + 9 (MEMBER :UNPARSED) + 16 (MEMBER :UNSPECIFIC :WILD :NEWEST NIL) + 9 (MEMBER :UNSPECIFIC) + 12 (MEMBER :UNTAGGED :TAGGED) + 12 (MEMBER :UP :BACK) + 9 (MEMBER :UP) + 14 (MEMBER :WILD :WILD-INFERIORS :UP) + 12 (MEMBER :WILD :WILD-INFERIORS) + 9 (MEMBER :WILD) + 9 (MEMBER :WILD-INFERIORS) + 12 (MEMBER AND INTERSECTION) + 12 (MEMBER AND OR) + 9 (MEMBER BYTE) + 9 (MEMBER CLASS) + 9 (MEMBER DECLARE) + 9 (MEMBER DEFINE-COMPILER-MACRO) + 9 (MEMBER DEFSTRUCT) + 9 (MEMBER EQL) + 9 (MEMBER FIND-CLASS) + 9 (MEMBER FIND-PACKAGE) + 12 (MEMBER FUNCTION QUOTE) + 12 (MEMBER FUNCTION SB-C::GLOBAL-FUNCTION) + 16 (MEMBER FUNCTION FUNCTION-DESIGNATOR SB-C::MODIFYING SB-C::INHIBIT-FLUSHING) + 9 (MEMBER FUNCTION) + 9 (MEMBER GO) + 9 (MEMBER IF) + 14 (MEMBER LAMBDA NAMED-LAMBDA SB-C:LAMBDA-WITH-LEXENV) + 14 (MEMBER LAMBDA NAMED-LAMBDA SB-IMPL::LAMBDA-WITH-LEXENV) + 12 (MEMBER LAMBDA NAMED-LAMBDA) + 9 (MEMBER LAMBDA) + 12 (MEMBER LIST VECTOR) + 9 (MEMBER LIST) + 9 (MEMBER LIST*) + 9 (MEMBER LOAD-TIME-VALUE) + 9 (MEMBER MULTIPLE-VALUE-LIST) + 14 (MEMBER NIL :END :START) + 12 (MEMBER NIL :INITIALIZING) + 16 (MEMBER NIL :NEWEST :WILD :UNSPECIFIC) + 14 (MEMBER NIL :START :END) + 12 (MEMBER NIL :UNPARSED) + 16 (MEMBER NIL :UNSPECIFIC :WILD :UNC) + 14 (MEMBER NIL :UNSPECIFIC :WILD) + 12 (MEMBER NIL :WILD) + 14 (MEMBER NIL T :ALWAYS-THREAD-LOCAL) + 9 (MEMBER NOT) + 12 (MEMBER OR UNION) + 9 (MEMBER OR) + 9 (MEMBER QUOTE) + 9 (MEMBER RETURN-FROM) + 9 (MEMBER SATISFIES) + 9 (MEMBER SB-C::COVERAGE-MAP) + 9 (MEMBER SB-C::LAMBDA-LIST) + 9 (MEMBER SB-C::SOURCE-FORM) + 9 (MEMBER SB-C::VOP-OPTIMIZE) + 12 (MEMBER SB-C::XEP SB-C::TL-XEP) + 9 (MEMBER SB-C:LAMBDA-WITH-LEXENV) + 9 (MEMBER EXPLICIT-CHECK) + 9 (MEMBER QUASIQUOTE) + 9 (MEMBER NEW-INSTANCE) + 18 (MEMBER TYPE-SPECIFIER SB-C::PROPER-SEQUENCE SB-C::PROPER-LIST SB-C::PROPER-OR-DOTTED-LIST SB-C::PROPER-OR-CIRCULAR-LIST) + 9 (MEMBER SB-PCL::.PV.) + 9 (MEMBER SB-PCL::CLASS-EQ) + 9 (MEMBER SB-PCL::FAST-METHOD) + 9 (MEMBER SB-PCL::PROTOTYPE) + 9 (MEMBER SB-PCL::SET-SLOTS) + 9 (MEMBER SB-PCL::SLOT-ACCESSOR) + 12 (MEMBER SB-PCL::SLOW-METHOD SB-PCL::FAST-METHOD) + 9 (MEMBER MACRO) + 9 (MEMBER SETF) + 9 (MEMBER SETQ) + 12 (MEMBER STRING SIMPLE-STRING) + 12 (MEMBER T :UNINITIALIZED) + 9 (MEMBER T) + 9 (MEMBER TERPRI) + 9 (MEMBER THE) + 9 (MEMBER VALUES) + 12 (MEMBER WHEN UNLESS) + 12 (MEMBER WRITE-STRING WRITE-CHAR) + 12 (MOD 100) + 12 (MOD 1114112) + 9 (MOD 128) + 12 (MOD 21) + 12 (MOD 36) + 12 (MOD 4611686018427387900) + 12 (MOD 4611686018427387901) + 27 (NOT (ARRAY T)) + 9 (NOT (MEMBER T)) + 18 (NOT (SATISFIES KEYWORDP)) +! 16 (NOT (SATISFIES LEGAL-FUN-NAME-P)) + 15 (NOT (VECTOR CHARACTER)) + 15 (NOT BASE-STRING) + 16 (NOT BIT-VECTOR) + 14 (NOT COMPILED-FUNCTION) + 15 (NOT INTEGER) + 11 (NOT LIST) + 9 (NOT NULL) + 17 (NOT NUMBER) +! 15 (NOT EXTENDED-SEQUENCE) + 13 (NOT FUNCALLABLE-INSTANCE) + 11 (NOT INSTANCE) + 14 (NOT INTERPRETED-FUNCTION) + 13 (NOT LAYOUT) + 15 (NOT SIMPLE-ARRAY) + 13 (NOT SIMPLE-VECTOR) + 15 (NOT STRING) + 15 (NOT SYMBOL) + 15 (NOT VECTOR) + 31 (OR (CONS (MEMBER FUNCTION FUNCTION-DESIGNATOR SB-C::MODIFYING SB-C::INHIBIT-FLUSHING)) (MEMBER TYPE-SPECIFIER SB-C::PROPER-SEQUENCE SB-C::PROPER-LIST SB-C::PROPER-OR-DOTTED-LIST SB-C::PROPER-OR-CIRCULAR-LIST)) + 21 (OR (ALIEN SB-UNIX:UNIX-OFFSET) (MEMBER NIL :START :END)) + 30 (OR (AND (NOT SYMBOL) (NOT LAYOUT) ATOM (NOT INTEGER))) + 21 (OR (CONS (EQL DECLARE)) STRING) +! 67 (OR (CONS (EQL FUNCTION) (CONS (SATISFIES LEGAL-FUN-NAME-P) NULL)) (CONS (EQL QUOTE) (CONS SYMBOL NULL)) (CONS (EQL LAMBDA))) +! 60 (OR (CONS (EQL FUNCTION) (CONS (SATISFIES LEGAL-FUN-NAME-P) NULL)) (CONS (EQL QUOTE) (CONS SYMBOL NULL))) + 14 (OR (CONS (MEMBER DECLARE) T)) + 31 (OR (CONS (MEMBER FUNCTION) (CONS SYMBOL NULL))) + 23 (OR (CONS (MEMBER LAMBDA NAMED-LAMBDA)) INTERPRETED-FUNCTION) + 57 (OR (CONS (NOT INTEGER) (CONS T NULL)) (CONS INTEGER (CONS (NOT INTEGER) NULL))) + 12 (OR (EQL :ALWAYS-THREAD-LOCAL) FIXNUM) + 17 (OR (EQL :HOME) (CONS (EQL :HOME))) + 16 (OR (EQL :WILD) SB-IMPL::PATTERN) + 12 (OR (INTEGER -4611686018427387904 4611686018427387903) CHARACTER) + 9 (OR (INTEGER 0 0)) + 18 (OR (INTEGER 1 15) SB-X86-64-ASM::REG) + 9 (OR (MEMBER *)) + 9 (OR (MEMBER :CONDITIONAL)) + 9 (OR (MEMBER :DEFAULT)) + 12 (OR (MEMBER :STANDARD :FIXED)) + 12 (OR (MEMBER :UNPARSED :FOO)) + 12 (OR (MEMBER :UNPARSED NIL)) + 9 (OR (MEMBER :UNPARSED)) + 14 (OR (MEMBER :UNSPECIFIC :WILD NIL)) + 12 (OR (MEMBER :UNSPECIFIC :WILD)) + 9 (OR (MEMBER :UNSPECIFIED)) + 16 (OR (MEMBER :WILD) SB-IMPL::PATTERN) + 9 (OR (MEMBER :WILD)) + 9 (OR (MEMBER FUNCTION)) + 14 (OR (MEMBER NIL :UNSPECIFIC :UNC)) + 16 (OR (MEMBER NIL :UNSPECIFIC :WILD :UNC)) + 12 (OR (MEMBER T :UNINITIALIZED)) + 12 (OR (MOD 4611686018427387901) (MEMBER)) + 19 (OR (NOT INTEGER) (MOD 4611686018427387901)) + 19 (OR (NOT NUMBER) FIXNUM) + 20 (OR (NOT SYMBOL) (MEMBER T NIL) KEYWORD) + 23 (OR (SIGNED-BYTE 32) SB-C:FIXUP) + 23 (OR (SIGNED-BYTE 32) SB-C:TN) +! 17 (OR (SIMPLE-ARRAY * (*)) EXTENDED-SEQUENCE (MEMBER)) + 15 (OR (SIMPLE-ARRAY CHARACTER (*)) SIMPLE-BASE-STRING) + 15 (OR (UNSIGNED-BYTE 32) SB-C:FIXUP) + 25 (OR (UNSIGNED-BYTE 64)) + 17 (OR (VECTOR CHARACTER) BASE-STRING (MEMBER :WILD)) + 15 (OR (VECTOR CHARACTER) BASE-STRING (MEMBER)) + 22 (OR (VECTOR CHARACTER) BASE-STRING CHARACTER PACKAGE) + 17 (OR (VECTOR CHARACTER) BASE-STRING CHARACTER) + 19 (OR (VECTOR CHARACTER) BASE-STRING NULL (SATISFIES UNBOUND-MARKER-P)) + 32 (OR (VECTOR CHARACTER) BASE-STRING NUMBER BIT-VECTOR PATHNAME) + 21 (OR (VECTOR CHARACTER) BASE-STRING PATHNAME) + 24 (OR ARRAY COMPLEX SIMD-PACK SIMD-PACK-256) + 35 (OR ARRAY CONS NUMBER CHARACTER STRUCTURE-OBJECT) + 15 (OR BASE-STRING (VECTOR CHARACTER)) + 18 (OR BIGNUM RATIO) + 17 (OR BIT-VECTOR STRING) +! 14 (OR BOOLEAN KEYWORD) + 17 (OR CHARACTER (VECTOR CHARACTER) BASE-STRING) + 15 (OR CHARACTER PACKAGE) + 21 (OR CHARACTER SYMBOL FIXNUM SINGLE-FLOAT) + 10 (OR CHARACTER) +! 25 (OR CLASS CTYPE) +! 6 (OR CLASS) + 37 (OR CONS (AND ARRAY (NOT (OR STRING BIT-VECTOR))) SB-IMPL::COMMA) + 28 (OR CONS NUMBER PATHNAME) + 23 (OR CONS INSTANCE STRING PATHNAME) + 16 (OR CONS INSTANCE) +! 23 (OR ERROR SB-C:COMPILER-ERROR) +! 23 (OR ERROR SB-DI:DEBUG-CONDITION) +! 23 (OR ERROR PARSE-UNKNOWN-TYPE) + 32 (OR FILE-STREAM SYNONYM-STREAM) + 15 (OR FIXNUM BIGNUM RATIO) + 12 (OR FIXNUM CHARACTER) + 15 (OR FIXNUM RATIO) + 23 (OR FIXNUM SYMBOL HASH-TABLE) + 30 (OR FLOAT (COMPLEX FLOAT) BIGNUM SIMD-PACK SIMD-PACK-256 SYSTEM-AREA-POINTER) + 17 (OR FLOAT RATIONAL) + 18 (OR FUNCTION (CONS (EQL FUNCTION))) + 13 (OR FUNCTION NULL) + 15 (OR INTEGER (MEMBER)) + 15 (OR INTEGER) + 16 (OR LIST SYMBOL) + 39 (OR LOGICAL-PATHNAME SYNONYM-STREAM FILE-STREAM) + 34 (OR NULL (CONS (EQL QUOTE) (CONS SYMBOL NULL))) + 25 (OR NULL (CONS (MEMBER :CHARACTER-SET) STRING)) + 23 (OR NULL (CONS (UNSIGNED-BYTE 21) SIMPLE-VECTOR)) + 25 (OR NULL (CONS STRING NULL)) + 23 (OR NULL (CONS T (OR STRING NULL))) + 16 (OR NULL (CONS T NULL)) + 21 (OR NULL (MEMBER :CONC-NAME :CONSTRUCTOR :COPIER :PREDICATE :NAMED)) + 23 (OR NULL (MEMBER :NEWEST :WILD :UNSPECIFIC) INTEGER) + 15 (OR NULL (MEMBER :WILD :UNSPECIFIC) LIST) + 21 (OR NULL (MEMBER :WILD :UNSPECIFIC) STRING) + 12 (OR NULL (SATISFIES UNBOUND-MARKER-P)) + 17 (OR NULL CHARACTER PACKAGE) + 12 (OR NULL CHARACTER) +! 23 (OR NULL FUNCTION CONDITION SB-PCL::CONDITION-CLASS) + 13 (OR NULL FUNCTION) + 53 (OR NULL NUMBER CHARACTER (AND ARRAY (NOT (ARRAY T))) SB-C::DEBUG-NAME-MARKER SIMD-PACK SIMD-PACK-256) + 19 (OR NULL NUMBER) + 23 (OR NULL SB-IMPL::PATTERN INTEGER) + 17 (OR NULL STRING) + 9 (OR NULL) + 19 (OR NUMBER CHARACTER) + 23 (OR NUMBER PATHNAME) + 24 (OR NUMBER SYMBOL) + 41 (OR PACKAGE FDEFN CODE-COMPONENT PATHNAME HOST HASH-TABLE) + 16 (OR PATHNAME NULL) + 34 (OR PATHNAME STREAM) + 43 (OR PATHNAME SYNONYM-STREAM FILE-STREAM BOOLEAN) + 41 (OR PATHNAME SYNONYM-STREAM FILE-STREAM NULL) + 40 (OR PATHNAME SYNONYM-STREAM FILE-STREAM) + 13 (OR RATIO) + 17 (OR RATIONAL FLOAT) + 17 (OR RATIONAL SINGLE-FLOAT) +! 23 (OR READER-ERROR END-OF-FILE) + 23 (OR SB-ASSEM:LABEL SB-X86-64-ASM::LABEL+ADDEND SB-C:FIXUP) + 18 (OR SB-C::CLAMBDA SB-C::LAMBDA-VAR) + 18 (OR SB-C::CRETURN EXIT) + 38 (OR SB-C::DEBUG-INFO SB-C::DEBUG-FUN SB-C::DEBUG-SOURCE SB-C:DEFINITION-SOURCE-LOCATION SB-C::DEBUG-NAME-MARKER) + 20 (OR SB-C::FUNCTIONAL SB-C::GLOBAL-VAR) + 18 (OR SB-C::OPTIONAL-DISPATCH SB-C::CLAMBDA) + 27 (OR SB-C:FIXUP NUMBER SB-X86-64-ASM::REG) + 20 (OR SB-DI::COMPILED-CODE-LOCATION SB-DI::COMPILED-DEBUG-FUN) + 30 (OR SB-DISASSEM::ADDRESS SYSTEM-AREA-POINTER) + 18 (OR SB-IMPL::PATTERN (MEMBER :WILD :WILD-INFERIORS)) + 16 (OR SB-IMPL::PATTERN (MEMBER :WILD)) + 22 (OR SB-IMPL::PATTERN (MEMBER NIL :UNSPECIFIC :WILD :UNC)) + 20 (OR SB-IMPL::PATTERN (MEMBER NIL :UNSPECIFIC :WILD)) +! 23 (OR BROKEN-PIPE END-OF-FILE) + 14 (OR INDEX NULL) +! 18 (OR CLASSOID CLASS) + 19 (OR CONSTANT SB-C::FUNCTIONAL) + 18 (OR CONSTANT SB-C::LAMBDA-VAR) +! 5 (OR EXTENDED-SEQUENCE) + 16 (OR HOST (MEMBER :UNSPECIFIC)) + 23 (OR HOST (VECTOR CHARACTER) BASE-STRING (MEMBER :UNSPECIFIC)) + 16 (OR HOST NULL) + 11 (OR INSTANCE (MEMBER)) + 14 (OR INSTANCE LIST) + 18 (OR SIMPLE-FUN CLOSURE) + 18 (OR SB-PRETTY::NEWLINE SB-PRETTY::BLOCK-START) + 18 (OR SB-X86-64-ASM::REG SB-X86-64-ASM::EA) + 15 (OR SIMPLE-BASE-STRING (SIMPLE-ARRAY CHARACTER (*))) + 23 (OR SIMPLE-STRING SB-IMPL::PATTERN (MEMBER :WILD)) + 13 (OR SIMPLE-VECTOR (MEMBER)) + 26 (OR SINGLE-FLOAT DOUBLE-FLOAT (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT) SIMD-PACK SIMD-PACK-256) + 15 (OR SINGLE-FLOAT DOUBLE-FLOAT) + 39 (OR STRING (CONS (EQL FUNCTION) (CONS SYMBOL NULL))) + 17 (OR STRING BIT-VECTOR) + 40 (OR STRING CONS NUMBER BIT-VECTOR PATHNAME SYMBOL) + 37 (OR STRING CONS NUMBER BIT-VECTOR PATHNAME) + 22 (OR STRING INTEGER) + 31 (OR STRING NULL (CONS T (OR STRING NULL))) + 17 (OR STRING NULL) + 25 (OR STRING SB-IMPL::PATTERN (MEMBER :WILD :WILD-INFERIORS)) + 21 (OR STRING SB-IMPL::PATTERN) + 34 (OR STRING SYMBOL (CONS (EQL :CHARACTER-SET) STRING)) +! 23 (OR STYLE-WARNING COMPILER-NOTE) +! 23 (OR STYLE-WARNING PACKAGE-AT-VARIANCE) + 44 (OR SYMBOL (CONS SYMBOL (CONS SYMBOL NULL))) + 21 (OR SYMBOL CHARACTER FIXNUM SINGLE-FLOAT) + 26 (OR SYMBOL CHARACTER NUMBER) +! 19 (OR SYMBOL CLASS) + 16 (OR SYMBOL CONS) + 19 (OR SYMBOL FIXNUM CHARACTER) + 17 (OR SYMBOL FIXNUM) + 29 (OR SYMBOL NUMBER CHARACTER INSTANCE) + 56 (OR SYMBOL NUMBER CHARACTER UNBOXED-ARRAY SB-C::DEBUG-NAME-MARKER SYSTEM-AREA-POINTER SIMD-PACK SIMD-PACK-256) + 28 (OR SYMBOL NUMBER STRING) + 20 (OR SYMBOL INSTANCE FIXNUM) + 20 (OR SYMBOL LAYOUT) + 23 (OR UNSIGNED-BYTE) + 15 (OR VECTOR (MEMBER)) +! 23 (OR WARNING ERROR) + 24 (OR WORD SB-VM:SIGNED-WORD) + 6 (OR) + 18 (RATIONAL (0)) + 24 (RATIONAL -24 24) + 24 (RATIONAL 0 (32)) + 24 (RATIONAL 0 1) + 24 (RATIONAL 0 1152921504606) + 18 (RATIONAL 0) +! 15 (SATISFIES FBOUNDP) + 18 (SATISFIES KEYWORDP) +! 15 (SATISFIES MACRO-FUNCTION) +! 16 (SATISFIES EXTENDED-FUNCTION-DESIGNATOR-P) +! 16 (SATISFIES LEGAL-FUN-NAME-P) + 10 (SATISFIES UNBOUND-MARKER-P) +! 16 (SATISFIES CLASSOID-DEFINITELY-INSTANCEP) + 16 (SATISFIES ARRAY-HEADER-P) + 13 (SATISFIES CLOSUREP) + 13 (SATISFIES SIMPLE-FUN-P) + 15 (SIMPLE-UNBOXED-ARRAY (*)) + 16 (SIGNED-BYTE 32) + 10 (SIGNED-BYTE 63) + 15 (SIGNED-BYTE 64) + 15 (SIGNED-BYTE 8) + 16 (SIMD-PACK DOUBLE-FLOAT) + 16 (SIMD-PACK SINGLE-FLOAT) + 16 (SIMD-PACK-256 DOUBLE-FLOAT) + 16 (SIMD-PACK-256 SINGLE-FLOAT) + 13 (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) + 13 (SIMPLE-ARRAY (COMPLEX SINGLE-FLOAT) (*)) + 13 (SIMPLE-ARRAY (SIGNED-BYTE 16) (*)) + 13 (SIMPLE-ARRAY (SIGNED-BYTE 32) (*)) + 13 (SIMPLE-ARRAY (SIGNED-BYTE 64) (*)) + 13 (SIMPLE-ARRAY (SIGNED-BYTE 8) (*)) + 13 (SIMPLE-ARRAY (SIGNED-BYTE 8) 1) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 15) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 2) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 31) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 4) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 62) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 63) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 64) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 7) (*)) + 13 (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) + 16 (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (512)) + 29 (SIMPLE-ARRAY (UNSIGNED-BYTE 8)) + 15 (SIMPLE-ARRAY * (*)) + 23 (SIMPLE-ARRAY * (0)) + 13 (SIMPLE-ARRAY BASE-CHAR (*)) + 13 (SIMPLE-ARRAY BIT (*)) + 13 (SIMPLE-ARRAY CHARACTER (*)) + 16 (SIMPLE-ARRAY CHARACTER (512)) + 13 (SIMPLE-ARRAY DOUBLE-FLOAT (*)) + 13 (SIMPLE-ARRAY FIXNUM (*)) +! 7 (SIMPLE-ARRAY NIL (*)) + 13 (SIMPLE-ARRAY SINGLE-FLOAT (*)) + 13 (SIMPLE-ARRAY T (*)) + 29 (SIMPLE-ARRAY T) + 16 (SIMPLE-BIT-VECTOR 64) + 18 (SIMPLE-STRING 1) + 16 (SIMPLE-VECTOR 6) + 16 (SIMPLE-VECTOR 62) + 16 (SINGLE-FLOAT (0.0)) + 15 (SINGLE-FLOAT (1.0)) + 9 (SINGLE-FLOAT -1.0 -1.0) + 21 (SINGLE-FLOAT 0.0 1.0) + 21 (SINGLE-FLOAT 0.0 1.1529215e12) + 21 (SINGLE-FLOAT 0.0 4.611686e18) + 16 (SINGLE-FLOAT 0.0) + 9 (SINGLE-FLOAT 1.0 1.0) + 27 (STRING 0) + 9 (UNSIGNED-BYTE 12) + 9 (UNSIGNED-BYTE 16) + 9 (UNSIGNED-BYTE 2) + 9 (UNSIGNED-BYTE 21) + 9 (UNSIGNED-BYTE 27) + 9 (UNSIGNED-BYTE 31) + 9 (UNSIGNED-BYTE 32) + 9 (UNSIGNED-BYTE 4) + 9 (UNSIGNED-BYTE 59) + 9 (UNSIGNED-BYTE 6) + 9 (UNSIGNED-BYTE 62) + 21 (UNSIGNED-BYTE 63) + 25 (UNSIGNED-BYTE 64) + 9 (UNSIGNED-BYTE 8) + 23 (UNSIGNED-BYTE) +! 5 (VECTOR (UNSIGNED-BYTE 16)) +! 5 (VECTOR (UNSIGNED-BYTE 32)) + 27 (VECTOR * 0) + 15 (VECTOR CHARACTER) +! 5 (VECTOR T) + 13 ARRAY + 13 ATOM + 10 BASE-CHAR + 15 BASE-STRING + 13 BIGNUM + 12 BIT + 16 BIT-VECTOR + 12 BOOLEAN + 10 CHARACTER +! 6 CLASS + 14 COMPILED-FUNCTION + 15 COMPLEX + 13 CONS + 13 DOUBLE-FLOAT + 13 EXTENDED-CHAR + 10 FIXNUM + 15 FLOAT +! 6 GENERIC-FUNCTION + 15 INTEGER +! 5 KEYWORD + 11 LIST + 13 LONG-FLOAT +! 6 METHOD-COMBINATION + 9 NULL + 17 NUMBER + 13 RATIO + 15 RATIONAL + 17 REAL + 9 SB-C::POLICY-QUALITY + 12 SB-DEBUG::TRACE-REPORT-TYPE + 25 SB-DISASSEM::ADDRESS + 12 SB-IMPL::ABSENT-PATHNAME-COMPONENT + 14 DEPRECATION-STATE + 12 INDEX + 9 INFO-NUMBER + 15 CHARACTER-STRING + 16 RANDOM-STATE-STATE + 13 CLOSURE + 18 FORMAT-CONTROL + 13 FUNCALLABLE-INSTANCE + 11 INSTANCE + 13 SIMPLE-CHARACTER-STRING + 13 SIMPLE-FUN + 21 STRING-DESIGNATOR +! 26 TYPE-SPECIFIER +! 6 SB-MOP:EQL-SPECIALIZER +! 6 SB-MOP:FORWARD-REFERENCED-CLASS +! 6 SB-MOP:FUNCALLABLE-STANDARD-CLASS +! 6 SB-MOP:SPECIALIZER +! 6 SB-PCL::CLASS-EQ-SPECIALIZER +! 6 SB-PCL::STD-CLASS +! 6 SB-PCL:SYSTEM-CLASS + 16 EXIT-CODE + 9 SB-VM:FINITE-SC-OFFSET + 9 SB-VM:SC-OFFSET + 15 SB-VM:SIGNED-WORD +! 5 SEQUENCE + 10 SHORT-FLOAT + 13 SIMD-PACK + 13 SIMD-PACK-256 + 15 SIMPLE-ARRAY + 13 SIMPLE-BASE-STRING + 13 SIMPLE-BIT-VECTOR + 15 SIMPLE-STRING + 13 SIMPLE-VECTOR + 10 SINGLE-FLOAT +! 5 STANDARD-CHAR +! 6 STANDARD-CLASS +! 6 STANDARD-GENERIC-FUNCTION + 15 STRING +! 6 STRUCTURE-CLASS + 6 T + 23 UNSIGNED-BYTE + 15 VECTOR + 25 WORD diff -Nru sbcl-2.0.6/tests/type.pure.lisp sbcl-2.1.1/tests/type.pure.lisp --- sbcl-2.0.6/tests/type.pure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/type.pure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -15,6 +15,18 @@ (flet ((try (f) (assert-error (funcall f 'hash-table 3)))) (mapc #'try '(typexpand-1 typexpand typexpand-all)))) +(with-test (:name :stream-layout-bits) + (loop for layout being each hash-value + of (sb-kernel:classoid-subclasses (sb-kernel:find-classoid 't)) + do (flet ((check-bit (bit ancestor-type) + (let ((ancestor (sb-kernel:find-layout ancestor-type))) + (when (or (eq layout ancestor) + (find ancestor (sb-kernel:layout-inherits layout))) + (assert (logtest bit (sb-kernel:layout-flags layout))))))) + (check-bit sb-kernel:+stream-layout-flag+ 'stream) + (check-bit sb-kernel:+string-stream-layout-flag+ 'string-stream) + (check-bit sb-kernel:+file-stream-layout-flag+ 'file-stream)))) + (with-test (:name (typep sb-kernel:ctypep)) (locally (declare (notinline mapcar)) @@ -320,6 +332,15 @@ (assert (eq yes cyes)) (assert (eq win cwin))))) +(with-test (:name :intelligent-satisfies) + (assert (sb-kernel:type= (sb-kernel:specifier-type '(satisfies realp)) + (sb-kernel:specifier-type 'real))) + ;; Part of an example in https://bugs.launchpad.net/sbcl/+bug/309455 + (multiple-value-bind (answer certain) + (subtypep 'complex '(and number (satisfies realp))) + (assert (not answer)) + (assert certain))) + ;;; CONS type SUBTYPEP could be too enthusiastic about thinking it was ;;; certain (with-test (:name (subtypep cons satisfies)) @@ -655,9 +676,9 @@ (with-test (:name :unparse-string) (assert (equal (type-specifier (specifier-type '(string 10))) - '(string 10))) + '(#+sb-unicode string #-sb-unicode base-string 10))) (assert (equal (type-specifier (specifier-type '(simple-string 10))) - '(simple-string 10)))) + '(#+sb-unicode simple-string #-sb-unicode simple-base-string 10)))) (with-test (:name :numeric-types-adjacent) (dolist (x '(-0s0 0s0)) @@ -689,3 +710,19 @@ (with-test (:name :pathnamep-flag-bit) (let ((f (compile nil '(lambda (x) (pathnamep x))))) (assert (not (ctu:find-code-constants f))))) + +(with-test (:name :structure-is-a) + (dolist (what '(sb-int:sset-element sb-c::leaf sb-c::functional + sb-c::optional-dispatch)) + (assert (eval `(sb-c::%structure-is-a ,(sb-kernel:find-layout 'sb-c::optional-dispatch) + ,(sb-kernel:find-layout what)))))) + +(with-test (:name :type-of-empty-instance) + (assert (eq (type-of (eval '(sb-kernel:%make-instance 12))) + 'sb-kernel:instance))) + +(with-test (:name :make-numeric-type-union) + (assert (equal (sb-kernel:type-specifier + (sb-kernel:make-numeric-type :low '(-79106810381456307))) + '(or (double-float (-7.91068103814563d16)) (single-float (-7.910681e16)) + (rational (-79106810381456307)))))) diff -Nru sbcl-2.0.6/tests/vm.before-xc.lisp sbcl-2.1.1/tests/vm.before-xc.lisp --- sbcl-2.0.6/tests/vm.before-xc.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/vm.before-xc.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -25,10 +25,10 @@ (not (immediate-constant-sc x))))) ;; target fixnums can be dealt with as immediates; target bignums ;; can not. - (yes #.sb-xc:most-positive-fixnum) - (yes #.sb-xc:most-negative-fixnum) - (no #.(1+ sb-xc:most-positive-fixnum)) - (no #.(1- sb-xc:most-negative-fixnum))) + (yes #.most-positive-fixnum) + (yes #.most-negative-fixnum) + (no #.(1+ most-positive-fixnum)) + (no #.(1- most-negative-fixnum))) ;; Assert that DO-PACKED-TNS has unsurprising behavior if the body RETURNs. ;; This isn't a test in the problem domain of CL - it's of an internal macro, diff -Nru sbcl-2.0.6/tests/walk.impure.lisp sbcl-2.1.1/tests/walk.impure.lisp --- sbcl-2.0.6/tests/walk.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/walk.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -469,7 +469,9 @@ Form: 'GLOBAL-FOO Context: EVAL \(EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))"))) -(test-util:with-test (:name (:walk multiple-value-bind)) +;; This test doesn't understand that gensyms appear in the expansion +;; (We either need "string=-modulo-tabspace-and-gensyms" or a sexpr-based comparison) +(test-util:with-test (:name (:walk multiple-value-bind) :fails-on :sbcl) (assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (multiple-value-bind (a b) @@ -482,7 +484,8 @@ Form: B Context: EVAL; lexically bound \(MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))"))) -(test-util:with-test (:name (:walk multiple-value-bind special)) +;; This test doesn't understand that gensyms appear in the expansion +(test-util:with-test (:name (:walk multiple-value-bind special) :fails-on :sbcl) (assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (multiple-value-bind (a b) @@ -1071,4 +1074,9 @@ ;;; Old PCL hung up on this. (defmethod #:foo () (defun #:bar ())) + +;; lp#1912362 +(defmethod zook (x) (let ((typep x 'vector)) typep)) +(test-util:with-test (:name :let-syntax-error) + (assertoid:assert-error (zook 1))) diff -Nru sbcl-2.0.6/tests/x86-64-codegen.impure.lisp sbcl-2.1.1/tests/x86-64-codegen.impure.lisp --- sbcl-2.0.6/tests/x86-64-codegen.impure.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tests/x86-64-codegen.impure.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -148,7 +148,8 @@ (let* ((lines (split-string (with-output-to-string (s) - (let ((sb-disassem:*disassem-location-column-width* 0)) + (let ((sb-disassem:*disassem-location-column-width* 0) + (sb-kernel::*print-layout-id* nil)) (disassemble '(lambda (x) (the sb-assem:label x)) :stream s))) #\newline)) @@ -346,6 +347,14 @@ (and (search "CMP QWORD PTR [" line) (search ":YUP" line)))))) +(defun thing-ref-thing-ref (arg1 arg2) + (declare (optimize (safety 0))) + (let ((answer (typep (thing-x (thing-x arg1)) 'fixnum))) + (frobify arg1 arg2) + answer)) +(defun frobify (a b) (values a b)) +(compile 'thing-ref-thing-ref) + (with-test (:name :fixnump-thing-ref) (flet ((try (access-form true false) (let* ((f (compile nil `(lambda (obj) (typep ,access-form 'fixnum)))) @@ -364,7 +373,9 @@ (try '(thing-x (truly-the thing obj)) (make-thing :x 1) (make-thing :x "hi")) (try '(car obj) '(1) '("hi")) - (try '(cdr obj) '("hi" . 1) '("hi")))) + (try '(cdr obj) '("hi" . 1) '("hi"))) + ;; fixnump of memref of memref was eliding one memref by accident + (assert (thing-ref-thing-ref (make-thing :x (make-thing :x 3)) 'foo))) (with-test (:name :huge-code :skipped-on (not :immobile-code)) (sb-vm::allocate-code-object :immobile 0 4 (* 2 1024 1024))) @@ -616,7 +627,8 @@ ;; to :dword because zeroing the upper 32 bits is a visible effect. (inst mov (reg-in-size rax-tn :qword) (reg-in-size rcx-tn :qword)) (inst mov rax-tn rcx-tn))) -(with-test (:name :mov-mov-elim-ignore-resized-reg) ; just don't crash +(with-test (:name :mov-mov-elim-ignore-resized-reg + :fails-on :sbcl) ; just don't crash (checked-compile '(lambda () (sb-sys:%primitive test) 0))) (defstruct a) @@ -740,13 +752,20 @@ #+immobile-code (with-test (:name :debug-fun-from-pc-more-robust) - (let ((trampoline - (sb-di::code-header-from-pc - (sb-sys:int-sap (sb-vm::fdefn-raw-addr - (sb-kernel::find-fdefn 'sb-kernel::get-internal-real-time)))))) - (assert (zerop (sb-kernel:code-n-entries trampoline))) - (assert (typep (sb-di::debug-fun-from-pc trampoline 8) - 'sb-di::bogus-debug-fun)))) + ;; This test verifies that debug-fun-from-pc does not croak when the PC points + ;; within a trampoline allocated to wrap a closure in a simple-funifying wrapper + ;; for installation into a global symbol. + (let ((closure (funcall (compile nil '(lambda (x) (lambda () x))) 0)) + (symbol (gensym))) + (assert (sb-kernel:closurep closure)) + (setf (fdefinition symbol) closure) + (let ((trampoline + (sb-di::code-header-from-pc + (sb-sys:int-sap (sb-vm::fdefn-raw-addr + (sb-kernel::find-fdefn symbol)))))) + (assert (zerop (sb-kernel:code-n-entries trampoline))) + (assert (typep (sb-di::debug-fun-from-pc trampoline 8) + 'sb-di::bogus-debug-fun))))) (defstruct foo (s 0 :type (or null string))) (with-test (:name :reduce-stringp-to-not-null) @@ -766,3 +785,166 @@ (with-test (:name :make-list-ridiculously-huge) (checked-compile '(lambda () (make-list 3826305079707827596)) :allow-warnings t)) + +(with-test (:name :with-foo-macro-elides-arg-count-trap) + (let ((lines + (split-string + (with-output-to-string (s) + (sb-c:dis '(lambda (x) (with-standard-io-syntax (eval x))) s)) + #\newline))) + ;; The outer lambda checks its arg count, but the lambda + ;; passed to call-with-mutex does not. + (assert (= (count-if (lambda (line) + (search "Invalid argument count trap" line)) + lines) + 1)))) + +#+compact-instance-header +(with-test (:name :gf-self-contained-trampoline) + (let ((l (sb-kernel:find-layout 'standard-generic-function))) + (assert (/= (sb-kernel:layout-bitmap l) sb-kernel:+layout-all-tagged+)))) + +(with-test (:name :known-array-rank) + (flet ((try (type) + (let ((lines + (disassembly-lines + `(lambda (x) + #+sb-safepoint (declare (optimize (sb-c::insert-safepoints 0))) + (array-rank (truly-the ,type x)))))) + ;; (format t "~{~&~A~}" lines) + ;; Naturally this is brittle as heck. I wish we had a better way. + (assert (<= (length lines) 9))))) + (try 'string) + (try '(and vector (not simple-array))) + (try '(or string bit-vector)) ; not an array type, but known rank + (try '(array * (4 5 *))))) + +;;; Match the same set of objects that %OTHER-POINTER-P does. +(deftype other-pointer-object () + '(not (or fixnum single-float function list sb-kernel:instance character))) + +;;; Helper to assert something about how many comparisons it takes to test +;;; for various sets of widetags. +(defun count-cmp-opcodes (type expect function) + (let ((lines (disassembly-lines function))) + (let ((actual + (loop for line in lines + count (or (search "CMP" line) + (search "TEST" line))))) + (unless (eql actual expect) + (format t "~{~&~a~}~%" lines) + (error "typep: needed ~d test ops but expected ~d for ~a" + expect actual type))))) + +(defun check-arrayp-cmp-opcodes (expect type) + ;; Assume the lowtag test passed already. + (count-cmp-opcodes type expect + `(lambda (x) + (declare (optimize (sb-c::verify-arg-count 0) + #+sb-safepoint (sb-c::insert-safepoints 0))) + (typep (truly-the other-pointer-object x) ',type)))) + +(with-test (:name :arrayp-exactly-one-comparison-etc) + (check-arrayp-cmp-opcodes 1 'array) + + (check-arrayp-cmp-opcodes 1 'string) + (check-arrayp-cmp-opcodes 1 'base-string) ; widetags differing in one bit + #+sb-unicode + (check-arrayp-cmp-opcodes 1 'sb-kernel::character-string) ; ditto + (check-arrayp-cmp-opcodes 1 'simple-string) ; 2 adjacent widetags + (check-arrayp-cmp-opcodes 1 '(and string (not simple-array))) + (check-arrayp-cmp-opcodes 1 'simple-base-string) + #+sb-unicode + (check-arrayp-cmp-opcodes 1 'sb-kernel::simple-character-string) + ;; FIXME: (AND STRING (NOT SIMPLE-STRING)) executs 4 tests + ;; but it denotes the same set of objects as (AND STRING (NOT SIMPLE-ARRAY)). + ;; The problem is with type algebra, not in the backend. + + ;; FIXME: this should be 1 comparison: widetag >= start-of-complex-widetags + (check-arrayp-cmp-opcodes 2 '(and array (not simple-array))) + + ;; some other interesting pairs + ;; This was passing just by random coincidence. + ;; The widetag patterns no longer differ in exactly 1 bit. + ;; Is there any real relevance to this test? + #+nil + (check-arrayp-cmp-opcodes 1 '(or (simple-array (unsigned-byte 8) (*)) + (simple-array (unsigned-byte 16) (*)))) + ;; FIXME: what's up with SIMPLE-UNBOXED-ARRAY requiring 1 SUB, + ;; 3 CMPs, and a MOVZX. Something doesn't feel right. + ;; In general, a lot of the array types are source-transforming to + ;; (AND (SB-KERNEL:%OTHER-POINTER-P #:OBJECT0) + ;; (EQ (SB-KERNEL:%OTHER-POINTER-WIDETAG #:OBJECT0) something)) + ) + +(defun check-integerp-cmp-opcodes (expect type) + (count-cmp-opcodes type expect + `(lambda (x) + (declare (optimize (sb-c::verify-arg-count 0) + #+sb-safepoint (sb-c::insert-safepoints 0))) + (typep x ',type)))) + +(with-test (:name :typep-integer-doubleton) + ;; This was taking 3 comparisons because it was a FIXNUMP test + ;; and some range-based testing rather than just 2 EQ tests. + (check-integerp-cmp-opcodes 2 '(integer 1 2))) + +(defun typep-asm-code-length (type) + (let* ((lines + (disassembly-lines + (compile nil + `(lambda (x) + (declare (optimize (sb-c::verify-arg-count 0) (debug 0))) + (typep x ',type))))) + (callp + (some (lambda (x) (or (search "#bignump-strength-reduction) + (let ((f1 (compile nil '(lambda (x) + (typecase x (fixnum 'a) (integer 'b) (t 'c))))) + (f2 (compile nil '(lambda (x) + (typecase x (fixnum 'a) (bignum 'b) (t 'c)))))) + (assert (= (length (disassembly-lines f1)) + (length (disassembly-lines f2)))))) diff -Nru sbcl-2.0.6/tools-for-build/editcore.lisp sbcl-2.1.1/tools-for-build/editcore.lisp --- sbcl-2.0.6/tools-for-build/editcore.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/editcore.lisp 2021-01-30 11:22:39.000000000 +0000 @@ -403,9 +403,9 @@ (physaddr start)) (loop (when (>= physaddr end) (return)) - (multiple-value-bind (obj tag size) - (reconstitute-object (ash physaddr (- n-fixnum-tag-bits))) - (when (and (= tag symbol-widetag) + (let* ((obj (reconstitute-object (ash physaddr (- n-fixnum-tag-bits)))) + (size (primitive-object-size obj))) + (when (and (symbolp obj) (string= symbol-name (translate (symbol-name obj) spaces)) (%instancep (symbol-package obj)) (string= package-name @@ -425,7 +425,7 @@ (defparameter label-prefix (if (member :darwin *features*) "_" "")) (defun labelize (x) (concatenate 'string label-prefix x)) -(defun compute-linkage-symbols (spaces entry-size) +(defun compute-linkage-symbols (spaces) (let* ((linkage-info (symbol-global-value (find-target-symbol "SB-SYS" "*LINKAGE-INFO*" spaces :physical))) @@ -459,8 +459,7 @@ (symbol-global-value (find-target-symbol "SB-VM" "LINKAGE-TABLE-ENTRY-SIZE" spaces :physical))) - (linkage-symbols (compute-linkage-symbols spaces linkage-entry-size)) - (inst-space (get-inst-space)) + (linkage-symbols (compute-linkage-symbols spaces)) (nil-object (compute-nil-object spaces)) (ambiguous-symbols (make-hash-table :test 'equal)) (core @@ -838,7 +837,7 @@ (total-nwords (cdr (pop ranges)))) (cond ((> jump-table-size 1) (format output "# jump table~%") - (format output ".quad ~d" jump-table-size) + (format output ".quad ~d" (sap-ref-word text-sap 0)) (dotimes (i (1- jump-table-size)) (format output ",\"~a\"+0x~x" base-symbol @@ -1528,19 +1527,17 @@ (return-from scan-obj)) (case widetag (#.instance-widetag - (let* ((layout (truly-the layout - (translate (%instance-layout obj) spaces))) - (bitmap (layout-bitmap layout)) - (translated - (if (fixnump bitmap) bitmap (translate bitmap spaces)))) - (do-instance-tagged-slot (i obj :bitmap translated) + (let ((layout (truly-the layout (translate (%instance-layout obj) spaces)))) + (do-instance-tagged-slot (i obj :layout layout) (scanptr vaddr obj (1+ i)))) (return-from scan-obj)) (#.simple-vector-widetag (let ((len (length (the simple-vector obj)))) - (when (eql (logand (get-header-data obj) #xFF) vector-addr-hashing-subtype) + (when (logtest (get-header-data obj) vector-addr-hashing-flag) (do ((i 2 (+ i 2)) (needs-rehash)) - ((= i len) + ;; Refer to the figure at the top of src/code/hash-table.lisp. + ;; LEN is an odd number. + ((>= i (1- len)) (when needs-rehash (setf (svref obj 1) 1))) ;; A weak or EQ-based hash table any of whose keys is a function @@ -1565,14 +1562,15 @@ (+ core-offs n-word-bytes) word))) (when (eq widetag funcallable-instance-widetag) - (let ((layout (truly-the layout (translate (%fun-layout obj) spaces)))) - (unless (fixnump (layout-bitmap layout)) - (error "Can't process bignum bitmap")) - (let ((bitmap (layout-bitmap layout))) - (unless (eql bitmap -1) + (let* ((layout (truly-the layout (translate (%fun-layout obj) spaces))) + (bitmap (%raw-instance-ref/signed-word + layout (sb-kernel::type-dd-length sb-kernel:layout)))) + (unless (= (sb-kernel:layout-bitmap-words layout) 1) + (error "Strange funcallable-instance bitmap")) + (unless (eql bitmap sb-kernel:+layout-all-tagged+) ;; tagged slots precede untagged slots, ;; so integer-length is the count of tagged slots. - (setq nwords (1+ (integer-length bitmap)))))))) + (setq nwords (1+ (integer-length bitmap))))))) ;; mixed boxed/unboxed objects (#.code-header-widetag (aver (not pie)) @@ -1708,6 +1706,7 @@ (fixedobj-range) ; = (START . SIZE-IN-BYTES) (relocs (make-array 100000 :adjustable t :fill-pointer 1))) + (declare (ignorable fixedobj-range)) ;; Remove old files (ignore-errors (delete-file asm-pathname)) (ignore-errors (delete-file elf-core-pathname)) diff -Nru sbcl-2.0.6/tools-for-build/grovel-features.sh sbcl-2.1.1/tools-for-build/grovel-features.sh --- sbcl-2.0.6/tools-for-build/grovel-features.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/grovel-features.sh 2021-01-30 11:22:39.000000000 +0000 @@ -6,25 +6,34 @@ # Assumes the presence of $1-test.c, which when built and # run should return with 104 if the feature is present. +# We presumes that the build machine matches the target machine +# in terms of a whether each feature presence test should pass. featurep() { bin="$1-test" + featurename=${2:-$1} rm -f $bin $GNUMAKE $bin -I ../src/runtime > /dev/null 2>&1 && echo "input" | ./$bin> /dev/null 2>&1 if [ "$?" -eq 104 ] then - printf " :$1" + printf " :$featurename" fi rm -f $bin } +# Adding a nonexistent link library to Config.*-win32 will fail, +# so we pass -lSynchronization to the featurep test specifically +# and not in the general make rule. +# It will get added in by Config.*-win32 only if LISP_FEATURE_SB_FUTEX. +if [ "$sbcl_os" = win32 ] ; then + LOADLIBES=-lSynchronization featurep os-provides-wakebyaddr sb-futex +fi + # KLUDGE: ppc/darwin dlopen is special cased in make-config.sh, as # we fake it with a shim. featurep os-provides-dlopen featurep os-provides-dladdr -featurep os-provides-putwc - featurep os-provides-blksize-t featurep os-provides-suseconds-t diff -Nru sbcl-2.0.6/tools-for-build/grovel-headers.c sbcl-2.1.1/tools-for-build/grovel-headers.c --- sbcl-2.0.6/tools-for-build/grovel-headers.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/grovel-headers.c 2021-01-30 11:22:39.000000000 +0000 @@ -55,17 +55,18 @@ #include #include -#ifdef LISP_FEATURE_HPUX -#include /* for TIOCGPGRP */ -#endif - #ifdef LISP_FEATURE_BSD #include #include #endif -#if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD) - #include "pthreads_win32.h" +#ifdef LISP_FEATURE_SB_THREAD +# ifdef LISP_FEATURE_WIN32 +# include "pthreads_win32.h" +# elif defined LISP_FEATURE_OS_THREAD_STACK +# include // PTHREAD_STACK_MIN is possibly in here +# include // instead of in here +# endif #endif #include "wrap.h" @@ -144,7 +145,7 @@ \n\ "); #ifdef _WIN32 - #include "grovel-headers-win32.h" + #include "grovel-headers-win32.inc" #else printf("(in-package \"SB-ALIEN\")\n\n"); @@ -154,7 +155,12 @@ defconstant ("rtld-now", RTLD_NOW); defconstant ("rtld-global", RTLD_GLOBAL); - printf("(in-package \"SB-UNIX\")\n\n"); + printf("\n(in-package \"SB-UNIX\")\n\n"); + +#if defined LISP_FEATURE_OS_THREAD_STACK + defconstant("pthread-min-stack", PTHREAD_STACK_MIN); + printf("\n"); +#endif printf(";;; select()\n"); defconstant("fd-setsize", FD_SETSIZE); @@ -262,6 +268,10 @@ printf("\n"); printf(";;; signals\n"); + defconstant("sizeof-sigset_t", sizeof (sigset_t)); + defconstant("sig_block", SIG_BLOCK); + defconstant("sig_unblock", SIG_UNBLOCK); + defconstant("sig_setmask", SIG_SETMASK); defsignal("sigalrm", SIGALRM); defsignal("sigbus", SIGBUS); defsignal("sigchld", SIGCHLD); @@ -330,6 +340,29 @@ #endif // !WIN32 printf("\n"); +#ifdef LISP_FEATURE_UNIX + defconstant("clock-realtime", CLOCK_REALTIME); + defconstant("clock-monotonic", CLOCK_MONOTONIC); + defconstant("clock-process-cputime-id", CLOCK_PROCESS_CPUTIME_ID); +#endif +#ifdef LISP_FEATURE_LINUX +#ifdef CLOCK_REALTIME_ALARM + defconstant("clock-realtime-alarm", CLOCK_REALTIME_ALARM); +#endif + defconstant("clock-realtime-coarse", CLOCK_REALTIME_COARSE); +#ifdef CLOCK_TAI + defconstant("clock-tai", CLOCK_TAI); // International Atomic Time. +#endif + defconstant("clock-monotonic-coarse", CLOCK_MONOTONIC_COARSE); + defconstant("clock-monotonic-raw", CLOCK_MONOTONIC_RAW); +#ifdef CLOCK_BOOTTIME + defconstant("clock-boottime", CLOCK_BOOTTIME); +#endif +#ifdef CLOCK_BOOTTIME_ALARM + defconstant("clock-boottime-alarn", CLOCK_BOOTTIME_ALARM); +#endif + defconstant("clock-thread-cputime-id", CLOCK_THREAD_CPUTIME_ID); +#endif printf(";;; structures\n"); DEFSTRUCT(timeval, struct timeval, DEFSLOT(tv-sec, tv_sec); diff -Nru sbcl-2.0.6/tools-for-build/grovel-headers-win32.h sbcl-2.1.1/tools-for-build/grovel-headers-win32.h --- sbcl-2.0.6/tools-for-build/grovel-headers-win32.h 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/grovel-headers-win32.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,225 +0,0 @@ -{ - printf("(in-package \"SB-WIN32\")\n\n"); - - defconstant ("input-record-size", sizeof (INPUT_RECORD)); - - defconstant ("MAX_PATH", MAX_PATH); - - printf(";;; CSIDL\n"); - - defconstant ("CSIDL_DESKTOP", CSIDL_DESKTOP); - defconstant ("CSIDL_INTERNET", CSIDL_INTERNET); - defconstant ("CSIDL_PROGRAMS", CSIDL_PROGRAMS); - defconstant ("CSIDL_CONTROLS", CSIDL_CONTROLS); - defconstant ("CSIDL_PRINTERS", CSIDL_PRINTERS); - defconstant ("CSIDL_PERSONAL", CSIDL_PERSONAL); - defconstant ("CSIDL_FAVORITES", CSIDL_FAVORITES); - defconstant ("CSIDL_STARTUP", CSIDL_STARTUP); - defconstant ("CSIDL_RECENT", CSIDL_RECENT); - defconstant ("CSIDL_SENDTO", CSIDL_SENDTO); - defconstant ("CSIDL_BITBUCKET", CSIDL_BITBUCKET); - defconstant ("CSIDL_STARTMENU", CSIDL_STARTMENU); - defconstant ("CSIDL_DESKTOPDIRECTORY", CSIDL_DESKTOPDIRECTORY); - defconstant ("CSIDL_DRIVES", CSIDL_DRIVES); - defconstant ("CSIDL_NETWORK", CSIDL_NETWORK); - defconstant ("CSIDL_NETHOOD", CSIDL_NETHOOD); - defconstant ("CSIDL_FONTS", CSIDL_FONTS); - defconstant ("CSIDL_TEMPLATES", CSIDL_TEMPLATES); - defconstant ("CSIDL_COMMON_STARTMENU", CSIDL_COMMON_STARTMENU); - defconstant ("CSIDL_COMMON_PROGRAMS", CSIDL_COMMON_PROGRAMS); - defconstant ("CSIDL_COMMON_STARTUP", CSIDL_COMMON_STARTUP); - defconstant ("CSIDL_COMMON_DESKTOPDIRECTORY", CSIDL_COMMON_DESKTOPDIRECTORY); - defconstant ("CSIDL_APPDATA", CSIDL_APPDATA); - defconstant ("CSIDL_PRINTHOOD", CSIDL_PRINTHOOD); - defconstant ("CSIDL_LOCAL_APPDATA", CSIDL_LOCAL_APPDATA); - defconstant ("CSIDL_ALTSTARTUP", CSIDL_ALTSTARTUP); - defconstant ("CSIDL_COMMON_ALTSTARTUP", CSIDL_COMMON_ALTSTARTUP); - defconstant ("CSIDL_COMMON_FAVORITES", CSIDL_COMMON_FAVORITES); - defconstant ("CSIDL_INTERNET_CACHE", CSIDL_INTERNET_CACHE); - defconstant ("CSIDL_COOKIES", CSIDL_COOKIES); - defconstant ("CSIDL_HISTORY", CSIDL_HISTORY); - defconstant ("CSIDL_COMMON_APPDATA", CSIDL_COMMON_APPDATA); - defconstant ("CSIDL_WINDOWS", CSIDL_WINDOWS); - defconstant ("CSIDL_SYSTEM", CSIDL_SYSTEM); - defconstant ("CSIDL_PROGRAM_FILES", CSIDL_PROGRAM_FILES); - defconstant ("CSIDL_MYPICTURES", CSIDL_MYPICTURES); - defconstant ("CSIDL_PROFILE", CSIDL_PROFILE); - defconstant ("CSIDL_SYSTEMX86", CSIDL_SYSTEMX86); - defconstant ("CSIDL_PROGRAM_FILESX86", CSIDL_PROGRAM_FILESX86); - defconstant ("CSIDL_PROGRAM_FILES_COMMON", CSIDL_PROGRAM_FILES_COMMON); - defconstant ("CSIDL_PROGRAM_FILES_COMMONX86", CSIDL_PROGRAM_FILES_COMMONX86); - defconstant ("CSIDL_COMMON_TEMPLATES", CSIDL_COMMON_TEMPLATES); - defconstant ("CSIDL_COMMON_DOCUMENTS", CSIDL_COMMON_DOCUMENTS); - defconstant ("CSIDL_COMMON_ADMINTOOLS", CSIDL_COMMON_ADMINTOOLS); - defconstant ("CSIDL_ADMINTOOLS", CSIDL_ADMINTOOLS); - defconstant ("CSIDL_CONNECTIONS", CSIDL_CONNECTIONS); - defconstant ("CSIDL_COMMON_MUSIC", CSIDL_COMMON_MUSIC); - defconstant ("CSIDL_COMMON_PICTURES", CSIDL_COMMON_PICTURES); - defconstant ("CSIDL_COMMON_VIDEO", CSIDL_COMMON_VIDEO); - defconstant ("CSIDL_RESOURCES", CSIDL_RESOURCES); - defconstant ("CSIDL_RESOURCES_LOCALIZED", CSIDL_RESOURCES_LOCALIZED); - defconstant ("CSIDL_COMMON_OEM_LINKS", CSIDL_COMMON_OEM_LINKS); - defconstant ("CSIDL_CDBURN_AREA", CSIDL_CDBURN_AREA); - defconstant ("CSIDL_COMPUTERSNEARME", CSIDL_COMPUTERSNEARME); - defconstant ("CSIDL_FLAG_DONT_VERIFY", CSIDL_FLAG_DONT_VERIFY); - defconstant ("CSIDL_FLAG_CREATE", CSIDL_FLAG_CREATE); - defconstant ("CSIDL_FLAG_MASK", CSIDL_FLAG_MASK); - - printf(";;; Exceptions\n"); - defconstant("+exception-access-violation+", EXCEPTION_ACCESS_VIOLATION); - defconstant("+exception-array-bounds-exceeded+", EXCEPTION_ARRAY_BOUNDS_EXCEEDED); - defconstant("+exception-breakpoint+", EXCEPTION_BREAKPOINT); - defconstant("+exception-datatype-misalignment+", EXCEPTION_DATATYPE_MISALIGNMENT); - defconstant("+exception-flt-denormal-operand+", EXCEPTION_FLT_DENORMAL_OPERAND); - defconstant("+exception-flt-divide-by-zero+", EXCEPTION_FLT_DIVIDE_BY_ZERO); - defconstant("+exception-flt-inexact-result+", EXCEPTION_FLT_INEXACT_RESULT); - defconstant("+exception-flt-invalid-operation+", EXCEPTION_FLT_INVALID_OPERATION); - defconstant("+exception-flt-overflow+", EXCEPTION_FLT_OVERFLOW); - defconstant("+exception-flt-stack-check+", EXCEPTION_FLT_STACK_CHECK); - defconstant("+exception-flt-underflow+", EXCEPTION_FLT_UNDERFLOW); - defconstant("+exception-illegal-instruction+", EXCEPTION_ILLEGAL_INSTRUCTION); - defconstant("+exception-in-page-error+", EXCEPTION_IN_PAGE_ERROR); - defconstant("+exception-int-divide-by-zero+", EXCEPTION_INT_DIVIDE_BY_ZERO); - defconstant("+exception-int-overflow+", EXCEPTION_INT_OVERFLOW); - defconstant("+exception-invalid-disposition+", EXCEPTION_INVALID_DISPOSITION); - defconstant("+exception-noncontinuable-exception+", EXCEPTION_NONCONTINUABLE_EXCEPTION); - defconstant("+exception-priv-instruction+", EXCEPTION_PRIV_INSTRUCTION); - defconstant("+exception-single-step+", EXCEPTION_SINGLE_STEP); - defconstant("+exception-stack-overflow+", EXCEPTION_STACK_OVERFLOW); - defconstant("+dbg-printexception-c+", DBG_PRINTEXCEPTION_C); -#ifdef DBG_PRINTEXCEPTION_WIDE_C - defconstant("+dbg-printexception-wide-c+", DBG_PRINTEXCEPTION_WIDE_C); -#else - defconstant("+dbg-printexception-wide-c+", 0x4001000a); -#endif - - defconstant("+exception-maximum-parameters+", EXCEPTION_MAXIMUM_PARAMETERS); - - printf(";;; FormatMessage\n"); - - defconstant("format-message-allocate-buffer", FORMAT_MESSAGE_ALLOCATE_BUFFER); - defconstant("format-message-from-system", FORMAT_MESSAGE_FROM_SYSTEM); - defconstant("format-message-max-width-mask", FORMAT_MESSAGE_MAX_WIDTH_MASK); - defconstant("format-message-ignore-inserts", FORMAT_MESSAGE_IGNORE_INSERTS); - - printf(";;; Errors\n"); - - printf(";;; Errors\n"); - - defconstant("ERROR_ENVVAR_NOT_FOUND", ERROR_ENVVAR_NOT_FOUND); - defconstant("ERROR_ALREADY_EXISTS", ERROR_ALREADY_EXISTS); - defconstant("ERROR_FILE_EXISTS", ERROR_FILE_EXISTS); - defconstant("ERROR_FILE_NOT_FOUND", ERROR_FILE_NOT_FOUND); - defconstant("ERROR_ACCESS_DENIED", ERROR_ACCESS_DENIED); - - defconstant("error-io-pending", ERROR_IO_PENDING); - defconstant("error-broken-pipe", ERROR_BROKEN_PIPE); - defconstant("error-no-data", ERROR_NO_DATA); - defconstant("error-handle-eof", ERROR_HANDLE_EOF); - - - printf(";;; GetComputerName\n"); - - defconstant ("MAX_COMPUTERNAME_LENGTH", MAX_COMPUTERNAME_LENGTH); - defconstant ("ERROR_BUFFER_OVERFLOW", ERROR_BUFFER_OVERFLOW); - - printf(";;; Windows Types\n"); - DEFTYPE("int-ptr", INT_PTR); - DEFTYPE("dword", DWORD); - DEFTYPE("bool", BOOL); - DEFTYPE("uint", UINT); - DEFTYPE("ulong", ULONG); - - printf(";;; File Desired Access\n"); - defconstant ("FILE_GENERIC_READ", FILE_GENERIC_READ); - defconstant ("FILE_GENERIC_WRITE", FILE_GENERIC_WRITE); - defconstant ("FILE_GENERIC_EXECUTE", FILE_GENERIC_EXECUTE); - defconstant ("FILE_SHARE_READ", FILE_SHARE_READ); - defconstant ("FILE_SHARE_WRITE", FILE_SHARE_WRITE); - defconstant ("FILE_SHARE_DELETE", FILE_SHARE_DELETE); - - printf(";;; File Creation Dispositions\n"); - defconstant("CREATE_NEW", CREATE_NEW); - defconstant("CREATE_ALWAYS", CREATE_ALWAYS); - defconstant("OPEN_EXISTING", OPEN_EXISTING); - defconstant("OPEN_ALWAYS", OPEN_ALWAYS); - defconstant("TRUNCATE_EXISTING", TRUNCATE_EXISTING); - - printf(";;; Desired Access\n"); - defconstant("ACCESS_GENERIC_READ", GENERIC_READ); - defconstant("ACCESS_GENERIC_WRITE", GENERIC_WRITE); - defconstant("ACCESS_GENERIC_EXECUTE", GENERIC_EXECUTE); - defconstant("ACCESS_GENERIC_ALL", GENERIC_ALL); - defconstant("ACCESS_FILE_APPEND_DATA", FILE_APPEND_DATA); - defconstant("ACCESS_DELETE", DELETE); - - printf(";;; Handle Information Flags\n"); - defconstant("HANDLE_FLAG_INHERIT", HANDLE_FLAG_INHERIT); - defconstant("HANDLE_FLAG_PROTECT_FROM_CLOSE", HANDLE_FLAG_PROTECT_FROM_CLOSE); - - printf(";;; Standard Handle Keys\n"); - defconstant("STD_INPUT_HANDLE", STD_INPUT_HANDLE); - defconstant("STD_OUTPUT_HANDLE", STD_OUTPUT_HANDLE); - defconstant("STD_ERROR_HANDLE", STD_ERROR_HANDLE); - - printf(";;; WinCrypt\n"); - defconstant("crypt-verifycontext", CRYPT_VERIFYCONTEXT); - defconstant("crypt-silent", CRYPT_SILENT); - defconstant("prov-rsa-full", PROV_RSA_FULL); - - defconstant("pipe-access-duplex", PIPE_ACCESS_DUPLEX); - defconstant("pipe-access-inbound", PIPE_ACCESS_INBOUND); - defconstant("pipe-access-outbound", PIPE_ACCESS_OUTBOUND); - defconstant("pipe-type-byte", PIPE_TYPE_BYTE); - - defconstant("wait-abandoned", WAIT_ABANDONED); - defconstant("wait-object-0", WAIT_OBJECT_0); - defconstant("wait-timeout", WAIT_TIMEOUT); - defconstant("wait-failed", WAIT_FAILED); - - defconstant("still-active", STILL_ACTIVE); - - /* FIXME: SB-UNIX and SB-WIN32 really need to be untangled. */ - printf("(in-package \"SB-UNIX\")\n\n"); - printf(";;; Unix-like constants and types on Windows\n"); - defconstant("o_rdonly", _O_RDONLY); - defconstant("o_wronly", _O_WRONLY); - defconstant("o_rdwr", _O_RDWR); - defconstant("o_creat", _O_CREAT); - defconstant("o_trunc", _O_TRUNC); - defconstant("o_append", _O_APPEND); - defconstant("o_excl", _O_EXCL); - defconstant("o_binary", _O_BINARY); - defconstant("o_noinherit", _O_NOINHERIT); - - defconstant("enoent", ENOENT); - defconstant("eexist", EEXIST); - defconstant("eintr", EINTR); - defconstant("eagain", EAGAIN); - defconstant("ebadf", EBADF); - - defconstant("s-ifmt", S_IFMT); - defconstant("s-ifdir", S_IFDIR); - defconstant("s-ifreg", S_IFREG); - - DEFTYPE("ino-t", ino_t); - DEFTYPE("time-t", time_t); - DEFTYPE("off-t", off_t); - DEFTYPE("size-t", size_t); - DEFTYPE("ssize-t", size_t); - DEFTYPE("mode-t", mode_t); - - DEFTYPE("wst-dev-t", wst_dev_t); - DEFTYPE("wst-ino-t", wst_ino_t); - DEFTYPE("wst-off-t", wst_off_t); - DEFTYPE("wst-blksize-t", wst_blksize_t); - DEFTYPE("wst-blkcnt-t", wst_blkcnt_t); - DEFTYPE("wst-nlink-t", wst_nlink_t); - DEFTYPE("wst-uid-t", wst_uid_t); - DEFTYPE("wst-gid-t", wst_gid_t); - - /* KLUDGE */ - defconstant("fd-setsize", 1024); - printf("\n"); - -} diff -Nru sbcl-2.0.6/tools-for-build/grovel-headers-win32.inc sbcl-2.1.1/tools-for-build/grovel-headers-win32.inc --- sbcl-2.0.6/tools-for-build/grovel-headers-win32.inc 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/grovel-headers-win32.inc 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,230 @@ +{ + printf("(in-package \"SB-WIN32\")\n\n"); + + defconstant ("input-record-size", sizeof (INPUT_RECORD)); + + defconstant ("MAX_PATH", MAX_PATH); + + printf(";;; CSIDL\n"); + + defconstant ("CSIDL_DESKTOP", CSIDL_DESKTOP); + defconstant ("CSIDL_INTERNET", CSIDL_INTERNET); + defconstant ("CSIDL_PROGRAMS", CSIDL_PROGRAMS); + defconstant ("CSIDL_CONTROLS", CSIDL_CONTROLS); + defconstant ("CSIDL_PRINTERS", CSIDL_PRINTERS); + defconstant ("CSIDL_PERSONAL", CSIDL_PERSONAL); + defconstant ("CSIDL_FAVORITES", CSIDL_FAVORITES); + defconstant ("CSIDL_STARTUP", CSIDL_STARTUP); + defconstant ("CSIDL_RECENT", CSIDL_RECENT); + defconstant ("CSIDL_SENDTO", CSIDL_SENDTO); + defconstant ("CSIDL_BITBUCKET", CSIDL_BITBUCKET); + defconstant ("CSIDL_STARTMENU", CSIDL_STARTMENU); + defconstant ("CSIDL_DESKTOPDIRECTORY", CSIDL_DESKTOPDIRECTORY); + defconstant ("CSIDL_DRIVES", CSIDL_DRIVES); + defconstant ("CSIDL_NETWORK", CSIDL_NETWORK); + defconstant ("CSIDL_NETHOOD", CSIDL_NETHOOD); + defconstant ("CSIDL_FONTS", CSIDL_FONTS); + defconstant ("CSIDL_TEMPLATES", CSIDL_TEMPLATES); + defconstant ("CSIDL_COMMON_STARTMENU", CSIDL_COMMON_STARTMENU); + defconstant ("CSIDL_COMMON_PROGRAMS", CSIDL_COMMON_PROGRAMS); + defconstant ("CSIDL_COMMON_STARTUP", CSIDL_COMMON_STARTUP); + defconstant ("CSIDL_COMMON_DESKTOPDIRECTORY", CSIDL_COMMON_DESKTOPDIRECTORY); + defconstant ("CSIDL_APPDATA", CSIDL_APPDATA); + defconstant ("CSIDL_PRINTHOOD", CSIDL_PRINTHOOD); + defconstant ("CSIDL_LOCAL_APPDATA", CSIDL_LOCAL_APPDATA); + defconstant ("CSIDL_ALTSTARTUP", CSIDL_ALTSTARTUP); + defconstant ("CSIDL_COMMON_ALTSTARTUP", CSIDL_COMMON_ALTSTARTUP); + defconstant ("CSIDL_COMMON_FAVORITES", CSIDL_COMMON_FAVORITES); + defconstant ("CSIDL_INTERNET_CACHE", CSIDL_INTERNET_CACHE); + defconstant ("CSIDL_COOKIES", CSIDL_COOKIES); + defconstant ("CSIDL_HISTORY", CSIDL_HISTORY); + defconstant ("CSIDL_COMMON_APPDATA", CSIDL_COMMON_APPDATA); + defconstant ("CSIDL_WINDOWS", CSIDL_WINDOWS); + defconstant ("CSIDL_SYSTEM", CSIDL_SYSTEM); + defconstant ("CSIDL_PROGRAM_FILES", CSIDL_PROGRAM_FILES); + defconstant ("CSIDL_MYPICTURES", CSIDL_MYPICTURES); + defconstant ("CSIDL_PROFILE", CSIDL_PROFILE); + defconstant ("CSIDL_SYSTEMX86", CSIDL_SYSTEMX86); + defconstant ("CSIDL_PROGRAM_FILESX86", CSIDL_PROGRAM_FILESX86); + defconstant ("CSIDL_PROGRAM_FILES_COMMON", CSIDL_PROGRAM_FILES_COMMON); + defconstant ("CSIDL_PROGRAM_FILES_COMMONX86", CSIDL_PROGRAM_FILES_COMMONX86); + defconstant ("CSIDL_COMMON_TEMPLATES", CSIDL_COMMON_TEMPLATES); + defconstant ("CSIDL_COMMON_DOCUMENTS", CSIDL_COMMON_DOCUMENTS); + defconstant ("CSIDL_COMMON_ADMINTOOLS", CSIDL_COMMON_ADMINTOOLS); + defconstant ("CSIDL_ADMINTOOLS", CSIDL_ADMINTOOLS); + defconstant ("CSIDL_CONNECTIONS", CSIDL_CONNECTIONS); + defconstant ("CSIDL_COMMON_MUSIC", CSIDL_COMMON_MUSIC); + defconstant ("CSIDL_COMMON_PICTURES", CSIDL_COMMON_PICTURES); + defconstant ("CSIDL_COMMON_VIDEO", CSIDL_COMMON_VIDEO); + defconstant ("CSIDL_RESOURCES", CSIDL_RESOURCES); + defconstant ("CSIDL_RESOURCES_LOCALIZED", CSIDL_RESOURCES_LOCALIZED); + defconstant ("CSIDL_COMMON_OEM_LINKS", CSIDL_COMMON_OEM_LINKS); + defconstant ("CSIDL_CDBURN_AREA", CSIDL_CDBURN_AREA); + defconstant ("CSIDL_COMPUTERSNEARME", CSIDL_COMPUTERSNEARME); + defconstant ("CSIDL_FLAG_DONT_VERIFY", CSIDL_FLAG_DONT_VERIFY); + defconstant ("CSIDL_FLAG_CREATE", CSIDL_FLAG_CREATE); + defconstant ("CSIDL_FLAG_MASK", CSIDL_FLAG_MASK); + + printf(";;; Exceptions\n"); + defconstant("+exception-access-violation+", EXCEPTION_ACCESS_VIOLATION); + defconstant("+exception-array-bounds-exceeded+", EXCEPTION_ARRAY_BOUNDS_EXCEEDED); + defconstant("+exception-breakpoint+", EXCEPTION_BREAKPOINT); + defconstant("+exception-datatype-misalignment+", EXCEPTION_DATATYPE_MISALIGNMENT); + defconstant("+exception-flt-denormal-operand+", EXCEPTION_FLT_DENORMAL_OPERAND); + defconstant("+exception-flt-divide-by-zero+", EXCEPTION_FLT_DIVIDE_BY_ZERO); + defconstant("+exception-flt-inexact-result+", EXCEPTION_FLT_INEXACT_RESULT); + defconstant("+exception-flt-invalid-operation+", EXCEPTION_FLT_INVALID_OPERATION); + defconstant("+exception-flt-overflow+", EXCEPTION_FLT_OVERFLOW); + defconstant("+exception-flt-stack-check+", EXCEPTION_FLT_STACK_CHECK); + defconstant("+exception-flt-underflow+", EXCEPTION_FLT_UNDERFLOW); + defconstant("+exception-illegal-instruction+", EXCEPTION_ILLEGAL_INSTRUCTION); + defconstant("+exception-in-page-error+", EXCEPTION_IN_PAGE_ERROR); + defconstant("+exception-int-divide-by-zero+", EXCEPTION_INT_DIVIDE_BY_ZERO); + defconstant("+exception-int-overflow+", EXCEPTION_INT_OVERFLOW); + defconstant("+exception-invalid-disposition+", EXCEPTION_INVALID_DISPOSITION); + defconstant("+exception-noncontinuable-exception+", EXCEPTION_NONCONTINUABLE_EXCEPTION); + defconstant("+exception-priv-instruction+", EXCEPTION_PRIV_INSTRUCTION); + defconstant("+exception-single-step+", EXCEPTION_SINGLE_STEP); + defconstant("+exception-stack-overflow+", EXCEPTION_STACK_OVERFLOW); + defconstant("+dbg-printexception-c+", DBG_PRINTEXCEPTION_C); +#ifdef DBG_PRINTEXCEPTION_WIDE_C + defconstant("+dbg-printexception-wide-c+", DBG_PRINTEXCEPTION_WIDE_C); +#else + defconstant("+dbg-printexception-wide-c+", 0x4001000a); +#endif + + defconstant("+exception-maximum-parameters+", EXCEPTION_MAXIMUM_PARAMETERS); + + printf(";;; FormatMessage\n"); + + defconstant("format-message-allocate-buffer", FORMAT_MESSAGE_ALLOCATE_BUFFER); + defconstant("format-message-from-system", FORMAT_MESSAGE_FROM_SYSTEM); + defconstant("format-message-max-width-mask", FORMAT_MESSAGE_MAX_WIDTH_MASK); + defconstant("format-message-ignore-inserts", FORMAT_MESSAGE_IGNORE_INSERTS); + + printf(";;; Errors\n"); + + printf(";;; Errors\n"); + + defconstant("ERROR_ENVVAR_NOT_FOUND", ERROR_ENVVAR_NOT_FOUND); + defconstant("ERROR_ALREADY_EXISTS", ERROR_ALREADY_EXISTS); + defconstant("ERROR_FILE_EXISTS", ERROR_FILE_EXISTS); + defconstant("ERROR_FILE_NOT_FOUND", ERROR_FILE_NOT_FOUND); + defconstant("ERROR_ACCESS_DENIED", ERROR_ACCESS_DENIED); + + defconstant("error-io-pending", ERROR_IO_PENDING); + defconstant("error-broken-pipe", ERROR_BROKEN_PIPE); + defconstant("error-no-data", ERROR_NO_DATA); + defconstant("error-handle-eof", ERROR_HANDLE_EOF); + + + printf(";;; GetComputerName\n"); + + defconstant ("MAX_COMPUTERNAME_LENGTH", MAX_COMPUTERNAME_LENGTH); + defconstant ("ERROR_BUFFER_OVERFLOW", ERROR_BUFFER_OVERFLOW); + + printf(";;; Windows Types\n"); + DEFTYPE("int-ptr", INT_PTR); + DEFTYPE("dword", DWORD); + DEFTYPE("bool", BOOL); + DEFTYPE("uint", UINT); + DEFTYPE("ulong", ULONG); + + printf(";;; File Desired Access\n"); + defconstant ("FILE_GENERIC_READ", FILE_GENERIC_READ); + defconstant ("FILE_GENERIC_WRITE", FILE_GENERIC_WRITE); + defconstant ("FILE_GENERIC_EXECUTE", FILE_GENERIC_EXECUTE); + defconstant ("FILE_SHARE_READ", FILE_SHARE_READ); + defconstant ("FILE_SHARE_WRITE", FILE_SHARE_WRITE); + defconstant ("FILE_SHARE_DELETE", FILE_SHARE_DELETE); + + printf(";;; File Creation Dispositions\n"); + defconstant("CREATE_NEW", CREATE_NEW); + defconstant("CREATE_ALWAYS", CREATE_ALWAYS); + defconstant("OPEN_EXISTING", OPEN_EXISTING); + defconstant("OPEN_ALWAYS", OPEN_ALWAYS); + defconstant("TRUNCATE_EXISTING", TRUNCATE_EXISTING); + + printf(";;; Desired Access\n"); + defconstant("ACCESS_GENERIC_READ", GENERIC_READ); + defconstant("ACCESS_GENERIC_WRITE", GENERIC_WRITE); + defconstant("ACCESS_GENERIC_EXECUTE", GENERIC_EXECUTE); + defconstant("ACCESS_GENERIC_ALL", GENERIC_ALL); + defconstant("ACCESS_FILE_APPEND_DATA", FILE_APPEND_DATA); + defconstant("ACCESS_DELETE", DELETE); + + printf(";;; Handle Information Flags\n"); + defconstant("HANDLE_FLAG_INHERIT", HANDLE_FLAG_INHERIT); + defconstant("HANDLE_FLAG_PROTECT_FROM_CLOSE", HANDLE_FLAG_PROTECT_FROM_CLOSE); + + printf(";;; Standard Handle Keys\n"); + defconstant("STD_INPUT_HANDLE", STD_INPUT_HANDLE); + defconstant("STD_OUTPUT_HANDLE", STD_OUTPUT_HANDLE); + defconstant("STD_ERROR_HANDLE", STD_ERROR_HANDLE); + + printf(";;; WinCrypt\n"); + defconstant("crypt-verifycontext", CRYPT_VERIFYCONTEXT); + defconstant("crypt-silent", CRYPT_SILENT); + defconstant("prov-rsa-full", PROV_RSA_FULL); + + defconstant("pipe-access-duplex", PIPE_ACCESS_DUPLEX); + defconstant("pipe-access-inbound", PIPE_ACCESS_INBOUND); + defconstant("pipe-access-outbound", PIPE_ACCESS_OUTBOUND); + defconstant("pipe-type-byte", PIPE_TYPE_BYTE); + + defconstant("wait-abandoned", WAIT_ABANDONED); + defconstant("wait-object-0", WAIT_OBJECT_0); + defconstant("wait-timeout", WAIT_TIMEOUT); + defconstant("wait-failed", WAIT_FAILED); + + defconstant("still-active", STILL_ACTIVE); + + /* FIXME: SB-UNIX and SB-WIN32 really need to be untangled. */ + printf("(in-package \"SB-UNIX\")\n\n"); + printf(";;; Unix-like constants and types on Windows\n"); + defconstant("o_rdonly", _O_RDONLY); + defconstant("o_wronly", _O_WRONLY); + defconstant("o_rdwr", _O_RDWR); + defconstant("o_creat", _O_CREAT); + defconstant("o_trunc", _O_TRUNC); + defconstant("o_append", _O_APPEND); + defconstant("o_excl", _O_EXCL); + defconstant("o_binary", _O_BINARY); + defconstant("o_noinherit", _O_NOINHERIT); + + defconstant("enoent", ENOENT); + defconstant("eexist", EEXIST); + defconstant("eintr", EINTR); + defconstant("eagain", EAGAIN); + defconstant("ebadf", EBADF); + + defconstant("s-ifmt", S_IFMT); + defconstant("s-ifdir", S_IFDIR); + defconstant("s-ifreg", S_IFREG); + + DEFTYPE("ino-t", ino_t); + DEFTYPE("time-t", time_t); + DEFTYPE("off-t", off_t); + DEFTYPE("size-t", size_t); + DEFTYPE("ssize-t", size_t); + DEFTYPE("mode-t", mode_t); + + DEFTYPE("wst-dev-t", wst_dev_t); + DEFTYPE("wst-ino-t", wst_ino_t); + DEFTYPE("wst-off-t", wst_off_t); + DEFTYPE("wst-blksize-t", wst_blksize_t); + DEFTYPE("wst-blkcnt-t", wst_blkcnt_t); + DEFTYPE("wst-nlink-t", wst_nlink_t); + DEFTYPE("wst-uid-t", wst_uid_t); + DEFTYPE("wst-gid-t", wst_gid_t); + + /* KLUDGE */ + defconstant("fd-setsize", 1024); + printf("\n"); + + defconstant("sizeof-sigset_t", sizeof (sigset_t)); + defconstant("sig_block", SIG_BLOCK); + defconstant("sig_unblock", SIG_UNBLOCK); + defconstant("sig_setmask", SIG_SETMASK); + +} diff -Nru sbcl-2.0.6/tools-for-build/ldso-stubs.lisp sbcl-2.1.1/tools-for-build/ldso-stubs.lisp --- sbcl-2.0.6/tools-for-build/ldso-stubs.lisp 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/ldso-stubs.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,222 +0,0 @@ -;;;; Generate stubs for C-linkage library functions which we need to refer to -;;;; from Lisp. -;;;; -;;;; These stubs exist for the benefit of Lisp code that needs to refer -;;;; to foreign symbols when dlsym() is not available (i.e. when dumping -;;;; cold-sbcl.core, when we may be running in a host that's not SBCL, -;;;; or on platforms that don't have it at all). If the runtime is -;;;; dynamically linked, library functions won't be linked into it, so -;;;; the map file won't show them. So, we need a bunch of stubs that -;;;; nm(1) _can_ see. -;;;; -;;;; 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. - -;;; This is an attempt to follow DB's hint of sbcl-devel -;;; 2001-09-18. -- CSR -;;; -(defun ldso-stubify (index fct stream) - (declare (ignorable index)) - #+hppa - (let ((stub (format nil "ldso_stub__~a" fct))) - (apply #'format stream (list -" .export ~A -~A: - .proc - .callinfo - b,n ~a - .procend - .import ~a,code~%" stub stub fct fct))) - - #-hppa - (format stream "LDSO_STUBIFY(~A)~%" fct)) - -(defvar *preludes* (list " -/* This is an automatically generated file, please do not hand-edit it. - * See the program tools-for-build/ldso-stubs.lisp. */ - -#ifndef __ASSEMBLER__ -#define __ASSEMBLER__ -#endif -#include \"sbcl.h\"" - -#+(and linux alpha) " -#define LDSO_STUBIFY(fct) \\ -.globl ldso_stub__ ## fct ; \\ - .type ldso_stub__ ## fct,@function ; \\ -ldso_stub__ ## fct: ; \\ - jmp fct ; \\ -.L ## fct ## e1: ; \\ - .size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ;" - -#+hppa " - .level 2.0 - .text" - -)) - -;;; Most of the #+- in here is just noise, but so is this whole file. -;;; So I don't really care to go through with a comb and remove the fluff. -(defvar *stubs* (append - '("_exit" - "accept" - "access" - "acos" - "acosh" - "asin" - "asinh" - "atanh" - "bind" - "chmod" - "chown" - "close" - "closedir" - "connect" - "cosh" - "creat" - "dup" - "dup2" - "execve" - "exit" - "fchmod" - "fchown" - "fcntl" - "fork" - "free" - "fstat" - #+inode64 "fstat$INODE64" - "fsync" - "ftruncate" - "getcwd" - "getdtablesize" - "getegid" - "getenv" - "getgid" - "gethostbyaddr" - "gethostbyname" - "gethostname" - "getitimer" - "getpeername" - "getpgrp" - "getpid" - "getppid" - "getrusage" - "getsockname" - "gettimeofday" - "getuid" - "hypot" - "ioctl" - "isatty" - "kill" - "killpg" - "link" - "listen" - "log1p" - "lseek" - "lstat" - #+inode64 "lstat$INODE64" - "malloc" - #+(or x86 x86-64) "memcmp" - "memmove" - "mkdir" - "nanosleep" - "open" - "opendir" - "pipe" - "poll" - "pow" - "read" - "readdir" - "readlink" - "realpath" - "recv" - "rename" - "rmdir" - "select" - "send" - "setitimer" - "setpgrp" - "setsid" - "sinh" - "socket" - "stat" - #+inode64 "stat$INODE64" - "strerror" - "strlen" - "symlink" - "sync" - "tanh" - "truncate" - "ttyname" - #-hpux "tzname" - "unlink" - "utimes" - "waitpid" - "write") - ;; These aren't needed on the X86 because they're microcoded into the - ;; FPU, so the Lisp VOPs can implement them directly without having to - ;; call C code. - ;; - ;; Note: There might be some other functions in this category as well. - ;; E.g. I notice tanh() and acos() in the list above.. -- WHN 2001-06-07 - #-x86 - '("sin" - "cos" - "tan" - "atan" - "atan2" - "exp" - "log" - "log10" - "sqrt") - #+alpha - '("ieee_get_fp_control" - "ieee_set_fp_control") - ;; FIXME: After 1.0 this should be made - ;; #-linkage-table, as we only need these stubs if - ;; we don't have linkage-table. Done this way now to - ;; cut down on the number of ports affected. - #-(or win32 darwin freebsd netbsd openbsd) - '("ptsname" - #-android "grantpt" - "unlockpt") - #+(or openbsd freebsd dragonfly) - '("openpty") - '("dlclose" - "dlerror" - "dlopen" - "dlsym") - #+bsd - '("sysctl") - #+darwin - '("sysctlbyname") - #+os-provides-dladdr - '("dladdr") - #-android - '("nl_langinfo" - "getpagesize" - "cfgetispeed" - "cfgetospeed" - "cfsetispeed" - "cfsetospeed" - "tcdrain" - "tcflow" - "tcflush" - "tcgetattr" - "tcsendbreak" - "tcsetattr"))) - -(with-open-file (f "src/runtime/ldso-stubs.S" :direction :output :if-exists :supersede) - (assert (= (length *preludes*) 2)) - (dolist (pre *preludes*) - (write-line pre f)) - (let ((i -1)) - (dolist (stub *stubs*) - (check-type stub string) - (ldso-stubify (incf i) stub f)))) diff -Nru sbcl-2.0.6/tools-for-build/Makefile sbcl-2.1.1/tools-for-build/Makefile --- sbcl-2.0.6/tools-for-build/Makefile 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/Makefile 2021-01-30 11:22:39.000000000 +0000 @@ -7,6 +7,10 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. +# it is illogical that this makefile pulls in Makefile.features, +# which is presumed not to exist, and which when it does exist causes +# confusion as to what flags should be added in for a generic C compile. +# Why do we do this??? -include genesis/Makefile.features -include Config diff -Nru sbcl-2.0.6/tools-for-build/os-provides-putwc-test.c sbcl-2.1.1/tools-for-build/os-provides-putwc-test.c --- sbcl-2.0.6/tools-for-build/os-provides-putwc-test.c 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/os-provides-putwc-test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -/* test to build and run so that we know if we have putwc */ - -#include -#include - -int main () -{ - wchar_t a = 'a'; - putwc(a, stdout); - return 104; -} diff -Nru sbcl-2.0.6/tools-for-build/os-provides-wakebyaddr-test.c sbcl-2.1.1/tools-for-build/os-provides-wakebyaddr-test.c --- sbcl-2.0.6/tools-for-build/os-provides-wakebyaddr-test.c 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/os-provides-wakebyaddr-test.c 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,50 @@ +#include + +int mutex_word = 0; +int expect = 9; + +DWORD waiter(void* arg) { + mutex_word = expect = 2; + return WaitOnAddress(&mutex_word, &expect, 4, 100); // .1 sec max +} +DWORD waker(void* arg) { + mutex_word = 0; + WakeByAddressSingle(&mutex_word); + return 0; +} + +int main() +{ + // Verify that WaitOnAddress returns right away if the mutex word has the wrong value. + int result = WaitOnAddress(&mutex_word, &expect, 4, 500); // max = .5 sec + if (!result) return 0; // what? shouldn't be an error to mismatch + + // Try really waiting + mutex_word = 9; + result = WaitOnAddress(&mutex_word, &expect, 4, 20); // wait 20 millisec + // expect a timeout + if (!(result == 0 && GetLastError()==ERROR_TIMEOUT)) return 0; + + // Simulate a lisp mutex being woken + HANDLE hWaiter, hWaker; + hWaiter = CreateThread(NULL, 0, + waiter, 0, /* function and argument */ + 0, /* flags */ + 0); /* id */ + + hWaker = CreateThread(NULL, 0, + waker, 0, /* function and argument */ + CREATE_SUSPENDED, /* flags */ + 0); /* id */ + + for (;;) { + // wait for the waiter to place itself into a wait state on the mutex + if (mutex_word == 2) break; + Sleep(10); // 10 millisec + } + // Give them some time to rendezvous + ResumeThread(hWaker); + WaitForSingleObject(hWaiter, 200); // .2 sec max + if (mutex_word == 0) return 104; + return 1; +} diff -Nru sbcl-2.0.6/tools-for-build/sparc-funcdef.sh sbcl-2.1.1/tools-for-build/sparc-funcdef.sh --- sbcl-2.0.6/tools-for-build/sparc-funcdef.sh 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/tools-for-build/sparc-funcdef.sh 2021-01-30 11:22:39.000000000 +0000 @@ -8,14 +8,14 @@ echo $SUN_FUNCDEF > $TMP # cribbed from ldso_stubs, just "some code" echo " -.globl ldso_stub__printf ; - FUNCDEF(ldso_stub__printf) ; -ldso_stub__printf: ; +.globl foo_stub__printf ; + FUNCDEF(foo_stub__printf) ; +foo_stub__printf: ; sethi %hi(printf),%g1 ; jmpl %g1+%lo(printf),%g0 ; nop /* delay slot*/ ; .Lprintfe1: ; - .size ldso_stub__printf,.Lprintfe1-ldso_stub__printf ;" >> $TMP + .size foo_stub__printf,.Lprintfe1-foo_stub__printf ;" >> $TMP if $GNUMAKE sparc-funcdef.o > /dev/null 2>&1 ; then echo $SUN_FUNCDEF diff -Nru sbcl-2.0.6/verify-header-parsing.sh sbcl-2.1.1/verify-header-parsing.sh --- sbcl-2.0.6/verify-header-parsing.sh 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.1/verify-header-parsing.sh 2021-01-30 11:22:39.000000000 +0000 @@ -0,0 +1,10 @@ +#!/bin/sh + +# This script is not part of the build, but running it tells you +# whether each genesis headers can be included without fussing +# around with all sorts of other headers. +for i in src/runtime/genesis/*.h +do + echo '#include "'$i'"' > tmp.c + cc -Isrc/runtime -c tmp.c +done diff -Nru sbcl-2.0.6/version.lisp-expr sbcl-2.1.1/version.lisp-expr --- sbcl-2.0.6/version.lisp-expr 2020-06-29 12:57:07.000000000 +0000 +++ sbcl-2.1.1/version.lisp-expr 2021-01-30 11:22:39.000000000 +0000 @@ -1,4 +1,4 @@ ;;; This file is auto-generated using generate-version.sh. Every time ;;; you re-run make.sh, this file will be overwritten if you are ;;; working from a Git checkout. -"2.0.6" +"2.1.1"