diff -Nru sbcl-2.1.10/contrib/sb-bsd-sockets/constants.lisp sbcl-2.1.11/contrib/sb-bsd-sockets/constants.lisp --- sbcl-2.1.10/contrib/sb-bsd-sockets/constants.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-bsd-sockets/constants.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -230,6 +230,7 @@ (:function fcntl ("fcntl" int (fd int) (cmd int) + &optional (arg long))) (:function getsockopt ("getsockopt" int (socket int) diff -Nru sbcl-2.1.10/contrib/sb-cover/cover.lisp sbcl-2.1.11/contrib/sb-cover/cover.lisp --- sbcl-2.1.10/contrib/sb-cover/cover.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-cover/cover.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -91,6 +91,12 @@ (if ,var (progn ,@body (setq predecessor cell)) (rplacd predecessor (cdr cell)))))))) + ;; Using different values here isn't great, but a 1 bit seemed + ;; the natural choice for "marked" which is fine for x86 which can + ;; store any immediate byte. But the architectures which can't + ;; have either a ZERO-TN or NULL-TN, and can store a byte from + ;; that register into the coverage mark. So they expect a 0 + ;; in the low bit and therefore a 1 in the unmarked state. (empty-mark-word () #+(or x86-64 x86) 0 #-(or x86-64 x86) sb-ext:most-positive-word) @@ -118,14 +124,18 @@ (defun reset-coverage (&optional object) "Reset all coverage data back to the `Not executed` state." (cond (object ; reset only this object - (multiple-value-bind (map code) (%find-coverage-map object) + (multiple-value-bind (map code) + (%find-coverage-map (the sb-kernel:code-component object)) (when map #-arm64 (sb-sys:with-pinned-objects (code) - (let ((sap (code-coverage-marks code))) - (dotimes (i (ceiling (length map) sb-vm:n-word-bytes)) - (setf (sb-sys:sap-ref-word sap (ash i sb-vm:n-word-bytes)) - (empty-mark-word))))) + (sb-alien:alien-funcall + (sb-alien:extern-alien "memset" + (function sb-alien:void sb-sys:system-area-pointer + sb-alien:int sb-alien:unsigned)) + (code-coverage-marks code) + (logand (empty-mark-word) #xFF) + (length map))) #+arm64 (fill (code-coverage-marks code) #xFF)))) (t ; reset everything diff -Nru sbcl-2.1.10/contrib/sb-introspect/introspect.lisp sbcl-2.1.11/contrib/sb-introspect/introspect.lisp --- sbcl-2.1.10/contrib/sb-introspect/introspect.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-introspect/introspect.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -802,22 +802,26 @@ ;; bits are packed in the opposite order. And thankfully, ;; this fix seems not to depend on whether the numbering ;; scheme is MSB 0 or LSB 0, afaict. - (let* ((index (sb-vm:find-page-index + (let* ((wp + (let ((card-index + (logand + (ash (get-lisp-obj-address object) ; pinned above + (- (integer-length (1- sb-vm:gencgc-card-bytes)))) + (sb-alien:extern-alien "gc_card_table_mask" sb-alien:int)))) + (eql 1 (sb-sys:sap-ref-8 + (sb-alien:extern-alien "gc_card_mark" + sb-sys:system-area-pointer) + card-index)))) + (index (sb-vm:find-page-index (get-lisp-obj-address object))) (flags (sb-alien:slot page 'sb-vm::flags)) . - ;; The unused WP-CLR is for ease of counting #+big-endian ((type (ldb (byte 5 3) flags)) - (wp (logbitp 2 flags)) - (wp-clr (logbitp 1 flags)) (dontmove (logbitp 0 flags))) #+little-endian ((type (ldb (byte 5 0) flags)) - (wp (logbitp 5 flags)) - (wp-clr (logbitp 6 flags)) (dontmove (logbitp 7 flags)))) - (declare (ignore wp-clr)) (list :space space :generation (sb-alien:slot page 'sb-vm::gen) :write-protected wp diff -Nru sbcl-2.1.10/crossbuild-runner/backends/ppc64/features sbcl-2.1.11/crossbuild-runner/backends/ppc64/features --- sbcl-2.1.10/crossbuild-runner/backends/ppc64/features 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/ppc64/features 2021-11-30 16:16:46.000000000 +0000 @@ -1,5 +1,5 @@ ; threads are required because differing versions of the vops for BOUNDP ; and [fast-]symbol-[global-]value and CAS create extra maintenance burden. -:64-bit :untagged-fdefns :sb-thread +:64-bit :untagged-fdefns :sb-thread :soft-card-marks :gencgc :compare-and-swap-vops :alien-callbacks diff -Nru sbcl-2.1.10/crossbuild-runner/backends/sparc/stuff-groveled-from-headers.lisp sbcl-2.1.11/crossbuild-runner/backends/sparc/stuff-groveled-from-headers.lisp --- sbcl-2.1.10/crossbuild-runner/backends/sparc/stuff-groveled-from-headers.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/sparc/stuff-groveled-from-headers.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -93,6 +93,7 @@ ;;; signals (defconstant sizeof-sigset_t 128) ; #x80 (defconstant sig_setmask 2) ; #x2 +(defconstant sig_unblock 2) ; #x2 (defconstant sigalrm 14) ; #xe (defconstant sigbus 10) ; #xa (defconstant sigchld 20) ; #x14 @@ -152,3 +153,4 @@ ;;; Our runtime types (define-alien-type os-vm-size-t (unsigned 32)) + diff -Nru sbcl-2.1.10/crossbuild-runner/backends/x86-64/features sbcl-2.1.11/crossbuild-runner/backends/x86-64/features --- sbcl-2.1.10/crossbuild-runner/backends/x86-64/features 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/x86-64/features 2021-11-30 16:16:46.000000000 +0000 @@ -1,5 +1,6 @@ :64-bit :gencgc +:soft-card-marks :stack-grows-downward-not-upward :c-stack-is-control-stack :compare-and-swap-vops diff -Nru sbcl-2.1.10/debian/changelog sbcl-2.1.11/debian/changelog --- sbcl-2.1.10/debian/changelog 2021-11-02 10:22:02.000000000 +0000 +++ sbcl-2.1.11/debian/changelog 2021-12-01 10:44:18.000000000 +0000 @@ -1,3 +1,10 @@ +sbcl (2:2.1.11-1) unstable; urgency=medium + + * New upstream release + * vop-existsp-test.patch: new patch, fixes test failure + + -- Sébastien Villemot Wed, 01 Dec 2021 11:44:18 +0100 + sbcl (2:2.1.10-1) unstable; urgency=medium * New upstream release diff -Nru sbcl-2.1.10/debian/patches/kfreebsd-pthread-futex.patch sbcl-2.1.11/debian/patches/kfreebsd-pthread-futex.patch --- sbcl-2.1.10/debian/patches/kfreebsd-pthread-futex.patch 2021-11-02 10:22:02.000000000 +0000 +++ sbcl-2.1.11/debian/patches/kfreebsd-pthread-futex.patch 2021-11-30 18:28:16.000000000 +0000 @@ -17,7 +17,7 @@ endif --- a/src/runtime/thread.c +++ b/src/runtime/thread.c -@@ -706,7 +706,7 @@ static void attach_os_thread(init_thread +@@ -714,7 +714,7 @@ static void attach_os_thread(init_thread # else pthread_attr_t attr; pthread_attr_init(&attr); diff -Nru sbcl-2.1.10/debian/patches/series sbcl-2.1.11/debian/patches/series --- sbcl-2.1.10/debian/patches/series 2021-08-25 08:54:42.000000000 +0000 +++ sbcl-2.1.11/debian/patches/series 2021-12-01 10:15:07.000000000 +0000 @@ -6,3 +6,4 @@ skip-some-autopkgtests.patch disable-fcb-threads-test.patch fix-chill-test.patch +vop-existsp-test.patch diff -Nru sbcl-2.1.10/debian/patches/vop-existsp-test.patch sbcl-2.1.11/debian/patches/vop-existsp-test.patch --- sbcl-2.1.10/debian/patches/vop-existsp-test.patch 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/debian/patches/vop-existsp-test.patch 2021-12-01 10:43:50.000000000 +0000 @@ -0,0 +1,19 @@ +Description: Fix no-v0p-ex1stsp-in-build with sb-xref-for-internals + We build the Debian package with fancy features, which include + sb-xref-for-internals. + With this feature, VOP-EXISTSP remains in the Lisp image, hence we need + to skip the test that checks for its absence. +Author: Sébastien Villemot +Bug: https://bugs.launchpad.net/sbcl/+bug/1952896 +Last-Update: 2021-12-01 +--- +This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ +--- a/tests/interface.pure.lisp ++++ b/tests/interface.pure.lisp +@@ -310,5 +310,5 @@ + '(1 2 3 4 5 6 7 8))))) + + (with-test (:name :no-v0p-ex1stsp-in-build ; spelled L33t Hax0r style on purpose +- :skipped-on :sb-devel) ; (otherwise self-induced failure) ++ :skipped-on (:or :sb-devel :sb-xref-for-internals)) ; (otherwise self-induced failure) + (assert (null (apropos-list "VOP-EXISTSP")))) diff -Nru sbcl-2.1.10/doc/manual/ffi.texinfo sbcl-2.1.11/doc/manual/ffi.texinfo --- sbcl-2.1.10/doc/manual/ffi.texinfo 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/doc/manual/ffi.texinfo 2021-11-30 16:16:46.000000000 +0000 @@ -1081,14 +1081,10 @@ conjunction with a core initializing global symbols to foreign callables as function pointers and with object code allocating those symbols to initialize the runtime properly. The arguments to @code{initialize_lisp} -are the same as the arguments to the main @code{sbcl} program. +are the same as the arguments to the main @code{sbcl} +program. -While standalone C code can call exposed Lisp functions which spawn Lisp -threads after the runtime has been initialized, it is currently not -advised to call into Lisp this way from separate C threads running -concurrently. - -Note: There is also currently no way to run exit hooks or otherwise undo +Note: There is currently no way to run exit hooks or otherwise undo Lisp initialization gracefully from C. @node Step-By-Step Example of the Foreign Function Interface diff -Nru sbcl-2.1.10/float-math.lisp-expr sbcl-2.1.11/float-math.lisp-expr --- sbcl-2.1.10/float-math.lisp-expr 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/float-math.lisp-expr 2021-11-30 16:16:46.000000000 +0000 @@ -553,6 +553,7 @@ (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5E800000)) T) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3F000000) #x0) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x3F000000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x4E800000)) T) @@ -730,6 +731,7 @@ (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF)) T) (< (#.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333) #.(MAKE-DOUBLE-FLOAT #x3FE6A09E #x667F3BCD)) NIL) +(< (#.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333) #.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) T) (< (#.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x43C921FB #x54442D18)) T) @@ -1822,6 +1824,7 @@ (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #x3FFFFFFFFFFFFFFC) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) @@ -2967,6 +2970,7 @@ (>= (#.(MAKE-SINGLE-FLOAT #x5E7FFFFF) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x5E800000) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x-21800000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x5E800000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-SINGLE-FLOAT #x-800001)) T) diff -Nru sbcl-2.1.10/freeze.sh sbcl-2.1.11/freeze.sh --- sbcl-2.1.10/freeze.sh 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/freeze.sh 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,171 @@ +#! /bin/bash + +# Sourceforge username +SFUSER=${SFUSER:-$USER} + +set -ex + +usage() { + if ! [ -z "$1" ] + then + echo $1 + fi + cat < /dev/null + then + echo "NEWS not in correct format!" + exit 1 + fi + + ## Make draft release notes + + if [ ! -f $SBCL_RELEASE_DIR/sbcl-$VERSION-release-notes.txt ]; then + awk "BEGIN { state = 0 } + /^changes relative to sbcl-/ { state = 1 } + /^changes in sbcl-/ { state = 0 } + { if(state == 1) print \$0 }" < $GIT_DIR/NEWS > $SBCL_RELEASE_DIR/sbcl-$VERSION-release-notes.txt + fi + + ## Tag + + # I'd like to use the same tag each time, but I can't convince + # myself that that will do the right thing when pushed, and I don't + # want to break all our mirrors for this. + + # echo "Tagging as release_candidate" + # git tag release_candidate + + git clone $GIT_DIR $SBCL_DIR +fi + +# check self-build (without float oracle) + +## Build x86-64 binary for bootstrap. + +if [ ! -d $SBCL_RELEASE_DIR/bin ]; then + echo "Building bootstrap x86-64 binary" + cd $SBCL_DIR + nice -20 ./make.sh >$LOGFILE 2>&1 + + cd tests + nice -20 sh ./run-tests.sh >>$LOGFILE 2>&1 + mkdir -p $SBCL_RELEASE_DIR/bin + cp $SBCL_DIR/src/runtime/sbcl $SBCL_RELEASE_DIR/bin/sbcl + cp $SBCL_DIR/output/sbcl.core $SBCL_RELEASE_DIR/bin/sbcl.core +fi + +## Build x86-64 release candidate binary. + +if [ ! -d $SBCL_RELEASE_DIR/sbcl-$VERSION-x86-64-linux ]; then + echo "Building release candidate x86-64 binary" + cd $SBCL_DIR + sh clean.sh + nice -20 ./make.sh "$SBCL_RELEASE_DIR/bin/sbcl --core $SBCL_RELEASE_DIR/bin/sbcl.core --no-userinit" >> $LOGFILE 2>&1 + cd doc && sh ./make-doc.sh + cd $SBCL_RELEASE_DIR + + ln -s $SBCL_DIR $SBCL_RELEASE_DIR/sbcl-$VERSION-x86-64-linux + sh $SBCL_DIR/binary-distribution.sh sbcl-$VERSION-x86-64-linux + bzip2 sbcl-$VERSION-x86-64-linux-binary.tar + sh $SBCL_DIR/html-distribution.sh sbcl-$VERSION + bzip2 sbcl-$VERSION-documentation-html.tar + + mv $SBCL_DIR/obj/from-xc obj_from-xc_sbcl +fi + +# check build from ccl + +if [ ! -d $SBCL_RELEASE_DIR/obj_from-xc_ccl ]; then + cd $SBCL_DIR + sh clean.sh + nice -20 ./make.sh "$CCL" >> $LOGFILE 2>&1 + cd $SBCL_RELEASE_DIR + + mv $SBCL_DIR/obj/from-xc obj_from-xc_ccl +fi + +# TODO: check binary-equality between ccl, sbcl objs + +# TODO: check build from clisp, abcl + +# upload rc build + +if [ ! -f $SBCL_RELEASE_DIR/uploaded ]; then + + read -n 1 -p "Ok to upload? " A; echo + if [ $A \!= "y" ]; then + exit 1 + fi + + cd $SBCL_RELEASE_DIR +cat > $SBCL_RELEASE_DIR/sftp-batch < ~/.cmucl-init.lisp working-directory: /tmp/ - name: build env: diff -Nru sbcl-2.1.10/.github/workflows/linux.yml sbcl-2.1.11/.github/workflows/linux.yml --- sbcl-2.1.10/.github/workflows/linux.yml 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/.github/workflows/linux.yml 2021-11-30 16:16:46.000000000 +0000 @@ -6,13 +6,15 @@ build: runs-on: ubuntu-latest + timeout-minutes: 60 strategy: matrix: - options: [--with-sb-thread, --without-sb-thread] + options: [--with-sb-thread, --without-sb-thread, --without-sb-unicode] arch: [x86, x86-64] subfeatures: [''] include: - { arch: x86-64, subfeatures: sse4, options: --with-sb-thread } + - { arch: x86-64, subfeatures: fasteval, options: --with-sb-fasteval --without-sb-eval } fail-fast: false @@ -36,5 +38,36 @@ run: ./make.sh ${{ matrix.options }} --xc-host='sbcl --dynamic-space-size 500MB --lose-on-corruption --disable-ldb --disable-debugger' --arch=${{ matrix.arch }} - name: test run: cd tests; ./run-tests.sh + - name: test + if: matrix.subfeatures == 'fasteval' + run: cd tests; ./run-tests.sh --evaluator-mode interpret - name: ansi-test run: cd tests; ./ansi-tests.sh + + - name: crossbuild arm + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh arm + - name: crossbuild arm64 + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh arm64 + - name: crossbuild mips + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh mips + - name: crossbuild ppc + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh ppc + - name: crossbuild ppc64 + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh ppc64 + - name: crossbuild riscv + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh riscv + - name: crossbuild sparc + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh sparc + - name: crossbuild x86 + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh x86 + - name: crossbuild x86-64 + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh x86-64 diff -Nru sbcl-2.1.10/.github/workflows/mac.yml sbcl-2.1.11/.github/workflows/mac.yml --- sbcl-2.1.10/.github/workflows/mac.yml 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/.github/workflows/mac.yml 2021-11-30 16:16:46.000000000 +0000 @@ -19,6 +19,21 @@ env: SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger run: ./make.sh ${{ matrix.options }} --xc-host='sbcl --dynamic-space-size 500MB --lose-on-corruption --disable-ldb --disable-debugger' + - name: make binary + run: | + name=sbcl-`cat version.lisp-expr | ./run-sbcl.sh --noinform --noprint --eval '(write-line (read))'`-darwin-x86-64 + mkdir sbcl-mac-binary${{ matrix.options }}; + cd .. + mv sbcl $name + ./$name/binary-distribution.sh $name + bzip2 $name-binary.tar + mv $name sbcl + mv $name-binary.tar.bz2 sbcl/sbcl-mac-binary${{ matrix.options }} + - name: save binary + uses: actions/upload-artifact@v1 + with: + name: sbcl-mac-binary${{ matrix.options }} + path: sbcl-mac-binary${{ matrix.options }} - name: test run: cd tests; ./run-tests.sh - name: ansi-test diff -Nru sbcl-2.1.10/make-target-2-load.lisp sbcl-2.1.11/make-target-2-load.lisp --- sbcl-2.1.10/make-target-2-load.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/make-target-2-load.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -327,10 +327,11 @@ ;; such that it now has neither properties nor globaldb info, ;; can have the slot set back to NIL if it wasn't already. (do-all-symbols (symbol) - (when (and (sb-kernel:symbol-info symbol) - (null (sb-kernel:symbol-info-vector symbol)) + (when (and (sb-kernel:symbol-%info symbol) ; "raw" value is something + ;; but both "cooked" values are empty + (null (sb-kernel:symbol-dbinfo symbol)) (null (symbol-plist symbol))) - (setf (sb-kernel:symbol-info symbol) nil))) + (setf (sb-kernel:symbol-%info symbol) nil))) ) (sb-ext:gc :full t) @@ -395,7 +396,7 @@ #+sb-devel (lambda (symbol accessibility) (declare (ignore accessibility)) - (or (sb-kernel:symbol-info symbol) + (or (sb-kernel:symbol-%info symbol) (and (boundp symbol) (not (keywordp symbol))))) ;; Release mode: retain all symbols satisfying this intricate test #-sb-devel @@ -448,7 +449,7 @@ sb-assem::*backend-instruction-set-package*) (or (eq accessibility :external) (asm-inst-p symbol)) ;; By default, retain any symbol with any attachments - (or (sb-kernel:symbol-info symbol) + (or (sb-kernel:symbol-%info symbol) (and (boundp symbol) (not (keywordp symbol)))))))) :verbose nil :print nil) (unintern 'sb-impl::shake-packages 'sb-impl) diff -Nru sbcl-2.1.10/NEWS sbcl-2.1.11/NEWS --- sbcl-2.1.10/NEWS 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/NEWS 2021-11-30 16:16:46.000000000 +0000 @@ -1,5 +1,34 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes in sbcl-2.1.11 relative to sbcl-2.1.10: + * minor incompatible change: *COMPILE-PRINT* now defaults to NIL. T gives + the old behavior of echoing top level forms. Users who want to see a + report of the phases of compilation can use *COMPILE-PROGRESS* and the + corresponding COMPILE-FILE :PROGRESS argument. + * optimization: The compiler assignment-converts functions much more + aggressively; local or non-entry block-compiled functions + which always return to the same place are automatically converted into the + equivalent loop or goto control structures. + * enhancement: on x86-64 and ppc64 platforms, the system uses inline + instructions rather than page protection to implement a store barrier for + the garbage collector. + * enhancement: improved reporting of code deletion notes. + * platform support: + ** unbound-variable restarts for amd64 are now supported. + ** bug fix: single-floats to foreign functions on 32-bit ARMel. + (lp#1950080, reported by Sebastien Villemot) + ** bug fix: opening files with names containing non-ASCII characters on + Windows works better. (reported by Nikolay) + ** bug fix: use fp_xsave to access the floating point flags and control + word in Haiku signal contexts. (Thanks to Al Hoang) + ** bug fix: complex single-float support on riscv64. + ** optimization: support for accessing elements of &rest args directly on + ppc64, mips, riscv. + ** optimization: parse a /proc file rather than executing uname for + SOFTWARE-VERSION on Linux + * bug fix: fix crash from SB-COVER:RESET-COVERAGE. (lp#1950059, reported by + Gregory Czerniak) + changes in sbcl-2.1.10 relative to sbcl-2.1.9: * incompatible change: simd-pack without a specific element-type is no longer treated as containing integers. A type must be supplied for VOPs to diff -Nru sbcl-2.1.10/src/assembly/arm64/alloc.lisp sbcl-2.1.11/src/assembly/arm64/alloc.lisp --- sbcl-2.1.10/src/assembly/arm64/alloc.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/assembly/arm64/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -5,7 +5,7 @@ (:translate ensure-symbol-tls-index) (:result-types positive-fixnum) (:policy :fast-safe)) - ((:arg symbol (descriptor-reg) r0-offset) + ((:arg symbol (descriptor-reg) r8-offset) (:temp free-tls-index (non-descriptor-reg) nl1-offset) (:res result (unsigned-reg) nl0-offset)) diff -Nru sbcl-2.1.10/src/assembly/arm64/assem-rtns.lisp sbcl-2.1.11/src/assembly/arm64/assem-rtns.lisp --- sbcl-2.1.10/src/assembly/arm64/assem-rtns.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/assembly/arm64/assem-rtns.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -178,7 +178,7 @@ (:export tail-call-symbol)) ((:temp fun (any-reg descriptor-reg) lexenv-offset) (:temp length (any-reg descriptor-reg) nl0-offset) - (:temp vector (any-reg descriptor-reg) r7-offset) + (:temp packed-info (any-reg descriptor-reg) r7-offset) (:temp temp (any-reg descriptor-reg) nl1-offset) (:temp temp2 (any-reg descriptor-reg) nl2-offset)) (inst str lr-tn (@ cfp-tn 8)) @@ -191,24 +191,30 @@ (inst cmp temp symbol-widetag) (inst b :ne not-callable) - (load-symbol-info-vector vector fun temp) + (load-symbol-dbinfo packed-info fun temp) - ;; info-vector-fdefn - (inst cmp vector null-tn) + ;; packed-info-fdefn + (inst cmp packed-info null-tn) (inst b :eq undefined) - (inst ldr temp (@ vector (- (* 2 n-word-bytes) other-pointer-lowtag))) + ;; read the 0th info descriptor + (inst ldr temp (@ packed-info + (- (ash (+ instance-slots-offset instance-data-start) word-shift) + instance-pointer-lowtag))) (inst and temp temp (fixnumize (1- (ash 1 (* info-number-bits 2))))) (inst movz temp2 (fixnumize (1+ (ash +fdefn-info-num+ info-number-bits)))) (inst cmp temp temp2) (inst b :lt undefined) - (inst ldr length (@ vector - (- (ash vector-length-slot word-shift) other-pointer-lowtag))) + ;; read the instance-length and mask out the extra bits + (inst ldr length (@ packed-info (- instance-pointer-lowtag))) + ;; these next two instructions should be one 'ubfx' but I'm not smart enough + (inst lsr length length instance-length-shift) + (inst and length length instance-length-mask) + (inst lsl length length word-shift) - (inst lsl length length (- word-shift n-fixnum-tag-bits)) - (inst sub length length (- other-pointer-lowtag 8)) - (inst ldr fun (@ vector length)) + (inst sub length length instance-pointer-lowtag) + (inst ldr fun (@ packed-info length)) (loadw lr-tn fun fdefn-raw-addr-slot other-pointer-lowtag) (inst add lr-tn lr-tn 4) (inst br lr-tn) diff -Nru sbcl-2.1.10/src/assembly/x86/assem-rtns.lisp sbcl-2.1.11/src/assembly/x86/assem-rtns.lisp --- sbcl-2.1.10/src/assembly/x86/assem-rtns.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86/assem-rtns.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -482,70 +482,6 @@ (inst mov eax-tn 1) ;; exception-continue-search (inst ret)) -#+sb-assembling -(define-assembly-routine (code-header-set (:return-style :none)) () - ;; stack: ret-pc, object, index, value-to-store - (symbol-macrolet ((object (make-ea :dword :base esp-tn :disp 4)) - (word-index (make-ea :dword :base esp-tn :disp 8)) - (newval (make-ea :dword :base esp-tn :disp 12)) - (prefix #+(and sb-thread (not win32)) :fs - #-(and sb-thread (not win32)) nil)) - (flet ((thread-slot-ea (slot-index) - (make-ea :dword - #+(or (not sb-thread) win32) :base #+(or (not sb-thread) win32) edi-tn - :disp (ash slot-index word-shift)))) - #-sb-thread - (progn - ;; Load 'all_threads' into EDI (which was already spilled) - ;; as the register with which to access thread slots. - (inst mov edi-tn - (make-ea :dword :disp (make-fixup "all_threads" :foreign-dataref))) - (inst mov edi-tn (make-ea :dword :base edi-tn))) - #+(and win32 sb-thread) - (inst mov edi-tn (make-ea :dword :disp +win32-tib-arbitrary-field-offset+) :fs) - - (inst mov eax-tn object) ; object - (inst sub eax-tn (thread-slot-ea thread-dynspace-addr-slot) prefix) - (inst shr eax-tn (1- (integer-length gencgc-card-bytes))) - (pseudo-atomic () - (assemble () - (inst cmp eax-tn (thread-slot-ea thread-dynspace-card-count-slot) - prefix) - (inst jmp :ae STORE) ; not dynamic space - ;; sizeof (struct page) depends on GENCGC-CARD-BYTES - ;; It's 4+2+1+1 = 8 bytes if GENCGC-CARD-BYTES is (unsigned-byte 16), - ;; or 4+4+1+1 = 10 bytes (rounded to 12) if wider than (unsigned-byte 16). - ;; See the corresponding alien structure definition in 'room.lisp' - (cond ((typep gencgc-card-bytes '(unsigned-byte 16)) - (inst shl eax-tn 3) ; multiply by 8 - (inst add eax-tn (thread-slot-ea thread-dynspace-pte-base-slot) - prefix) - ;; clear WP - bit index 5 of flags byte - (inst and (make-ea :byte :base eax-tn :disp 6) (lognot (ash 1 5)) - :lock)) - (t - (inst lea eax-tn ; multiply by 3 - (make-ea :dword :base eax-tn :index eax-tn :scale 2)) - (inst shl eax-tn 2) ; then by 4, = 12 - (inst add eax-tn (thread-slot-ea thread-dynspace-pte-base-slot) - prefix) - ;; clear WP - (inst and (make-ea :byte :base eax-tn :disp 8) (lognot (ash 1 5)) - :lock))) - STORE - (inst mov edi-tn object) - (inst mov edx-tn word-index) - (inst mov eax-tn newval) - ;; set 'written' flag in the code header - (inst or (make-ea :byte :base edi-tn :disp (- 3 other-pointer-lowtag)) - #x40 :lock) - ;; store newval into object - (inst mov (make-ea :dword :base edi-tn - :index edx-tn :scale (ash 1 word-shift) - :disp (- other-pointer-lowtag)) - eax-tn))))) - (inst ret 12)) ; remove 3 stack args - #| Turns out that setting the direction flag not only requires trapping into microcode, but also prevents the processor from using its fast REP diff -Nru sbcl-2.1.10/src/assembly/x86-64/array.lisp sbcl-2.1.11/src/assembly/x86-64/array.lisp --- sbcl-2.1.10/src/assembly/x86-64/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -25,16 +25,46 @@ (:arg end (any-reg descriptor-reg) rsi-offset) (:res res (descriptor-reg) rdx-offset) (:temp count unsigned-reg rcx-offset) + (:temp end-card-index unsigned-reg rbx-offset) ;; storage class doesn't matter since all float regs ;; and sse regs map to the same storage base. (:temp wordpair double-reg float0-offset)) (move res vector) ; to "use" res + + ;; Mark each GC card of the vector unless ITEM is not a pointer + ;; (NIL is non-pointer) or the COUNT is 0. + (inst cmp start end) + (inst jmp :ge DONE) + (inst lea :dword count (ea -3 item)) ; same as POINTERP (see type-vops) + (inst test :byte count #b11) + (inst jmp :nz DONE-CARD-MARKING) + (inst cmp item nil-value) + (inst jmp :e DONE-CARD-MARKING) + + (let ((disp (- (ash vector-data-offset word-shift) other-pointer-lowtag)) + (card-index count) + (loop (gen-label))) + ;; Compute EA of starting and ending (inclusive) indices + (inst lea card-index (ea disp vector start (ash 1 (- word-shift n-fixnum-tag-bits)))) + (inst lea end-card-index (ea (- disp n-word-bytes) + vector end (ash 1 (- word-shift n-fixnum-tag-bits)))) + (inst shr card-index gencgc-card-shift) + (inst shr end-card-index gencgc-card-shift) + (inst and :dword card-index card-index-mask) + (inst and :dword end-card-index card-index-mask) + (emit-label LOOP) + (inst mov :byte (ea gc-card-table-reg-tn card-index) 0) ; mark one card + (inst cmp card-index end-card-index) + (inst jmp :e DONE-CARD-MARKING) + (inst inc :dword card-index) + (inst and :dword card-index card-index-mask) + (inst jmp LOOP)) + + DONE-CARD-MARKING (move count end) (inst sub count start) - ;; 'start' and 'limit' will be interior pointers into 'vector', + ;; 'start' is an interior pointer to 'vector', ;; but 'vector' is pinned because it's in a register, so this is ok. - ;; If we had a precise GC we'd want to keep start and limit as offsets - ;; because we couldn't tie them both to the vector. (inst lea start (ea (- (ash vector-data-offset word-shift) other-pointer-lowtag) vector start (ash 1 (- word-shift n-fixnum-tag-bits)))) ;; REP STOS has a fixed cost that makes it suboptimal below diff -Nru sbcl-2.1.10/src/assembly/x86-64/assem-rtns.lisp sbcl-2.1.11/src/assembly/x86-64/assem-rtns.lisp --- sbcl-2.1.10/src/assembly/x86-64/assem-rtns.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/assem-rtns.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -229,27 +229,38 @@ #+sb-assembling (define-assembly-routine (call-symbol (:return-style :none)) - ((:temp fun (any-reg descriptor-reg) rax-offset) + ((:temp fun (any-reg descriptor-reg) rax-offset) ; FUN = the symbol (:temp length (any-reg descriptor-reg) rax-offset) - (:temp vector (any-reg descriptor-reg) rbx-offset)) - (%lea-for-lowtag-test vector fun other-pointer-lowtag) - (inst test :byte vector lowtag-mask) + (:temp info (any-reg descriptor-reg) rbx-offset)) ; for the packed symbol-info + (%lea-for-lowtag-test info fun other-pointer-lowtag) + (inst test :byte info lowtag-mask) (inst jmp :nz not-callable) (inst cmp :byte (ea (- other-pointer-lowtag) fun) symbol-widetag) (inst jmp :ne not-callable) - (load-symbol-info-vector vector fun) - ;; info-vector-fdefn - (inst cmp vector nil-value) + (load-symbol-dbinfo info fun) + ;; reimplement by hand PACKED-INFO-FDEFN, q.v. + + ;; This only has to compare the low byte of INFO, + ;; because INSTANCE-POINTER-LOWTAG won't match NIL in the low 8 bits. + (inst cmp :byte info (logand nil-value #xff)) (inst jmp :e undefined) - (inst mov :dword r10-tn (ea (- (* 2 n-word-bytes) other-pointer-lowtag) vector)) + ;; XXX - WHAT IS R10? ARBITRARY? COMMENT NEEDED + (inst mov :dword r10-tn (ea (- (ash (+ instance-slots-offset instance-data-start) word-shift) + instance-pointer-lowtag) info)) (inst and :dword r10-tn (fixnumize (1- (ash 1 (* info-number-bits 2))))) (inst cmp :dword r10-tn (fixnumize (1+ (ash +fdefn-info-num+ info-number-bits)))) (inst jmp :b undefined) - (inst mov vector-len-op-size length (vector-len-ea vector)) - (inst mov fun (ea (- 8 other-pointer-lowtag) vector length - (ash 1 (- word-shift n-fixnum-tag-bits)))) + ;; Read the logical instance length, i.e. excluding a stable hash slot if present, + ;; but including a LAYOUT slot if #-compact-instance-header. + ;; There's a optimization possibility here to eliminate one SHR, which would use + ;; a 4-byte unaligned load at byte index 1 of the header, which would put the length + ;; in byte index 0 of the register, but over by 2 bits; mask that, adjust the EA SCALE + ;; to get the indexing right. That's too abstraction-violating for my taste. + (load-instance-length length info nil) + ;; After this MOV, the FUN register will hold the FDEFN. + (inst mov fun (ea (- instance-pointer-lowtag) info length n-word-bytes)) (inst jmp (ea (- (* fdefn-raw-addr-slot n-word-bytes) other-pointer-lowtag) fun)) UNDEFINED @@ -393,20 +404,18 @@ (inst mov thread-tn (ea (make-fixup "all_threads" :foreign-dataref))) (inst mov thread-tn (ea thread-tn)))) -;;; Perform a store to code, updating the GC page (card) protection bits. -;;; This is not a "good" implementation of soft card marking. -;;; It is used *only* for pages of code. The real implementation (work in -;;; progress) will differ in at least these ways: -;;; - there will be no use of pseudo-atomic -;;; - stores will be inlined without the helper routine below -;;; - will be insensitive to the size of a page table entry -;;; - will avoid use of a :lock prefix by allocating 1 byte per mark -;;; - won't need to subtract the heap base or compare to the card count -;;; to compute the mark address, so will use fewer instructions. -;;; It is similar in that for code objects (indeed most objects -;;; except simple-vectors), it marks the object header which is -;;; not always on the same GC card affected by the store operation -;;; +;;; Perform a store to code, updating the GC card mark bit. +;;; This has two additional complications beyond the ordinary +;;; generational barrier: +;;; 1. immobile code uses its own card table which maps linearly +;;; with the page index, unlike the dynamic space card table +;;; that has a different way of computing a card address. +;;; 2. code objects are so seldom written that it behooves us to +;;; track within each object whether it has been written, +;;; thereby avoiding scanning of unwritten objects. +;;; This is especially important for immobile space where +;;; it is likely that new code will be co-located on a page +;;; with old code due to the non-moving allocator. #+sb-assembling (define-assembly-routine (code-header-set (:return-style :none)) () ;; stack: ret-pc, object, index, value-to-store @@ -427,33 +436,14 @@ (inst shr rax (1- (integer-length immobile-card-bytes))) (inst cmp rax (thread-slot-ea thread-varyobj-card-count-slot)) (inst jmp :ae try-dynamic-space) - (inst mov rdi-tn (thread-slot-ea thread-varyobj-card-marks-slot)) + (inst mov rdi (thread-slot-ea thread-varyobj-card-marks-slot)) (inst bts :dword :lock (ea rdi-tn) rax) (inst jmp store)) - TRY-DYNAMIC-SPACE - (inst mov rax object) ; reload - (inst sub rax (thread-slot-ea thread-dynspace-addr-slot)) - (inst shr rax (1- (integer-length gencgc-card-bytes))) - (inst cmp rax (thread-slot-ea thread-dynspace-card-count-slot)) - (inst jmp :ae store) ; neither dynamic nor immobile space. (weird!) - - ;; sizeof (struct page) depends on GENCGC-CARD-BYTES - ;; It's 4+2+1+1 = 8 bytes if GENCGC-CARD-BYTES is (unsigned-byte 16), - ;; or 4+4+1+1 = 10 bytes (rounded to 12) if wider than (unsigned-byte 16). - ;; See the corresponding alien structure definition in 'room.lisp' - (cond ((typep gencgc-card-bytes '(unsigned-byte 16)) - (inst shl rax 3) ; multiply by 8 - (inst add rax (thread-slot-ea thread-dynspace-pte-base-slot)) - ;; clear WP - bit index 5 of flags byte - (inst and :byte :lock (ea 6 rax) (lognot (ash 1 5)))) - (t - (inst lea rax (ea rax rax 2)) ; multiply by 3 - (inst shl rax 2) ; then by 4, = 12 - (inst add rax (thread-slot-ea thread-dynspace-pte-base-slot)) - ;; clear WP - (inst and :byte :lock (ea 8 rax) (lognot (ash 1 5))))) - + (inst mov rax object) + (inst shr rax gencgc-card-shift) + (inst and :dword rax card-index-mask) + (inst mov :byte (ea gc-card-table-reg-tn rax) 0) STORE (inst mov rdi object) (inst mov rdx word-index) diff -Nru sbcl-2.1.10/src/assembly/x86-64/support.lisp sbcl-2.1.11/src/assembly/x86-64/support.lisp --- sbcl-2.1.10/src/assembly/x86-64/support.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -75,8 +75,10 @@ (flet ((gpr-save/restore (operation except) (declare (type (member push pop) operation)) (let ((registers (ecase convention + ;; RBX and R12..R15 are preserved across C call (c '#1=(rax-tn rcx-tn rdx-tn rsi-tn rdi-tn r8-tn r9-tn r10-tn r11-tn)) - (lisp '(rbx-tn r12-tn r14-tn r15-tn . #1#))))) + ;; all GPRs are potentially destroyed across lisp call + (lisp '(rbx-tn r12-tn #-sb-thread r13-tn r14-tn r15-tn . #1#))))) (when except (setf registers (remove except registers))) ;; Preserve alignment diff -Nru sbcl-2.1.10/src/assembly/x86-64/tramps.lisp sbcl-2.1.11/src/assembly/x86-64/tramps.lisp --- sbcl-2.1.10/src/assembly/x86-64/tramps.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/tramps.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -32,29 +32,17 @@ fpr-restore ; KLUDGE: this is element 6 of the entry point vector (do-fprs pop :xmm))) -;;; It is arbitrary whether each of the next 4 routines is named ALLOC-something, -;;; exporting an additional entry named CONS-something, versus being named CONS-something -;;; and exporting ALLOC-something. It just depends on which of those you would like -;;; to have to set and clear the low bit to match ALLOC-DISPATCH. -;;; Think of "cons" as meaning the generic sense of "consing", not as actually -;;; allocating conses, because fixed-sized non-cons object allocation may enter -;;; through the cons entry point. Cons cells *must* use that entry point. -(define-assembly-routine (alloc->rnn (:export cons->rnn)) () - (inst or :byte (ea 8 rsp-tn) 1) - CONS->RNN +(define-assembly-routine (alloc-tramp) () (with-registers-preserved (c) (inst mov rdi-tn (ea 16 rbp-tn)) - (inst call (make-fixup 'alloc-dispatch :assembly-routine)) + (inst call (make-fixup "alloc" :foreign)) (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack -(define-assembly-routine (alloc-dispatch (:return-style :none)) () - ;; If RDI has a 0 in the low bit, then we're allocating cons cells. - ;; A 1 bit signifies anything other than cons cells, and is equivalent - ;; to "could this object consume large-object pages" in gencgc. - (inst test :byte rdi-tn 1) - (inst jmp :z (make-fixup "alloc_list" :foreign)) - (inst xor :byte rdi-tn 1) ; clear the bit - (inst jmp (make-fixup "alloc" :foreign))) +(define-assembly-routine (list-alloc-tramp) () + (with-registers-preserved (c) + (inst mov rdi-tn (ea 16 rbp-tn)) + (inst call (make-fixup "alloc_list" :foreign)) + (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack ;;; These routines are for the deterministic consing profiler. ;;; The C support routine's argument is the return PC. diff -Nru sbcl-2.1.10/src/code/alloc.lisp sbcl-2.1.11/src/code/alloc.lisp --- sbcl-2.1.10/src/code/alloc.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -430,13 +430,11 @@ (alloc-immobile-fixedobj symbol-size (logior (ash (1- symbol-size) n-widetag-bits) symbol-widetag))))) - ;; no pin, it's immobile (and obviously live) - (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address symbol)) - (- (ash symbol-name-slot word-shift) other-pointer-lowtag)) - name) + ;; symbol-hash was initialized to 0 (%set-symbol-global-value symbol (make-unbound-marker)) - ;; symbol-hash is 0 - (setf (symbol-info symbol) nil) + (setf (symbol-%info symbol) nil) + (%primitive sb-vm::set-slot symbol name + 'make-symbol sb-vm:symbol-name-slot sb-vm:other-pointer-lowtag) (%set-symbol-package symbol nil) symbol)) diff -Nru sbcl-2.1.10/src/code/aprof.lisp sbcl-2.1.11/src/code/aprof.lisp --- sbcl-2.1.10/src/code/aprof.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/aprof.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -66,7 +66,7 @@ (:use #:cl #:sb-ext #:sb-alien #:sb-sys #:sb-int #:sb-kernel) (:export #:aprof-run #:aprof-show #:aprof-reset) (:import-from #:sb-di #:valid-lisp-pointer-p) - (:import-from #:sb-vm #:rbp-offset) + (:import-from #:sb-vm #:thread-reg) (:import-from #:sb-x86-64-asm #:register-p #:get-gpr #:reg #:reg-num #:machine-ea #:machine-ea-p @@ -205,6 +205,13 @@ ?free ?nbytes)) (shr ?nbytes 4)) + (acons (lea :qword ?end (ea 32 ?free)) + (cmp :qword ?end :tlab-limit) + (jmp :nbe ?_) + (mov :qword :tlab-freeptr ?end) + (:repeat (mov . ignore)) + (lea :qword ?result (ea #.(+ 16 sb-vm:list-pointer-lowtag) ?free))) + ;; either non-headered object (cons) or unknown header or unknown nbytes (unknown-header (:or (lea :qword ?end (ea ?nbytes ?free ?nbytes-var)) (lea :qword ?end (ea 0 ?nbytes-var ?free)) @@ -385,9 +392,9 @@ (ea ,(- sb-vm:static-space-start sb-vm:gc-safepoint-trap-offset) nil)) (mov :dword (ea 1 ?result) ?layout)) #-sb-safepoint - `((xor :qword ,p-a-flag ,(get-gpr :qword rbp-offset)) + `((xor :qword ,p-a-flag ,(get-gpr :qword thread-reg)) (jmp :eq ?_) - (break . ignore) + #+linux (icebp) #-linux (break . ignore) (mov :dword (ea 1 ?result) ?layout)) t) bindings))) @@ -441,7 +448,7 @@ ;; Expect a store to the pseudo-atomic flag #-sb-safepoint (when (eq (matchp iterator - (load-time-value `((mov :qword ,p-a-flag ,(get-gpr :qword rbp-offset))) t) + (load-time-value `((mov :qword ,p-a-flag ,(get-gpr :qword thread-reg))) t) nil) :fail) (return-from deduce-type (values nil nil))) @@ -485,6 +492,8 @@ (setq type (deduce-layout iterator bindings)))) ((eq type 'list) ; listify-rest-arg (setq nbytes nil)) + ((eq type 'acons) + (setq type 'list nbytes (* 2 sb-vm:cons-size sb-vm:n-word-bytes))) ((member type '(any unknown-header)) (setq type (case lowtag (#.sb-vm:list-pointer-lowtag 'list) diff -Nru sbcl-2.1.10/src/code/arm64-vm.lisp sbcl-2.1.11/src/code/arm64-vm.lisp --- sbcl-2.1.10/src/code/arm64-vm.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/arm64-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -115,6 +115,12 @@ (address unsigned) (value unsigned)) + (define-alien-routine jit-patch-code + void + (code unsigned) + (value unsigned) + (index unsigned)) + (define-alien-routine jit-patch-int void (address unsigned) @@ -156,15 +162,7 @@ (defun (setf code-header-ref) (value code index) (with-pinned-objects (code value) - (jit-patch (+ (get-lisp-obj-address code) - (- other-pointer-lowtag) - (* index n-word-bytes)) - (get-lisp-obj-address value))) - value) - - (defun (setf %code-debug-info) (value code) - (with-pinned-objects (code value) - (jit-patch (+ (get-lisp-obj-address code) - (- other-pointer-lowtag) - (* code-debug-info-slot n-word-bytes)) - (get-lisp-obj-address value))))) + (jit-patch-code (get-lisp-obj-address code) + (get-lisp-obj-address value) + index)) + value)) diff -Nru sbcl-2.1.10/src/code/array.lisp sbcl-2.1.11/src/code/array.lisp --- sbcl-2.1.10/src/code/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -543,11 +543,11 @@ (t complex-array-widetag)) array-rank))) (cond (fill-pointer - (logior-header-bits array +array-fill-pointer-p+) + (logior-array-flags array +array-fill-pointer-p+) (setf (%array-fill-pointer array) (if (eq fill-pointer t) total-size fill-pointer))) (t - (reset-header-bits array +array-fill-pointer-p+) + (reset-array-flags array +array-fill-pointer-p+) (setf (%array-fill-pointer array) total-size))) (setf (%array-available-elements array) total-size) (setf (%array-data array) data) @@ -1500,10 +1500,10 @@ (setf (%array-available-elements array) length) (cond (fill-pointer (setf (%array-fill-pointer array) fill-pointer) - (logior-header-bits array +array-fill-pointer-p+)) + (logior-array-flags array +array-fill-pointer-p+)) (t (setf (%array-fill-pointer array) length) - (reset-header-bits array +array-fill-pointer-p+))) + (reset-array-flags array +array-fill-pointer-p+))) (setf (%array-displacement array) displacement) (populate-dimensions array dimensions (array-rank array)) (setf (%array-displaced-p array) displacedp) @@ -1883,7 +1883,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-flag n-widetag-bits) simple-vector-widetag))) + (let ((type (logior (ash vector-weak-flag array-flags-position) simple-vector-widetag))) ;; These allocation calls are the transforms of MAKE-ARRAY for a vector with ;; the respective initializing keyword arg. This is badly OAOO-violating and ;; almost makes me want to cry, but not quite enough for me to improve it. @@ -1903,5 +1903,5 @@ (defun weak-vector-p (x) (and (simple-vector-p x) - #+(or x86 x86-64) (test-header-bit x vector-weak-flag) - #-(or x86 x86-64) (logtest (get-header-data x) vector-weak-flag))) + #+(or x86 x86-64) (test-header-bit x (ash vector-weak-flag array-flags-data-position)) + #-(or x86 x86-64) (logtest (get-header-data x) (ash vector-weak-flag array-flags-data-position)))) diff -Nru sbcl-2.1.10/src/code/cas.lisp sbcl-2.1.11/src/code/cas.lisp --- sbcl-2.1.10/src/code/cas.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/cas.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -39,7 +39,6 @@ (def %raw-instance-cas/signed-word (instance index) %raw-instance-ref/signed-word %raw-instance-set/signed-word) - (def %compare-and-swap-symbol-info (symbol) symbol-info) (def %compare-and-swap-symbol-value (symbol) symbol-value) (def %compare-and-swap-svref (vector index) svref)) diff -Nru sbcl-2.1.10/src/code/cross-type.lisp sbcl-2.1.11/src/code/cross-type.lisp --- sbcl-2.1.10/src/code/cross-type.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/cross-type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -82,7 +82,7 @@ ;;; The logic is a mixture of the code for CTYPEP and %%TYPEP ;;; because it handles both. ;;; The order of clauses is fairly symmetrical with that of %%TYPEP. -(defvar *xtypep-uncertainty-action* 'warn) ; {BREAK WARN STYLE-WARN ERROR NIL} +(defvar *xtypep-uncertainty-action* #-sb-devel 'warn #+sb-devel nil) ; {BREAK WARN STYLE-WARN ERROR NIL} (macrolet ((unimplemented () '(bug "Incomplete implementation of ~S ~S ~S" caller obj type)) (uncertain () @@ -313,6 +313,7 @@ (and (boundp 'sb-c::*compilation*) (eq (sb-c::block-compile sb-c::*compilation*) t))) (values answer certain) + #-sb-devel (warn 'cross-type-giving-up :call `(ctypep ,obj ,ctype))))) (defun ctype-of (x) diff -Nru sbcl-2.1.10/src/code/debug-var-io.lisp sbcl-2.1.11/src/code/debug-var-io.lisp --- sbcl-2.1.10/src/code/debug-var-io.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/debug-var-io.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -164,9 +164,10 @@ ;;; the code that could not be deduced by examining the object. ;;; It makes sense to store these externally to the object, as it would otherwise ;;; intrude on text pages. Also, some of the bignums are shareable this way. -(defun pack-code-fixup-locs (abs-fixups rel-fixups) +(defun pack-code-fixup-locs (abs-fixups rel-fixups more) (dx-let ((bytes (make-array (min (* 2 (+ (length abs-fixups) ; guess at final length - (length rel-fixups))) + (length rel-fixups) + (length more))) 1024) ; limit the stack usage :fill-pointer 0 :adjustable t :element-type '(unsigned-byte 8)))) @@ -178,9 +179,12 @@ (write-var-integer (- x prev) bytes) (setq prev x)))) (pack (sort abs-fixups #'<)) - (when rel-fixups + (when (or rel-fixups more) (write-var-integer 0 bytes) - (pack (sort rel-fixups #'<)))) + (pack (sort rel-fixups #'<))) + (when more + (write-var-integer 0 bytes) + (pack (sort more #'<)))) ;; Stuff octets into an integer ;; It would be quite possible in the target to do something clever here ;; by creating a bignum directly from the ub8 vector. @@ -211,12 +215,14 @@ (let ((,loc (+ ,prev ,acc))) ,@body (setq ,prev ,loc)) (setq ,acc 0 ,shift 0)))))))) +;;; Unpack the (potentially) three stream of data in PACKED-INTEGER. (defun unpack-code-fixup-locs (packed-integer) - (collect ((abs-locs) (rel-locs)) + (collect ((stream1) (stream2) (stream3)) (let ((pos 0)) - (do-packed-varints (loc packed-integer pos) (abs-locs loc)) - (do-packed-varints (loc packed-integer pos) (rel-locs loc))) - (values (abs-locs) (rel-locs)))) + (do-packed-varints (loc packed-integer pos) (stream1 loc)) + (do-packed-varints (loc packed-integer pos) (stream2 loc)) + (do-packed-varints (loc packed-integer pos) (stream3 loc))) + (values (stream1) (stream2) (stream3)))) (define-symbol-macro lz-symbol-1 210) ; arbitrary value that isn't frequent in the input (define-symbol-macro lz-symbol-2 218) ; ditto diff -Nru sbcl-2.1.10/src/code/defsetfs.lisp sbcl-2.1.11/src/code/defsetfs.lisp --- sbcl-2.1.10/src/code/defsetfs.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/defsetfs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -29,21 +29,36 @@ (progn (declaim (inline assign-vector-flags logior-header-bits reset-header-bits)) (defun assign-vector-flags (vector flags) - (set-header-data vector (dpb flags (byte 8 0) (get-header-data vector))) + (set-header-data vector (dpb flags (byte 8 #.array-flags-data-position) (get-header-data vector))) (values)) - (defun logior-header-bits (vector bits) - (set-header-data vector (logior (get-header-data vector) bits)) - vector) - (defun reset-header-bits (vector bits) - (set-header-data vector (logand (get-header-data vector) (lognot bits))) + (defun logior-header-bits (object bits) + (set-header-data object (logior (get-header-data object) bits)) + object) + (defun reset-header-bits (object bits) + (set-header-data object (logand (get-header-data object) (lognot bits))) (values))) +(defmacro logior-array-flags (array flags) + `(logior-header-bits ,array (ash ,flags #.array-flags-data-position))) +(defmacro reset-array-flags (array flags) + `(reset-header-bits ,array (ash ,flags #.array-flags-data-position))) + (in-package "SB-IMPL") (declaim (inline (setf %funcallable-instance-info))) -(defun (setf %funcallable-instance-info) (value instance index) - (%set-funcallable-instance-info instance index value) - value) +;;; Funcallable instances are just like closures, but there's another slot or two +;;; depending on whether the layout pointer is in a slot or in the header word. +(defun (setf %funcallable-instance-info) (newval fin index) + (%closure-index-set fin (+ index (- sb-vm:funcallable-instance-info-offset + sb-vm:closure-info-offset)) + newval) + newval) +;;; This is just to keep the DEFSTRUCT logic consistent with %INSTANCE-SET, +;;; but the canonical setter is the function named (setf %funcallable-instance-info) +(declaim (inline %set-funcallable-instance-info)) +(defun %set-funcallable-instance-info (fin index newval) + (funcall #'(setf %funcallable-instance-info) newval fin index) + (values)) ;;; from early-setf.lisp @@ -152,7 +167,6 @@ bits) (defsetf symbol-value set) (defsetf symbol-global-value set-symbol-global-value) -(defsetf symbol-plist %set-symbol-plist) (defsetf fill-pointer %set-fill-pointer) (defsetf subseq (sequence start &optional end) (v) `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) ,v)) diff -Nru sbcl-2.1.10/src/code/early-raw-slots.lisp sbcl-2.1.11/src/code/early-raw-slots.lisp --- sbcl-2.1.10/src/code/early-raw-slots.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/early-raw-slots.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -212,7 +212,7 @@ ;; the mask word indefinitely. Most bitmaps will have only 1 word, ;; so this is almost always MOST-POSITIVE-FIXNUM. (,nbits (if (= ,bitmap-index ,bitmap-limit) - sb-vm::instance-length-mask + sb-vm:instance-length-mask (- sb-vm:n-word-bits sb-vm:instance-data-start)))) (declare (type sb-vm:signed-word ,mask) (type fixnum ,nbits)) @@ -227,7 +227,7 @@ (when (zerop ,nbits) (setq ,mask (%raw-instance-ref/signed-word ,bitmap ,bitmap-index) ,nbits (if (= (incf ,bitmap-index) ,bitmap-limit) - sb-vm::instance-length-mask + sb-vm:instance-length-mask sb-vm:n-word-bits))) (when (logbitp 0 ,mask) ,@body) (setq ,mask (ash ,mask -1) diff -Nru sbcl-2.1.10/src/code/error.lisp sbcl-2.1.11/src/code/error.lisp --- sbcl-2.1.10/src/code/error.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/error.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -187,7 +187,11 @@ ;; Should be (THE (FUNCTION-DESIGNATOR (CONDITION))) ;; but the cast kills DX allocation. `(lambda (c) (funcall ,name c)))))) - (local-functions `(,name ,@(rest lexpr))) + (local-functions + `(,name ,(cadr lexpr) + ,@(when (typep (cadr lexpr) '(cons t null)) + '((declare (sb-c::local-optimize (sb-c::verify-arg-count 0))))) + ,@(cddr lexpr))) `#',name)))))))) `(let ,(complex-initforms) @@ -238,7 +242,7 @@ (annotated-cases (mapcar (lambda (case) (with-current-source-form (case) - (with-unique-names (tag fun) + (with-unique-names (block fun) (destructuring-bind (type ll &body body) case (unless (and (listp ll) (symbolp (car ll)) @@ -248,47 +252,43 @@ (multiple-value-bind (body declarations) (parse-body body nil) (push `(,fun ,ll ,@declarations (progn ,@body)) local-funs)) - (list tag type ll fun))))) + (list block type ll fun))))) cases))) - (with-unique-names (block cell form-fun) - `(dx-flet ((,form-fun () - #-x86 (progn ,form) ;; no declarations are accepted - ;; Need to catch FP errors here! - #+x86 (multiple-value-prog1 ,form (float-wait))) - ,@(reverse local-funs)) - (declare (optimize (sb-c::check-tag-existence 0))) - (block ,block - ;; KLUDGE: We use a dx CONS cell instead of just assigning to - ;; the variable directly, so that we can stack allocate - ;; robustly: dx value cells don't work quite right, and it is - ;; possible to construct user code that should loop - ;; indefinitely, but instead eats up some stack each time - ;; around. - (dx-let ((,cell (cons :condition nil))) - (declare (ignorable ,cell)) - (tagbody - (%handler-bind - ,(mapcar (lambda (annotated-case) - (destructuring-bind (tag type ll fun-name) annotated-case - (declare (ignore fun-name)) - (list type - `(lambda (temp) - ,(if ll - `(setf (cdr ,cell) temp) - '(declare (ignore temp))) - (go ,tag))))) - annotated-cases) - (return-from ,block (,form-fun))) - ,@(mapcan - (lambda (annotated-case) - (destructuring-bind (tag type ll fun-name) annotated-case - (declare (ignore type)) - (list tag - `(return-from ,block - ,(if ll - `(,fun-name (cdr ,cell)) - `(,fun-name)))))) - annotated-cases)))))))))) + (with-unique-names (block form-fun) + (let ((body `(%handler-bind + ,(mapcar (lambda (annotated-case) + (destructuring-bind (block type ll fun-name) annotated-case + (declare (ignore fun-name)) + (list type + `(lambda (temp) + ,@(unless ll + `((declare (ignore temp)))) + (return-from ,block + ,@(and ll '(temp))))))) + annotated-cases) + (return-from ,block (,form-fun))))) + (labels ((wrap (cases) + (if cases + (destructuring-bind (fun-block type ll fun-name) (car cases) + (declare (ignore type)) + `(return-from ,block + ,(if ll + `(,fun-name (block ,fun-block + ,(wrap (cdr cases)))) + `(progn (block ,fun-block + ,(wrap (cdr cases))) + (,fun-name))))) + body))) + `(flet ((,form-fun () + #-x86 (progn ,form) ;; no declarations are accepted + ;; Need to catch FP errors here! + #+x86 (multiple-value-prog1 ,form (float-wait))) + ,@(reverse local-funs)) + (declare (optimize (sb-c::check-tag-existence 0)) + (inline ,form-fun + ,@(mapcar #'car local-funs))) + (block ,block + ,(wrap annotated-cases)))))))))) (sb-xc:defmacro ignore-errors (&rest forms) "Execute FORMS handling ERROR conditions, returning the result of the last diff -Nru sbcl-2.1.10/src/code/fdefinition.lisp sbcl-2.1.11/src/code/fdefinition.lisp --- sbcl-2.1.10/src/code/fdefinition.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/fdefinition.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -37,14 +37,14 @@ #+immobile-code (sb-vm::%set-fdefn-fun fdefn fun) #-immobile-code (setf (fdefn-fun fdefn) fun)) -;; Given Info-Vector VECT, return the fdefn that it contains for its root name, +;; Given PACKED-INFO, return the fdefn that it contains for its root name, ;; or nil if there is no value. NIL input is acceptable and will return NIL. ;; (see src/compiler/info-vector for more details) -(declaim (inline info-vector-fdefn)) -(defun info-vector-fdefn (vect) - (when vect - ;; This is safe: Info-Vector invariant requires that it have length >= 1. - (let ((word (the fixnum (svref vect 0)))) +(declaim (inline packed-info-fdefn)) +(defun packed-info-fdefn (packed-info) + (when packed-info + ;; This is safe: PACKED-INFO invariant requires that it have length >= 1. + (let ((word (the fixnum (%info-ref packed-info 0)))) ;; Test that the first info-number is +fdefn-info-num+ and its n-infos ;; field is nonzero. These conditions can be tested simultaneously ;; using a SIMD-in-a-register idea. The low 6 bits must be nonzero @@ -52,16 +52,15 @@ ;; as a 12-bit unsigned integer it must be >= #b111111000001 (when (>= (ldb (byte (* info-number-bits 2) 0) word) (1+ (ash +fdefn-info-num+ info-number-bits))) - ;; DATA-REF-WITH-OFFSET doesn't know the info-vector length invariant, - ;; so depite (safety 0) eliding bounds check, FOLD-INDEX-ADDRESSING - ;; wasn't kicking in without (TRULY-THE (INTEGER 1 *)). - (aref vect (1- (truly-the (integer 1 *) (length vect)))))))) + (%info-ref packed-info + (1- (truly-the (integer 1 *) + (packed-info-len packed-info)))))))) ;; Return SYMBOL's fdefinition, if any, or NIL. SYMBOL must already ;; have been verified to be a symbol by the caller. (defun symbol-fdefn (symbol) (declare (optimize (safety 0))) - (info-vector-fdefn (symbol-info-vector symbol))) + (packed-info-fdefn (symbol-dbinfo symbol))) ;; Return the fdefn object for NAME, or NIL if there is no fdefn. ;; Signal an error if name isn't valid. @@ -80,7 +79,7 @@ (return-from find-fdefn it)) :simple (progn - (awhen (symbol-info-vector key1) + (awhen (symbol-dbinfo key1) (multiple-value-bind (data-idx descriptor-idx field-idx) (info-find-aux-key/packed it key2) (declare (type index descriptor-idx) @@ -93,7 +92,7 @@ (when (eql (packed-info-field it descriptor-idx field-idx) +fdefn-info-num+) (return-from find-fdefn - (aref it (1- (the index data-idx)))))))) + (%info-ref it (1- (the index data-idx)))))))) (when (eq key1 'setf) ; bypass the legality test (return-from find-fdefn nil)))) (legal-fun-name-or-type-error name)) diff -Nru sbcl-2.1.10/src/code/fd-stream.lisp sbcl-2.1.11/src/code/fd-stream.lisp --- sbcl-2.1.10/src/code/fd-stream.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/fd-stream.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -2308,6 +2308,10 @@ namestring err "~@" namestring original)))) +(defun file-exist-p (path) + #-win32 (sb-unix:unix-access path sb-unix:f_ok) + #+win32 (/= (sb-win32:get-file-attributes path) sb-win32::invalid-file-attributes)) + (defun %open-error (pathname errno if-exists if-does-not-exist) (flet ((signal-it (&rest arguments) (apply #'file-perror pathname errno arguments))) @@ -2394,7 +2398,7 @@ (physical (native-namestring (physicalize-pathname pathname) :as-file t)) ;; One call to access() is reasonable. 40 calls to lstat() is not. ;; So DO NOT CALL TRUENAME HERE. - (existsp (sb-unix:unix-access physical sb-unix:f_ok)) + (existsp (file-exist-p physical)) ;; Leave NAMESTRING as NIL if nonexistent and not creating a file. (namestring (when (or existsp (or (not input) @@ -2554,134 +2558,6 @@ (when new-if-does-not-exist (setf if-does-not-exist new-if-does-not-exist if-does-not-exist-given t))))))))) - -;;;; initialization - -;;; the stream connected to the controlling terminal, or NIL if there is none -(defvar *tty*) - -;;; the stream connected to the standard input (file descriptor 0) -(defvar *stdin*) - -;;; the stream connected to the standard output (file descriptor 1) -(defvar *stdout*) - -;;; the stream connected to the standard error output (file descriptor 2) -(defvar *stderr*) - -;;; This is called when the cold load is first started up, and may also -;;; be called in an attempt to recover from nested errors. -(defun stream-cold-init-or-reset () - (stream-reinit) - (setf *terminal-io* (make-synonym-stream '*tty*)) - (setf *standard-output* (make-synonym-stream '*stdout*)) - (setf *standard-input* (make-synonym-stream '*stdin*)) - (setf *error-output* (make-synonym-stream '*stderr*)) - (setf *query-io* (make-synonym-stream '*terminal-io*)) - (setf *debug-io* *query-io*) - (setf *trace-output* *standard-output*) - (values)) - -(defun stream-deinit () - (setq *tty* nil *stdin* nil *stdout* nil *stderr* nil) - ;; Unbind to make sure we're not accidently dealing with it - ;; before we're ready (or after we think it's been deinitialized). - ;; This uses the internal %MAKUNBOUND because the CL: function would - ;; rightly complain that *AVAILABLE-BUFFERS* is proclaimed always bound. - (%makunbound '*available-buffers*)) - -(defvar *streams-closed-by-slad*) - -(defun restore-fd-streams () - (loop for (stream in bin n-bin out bout sout misc) in *streams-closed-by-slad* - do - (setf (ansi-stream-in stream) in) - (setf (ansi-stream-bin stream) bin) - (setf (ansi-stream-n-bin stream) n-bin) - (setf (ansi-stream-out stream) out) - (setf (ansi-stream-bout stream) bout) - (setf (ansi-stream-sout stream) sout) - (setf (ansi-stream-misc stream) misc))) - -(defun stdstream-external-format (fd) - #-win32 (declare (ignore fd)) - (let* ((keyword (cond #+(and win32 sb-unicode) - ((sb-win32::console-handle-p fd) - :ucs-2) - (t - (default-external-format)))) - (ef (get-external-format keyword)) - (replacement (ef-default-replacement-character ef))) - `(,keyword :replacement ,replacement))) - -;;; This is called whenever a saved core is restarted. -(defun stream-reinit (&optional init-buffers-p) - (when init-buffers-p - ;; Use the internal %BOUNDP for similar reason to that cited above- - ;; BOUNDP on a known global transforms to the constant T. - (aver (not (%boundp '*available-buffers*))) - (setf *available-buffers* nil)) - (%with-output-to-string (*error-output*) - (multiple-value-bind (in out err) - #-win32 (values 0 1 2) - #+win32 (sb-win32::get-std-handles) - (labels (#+win32 - (nul-stream (name inputp outputp) - (let ((nul-handle - (cond - ((and inputp outputp) - (sb-win32:unixlike-open "NUL" sb-unix:o_rdwr)) - (inputp - (sb-win32:unixlike-open "NUL" sb-unix:o_rdonly)) - (outputp - (sb-win32:unixlike-open "NUL" sb-unix:o_wronly)) - (t - ;; Not quite sure what to do in this case. - nil)))) - (make-fd-stream - nul-handle - :name name - :input inputp - :output outputp - :buffering :line - :element-type :default - :serve-events inputp - :auto-close t - :external-format (stdstream-external-format nul-handle)))) - (stdio-stream (handle name inputp outputp) - (cond - #+win32 - ((null handle) - ;; If no actual handle was present, create a stream to NUL - (nul-stream name inputp outputp)) - (t - (make-fd-stream - handle - :name name - :input inputp - :output outputp - :buffering :line - :element-type :default - :serve-events inputp - :external-format (stdstream-external-format handle)))))) - (setf *stdin* (stdio-stream in "standard input" t nil) - *stdout* (stdio-stream out "standard output" nil t) - *stderr* (stdio-stream err "standard error" nil t)))) - #+win32 - (setf *tty* (make-two-way-stream *stdin* *stdout*)) - #-win32 - (let ((tty (sb-unix:unix-open "/dev/tty" sb-unix:o_rdwr #o666))) - (setf *tty* - (if tty - (make-fd-stream tty :name "the terminal" - :input t :output t :buffering :line - :external-format (stdstream-external-format tty) - :serve-events t - :auto-close t) - (make-two-way-stream *stdin* *stdout*)))) - (princ (get-output-stream-string *error-output*) *stderr*)) - (values)) - ;;;; miscellany ;;; the Unix way to beep diff -Nru sbcl-2.1.10/src/code/fop.lisp sbcl-2.1.11/src/code/fop.lisp --- sbcl-2.1.10/src/code/fop.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/fop.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -423,17 +423,23 @@ (define-load-time-global *show-new-code* nil) (define-fop 16 :not-host (fop-load-code ((:operands header n-code-bytes n-fixups))) - (let* ((n-named-calls (read-unsigned-byte-32-arg (fasl-input-stream))) + (let* ((n-simple-funs (read-unsigned-byte-32-arg (fasl-input-stream))) + (n-named-calls (read-unsigned-byte-32-arg (fasl-input-stream))) (n-boxed-words (ash header -1)) (n-constants (- n-boxed-words sb-vm:code-constants-offset))) ;; stack has (at least) N-CONSTANTS words plus debug-info (with-fop-stack ((stack (operand-stack)) ptr (1+ n-constants)) - (let* ((n-boxed-words (+ sb-vm:code-constants-offset n-constants)) - (code (sb-c:allocate-code-object - (if (oddp header) :immobile :dynamic) - n-named-calls - (align-up n-boxed-words sb-c::code-boxed-words-align) - n-code-bytes))) + ;; We've already ensured that all FDEFNs the code uses exist. + ;; This happened by virtue of calling fop-fdefn for each. + (let ((stack-index (+ ptr (* n-simple-funs sb-vm:code-slots-per-simple-fun)))) + (dotimes (i n-named-calls) + (aver (typep (svref stack stack-index) 'fdefn)) + (incf stack-index))) + (let ((code (sb-c:allocate-code-object + (if (oddp header) :immobile :dynamic) + n-named-calls + (align-up n-boxed-words sb-c::code-boxed-words-align) + n-code-bytes))) (with-pinned-objects (code) ;; * DO * NOT * SEPARATE * THESE * STEPS * ;; For a full explanation, refer to the comment above MAKE-CORE-COMPONENT @@ -445,6 +451,7 @@ (read-n-bytes (fasl-input-stream) buf 0 n-code-bytes) (with-pinned-objects (buf) (sb-vm::jit-memcpy (code-instructions code) (vector-sap buf) n-code-bytes))) + (aver (= (code-n-entries code) n-simple-funs)) ;; Serial# shares a word with the jump-table word count, ;; so we can't assign serial# until after all raw bytes are copied in. (sb-c::assign-code-serialno code) @@ -458,7 +465,7 @@ (let* ((header-index sb-vm:code-constants-offset) (stack-index ptr)) (declare (type index header-index stack-index)) - (dotimes (n (code-n-entries code)) + (dotimes (n n-simple-funs) (dotimes (i sb-vm:code-slots-per-simple-fun) (setf (code-header-ref code header-index) (svref stack stack-index)) (incf header-index) diff -Nru sbcl-2.1.10/src/code/format.lisp sbcl-2.1.11/src/code/format.lisp --- sbcl-2.1.10/src/code/format.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/format.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -33,8 +33,9 @@ t))) (if (logtest (get-header-data string) ;; shareable = readonly - (logior sb-vm:+vector-shareable+ - sb-vm:+vector-shareable-nonstd+)) + (ash (logior sb-vm:+vector-shareable+ + sb-vm:+vector-shareable-nonstd+) + sb-vm:array-flags-data-position)) (memoize (compute-it)) (compute-it)))) diff -Nru sbcl-2.1.10/src/code/gc.lisp sbcl-2.1.11/src/code/gc.lisp --- sbcl-2.1.10/src/code/gc.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/gc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -77,6 +77,27 @@ and submit it as a patch." (+ (dynamic-usage) *n-bytes-freed-or-purified*)) + +;;; * If symbols are 7 words incl header, as they are on 32-bit w/threads, +;;; then the part of NIL that manifests as symbol slots consumes 6 words +;;; (less the header) because NIL's symbol widetag precedes it by 1 word. +;;; So, there are 6 post-header words and 2 pre-header: one containing +;;; the widetag (not that it is ever read), and one 0 word. +;;; * If symbols are 6 words incl header, as they are on 64-bit and +;;; 32-bit w/o threads, then the symbol-like part of NIL is 5 words, +;;; which aligns up to 6, plus the two pre-header words. +;;; So either way, NIL's alignment padding makes it come out to 8 words in total. +(defconstant sb-vm::sizeof-nil-in-words (+ 2 (sb-int:align-up (1- sb-vm:symbol-size) 2))) + +(defun primitive-object-size (object) + "Return number of bytes of heap or stack directly consumed by OBJECT" + (cond ((not (sb-vm:is-lisp-pointer (get-lisp-obj-address object))) 0) + ((eq object nil) (ash sb-vm::sizeof-nil-in-words sb-vm:word-shift)) + ((simple-fun-p object) (code-object-size (fun-code-header object))) + (t + (with-alien ((sizer (function unsigned unsigned) :extern "primitive_object_size")) + (with-pinned-objects (object) + (alien-funcall sizer (get-lisp-obj-address object))))))) ;;;; GC hooks diff -Nru sbcl-2.1.10/src/code/icf.lisp sbcl-2.1.11/src/code/icf.lisp --- sbcl-2.1.10/src/code/icf.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/icf.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -60,13 +60,7 @@ (data-vector-ref `(setf (svref ,@(cdr place)) newval touchedp t)) (value-cell-ref - ;; pinned already because we're iterating over the heap - ;; which disables GC, but maybe some day it won't. - `(with-pinned-objects (object) - (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address object)) - (- (ash value-cell-value-slot word-shift) - other-pointer-lowtag)) - newval))) + `(%primitive value-cell-set object newval)) (weak-pointer-value ;; Preserve gencgc invariant that a weak pointer ;; can't point to an object younger than itself. @@ -77,12 +71,10 @@ #+nil (warn "Can't update weak pointer ~s" object)) (t - (with-pinned-objects (object) - (setf (sap-ref-lispobj - (int-sap (get-lisp-obj-address object)) - (- (ash weak-pointer-value-slot word-shift) - other-pointer-lowtag)) - newval))))) + (%primitive set-slot object newval + '(setf weak-pointer-value) + weak-pointer-value-slot + other-pointer-lowtag)))) (%primitive (ecase (cadr place) (fast-symbol-global-value @@ -118,6 +110,7 @@ (let* ((oldval (%closure-fun object)) (newval (forward oldval))) (unless (eq newval oldval) + #+nil ; FIXME: gotta figure out GC marking situation here (with-pinned-objects (object newval) (setf (sap-ref-sap (int-sap (- (get-lisp-obj-address object) fun-pointer-lowtag)) @@ -127,11 +120,7 @@ (let* ((oldval (%closure-index-ref object i)) (newval (forward oldval))) (unless (eq newval oldval) - (with-pinned-objects (object) - (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address object)) - (- (ash (+ i closure-info-offset) word-shift) - fun-pointer-lowtag)) - newval)))))) + (%closure-index-set object i newval))))) (ratio :override) ((complex rational) :override) (t diff -Nru sbcl-2.1.10/src/code/late-globaldb.lisp sbcl-2.1.11/src/code/late-globaldb.lisp --- sbcl-2.1.10/src/code/late-globaldb.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/late-globaldb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,14 +9,27 @@ (in-package "SB-IMPL") -;; Call FUNCTION once for each Name in globaldb that has information associated -;; with it, passing the function the Name as its only argument. -;; ;; This is in its own file to avoid creating an early dependency on ;; target-package iterators. (macrolet ((def (&rest situations) `(eval-when ,situations + ;; Return all function names that are stored in SYMBOL's packe-info. + ;; As an example, (INFO-NAME-LIST 'SB-PCL::DIRECT-SUPERCLASSES) => + ;; ((SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::READER) + ;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES BOUNDP) + ;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::WRITER)) + (defun info-name-list (symbol) + (let ((packed-info (symbol-dbinfo symbol)) + (list)) + (when packed-info + (do-packed-info-aux-key (packed-info key-index) + (push (construct-globaldb-name (%info-ref packed-info key-index) symbol) + list)) + (nconc (and (plusp (packed-info-field packed-info 0 0)) (list symbol)) + (nreverse list))))) + ;; Call FUNCTION once for each Name in globaldb that has information associated + ;; with it, passing the function the Name as its only argument. (defun call-with-each-globaldb-name (fun-designator) (let ((function (cl:coerce fun-designator 'function))) (with-package-iterator (iter (list-all-packages) :internal :external) @@ -28,7 +41,7 @@ ;; always keep it since we can't know if it has been seen once. (when (or (not (sb-xc:symbol-package symbol)) (eq package (sb-xc:symbol-package symbol))) - (dolist (name (info-vector-name-list symbol)) + (dolist (name (info-name-list symbol)) (funcall function name)))))) ,@(unless (equal situations '(:compile-toplevel)) `((dovector (obj (car *fdefns*)) diff -Nru sbcl-2.1.10/src/code/list.lisp sbcl-2.1.11/src/code/list.lisp --- sbcl-2.1.10/src/code/list.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/list.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1194,7 +1194,11 @@ (defun acons (key datum alist) "Construct a new alist by adding the pair (KEY . DATUM) to ALIST." - (cons (cons key datum) alist)) + ;; This function is maybe-inline, so can't use vop-existsp + ;; which does not remain in the image post-build. + #.(if (gethash 'acons sb-c::*backend-template-names*) + '(acons key datum alist) ; vop translated + '(cons (cons key datum) alist))) (defun pairlis (keys data &optional (alist '())) "Construct an association list from KEYS and DATA (adding to ALIST)." diff -Nru sbcl-2.1.10/src/code/module.lisp sbcl-2.1.11/src/code/module.lisp --- sbcl-2.1.10/src/code/module.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/module.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -82,8 +82,9 @@ (merge-pathnames (make-pathname :directory (list :relative "contrib") :name filesys-name) - (truename (or (sbcl-homedir-pathname) - (return-from module-provide-contrib nil))))) + ;; DO NOT CALL TRUENAME HERE. YOU SHOULD NOT NEED THAT. + (or (sbcl-homedir-pathname) + (return-from module-provide-contrib nil)))) (fasl-path (merge-pathnames (make-pathname :type *fasl-file-type*) unadorned-path)) @@ -93,9 +94,24 @@ ;; be removed by the time we get round to trying to load it. ;; Maybe factor out the logic in the LOAD guesser as to which file ;; was meant, so that we can use it here on open streams instead? - (let ((file (or (probe-file fasl-path) - (probe-file unadorned-path) - (probe-file lisp-path)))) + ;; + ;; Prefer the untruename as the argument to give to LOAD, + ;; because users need to see (in backtraces and similar) the pathnames + ;; actually handed off to the filesystem calls, like: + ;; ... #P"blaze-out/k8-fastbuild/bin/third_party/lisp/sbcl/binary-distribution/k8/sbcl/bin/../lib/sbcl/contrib/sb-md5.fasl" + ;; and not names that have been obtained through readlink like + ;; ... #P"/build/cas/081/081f9f05e4af917b63b6ccf7453e4565fc66587a093a45fb1c6dbe64e8c8ad58_0100b65b" + ;; as the latter can not be reverse-engineered to a source file + ;; except possibly by much trial and error. + ;; + ;; If the idea of using PROBE-FILE was to get the newest version + ;; on a versioned file system, I don't see how it helps to truenameize early, + ;; because as per the "possible race" cited above, there may be an even newer version + ;; when you call LOAD, or it may go away. Aside from ensuring existence, + ;; was there any benefit to using the result of PROBE-FILE? + (let ((file (cond ((probe-file fasl-path) fasl-path) + ((probe-file unadorned-path) unadorned-path) + ((probe-file lisp-path) lisp-path)))) (when file (handler-bind (((or style-warning package-at-variance) #'muffle-warning)) diff -Nru sbcl-2.1.10/src/code/package.lisp sbcl-2.1.11/src/code/package.lisp --- sbcl-2.1.10/src/code/package.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/package.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -57,7 +57,7 @@ (sb-xc:defstruct (package (:constructor %make-package - (%name internal-symbols external-symbols)) + (internal-symbols external-symbols)) (:copier nil) (:predicate packagep)) "the standard structure for the description of a package" diff -Nru sbcl-2.1.10/src/code/room.lisp sbcl-2.1.11/src/code/room.lisp --- sbcl-2.1.10/src/code/room.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/room.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -188,65 +188,6 @@ (ash header-word (- hash-slot-present-flag)) 1)))) -;;; * If symbols are 7 words incl header, as they are on 32-bit w/threads, -;;; then the part of NIL that manifests as symbol slots consumes 6 words -;;; (less the header) because NIL's symbol widetag precedes it by 1 word. -;;; So, there are 6 post-header words and 2 pre-header: one containing -;;; the widetag (not that it is ever read), and one 0 word. -;;; * If symbols are 6 words incl header, as they are on 64-bit and -;;; 32-bit w/o threads, then the symbol-like part of NIL is 5 words, -;;; which aligns up to 6, plus the two pre-header words. -;;; So either way, NIL's alignment padding makes it come out to 8 words in total. -(defconstant sizeof-nil-in-words (+ 2 (sb-int:align-up (1- sb-vm:symbol-size) 2))) - -;;; It's unclear to me whether reinventing sizetab[] in lisp is strictly -;;; an improvement over doing the obvious: -;;; (WITH-PINNED-OBJECTS (object) (alien-funcall "ext_lispboj_size" ...)) -;;; It certainly doesn't feel that it's better, but it has significantly less overhead -;;; at least on cheneygc if not also on the precise gencgc platforms. -;;; But see WITH-PINNED-OBJECT-ITERATOR in 'target-hash-table' which offers -;;; a way to mitigate the need to bind/unbind a special var when doing a massive -;;; numbers of WITH-PINNED-OBJECT operations. -(defun primitive-object-size (object) - "Return number of bytes of heap or stack directly consumed by OBJECT" - (unless (is-lisp-pointer (get-lisp-obj-address object)) - (return-from primitive-object-size 0)) - (let ((words - ;; This should pick off the most frequently-occurring things first. - ;; CONS and INSTANCE of course top the list. - (typecase object - (list (if object 2 sizeof-nil-in-words)) - (instance (1+ (instance-length object))) - (function - (when (= (%fun-pointer-widetag 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))) - ;; Must be an OTHER pointer now - (code-component - (return-from primitive-object-size (code-object-size 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 - (bignum - #+bignum-assertions - (+ (* (sb-bignum:%bignum-length object) 2) 2) - #-bignum-assertions - ;; 64-bit machines might want to store the bignum length in the upper 4 - ;; bytes of the header which would simplify %bignum-set-length. - (1+ (sb-bignum:%bignum-length object))) - (t - (let ((room-info (aref *room-info* (%other-pointer-widetag object)))) - (if (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)) - ;; GET-HEADER-DATA works for everything that's left - (1+ (logand (get-header-data object) - (room-info-mask room-info))))))))) - (* (align-up words 2) n-word-bytes))) - ;;; Macros not needed after this file (and avoids a redefinition warning this way) (eval-when (:compile-toplevel) (defmacro widetag@baseptr (sap) @@ -305,25 +246,6 @@ #-sb-devel (aver (sap= start end))))) -;;; Test the sizing function ASAP, because if it's broken, then MAP-ALLOCATED-OBJECTS -;;; is too, and then creating the initial core will crash because of the various heap -;;; traversals performed in SAVE-LISP-AND-DIE. Don't delay a crash. -(dovector (saetp *specialized-array-element-type-properties*) - (let ((length 0) (et (saetp-specifier saetp))) - (loop (let* ((array (make-array length :element-type et)) - (size-from-lisp (primitive-object-size array)) - (size-from-c - (with-pinned-objects (array) - (alien-funcall (extern-alien "ext_lispobj_size" (function unsigned unsigned)) - (logandc2 (get-lisp-obj-address array) lowtag-mask))))) - (unless (= size-from-lisp size-from-c) - (bug "size calculation mismatch on ~S" array)) - ;; Stop after enough trials to hit all the edge case - (when (or (>= size-from-lisp (* 8 sb-vm:n-word-bytes)) - (and (eq et nil) (>= length 4))) ; always 2 words - (return)) - (incf length))))) - ;;; Access to the GENCGC page table for better precision in ;;; MAP-ALLOCATED-OBJECTS #+gencgc @@ -1117,7 +1039,7 @@ ,.(make-case 'array) ,.(make-case* 'symbol `(,functoid (%primitive sb-c:fast-symbol-global-value ,obj) ,@more) - `(,functoid (symbol-info ,obj) ,@more) + `(,functoid (symbol-%info ,obj) ,@more) `(,functoid (symbol-name ,obj) ,@more) `(,functoid (symbol-package ,obj) ,@more) `(when (symbol-extra-slot-p ,obj) @@ -1336,17 +1258,18 @@ #+gencgc (defun generation-of (object) - (let* ((addr (get-lisp-obj-address object)) - (page (find-page-index addr))) - (cond ((>= page 0) (slot (deref page-table page) 'gen)) - #+immobile-space - ((immobile-space-addr-p addr) - ;; SIMPLE-FUNs don't contain a generation byte - (when (simple-fun-p object) - (setq addr (get-lisp-obj-address (fun-code-header object)))) - (let ((sap (int-sap (logandc2 addr lowtag-mask)))) - (logand (if (fdefn-p object) (sap-ref-8 sap 1) (sap-ref-8 sap 3)) - #xF)))))) + (with-pinned-objects (object) + (let* ((addr (get-lisp-obj-address object)) + (page (find-page-index addr))) + (cond ((>= page 0) (slot (deref page-table page) 'gen)) + #+immobile-space + ((immobile-space-addr-p addr) + ;; SIMPLE-FUNs don't contain a generation byte + (when (simple-fun-p object) + (setq addr (get-lisp-obj-address (fun-code-header object)))) + (let ((sap (int-sap (logandc2 addr lowtag-mask)))) + (logand (if (fdefn-p object) (sap-ref-8 sap 1) (sap-ref-8 sap 3)) + #xF))))))) ;;; Show objects in a much simpler way than print-allocated-objects. ;;; Probably don't use this for generation 0 of dynamic space. Other spaces are ok. @@ -1364,7 +1287,10 @@ ;;; Unfortunately this is a near total copy of the test in gc.impure.lisp (defun !ensure-genesis-code/data-separation () #+gencgc - (let* ((n-bits (+ next-free-page 10)) + (let* ((n-bits + (progn + (sb-vm::close-current-gc-region) + (+ next-free-page 50))) (code-bits (make-array n-bits :element-type 'bit :initial-element 0)) (data-bits (make-array n-bits :element-type 'bit :initial-element 0)) (total-code-size 0)) diff -Nru sbcl-2.1.10/src/code/run-program.lisp sbcl-2.1.11/src/code/run-program.lisp --- sbcl-2.1.10/src/code/run-program.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/run-program.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1328,6 +1328,9 @@ (or sb-sys::*software-version* (setf sb-sys::*software-version* (possibly-base-stringize + #+linux + (with-open-file (f "/proc/sys/kernel/osrelease") (read-line f)) + #-linux (string-trim '(#\newline) (%with-output-to-string (stream) (run-program "/bin/uname" diff -Nru sbcl-2.1.10/src/code/seq.lisp sbcl-2.1.11/src/code/seq.lisp --- sbcl-2.1.10/src/code/seq.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/seq.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1223,7 +1223,7 @@ (progn (setf (car in-apply-args) (funcall elt s state)) (setf (caar in-iters) (funcall step s state from-end))))))))))))) -#-sb-devel + (declaim (start-block map %map)) (defun %map-to-list (fun sequences) diff -Nru sbcl-2.1.10/src/code/serve-event.lisp sbcl-2.1.11/src/code/serve-event.lisp --- sbcl-2.1.10/src/code/serve-event.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/serve-event.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -192,7 +192,6 @@ ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends -#-sb-devel (declaim (start-block wait-until-fd-usable serve-event serve-all-events compute-pollfds)) ;;; When a *periodic-polling-function* is defined the server will not diff -Nru sbcl-2.1.10/src/code/setf-funs.lisp sbcl-2.1.11/src/code/setf-funs.lisp --- sbcl-2.1.10/src/code/setf-funs.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/setf-funs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,10 +14,18 @@ (eval-when (:compile-toplevel :execute) +(defun c*r-function-p (string) + (and (char= (char string 0) #\C) + (char= (char string (1- (length string))) #\R) + (loop for i from 1 below (1- (length string)) + always (member (char string i) '(#\A #\D))))) + (defun compute-one-setter (name type) (let ((args (second type))) (cond ((null (intersection args lambda-list-keywords)) + (when (c*r-function-p (string name)) + (setq args '(cons))) (let ((res (type-specifier (single-value-type (values-specifier-type (third type))))) diff -Nru sbcl-2.1.10/src/code/share-vm.lisp sbcl-2.1.11/src/code/share-vm.lisp --- sbcl-2.1.10/src/code/share-vm.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/share-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -55,9 +55,7 @@ ;; the pointer in order to read the lower half. This has been broken ;; at least twice in the past. MIPS also appears to be the ONLY ;; system for which the signal context field size may differ from -;; n-word-bits (well, and ALPHA, but that's a separate matter), but -;; this entire thing will likely need to be revisited when we add x32 -;; or n32 ABI support. +;; n-word-bits. (defconstant kludge-big-endian-short-pointer-offset (+ 0 #+(and mips big-endian (not 64-bit)) 1)) diff -Nru sbcl-2.1.10/src/code/simple-fun.lisp sbcl-2.1.11/src/code/simple-fun.lisp --- sbcl-2.1.10/src/code/simple-fun.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/simple-fun.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -48,16 +48,7 @@ (and (logtest (function-header-word closure) closure-extra-data-indicator) (evenp (get-closure-length closure)))) -(macrolet ((%closure-index-set (closure index val) - ;; Use the identical convention as %CLOSURE-INDEX-REF for the index. - ;; There are no closure slot setters, and in fact SLOT-SET - ;; does not exist in a variant that takes a non-constant index. - `(setf (sap-ref-lispobj (int-sap (get-lisp-obj-address ,closure)) - (+ (ash ,index sb-vm:word-shift) - (- (ash sb-vm:closure-info-offset sb-vm:word-shift) - sb-vm:fun-pointer-lowtag))) - ,val)) - (new-closure (nvalues) +(macrolet ((new-closure (nvalues) ;; argument is the number of INFO words #-(or x86 x86-64) `(sb-vm::%alloc-closure ,nvalues (%closure-fun closure)) @@ -68,24 +59,24 @@ ;; until after the new closure is made. (sb-vm::%alloc-closure ,nvalues (sb-vm::%closure-callee closure)))) (copy-slots (has-extra-data) - `(do ((sap (sap+ (int-sap (get-lisp-obj-address copy)) - (- sb-vm:fun-pointer-lowtag))) - (i (ash sb-vm:closure-info-offset sb-vm:word-shift) - (+ i sb-vm:n-word-bytes)) - (j 0 (1+ j))) + `(do ((j 0 (1+ j))) ((>= j nvalues) - ,@(when has-extra-data - `((setf (sap-ref-word sap 0) - (logior (function-header-word copy) - closure-extra-data-indicator)))) - #+immobile-space ; copy the layout - (setf (sap-ref-32 sap 4) ; ASSUMPTION: little-endian - (logior (get-lisp-obj-address - (wrapper-friend ,(find-layout 'function))))) - #+metaspace ; copy the CODE (not accessible by index-ref) - (setf (sap-ref-lispobj sap (ash sb-vm::closure-code-slot sb-vm:word-shift)) - (sb-vm::%closure-code closure))) - (setf (sap-ref-lispobj sap i) (%closure-index-ref closure j))))) + (with-pinned-objects (copy) + (let ((sap (sap+ (int-sap (get-lisp-obj-address copy)) + (- sb-vm:fun-pointer-lowtag)))) + (declare (ignorable sap)) + ,@(when has-extra-data + `((setf (sap-ref-word sap 0) + (logior (function-header-word copy) + closure-extra-data-indicator)))) + #+immobile-space ; copy the layout + (setf (sap-ref-32 sap 4) ; ASSUMPTION: little-endian + (logior (get-lisp-obj-address + (wrapper-friend ,(find-layout 'function))))) + #+metaspace ; copy the CODE (not accessible by index-ref) + (setf (sap-ref-lispobj sap (ash sb-vm::closure-code-slot sb-vm:word-shift)) + (sb-vm::%closure-code closure))))) + (%closure-index-set copy j (%closure-index-ref closure j))))) ;; This is factored out because of a cutting-edge implementation ;; of tracing wrappers that I'm trying to finish. @@ -94,7 +85,7 @@ (let* ((nvalues (closure-len->nvalues (get-closure-length (truly-the function closure)))) (copy (new-closure nvalues))) - (with-pinned-objects (copy) (copy-slots nil)) + (copy-slots nil) copy)) ;;; Assign CLOSURE a new name and/or docstring in VALUES, and return the @@ -379,14 +370,13 @@ ;;;; CODE-COMPONENT -#+(or x86 x86-64) -(progn ; software mark bits require that these go through the CODE-HEADER-SET vop +;;; software mark bits on pages of code require that all assignments to +;;; header slots go through the CODE-HEADER-SET vop, +;;; which is slightly different from the general soft card mark implementation +;;; for historical reasons. (defun (setf %code-debug-info) (newval code) - (code-header-set code sb-vm::code-debug-info-slot newval) + (setf (code-header-ref code sb-vm:code-debug-info-slot) newval) newval) -(defun (setf sb-vm::%code-fixups) (newval code) - (code-header-set code sb-vm::code-fixups-slot newval) - newval)) (defun %code-debug-info (code-obj) ;; Extract the unadulterated debug-info emitted by the compiler. The slot @@ -397,6 +387,10 @@ ;; return it unchanged in all other cases info))) +(defun (setf sb-vm::%code-fixups) (newval code) + (code-header-set code sb-vm::code-fixups-slot newval) + newval) + (declaim (inline code-obj-is-filler-p)) (defun code-obj-is-filler-p (code-obj) ;; See also HOLE-P in the allocator (same thing but using SAPs) diff -Nru sbcl-2.1.10/src/code/stream.lisp sbcl-2.1.11/src/code/stream.lisp --- sbcl-2.1.10/src/code/stream.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/stream.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -2596,4 +2596,131 @@ (concatenate 'string (subseq string 0 8) "...") string))))) -;;;; etc. + +;;;; initialization + +;;; the stream connected to the controlling terminal, or NIL if there is none +(defvar *tty*) + +;;; the stream connected to the standard input (file descriptor 0) +(defvar *stdin*) + +;;; the stream connected to the standard output (file descriptor 1) +(defvar *stdout*) + +;;; the stream connected to the standard error output (file descriptor 2) +(defvar *stderr*) + +;;; This is called when the cold load is first started up, and may also +;;; be called in an attempt to recover from nested errors. +(defun stream-cold-init-or-reset () + (stream-reinit) + (setf *terminal-io* (make-synonym-stream '*tty*)) + (setf *standard-output* (make-synonym-stream '*stdout*)) + (setf *standard-input* (make-synonym-stream '*stdin*)) + (setf *error-output* (make-synonym-stream '*stderr*)) + (setf *query-io* (make-synonym-stream '*terminal-io*)) + (setf *debug-io* *query-io*) + (setf *trace-output* *standard-output*) + (values)) + +(defun stream-deinit () + (setq *tty* nil *stdin* nil *stdout* nil *stderr* nil) + ;; Unbind to make sure we're not accidently dealing with it + ;; before we're ready (or after we think it's been deinitialized). + ;; This uses the internal %MAKUNBOUND because the CL: function would + ;; rightly complain that *AVAILABLE-BUFFERS* is proclaimed always bound. + (%makunbound '*available-buffers*)) + +(defvar *streams-closed-by-slad*) + +(defun restore-fd-streams () + (loop for (stream in bin n-bin out bout sout misc) in *streams-closed-by-slad* + do + (setf (ansi-stream-in stream) in) + (setf (ansi-stream-bin stream) bin) + (setf (ansi-stream-n-bin stream) n-bin) + (setf (ansi-stream-out stream) out) + (setf (ansi-stream-bout stream) bout) + (setf (ansi-stream-sout stream) sout) + (setf (ansi-stream-misc stream) misc))) + +(defun stdstream-external-format (fd) + #-win32 (declare (ignore fd)) + (let* ((keyword (cond #+(and win32 sb-unicode) + ((sb-win32::console-handle-p fd) + :ucs-2) + (t + (default-external-format)))) + (ef (get-external-format keyword)) + (replacement (ef-default-replacement-character ef))) + `(,keyword :replacement ,replacement))) + +;;; This is called whenever a saved core is restarted. +(defun stream-reinit (&optional init-buffers-p) + (when init-buffers-p + ;; Use the internal %BOUNDP for similar reason to that cited above- + ;; BOUNDP on a known global transforms to the constant T. + (aver (not (%boundp '*available-buffers*))) + (setf *available-buffers* nil)) + (%with-output-to-string (*error-output*) + (multiple-value-bind (in out err) + #-win32 (values 0 1 2) + #+win32 (sb-win32::get-std-handles) + (labels (#+win32 + (nul-stream (name inputp outputp) + (let ((nul-handle + (cond + ((and inputp outputp) + (sb-win32:unixlike-open "NUL" sb-unix:o_rdwr)) + (inputp + (sb-win32:unixlike-open "NUL" sb-unix:o_rdonly)) + (outputp + (sb-win32:unixlike-open "NUL" sb-unix:o_wronly)) + (t + ;; Not quite sure what to do in this case. + nil)))) + (make-fd-stream + nul-handle + :name name + :input inputp + :output outputp + :buffering :line + :element-type :default + :serve-events inputp + :auto-close t + :external-format (stdstream-external-format nul-handle)))) + (stdio-stream (handle name inputp outputp) + (cond + #+win32 + ((null handle) + ;; If no actual handle was present, create a stream to NUL + (nul-stream name inputp outputp)) + (t + (make-fd-stream + handle + :name name + :input inputp + :output outputp + :buffering :line + :element-type :default + :serve-events inputp + :external-format (stdstream-external-format handle)))))) + (setf *stdin* (stdio-stream in "standard input" t nil) + *stdout* (stdio-stream out "standard output" nil t) + *stderr* (stdio-stream err "standard error" nil t)))) + #+win32 + (setf *tty* (make-two-way-stream *stdin* *stdout*)) + #-win32 + (let ((tty (sb-unix:unix-open "/dev/tty" sb-unix:o_rdwr #o666))) + (setf *tty* + (if tty + (make-fd-stream tty :name "the terminal" + :input t :output t :buffering :line + :external-format (stdstream-external-format tty) + :serve-events t + :auto-close t) + (make-two-way-stream *stdin* *stdout*)))) + (princ (get-output-stream-string *error-output*) *stderr*)) + (values)) + diff -Nru sbcl-2.1.10/src/code/string.lisp sbcl-2.1.11/src/code/string.lisp --- sbcl-2.1.10/src/code/string.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/string.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -621,7 +621,7 @@ ;; coalescing of strings used as literals in code compiled to memory, ;; the string is shareable. (when (eq (heap-allocated-p vector) :dynamic) - (logior-header-bits (the (simple-array * 1) vector) + (logior-array-flags (the (simple-array * 1) vector) (if always-shareable sb-vm:+vector-shareable+ sb-vm:+vector-shareable-nonstd+))) diff -Nru sbcl-2.1.10/src/code/stubs.lisp sbcl-2.1.11/src/code/stubs.lisp --- sbcl-2.1.10/src/code/stubs.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/stubs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -112,7 +112,7 @@ (def value-cell-ref) (def %caller-frame ()) (def %caller-pc ()) - #+(or x86 x86-64) (def sb-vm::%code-fixups) + (def sb-vm::%code-fixups) #+x86-64 (def pointerp) ;; instances @@ -131,7 +131,6 @@ (def %funcallable-instance-fun) (def (setf %funcallable-instance-fun) (fin new-value)) (def %funcallable-instance-info (fin i)) - (def %set-funcallable-instance-info (fin i new-value)) #+compact-instance-header (progn (def wrapper-of) (def %instanceoid-layout)) @@ -163,7 +162,11 @@ (def symbol-hash) (def sb-vm::symbol-extra) #+sb-thread (def symbol-tls-index) - #.(if (fboundp 'symbol-info-vector) (values) '(def symbol-info-vector)) + (def symbol-%info) ; primitive reader always needs a stub + (def (setf symbol-%info) (info symbol)) ; as does primitive writer + ;; but the "wrapped" reader might not need a stub. + ;; If it's already a proper function, then it doesn't. + #.(if (fboundp 'symbol-dbinfo) (values) '(def symbol-dbinfo)) #-(or x86 x86-64) (def lra-code-header) (def %make-lisp-obj) (def get-lisp-obj-address) diff -Nru sbcl-2.1.10/src/code/symbol.lisp sbcl-2.1.11/src/code/symbol.lisp --- sbcl-2.1.10/src/code/symbol.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/symbol.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -135,6 +135,19 @@ (let ((fdefn (find-or-create-fdefn symbol))) (setf (fdefn-fun fdefn) new-value)))) +;;; Incredibly bogus kludge: the :CAS-TRANS option in objdef makes no indication +;;; that you can not use it on certain platforms, so then you do try to use it, +;;; and you silently get no automatic IR2 conversion. The workaround in src/code/cas +;;; is unnecessary imho - why are we comparing the old value? +;;; To catch programming errors that occur only for non-threads apparently? +;;; The flaw is that it's dissociated from objdef, which ought to you give you +;;; the stub automatically somehow. +;;; Furthermore it's annoying that you can't name the CAS function (CAS fn). +#-compare-and-swap-vops +(defun cas-symbol-%info (symbol old new) + (setf (symbol-%info symbol) new) + old) + ;;; Accessors for the dual-purpose info/plist slot ;; A symbol's INFO slot is always in one of three states: @@ -149,14 +162,6 @@ ;; State 2 transitions to state 3 via ({SETF|CAS} SYMBOL-PLIST). ;; There are *no* other permissible state transitions. -(defun symbol-info (symbol) - (symbol-info symbol)) - -;; An "interpreter stub" for an operation that is only implemented for -;; the benefit of platforms without compare-and-swap-vops. -(defun (setf symbol-info) (new-info symbol) - (setf (symbol-info symbol) new-info)) - ;; Atomically update SYMBOL's info/plist slot to contain a new info vector. ;; The vector is computed by calling UPDATE-FN on the old vector, ;; repeatedly as necessary, until no conflict happens with other updaters. @@ -164,25 +169,25 @@ (defun update-symbol-info (symbol update-fn) (declare (symbol symbol) (type (function (t) t) update-fn)) - (prog ((info-holder (symbol-info symbol)) - (current-vect)) + (prog ((info-holder (symbol-%info symbol)) + (current-info)) ; a PACKED-INFO or NIL outer-restart - ;; Do not use SYMBOL-INFO-VECTOR - this must not perform a slot read again. - (setq current-vect (if (listp info-holder) (cdr info-holder) info-holder)) + ;; This _must_ _not_ perform another read of the INFO slot here. + (setq current-info (if (listp info-holder) (cdr info-holder) info-holder)) inner-restart - (let ((new-vect (funcall update-fn (or current-vect +nil-packed-infos+)))) - (unless (simple-vector-p new-vect) - (aver (null new-vect)) + (let ((new-info (funcall update-fn (or current-info +nil-packed-infos+)))) + (unless (%instancep new-info) + (aver (null new-info)) (return)) ; nothing to do (if (consp info-holder) ; State 3: exchange the CDR - (let ((old (%compare-and-swap-cdr info-holder current-vect new-vect))) - (when (eq old current-vect) (return t)) ; win - (setq current-vect old) ; Don't touch holder- it's still a cons + (let ((old (cas (cdr info-holder) current-info new-info))) + (when (eq old current-info) (return t)) ; win + (setq current-info old) ; Don't touch holder- it's still a cons (go inner-restart))) - ;; State 1 or 2: info-holder is NIL or a vector. - ;; Exchange the contents of the info slot. Type-inference derives - ;; SIMPLE-VECTOR-P on the args to CAS, so no extra checking. - (let ((old (%compare-and-swap-symbol-info symbol info-holder new-vect))) + ;; State 1 or 2: info-holder is NIL or a PACKED-INFO. + ;; Exchange the contents of the info slot. Type-inference should have + ;; derived that NEW-INFO satisfies the slot type restriction (I hope). + (let ((old (cas-symbol-%info symbol info-holder new-info))) (when (eq old info-holder) (return t)) ; win ;; Check whether we're in state 2 or 3 now. ;; Impossible to be in state 1: nobody ever puts NIL in the slot. @@ -190,38 +195,25 @@ (setq info-holder old) (go outer-restart))))) -(eval-when (:compile-toplevel) - ;; If we're in state 1 or state 3, we can take (CAR (SYMBOL-INFO S)) - ;; to get the property list. If we're in state 2, this same access - ;; gets the fixnum which is the VECTOR-LENGTH of the info vector. - ;; So all we have to do is turn any fixnum to NIL, and we have a plist. - ;; Ensure that this pun stays working. - #-ppc64 ; ppc64 has unevenly spaced lowtags - (assert (= (- (* sb-vm:n-word-bytes sb-vm:cons-car-slot) - sb-vm:list-pointer-lowtag) - (- (* sb-vm:n-word-bytes sb-vm:vector-length-slot) - sb-vm:other-pointer-lowtag)))) - (defun symbol-plist (symbol) "Return SYMBOL's property list." - (if (sb-c::vop-existsp :translate cl:symbol-plist) - (symbol-plist symbol) - (let ((list (car (truly-the list (symbol-info symbol))))) ; a harmless lie - ;; Just ensure the result is not a fixnum, and we're done. - (if (fixnump list) nil list)))) + (let ((list (symbol-%info symbol))) + ;; See the comments above UPDATE-SYMBOL-INFO for a + ;; reminder as to why this logic is right. + (if (%instancep list) nil (car list)))) (declaim (ftype (sfunction (symbol t) cons) %ensure-plist-holder) (inline %ensure-plist-holder)) ;; When a plist update (setf or cas) is first performed on a symbol, ;; a one-time allocation of an extra cons is done which creates two -;; "slots" from one: a slot for the info-vector and a slot for the plist. +;; "slots" from one: a slot for the PACKED-INFO and a slot for the plist. ;; This avoids complications in the implementation of the user-facing ;; (CAS SYMBOL-PLIST) function, which should not have to be aware of ;; competition from globaldb mutators even if no other threads attempt ;; to manipulate the plist per se. -;; Given a SYMBOL and its current INFO of type (OR LIST SIMPLE-VECTOR) +;; Given a SYMBOL and its current INFO of type (OR LIST INSTANCE) ;; ensure that SYMBOL's current info is a cons, and return that. ;; If racing with multiple threads, at most one thread will install the cons. (defun %ensure-plist-holder (symbol info) @@ -233,54 +225,55 @@ ;; The pointer from the new cons to the old info must be persisted ;; to memory before the symbol's info slot points to the cons. ;; [x86oid doesn't need the barrier, others might] - (sb-thread:barrier (:write) - (setq newcell (cons nil info))) - (loop (let ((old (%compare-and-swap-symbol-info symbol info newcell))) + (setq newcell (cons nil info)) + (sb-thread:barrier (:write)) ; oh such ghastly syntax + (loop (let ((old (cas-symbol-%info symbol info newcell))) (cond ((eq old info) (return newcell)) ; win ((consp old) (return old))) ; somebody else made a cons! (setq info old) - (sb-thread:barrier (:write) ; Retry using same newcell - (rplacd newcell info))))))) + (rplacd newcell info) + (sb-thread:barrier (:write))))))) ; Retry using same newcell -(declaim (inline (cas symbol-plist) %set-symbol-plist)) +(declaim (inline (cas symbol-plist) (setf symbol-plist))) (defun (cas symbol-plist) (old new symbol) ;; If SYMBOL's info cell is a cons, we can do (CAS CAR). Otherwise punt. (declare (symbol symbol) (list old new)) - (let ((cell (symbol-info symbol))) + (let ((cell (symbol-%info symbol))) (if (consp cell) (%compare-and-swap-car cell old new) - (%compare-and-swap-symbol-plist old new symbol)))) + (%cas-symbol-plist old new symbol)))) -(defun %compare-and-swap-symbol-plist (old new symbol) +(defun %cas-symbol-plist (old new symbol) ;; This is just the second half of a partially-inline function, to avoid ;; code bloat in the exceptional case. Type assertions should have been ;; done - or not, per policy - by the caller of %COMPARE-AND-SWAP-SYMBOL-PLIST ;; so now use TRULY-THE to avoid further type checking. (%compare-and-swap-car (%ensure-plist-holder (truly-the symbol symbol) - (symbol-info symbol)) + (symbol-%info symbol)) old new)) -(defun %set-symbol-plist (symbol new-value) - ;; This is the entry point into which (SETF SYMBOL-PLIST) is transformed. +(defun (setf symbol-plist) (new-value symbol) ;; If SYMBOL's info cell is a cons, we can do (SETF CAR). Otherwise punt. (declare (symbol symbol) (list new-value)) - (let ((cell (symbol-info symbol))) + (let ((cell (symbol-%info symbol))) (if (consp cell) (setf (car cell) new-value) - (%%set-symbol-plist symbol new-value)))) + (%set-symbol-plist symbol new-value)))) -(defun %%set-symbol-plist (symbol new-value) - ;; Same considerations as for %%COMPARE-AND-SWAP-SYMBOL-PLIST, +(defun %set-symbol-plist (symbol new-value) + ;; Same considerations as for %CAS-SYMBOL-PLIST, ;; with a slight efficiency hack: if the symbol has no plist holder cell ;; and the NEW-VALUE is NIL, try to avoid creating a holder cell. ;; Yet we must write something, because omitting a memory operation ;; could have a subtle effect in the presence of multi-threading. - (let ((info (symbol-info (truly-the symbol symbol)))) + (let ((info (symbol-%info (truly-the symbol symbol)))) (when (and (not new-value) (atom info)) ; try to treat this as a no-op - (let ((old (%compare-and-swap-symbol-info symbol info info))) + ;; INFO is either an INSTANCE (a PACKED-INFO) or NIL. + ;; Write the same thing back, to say we set the plist to NIL. + (let ((old (cas-symbol-%info symbol info info))) (if (eq old info) ; good enough - (return-from %%set-symbol-plist new-value) ; = nil + (return-from %set-symbol-plist new-value) ; = nil (setq info old)))) (setf (car (%ensure-plist-holder symbol info)) new-value))) @@ -327,7 +320,7 @@ #+immobile-space (defun %make-symbol (kind name) (declare (ignorable kind) (type simple-string name)) - (logior-header-bits name sb-vm:+vector-shareable+) ; Set "logically read-only" bit + (logior-array-flags name sb-vm:+vector-shareable+) ; Set "logically read-only" bit (if #-immobile-symbols (or (eql kind 1) ; keyword (and (eql kind 2) ; random interned symbol diff -Nru sbcl-2.1.10/src/code/target-alieneval.lisp sbcl-2.1.11/src/code/target-alieneval.lisp --- sbcl-2.1.10/src/code/target-alieneval.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/target-alieneval.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -787,38 +787,41 @@ (arg-types) (alien-vars) (alien-args) (results)) (dolist (arg args) - (if (stringp arg) - (docs arg) - (destructuring-bind (name type &optional (style :in)) arg - (unless (member style '(:in :copy :out :in-out)) - (error "bogus argument style ~S in ~S" style arg)) - (when (and (member style '(:out :in-out)) - (typep (parse-alien-type type lexenv) - 'alien-pointer-type)) - (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" - type)) - (let (arg-type) - (cond ((eq style :in) - (setq arg-type type) - (alien-args name)) - (t - (setq arg-type `(* ,type)) - (if (eq style :out) - (alien-vars `(,name ,type)) - (alien-vars `(,name ,type ,name))) - (alien-args `(addr ,name)))) - (arg-types arg-type) - (unless (eq style :out) - (lisp-args name) - (lisp-arg-types t - ;; FIXME: It should be something - ;; like `(ALIEN ,ARG-TYPE), except - ;; for we also accept SAPs where - ;; pointers are required. - ))) - (when (or (eq style :out) (eq style :in-out)) - (results name) - (lisp-result-types `(alien ,type)))))) + (cond ((stringp arg) + (docs arg)) + ((eq arg '&optional) + (arg-types arg)) + (t + (destructuring-bind (name type &optional (style :in)) arg + (unless (member style '(:in :copy :out :in-out)) + (error "bogus argument style ~S in ~S" style arg)) + (when (and (member style '(:out :in-out)) + (typep (parse-alien-type type lexenv) + 'alien-pointer-type)) + (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" + type)) + (let (arg-type) + (cond ((eq style :in) + (setq arg-type type) + (alien-args name)) + (t + (setq arg-type `(* ,type)) + (if (eq style :out) + (alien-vars `(,name ,type)) + (alien-vars `(,name ,type ,name))) + (alien-args `(addr ,name)))) + (arg-types arg-type) + (unless (eq style :out) + (lisp-args name) + (lisp-arg-types t + ;; FIXME: It should be something + ;; like `(ALIEN ,ARG-TYPE), except + ;; for we also accept SAPs where + ;; pointers are required. + ))) + (when (or (eq style :out) (eq style :in-out)) + (results name) + (lisp-result-types `(alien ,type))))))) `(progn ;; The theory behind this automatic DECLAIM is that (1) if ;; you're calling C, static typing is what you're doing diff -Nru sbcl-2.1.10/src/code/target-hash-table.lisp sbcl-2.1.11/src/code/target-hash-table.lisp --- sbcl-2.1.10/src/code/target-hash-table.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/target-hash-table.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -312,7 +312,7 @@ ;; If GC observes VECTOR-HASHING-FLAG, it needs to see a valid value ;; in the 'supplement' slot. Neither 0 nor +empty-ht-slot+ is valid. (setf (kv-vector-supplement v) nil) - (logior-header-bits v sb-vm:vector-hashing-flag) + (logior-array-flags v sb-vm:vector-hashing-flag) v)) (defun install-hash-table-lock (table) @@ -547,7 +547,7 @@ table (or hash-vector (= table-kind hash-table-kind-eql)))) (when weakp - (logior-header-bits kv-vector (logior sb-vm:vector-hashing-flag + (logior-array-flags kv-vector (logior sb-vm:vector-hashing-flag sb-vm:vector-weak-flag))))) (when (logtest flags hash-table-synchronized-flag) (install-hash-table-lock table)) @@ -738,7 +738,7 @@ ;; Set address-sensitivity BEFORE depending on the bits. ;; Precise GC platforms can move any key except the ones which ;; are explicitly pinned. - (logior-header-bits kv-vector sb-vm:vector-addr-hashing-flag) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag) (push-in-chain (pointer-hash->bucket (pointer-hash key) mask))))))) ((= (ht-flags-kind (hash-table-flags table)) hash-table-kind-eql) ;; There's a very tricky issue here with using EQL-HASH - you can't just @@ -769,7 +769,7 @@ (pin-object key) (multiple-value-bind (hash address-based) (eql-hash-no-memoize key) (when address-based - (logior-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) (push-in-chain (mask-hash (prefuzz-hash hash) mask))))))))) (t (do ((i hwm (1- i))) ((zerop i)) @@ -779,7 +779,7 @@ (setf (aref next-vector i) next-free next-free i)) (t (when (sb-vm:is-lisp-pointer (get-lisp-obj-address key)) - (logior-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) (push-in-chain (pointer-hash->bucket (pointer-hash key) mask)))))))) ;; This is identical to the calculation of next-free-kv in INSERT-AT. (cond ((/= next-free 0) next-free) @@ -815,7 +815,7 @@ ;; to the hashing vectors, since at most one thread can win this CAS. (when (eq (cas (svref kv-vector rehash-stamp-elt) epoch rehashing-state) epoch) ;; Remove address-sensitivity, preserving the other flags. - (reset-header-bits kv-vector sb-vm:vector-addr-hashing-flag) + (reset-array-flags kv-vector sb-vm:vector-addr-hashing-flag) ;; Rehash in place. For the duration of the rehash, readers who otherwise ;; might have seen intact chains (by which to find address-insensitive keys) ;; can't. No big deal. If we were willing to cons new vectors, we could @@ -837,7 +837,7 @@ (cond ((/= (aref hash-vector i) +magic-hash-vector-value+) (push-in-chain (mask-hash (aref hash-vector i) mask))) (t - (logior-header-bits kv-vector sb-vm:vector-addr-hashing-flag) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag) (push-in-chain (pointer-hash->bucket (pointer-hash pair-key) mask)))) (when (eq pair-key key) (setq result key-index)))))) @@ -850,7 +850,7 @@ (pin-object pair-key) (multiple-value-bind (hash address-based) (eql-hash-no-memoize pair-key) (when address-based - (logior-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) (push-in-chain (mask-hash (prefuzz-hash hash) mask))) (when (eq pair-key key) (setq result key-index))))))) (t @@ -860,7 +860,7 @@ (with-pair (pair-key) (unless (empty-ht-slot-p pair-key) (when (sb-vm:is-lisp-pointer (get-lisp-obj-address pair-key)) - (logior-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) (push-in-chain (pointer-hash->bucket (pointer-hash pair-key) mask)) (when (eq pair-key key) (setq result key-index))))))) @@ -960,7 +960,7 @@ ;; Now that the table points to the right hash-vector ;; we can set the vector's backpointer and turn it weak. (setf (kv-vector-supplement new-kv-vector) table) - (logior-header-bits new-kv-vector sb-vm:vector-weak-flag)) + (logior-array-flags new-kv-vector sb-vm:vector-weak-flag)) ;; Zero-fill the old kv-vector. For weak hash-tables this removes the ;; strong references to each k/v. For non-weak vectors there is no technical @@ -1373,7 +1373,7 @@ ;; so clear the list of GC-smashed cells. (setf (hash-table-smashed-cells hash-table) nil) ;; Re-enable weakness - (logior-header-bits kv-vector sb-vm:vector-weak-flag) + (logior-array-flags kv-vector sb-vm:vector-weak-flag) (done-rehashing kv-vector initial-stamp)) ;; One more try gives the definitive answer even if the hashes are ;; obsolete again. KEY's hash can't have changed, and there @@ -1658,7 +1658,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 - (logior-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) ;; Store the hash unless an EQ table. Because the key is pinned, it is ;; OK that GC would not have seen +magic-hash-vector-value+ for this @@ -1893,7 +1893,7 @@ (when (hash-table-weak-p hash-table) (aver (eq (kv-vector-supplement kv-vector) hash-table))) ;; Remove address-sensitivity. - (reset-header-bits kv-vector sb-vm:vector-addr-hashing-flag) + (reset-array-flags kv-vector sb-vm:vector-addr-hashing-flag) ;; Do this only after unsetting the address-sensitive bit, ;; otherwise GC might come along and touch this bit again. (setf (kv-vector-rehash-stamp kv-vector) 0) diff -Nru sbcl-2.1.10/src/code/target-package.lisp sbcl-2.1.11/src/code/target-package.lisp --- sbcl-2.1.10/src/code/target-package.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/target-package.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1001,6 +1001,8 @@ implementation it is ~S." *!default-package-use-list*) (prog ((name (stringify-string-designator name)) (nicks (stringify-string-designators nicknames)) + (package (%make-package (make-package-hashtable internal-symbols) + (make-package-hashtable external-symbols))) clobber) :restart (when (find-package name) @@ -1017,19 +1019,13 @@ points. Consider moving the package creation form outside the ~ scope of a block compilation.")) (with-package-graph () - ;; Check for race, signal the error outside the lock. - (when (and (not clobber) (find-package name)) - (go :restart)) - (let ((package - (%make-package - name - (make-package-hashtable internal-symbols) - (make-package-hashtable external-symbols)))) - + ;; Check for race, signal the error outside the lock. + (when (and (not clobber) (find-package name)) + (go :restart)) + (setf (package-%name package) name) ;; Do a USE-PACKAGE for each thing in the USE list so that checking for ;; conflicting exports among used packages is done. (use-package use package) - ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal, ;; which would leave us with possibly-bad side effects from the earlier ;; USE-PACKAGE (e.g. this package on the used-by lists of other packages, @@ -1046,7 +1042,7 @@ (with-package-names (table) (%register-package table name package)) (atomic-incf *package-names-cookie*) - (return package))) + (return package)) (bug "never"))) (flet ((remove-names (package name-table keep-primary-name) @@ -1174,11 +1170,12 @@ (dolist (used (package-use-list package)) (unuse-package used package)) (setf (package-%local-nicknames package) nil) - ;; FIXME: lacking a way to advise UNINTERN that this package - ;; is pending deletion, a large package conses successively - ;; many smaller tables for no good reason. - (do-symbols (sym package) - (unintern sym package)) + (flet ((nullify-home (symbols) + (dovector (x (package-hashtable-cells symbols)) + (when (and (symbolp x) (eq (symbol-package x) package)) + (%set-symbol-package x nil))))) + (nullify-home (package-internal-symbols package)) + (nullify-home (package-external-symbols package))) (with-package-names (table) (remove-names package table nil) (setf (package-%name package) nil diff -Nru sbcl-2.1.10/src/code/target-random.lisp sbcl-2.1.11/src/code/target-random.lisp --- sbcl-2.1.10/src/code/target-random.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/target-random.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -275,7 +275,6 @@ (ash y -1) (aref state (logand y 1))))) (values)) -#-sb-devel (declaim (start-block random %random-single-float %random-double-float random-chunk big-random-chunk)) diff -Nru sbcl-2.1.10/src/code/target-signal-common.lisp sbcl-2.1.11/src/code/target-signal-common.lisp --- sbcl-2.1.10/src/code/target-signal-common.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/target-signal-common.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -54,6 +54,19 @@ (receive-pending-interrupt)) (funcall function)))) +(defmacro pthread-sigmask (how new old) + `(let ((how ,how) (new ,new) (old ,old)) + (alien-funcall (extern-alien + #+sb-thread ,(or #+unix "pthread_sigmask" #-unix "sb_pthread_sigmask") + #-sb-thread ,(or #+netbsd "sb_sigprocmask" #-netbsd "sigprocmask") + (function void int system-area-pointer system-area-pointer)) + how + (cond ((system-area-pointer-p new) new) + (new (vector-sap new)) + (t (int-sap 0))) + (cond ((system-area-pointer-p old) old) + (old (vector-sap old)) + (t (int-sap 0)))))) (defun invoke-interruption (function) (without-interrupts @@ -69,16 +82,18 @@ (sb-thread::without-thread-waiting-for (:already-without-interrupts t) (allow-with-interrupts (nlx-protect (funcall function) - ;; We've been running with deferrables - ;; blocked in Lisp called by a C signal - ;; handler. If we return normally the sigmask - ;; in the interrupted context is restored. - ;; However, if we do an nlx the operating - ;; system will not restore it for us. - (when *unblock-deferrables-on-enabling-interrupts-p* - ;; This means that storms of interrupts - ;; doing an nlx can still run out of stack. - (unblock-deferrable-signals))) + ;; We've been running with blockable + ;; blocked in Lisp called by a C signal + ;; handler. If we return normally the sigmask + ;; in the interrupted context is restored. + ;; However, if we do an nlx the operating + ;; system will not restore it for us. + (when *unblock-deferrables-on-enabling-interrupts-p* + ;; This means that storms of interrupts + ;; doing an nlx can still run out of stack. + (pthread-sigmask SIG_UNBLOCK + (foreign-symbol-sap "blockable_sigset" t) + nil))) ;; The return value doesn't matter, just return 0 0)))))) @@ -86,4 +101,3 @@ "Convenience macro on top of INVOKE-INTERRUPTION." `(dx-flet ((interruption () ,@body)) (invoke-interruption #'interruption))) - diff -Nru sbcl-2.1.10/src/code/target-signal.lisp sbcl-2.1.11/src/code/target-signal.lisp --- sbcl-2.1.10/src/code/target-signal.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/target-signal.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -61,7 +61,6 @@ (with-alien ((%unblock-gc-signals (function void) :extern "unblock_gc_signals")) (alien-funcall %unblock-gc-signals) nil)) - ;;;; interface to installing signal handlers @@ -78,23 +77,29 @@ nil) (defun %install-handler (signal handler) - (flet ((run-handler (signo info-sap context-sap) - #-(or c-stack-is-control-stack sb-safepoint) ;; able to do that in interrupt_handle_now() - (unblock-gc-signals) - (in-interruption () - (funcall handler signo info-sap context-sap)))) - (with-pinned-objects (#'run-handler) - ;; 0 and 1 probably coincide with SIG_DFL and SIG_IGN, but those - ;; constants are opaque. We use our own explicit translation - ;; of them in the C install_handler() argument convention. - (with-alien ((%sigaction (function void int unsigned) :extern "install_handler")) - (alien-funcall %sigaction - signal + ;; 0 and 1 should coincide with SIG_DFL and SIG_IGN, but in theory those values + ;; are opaque. We use our own explicit translation of 0 and 1 to them + ;; in the C install_handler() argument passing convention. + (with-alien ((%sigaction (function void int unsigned) :extern "install_handler")) + #+sb-safepoint + (alien-funcall %sigaction signal + (case handler + (:default 0) + (:ignore 1) + (t (sb-kernel:get-lisp-obj-address handler)))) + #-sb-safepoint + (flet ((run-handler (signo info-sap context-sap) + #-(or c-stack-is-control-stack sb-safepoint) ;; able to do that in interrupt_handle_now() + (unblock-gc-signals) + (in-interruption () (funcall handler signo info-sap context-sap)))) + (with-pinned-objects (#'run-handler) + (alien-funcall %sigaction signal (case handler (:default 0) (:ignore 1) (t (sb-kernel:get-lisp-obj-address #'run-handler))))))) nil) + ;;;; default LISP signal handlers ;;;; @@ -186,20 +191,6 @@ (declare (ignore signal code context)) (sb-impl::get-processes-status-changes)) -(defmacro pthread-sigmask (how new old) - `(let ((how ,how) (new ,new) (old ,old)) - (alien-funcall (extern-alien - #+sb-thread ,(or #+unix "pthread_sigmask" #-unix "sb_pthread_sigmask") - #-sb-thread ,(or #+netbsd "sb_sigprocmask" #-netbsd "sigprocmask") - (function void int system-area-pointer system-area-pointer)) - how - (cond ((system-area-pointer-p new) new) - (new (vector-sap new)) - (t (int-sap 0))) - (cond ((system-area-pointer-p old) old) - (old (vector-sap old)) - (t (int-sap 0)))))) - (defun sb-kernel:signal-cold-init-or-reinit () "Enable all the default signals that Lisp knows how to deal with." (%install-handler sigint #'sigint-handler) @@ -251,6 +242,8 @@ (define-load-time-global *sighandler-thread* nil) (declaim (type (or sb-thread:thread null) *sighandler-thread*)) (defun signal-handler-loop () + ;; We could potentially use sigwaitinfo() to obtain more information about the signal, + ;; but I don't see the point. This is just minimal functionality. (with-alien ((sigwait (function int system-area-pointer (* int)) :extern "sigwait") (mask (array (unsigned 8) #.sizeof-sigset_t)) (num int)) @@ -262,7 +255,4 @@ (let ((fun (sap-ref-lispobj (foreign-symbol-sap "lisp_sig_handlers" t) (ash num sb-vm:word-shift)))) (when (functionp fun) - (let ((userfun (sb-kernel:%closure-index-ref fun 0))) - ;; We could potentially use sigwaitinfo() but I don't see the point. - ;; This is just minimal functionality. - (funcall userfun num nil nil)))))))))) + (funcall fun num nil nil))))))))) diff -Nru sbcl-2.1.10/src/code/target-thread.lisp sbcl-2.1.11/src/code/target-thread.lisp --- sbcl-2.1.10/src/code/target-thread.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/target-thread.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1855,7 +1855,9 @@ (with-pinned-objects (mask) (sb-unix::pthread-sigmask sb-unix::SIG_SETMASK mask nil)) ;; Otherwise just do the usual thing - (sb-unix::unblock-deferrable-signals))))) + (sb-unix::pthread-sigmask sb-unix::SIG_UNBLOCK + (foreign-symbol-sap "thread_start_sigset" t) + nil))))) ;; notinline keeps array off the call stack by getting it out of the curent frame (declare (notinline unmask-signals)) ;; Signals other than stop-for-GC are masked. The WITH/WITHOUT noise is diff -Nru sbcl-2.1.10/src/code/type.lisp sbcl-2.1.11/src/code/type.lisp --- sbcl-2.1.10/src/code/type.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1165,7 +1165,6 @@ (defun ctype-interned-p (ctype) (logtest (type-hash-value ctype) +type-internedp+)) -#-sb-devel (declaim (start-block)) ;;; If two types are definitely equivalent, return true. The second diff -Nru sbcl-2.1.10/src/code/typep.lisp sbcl-2.1.11/src/code/typep.lisp --- sbcl-2.1.10/src/code/typep.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/typep.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,7 +9,7 @@ (in-package "SB-KERNEL") -#-sb-devel(declaim (start-block)) +(declaim (start-block)) ;;; (Note that when cross-compiling, SB-XC:TYPEP is interpreted as a ;;; test that the host Lisp object OBJECT translates to a target SBCL diff -Nru sbcl-2.1.10/src/code/x86-64-vm.lisp sbcl-2.1.11/src/code/x86-64-vm.lisp --- sbcl-2.1.10/src/code/x86-64-vm.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/code/x86-64-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -296,7 +296,7 @@ (truly-the word (+ addr insts-offs)) (sap-ref-word sap insts-offs) #xFFFFFFE9058B48 ; MOV RAX,[RIP-23] (sap-ref-32 sap (+ insts-offs 7)) #x00FD60FF))) ; JMP [RAX-3] - (%set-funcallable-instance-info gf 0 slot-vector) + (setf (%funcallable-instance-info gf 0) slot-vector) gf)) (defun fdefn-has-static-callers (fdefn) @@ -390,7 +390,16 @@ (defun alloc-dynamic-space-code (total-words) (values (%primitive alloc-dynamic-space-code (the fixnum total-words)))) -;;; Remove calls via fdefns from CODE when compiling into memory. +(define-load-time-global *never-statically-link* '(find-package)) +;;; Remove calls via fdefns from CODE. This is called after compiling +;;; to memory, or when saving a core. +;;; Do not replace globally notinline functions, because notinline has +;;; an extra connotation of ensuring that replacement of the function +;;; under that name always works. It usually works to replace a statically +;;; linked function, but with a caveat: un-statically-linking requires calling +;;; MAP-OBJECTS-IN-RANGE, which is unreliable in the presence of +;;; multiple threads. Unfortunately, some users dangerously redefine +;;; builtin functions, and moreover, while there are multiple threads. (defun statically-link-code-obj (code fixups) (declare (ignorable code fixups)) (unless (immobile-space-obj-p code) @@ -413,7 +422,9 @@ (let* ((fdefn (code-header-ref code (+ fdefns-start i))) (fun (when (fdefn-p fdefn) (fdefn-fun fdefn)))) (when (and (immobile-space-obj-p fun) - (not (fun-requires-simplifying-trampoline-p fun))) + (not (fun-requires-simplifying-trampoline-p fun)) + (not (member (fdefn-name fdefn) *never-statically-link* :test 'equal)) + (neq (info :function :inlinep (fdefn-name fdefn)) 'notinline)) (setf any-replacements t (aref replacements i) fun)))) (dotimes (i fdefns-count) (when (and (aref replacements i) diff -Nru sbcl-2.1.10/src/cold/build-order.lisp-expr sbcl-2.1.11/src/cold/build-order.lisp-expr --- sbcl-2.1.10/src/cold/build-order.lisp-expr 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/cold/build-order.lisp-expr 2021-11-30 16:16:46.000000000 +0000 @@ -436,7 +436,7 @@ ("src/compiler/{arch}/show") ("src/compiler/{arch}/array") ("src/compiler/generic/type-error") - ("src/compiler/physenvanal") + ("src/compiler/envanal") ;; KLUDGE: The assembly files need to be compiled twice: once as ;; normal lisp files, and once by sb-c:assemble-file. We use a diff -Nru sbcl-2.1.10/src/cold/package-data-list.lisp-expr sbcl-2.1.11/src/cold/package-data-list.lisp-expr --- sbcl-2.1.10/src/cold/package-data-list.lisp-expr 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/cold/package-data-list.lisp-expr 2021-11-30 16:16:46.000000000 +0000 @@ -307,7 +307,7 @@ "DIS" "DO-FORMS-FROM-INFO" "EMIT-BLOCK-HEADER" - "PHYSENV-DEBUG-LIVE-TN" "PHYSENV-LIVE-TN" + "ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN" "FAST-SYMBOL-VALUE" "FAST-SYMBOL-GLOBAL-VALUE" "FIXUP-NOTE-KIND" @@ -329,7 +329,7 @@ "INSERT-STEP-CONDITIONS" "INSTRUMENT-CONSING" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" - "IR2-PHYSENV-NUMBER-STACK-P" + "IR2-ENVIRONMENT-NUMBER-STACK-P" "KNOWN-CALL-LOCAL" "KNOWN-RETURN" "LAMBDA-VAR-IGNOREP" "LAMBDA-WITH-LEXENV" "LEXENV-FIND" @@ -350,7 +350,7 @@ "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED" "MULTIPLE-CALL-VARIABLE" "%%NIP-VALUES" - "NLX-ENTRY" "NLX-ENTRY-MULTIPLE" + "NLX-ENTRY" "NLX-ENTRY-MULTIPLE" "NLX-ENTRY-SINGLE" "NODE-STACK-ALLOCATE-P" "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START" "NOTE-THIS-LOCATION" "*LOCATION-CONTEXT*" @@ -459,7 +459,8 @@ "MAP-PACKED-XREF-DATA" "MAP-SIMPLE-FUNS" "DO-BLOCKS" "DO-BLOCKS-BACKWARDS" - "DO-NODES" "DO-NODES-BACKWARDS")) + "DO-NODES" "DO-NODES-BACKWARDS" + "DO-IR2-BLOCKS")) #s(sb-cold:package-data :name "SB-DEBUG" @@ -1092,6 +1093,7 @@ "*RECOGNIZED-DECLARATIONS*" "+INFOS-PER-WORD+" "+FDEFN-INFO-NUM+" + "PACKED-INFO" "+NIL-PACKED-INFOS+" "ATOMIC-SET-INFO-VALUE" "CALL-WITH-EACH-GLOBALDB-NAME" @@ -1109,7 +1111,7 @@ "INFO-MAPHASH" "INFO-NUMBER" "INFO-NUMBER-BITS" - "INFO-VECTOR-FDEFN" + "PACKED-INFO-FDEFN" "MAKE-INFO-HASHTABLE" "META-INFO" "META-INFO-NUMBER" @@ -1557,6 +1559,7 @@ "%ARRAY-DISPLACED-FROM" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%ARRAY-RANK" "%ARRAY-RANK=" + "SIMPLE-ARRAY-HEADER-OF-RANK-P" "%ARRAY-ATOMIC-INCF/WORD" "%ASH/RIGHT" "%ASSOC" @@ -1587,7 +1590,6 @@ "%COMPARE-AND-SWAP-CAR" "%COMPARE-AND-SWAP-CDR" "%COMPARE-AND-SWAP-SVREF" - "%COMPARE-AND-SWAP-SYMBOL-INFO" "%COMPARE-AND-SWAP-SYMBOL-VALUE" "%CONCATENATE-TO-BASE-STRING" "%CONCATENATE-TO-STRING" @@ -2013,6 +2015,7 @@ "SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE" "SET-ARRAY-HEADER" "SET-HEADER-DATA" "ASSIGN-VECTOR-FLAGS" "LOGIOR-HEADER-BITS" "RESET-HEADER-BITS" + "LOGIOR-ARRAY-FLAGS" "RESET-ARRAY-FLAGS" "TEST-HEADER-BIT" "SHIFT-TOWARDS-END" "SHIFT-TOWARDS-START" "SHRINK-VECTOR" "%SHRINK-VECTOR" @@ -2190,6 +2193,7 @@ "DO-CLOSURE-VALUES" "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" + "%CLOSURE-INDEX-SET" "%CLOSURE-VALUES" ;; Abstract function accessors @@ -2277,7 +2281,7 @@ "MAKE-STATIC-CLASSOID" "%MAKE-SYMBOL" "%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH" "SYMBOL-HASH*" - "SYMBOL-INFO" "SYMBOL-INFO-VECTOR" + "SYMBOL-%INFO" "SYMBOL-DBINFO" "%INFO-REF" "EXTENDED-SEQUENCE" "*EXTENDED-SEQUENCE-TYPE*" "EXTENDED-SEQUENCE-P" @@ -2985,7 +2989,9 @@ "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT" "ARRAY-DISPLACED-FROM-SLOT" "ARRAY-ELEMENTS-SLOT" - "ARRAY-FILL-POINTER-SLOT" "ATOMIC-FLAG" + "ARRAY-FILL-POINTER-SLOT" + "ARRAY-RANK-POSITION" "ARRAY-FLAGS-POSITION" + "ARRAY-FLAGS-DATA-POSITION" "CHARACTER-REG-SC-NUMBER" "CHARACTER-STACK-SC-NUMBER" "CHARACTER-WIDETAG" "BIGNUM-DIGITS-OFFSET" "BIGNUM-WIDETAG" "BINDING-SIZE" @@ -3102,7 +3108,6 @@ "INSTANCE-WIDETAG" "INSTANCE-POINTER-LOWTAG" "INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE" "INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGS" - "INTERRUPTED-FLAG" "IS-LISP-POINTER" #+gencgc "LARGE-OBJECT-SIZE" "LAYOUT" @@ -3254,6 +3259,7 @@ "THREAD-SPROF-DATA-SLOT" "TLS-SIZE" "N-WIDETAG-BITS" "WIDETAG-MASK" "INSTANCE-LENGTH-SHIFT" + "INSTANCE-LENGTH-MASK" "UNBOUND-MARKER-WIDETAG" "UNDEFINED-FUNCTION-TRAP" "NO-TLS-VALUE-MARKER-WIDETAG" diff -Nru sbcl-2.1.10/src/cold/set-up-cold-packages.lisp sbcl-2.1.11/src/cold/set-up-cold-packages.lisp --- sbcl-2.1.10/src/cold/set-up-cold-packages.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/cold/set-up-cold-packages.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -535,7 +535,7 @@ (cond ((not s) (push (cons pkg string) nonexistent)) ((and (not (boundp s)) - (not (sb-kernel:symbol-info s)) + (not (sb-kernel:symbol-%info s)) (not (gethash s sb-c::*backend-parsed-vops*))) (push s uninteresting)))))))) (format t "~&Nonexistent:~%") diff -Nru sbcl-2.1.10/src/cold/shared.lisp sbcl-2.1.11/src/cold/shared.lisp --- sbcl-2.1.10/src/cold/shared.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/cold/shared.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -324,6 +324,8 @@ ("(and sb-safepoint (not sb-thread))" ":SB-SAFEPOINT requires :SB-THREAD") ("(and sb-thread (not (or riscv ppc ppc64 x86 x86-64 arm64)))" ":SB-THREAD not supported on selected architecture") + ("(and (not sb-thread) (or arm64 ppc64))" + "The selected architecture requires :SB-THREAD") ("(and gencgc cheneygc)" ":GENCGC and :CHENEYGC are incompatible") ("(and cheneygc (not (or arm mips ppc riscv sparc)))" diff -Nru sbcl-2.1.10/src/compiler/aliencomp.lisp sbcl-2.1.11/src/compiler/aliencomp.lisp --- sbcl-2.1.10/src/compiler/aliencomp.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/aliencomp.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -667,10 +667,10 @@ (cond #+arm-softfp - ((and (proper-list-of-length-p tn 3) - (symbolp (third tn))) + ((and (listp tn) + (symbolp (car (last tn)))) (emit-template call block - (template-or-lose (third tn)) + (template-or-lose (car (last tn))) (reference-tn (lvar-tn call block arg) nil) (reference-tn-list (butlast tn) t))) (t @@ -736,12 +736,12 @@ (cond #+arm-softfp ((and lvar - (fourth result-tns)) + (symbolp (car (last result-tns)))) (emit-template call block - (template-or-lose (fourth result-tns)) + (template-or-lose (car (last result-tns))) (reference-tn-list (butlast result-tns 2) nil) - (reference-tn (third result-tns) t)) - (move-lvar-result call block (list (third result-tns)) lvar)) + (reference-tn (car (last result-tns 2)) t)) + (move-lvar-result call block (list (car (last result-tns 2))) lvar)) (t (move-lvar-result call block result-tns lvar))))))) diff -Nru sbcl-2.1.10/src/compiler/arm/array.lisp sbcl-2.1.11/src/compiler/arm/array.lisp --- sbcl-2.1.10/src/compiler/arm/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -36,7 +36,7 @@ ;; See ENCODE-ARRAY-RANK. (inst sub ndescr rank (fixnumize 1)) (inst and ndescr ndescr (fixnumize array-rank-mask)) - (inst orr ndescr type (lsl ndescr array-rank-byte-pos)) + (inst orr ndescr type (lsl ndescr array-rank-position)) (inst mov ndescr (lsr ndescr n-fixnum-tag-bits)) ;; And store the header value. (storew ndescr header 0 other-pointer-lowtag)) diff -Nru sbcl-2.1.10/src/compiler/arm/call.lisp sbcl-2.1.11/src/compiler/arm/call.lisp --- sbcl-2.1.10/src/compiler/arm/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,48 +14,31 @@ (defconstant arg-count-sc (make-sc+offset immediate-arg-scn nargs-offset)) (defconstant closure-sc (make-sc+offset descriptor-reg-sc-number lexenv-offset)) -;;; Always wire the return PC location to the stack in its standard -;;; location. -(defun make-return-pc-passing-location (standard) - (declare (ignore standard)) - (make-wired-tn *backend-t-primitive-type* control-stack-sc-number - lra-save-offset)) - (defconstant return-pc-passing-offset (make-sc+offset control-stack-sc-number lra-save-offset)) -;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a -;;; location to pass OLD-FP in. -;;; -;;; This is wired in both the standard and the local-call conventions, -;;; because we want to be able to assume it's always there. Besides, -;;; the ARM doesn't have enough registers to really make it profitable -;;; to pass it in a register. -(defun make-old-fp-passing-location () - (make-wired-tn *fixnum-primitive-type* control-stack-sc-number - ocfp-save-offset)) - (defconstant old-fp-passing-offset (make-sc+offset control-stack-sc-number ocfp-save-offset)) ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current ;;; function. We treat these specially so that the debugger can find ;;; them at a known location. -(defun make-old-fp-save-location (env) +(defun make-old-fp-save-location () ;; Unlike the other backends, ARM function calling is designed to ;; pass OLD-FP within the stack frame rather than in a register. As ;; such, in order for lifetime analysis not to screw up, we need it ;; to be a stack TN wired to the save offset, not a normal TN with a ;; wired SAVE-TN. - (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset) - env)) -(defun make-return-pc-save-location (physenv) - (physenv-debug-live-tn - (make-wired-tn *backend-t-primitive-type* control-stack-sc-number - lra-save-offset) - physenv)) + (let ((tn (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + ocfp-save-offset))) + (setf (tn-kind tn) :environment) + tn)) +(defun make-return-pc-save-location () + (let ((tn (make-wired-tn *backend-t-primitive-type* control-stack-sc-number + lra-save-offset))) + (setf (tn-kind tn) :environment) + tn)) ;;; Make a TN for the standard argument count passing location. We ;;; only need to make the standard location, since a count is never @@ -151,7 +134,7 @@ (* (max 1 (sb-allocated-size 'control-stack)) n-word-bytes)) (store-csp nfp) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) (inst sub nfp nsp-tn nbytes) (inst mov nsp-tn nfp))))) diff -Nru sbcl-2.1.10/src/compiler/arm/c-call.lisp sbcl-2.1.11/src/compiler/arm/c-call.lisp --- sbcl-2.1.10/src/compiler/arm/c-call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/c-call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -55,7 +55,17 @@ #+arm-softfp (define-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) - (int-arg state 'single-float unsigned-reg-sc-number single-stack-sc-number)) + (let ((register (arg-state-num-register-args state))) + (cond ((>= register +max-register-args+) + (let ((frame-size (arg-state-stack-frame-size state))) + (incf (arg-state-stack-frame-size state)) + (make-wired-tn* 'single-float single-stack-sc-number frame-size))) + (t + (incf (arg-state-num-register-args state)) + (list + (make-wired-tn* 'unsigned-byte-32 unsigned-reg-sc-number + (register-args-offset register)) + 'move-single-to-int-args))))) #-arm-softfp (define-alien-type-method (single-float :arg-tn) (type state) @@ -123,7 +133,9 @@ #+arm-softfp (define-alien-type-method (single-float :result-tn) (type state) (declare (ignore type state)) - (make-wired-tn* 'single-float unsigned-reg-sc-number nargs-offset)) + (list (make-wired-tn* 'unsigned-byte-32 unsigned-reg-sc-number nargs-offset) + (make-normal-tn (primitive-type-or-lose 'single-float)) + 'move-int-args-to-single)) #-arm-softfp (define-alien-type-method (single-float :result-tn) (type state) @@ -247,26 +259,46 @@ ;;; #+arm-softfp -(define-vop (move-double-to-int-args) - (:args (double :scs (double-reg))) - (:results (lo-bits :scs (unsigned-reg)) - (hi-bits :scs (unsigned-reg))) - (:arg-types double-float) - (:result-types unsigned-num unsigned-num) - (:policy :fast-safe) - (:generator 1 - (inst fmrrd lo-bits hi-bits double))) - -#+arm-softfp -(define-vop (move-int-args-to-double) - (:args (lo-bits :scs (unsigned-reg)) - (hi-bits :scs (unsigned-reg))) - (:results (double :scs (double-reg))) - (:arg-types unsigned-num unsigned-num) - (:result-types double-float) - (:policy :fast-safe) - (:generator 1 - (inst fmdrr double lo-bits hi-bits))) +(progn + (define-vop (move-double-to-int-args) + (:args (double :scs (double-reg))) + (:results (lo-bits :scs (unsigned-reg)) + (hi-bits :scs (unsigned-reg))) + (:arg-types double-float) + (:result-types unsigned-num unsigned-num) + (:policy :fast-safe) + (:generator 1 + (inst fmrrd lo-bits hi-bits double))) + + + (define-vop (move-int-args-to-double) + (:args (lo-bits :scs (unsigned-reg)) + (hi-bits :scs (unsigned-reg))) + (:results (double :scs (double-reg))) + (:arg-types unsigned-num unsigned-num) + (:result-types double-float) + (:policy :fast-safe) + (:generator 1 + (inst fmdrr double lo-bits hi-bits))) + + (define-vop (move-single-to-int-args) + (:args (single :scs (single-reg))) + (:results (bits :scs (unsigned-reg))) + (:arg-types single-float) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (inst fmrs bits single))) + + + (define-vop (move-int-args-to-single) + (:args (bits :scs (unsigned-reg))) + (:results (single :scs (single-reg))) + (:arg-types unsigned-num) + (:result-types single-float) + (:policy :fast-safe) + (:generator 1 + (inst fmsr single bits)))) ;;; long-long support (deftransform %alien-funcall ((function type &rest args) * * :node node) diff -Nru sbcl-2.1.10/src/compiler/arm/cell.lisp sbcl-2.1.11/src/compiler/arm/cell.lisp --- sbcl-2.1.10/src/compiler/arm/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -61,14 +61,12 @@ (inst b :eq err-lab)))) ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) +(define-vop (boundp) (:args (object :scs (descriptor-reg))) (:conditional) (:info target not-p) (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value)) - -(define-vop (boundp boundp-frob) + (:temporary (:scs (descriptor-reg)) value) (:translate boundp) (:generator 9 (loadw value object symbol-value-slot other-pointer-lowtag) @@ -227,9 +225,9 @@ closure-info-offset fun-pointer-lowtag (descriptor-reg any-reg) * %closure-index-ref) -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (descriptor-reg any-reg null) * %set-funcallable-instance-info) +(define-full-setter %closure-index-set * + closure-info-offset fun-pointer-lowtag + (descriptor-reg any-reg null) * %closure-index-set) (define-full-reffer funcallable-instance-info * funcallable-instance-info-offset fun-pointer-lowtag @@ -286,8 +284,46 @@ (define-full-reffer code-header-ref * 0 other-pointer-lowtag (descriptor-reg any-reg) * code-header-ref) -(define-full-setter code-header-set * 0 other-pointer-lowtag - (descriptor-reg any-reg null) * code-header-set) +(define-vop (code-header-set) + (:translate code-header-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp card) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) pa-flag) + (:generator 10 + (let ((mask-fixup-label (gen-label)) + (table-fixup-label (gen-label))) + (inst load-from-label temp lip mask-fixup-label) + (inst ldr temp (@ temp)) + (inst ldr temp (@ temp)) + (pseudo-atomic (pa-flag) + ;; Compute card mark index + (inst mov card (lsr object gencgc-card-shift)) + (inst and card card temp) + ;; Load mark table base + (inst load-from-label temp lip table-fixup-label) + (inst ldr temp (@ temp)) + (inst ldr temp (@ temp)) + ;; Touch the card mark byte. + (inst mov lip 0) + (inst strb lip (@ temp card)) + ;; set 'written' flag in the code header + ;; If two threads get here at the same time, they'll write the same byte. + (let ((byte (- #+little-endian 3 other-pointer-lowtag))) + (inst ldrb temp (@ object byte)) + (inst orr temp temp #x40) + (inst strb temp (@ object byte))) + (inst sub temp index other-pointer-lowtag) + (inst str value (@ object temp))) + (assemble (:elsewhere) + (emit-label mask-fixup-label) + (inst word (make-fixup "gc_card_table_mask" :foreign-dataref)) + (emit-label table-fixup-label) + (inst word (make-fixup "gc_card_mark" :foreign-dataref)))))) ;;;; raw instance slot accessors diff -Nru sbcl-2.1.10/src/compiler/arm/nlx.lisp sbcl-2.1.11/src/compiler/arm/nlx.lisp --- sbcl-2.1.10/src/compiler/arm/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -182,6 +182,21 @@ (load-stack-tn move-temp sp) (store-csp move-temp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:temporary (:scs (descriptor-reg)) move-temp) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (move res value) + (load-stack-tn move-temp sp) + (store-csp move-temp))) + (define-vop (nlx-entry-multiple) (:args (top :target result) (src) (count)) ;; Again, no SC restrictions for the args, 'cause the loading would diff -Nru sbcl-2.1.10/src/compiler/arm/system.lisp sbcl-2.1.11/src/compiler/arm/system.lisp --- sbcl-2.1.10/src/compiler/arm/system.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/system.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -216,9 +216,9 @@ (inst sub ndescr ndescr (- other-pointer-lowtag fun-pointer-lowtag)) (inst add func code ndescr))) ;;; -(define-vop (symbol-info-vector) +(define-vop (symbol-dbinfo) (:policy :fast-safe) - (:translate symbol-info-vector) + (:translate symbol-dbinfo) (:args (x :scs (descriptor-reg))) (:results (res :scs (descriptor-reg))) (:temporary (:sc unsigned-reg) temp) @@ -228,19 +228,6 @@ (inst and temp res lowtag-mask) (inst cmp temp list-pointer-lowtag) (loadw res res cons-cdr-slot list-pointer-lowtag :eq))) - -(define-vop (symbol-plist) - (:policy :fast-safe) - (:translate symbol-plist) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x) - ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist. - (loadw res res cons-car-slot list-pointer-lowtag) - (inst tst res fixnum-tag-mask) - (inst mov :eq res null-tn))) ;;;; other miscellaneous VOPs diff -Nru sbcl-2.1.10/src/compiler/arm64/alloc.lisp sbcl-2.1.11/src/compiler/arm64/alloc.lisp --- sbcl-2.1.10/src/compiler/arm64/alloc.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,7 +12,7 @@ (in-package "SB-VM") (define-vop (list) - (:args (things :more t :scs (control-stack))) + (:args (things :more t :scs (descriptor-reg any-reg control-stack constant immediate))) (:temporary (:scs (descriptor-reg)) ptr) (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) res) @@ -21,38 +21,55 @@ (:info star cons-cells) (:results (result :scs (descriptor-reg))) (:node-var node) + (:vop-var vop) (:generator 0 - (macrolet ((maybe-load (tn) + (let ((alloc (* (pad-data-block cons-size) cons-cells)) + (dx (node-stack-allocate-p node)) + (prev-constant)) + (macrolet ((maybe-load (tn) (once-only ((tn tn)) `(sc-case ,tn ((any-reg descriptor-reg) ,tn) + ((immediate constant) + (cond ((eql (tn-value ,tn) 0) + zr-tn) + ((or (eql prev-constant (tn-value ,tn)) + (progn + (setf prev-constant (tn-value ,tn)) + nil)) + temp) + ((sc-is ,tn constant) + (load-constant vop ,tn temp) + temp) + (t + (load-immediate vop ,tn temp) + temp))) (control-stack + (setf prev-constant nil) (load-stack-tn temp ,tn) temp))))) - (let ((alloc (* (pad-data-block cons-size) cons-cells)) - (dx (node-stack-allocate-p node))) - (pseudo-atomic (pa-flag :sync nil :elide-if dx) - (allocation 'list alloc list-pointer-lowtag res - :flag-tn pa-flag - :stack-allocate-p dx - :lip lip) - (move ptr res) - (dotimes (i (1- cons-cells)) - (storew (maybe-load (tn-ref-tn things)) ptr - cons-car-slot list-pointer-lowtag) - (setf things (tn-ref-across things)) - (inst add ptr ptr (pad-data-block cons-size)) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-lowtag)) - (storew (maybe-load (tn-ref-tn things)) ptr - cons-car-slot list-pointer-lowtag) - (storew (if star - (maybe-load (tn-ref-tn (tn-ref-across things))) - null-tn) - ptr cons-cdr-slot list-pointer-lowtag)) - (move result res))))) + (pseudo-atomic (pa-flag :sync nil :elide-if dx) + (allocation 'list alloc list-pointer-lowtag res + :flag-tn pa-flag + :stack-allocate-p dx + :lip lip) + (move ptr res) + (dotimes (i (1- cons-cells)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-lowtag) + (setf things (tn-ref-across things)) + (inst add ptr ptr (pad-data-block cons-size)) + (storew ptr ptr + (- cons-cdr-slot cons-size) + list-pointer-lowtag)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-lowtag) + (storew (if star + (maybe-load (tn-ref-tn (tn-ref-across things))) + null-tn) + ptr cons-cdr-slot list-pointer-lowtag)) + (move result res))))) ;;;; Special purpose inline allocators. diff -Nru sbcl-2.1.10/src/compiler/arm64/array.lisp sbcl-2.1.11/src/compiler/arm64/array.lisp --- sbcl-2.1.10/src/compiler/arm64/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -37,7 +37,7 @@ ;; See ENCODE-ARRAY-RANK. (inst sub ndescr rank (fixnumize 1)) (inst and ndescr ndescr (fixnumize array-rank-mask)) - (inst orr ndescr type (lsl ndescr array-rank-byte-pos)) + (inst orr ndescr type (lsl ndescr array-rank-position)) (inst lsr ndescr ndescr n-fixnum-tag-bits) ;; And store the header value. (storew ndescr header 0 other-pointer-lowtag)) @@ -59,10 +59,44 @@ (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (inst ldrb res (@ x #+little-endian (- 2 other-pointer-lowtag) - #+big-endian (- 5 other-pointer-lowtag))) - (inst add res res 1) - (inst and res res array-rank-mask))) + (inst ldrsb res (@ x (- (/ array-rank-position n-word-bytes) + other-pointer-lowtag))) + (inst add res res 1))) + +(define-vop () + (:translate %array-rank=) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg))) + (:temporary (:scs (unsigned-reg)) x) + (:info rank) + (:arg-types * (:constant t)) + (:conditional :eq) + (:generator 2 + (inst ldrb x (@ array (- (/ array-rank-position n-word-bytes) + other-pointer-lowtag))) + (inst cmp x (add-sub-immediate (encode-array-rank rank))))) + +(define-vop (simple-array-header-of-rank-p type-predicate) + (:translate sb-c::simple-array-header-of-rank-p) + (:policy :fast-safe) + (:info target not-p rank) + (:arg-types * (:constant t)) + (:generator 2 + (unless (other-pointer-tn-ref-p args) + (%test-lowtag value temp (if not-p + target + drop-through) + t other-pointer-lowtag)) + (inst ldrh temp (@ value (- other-pointer-lowtag))) + (inst cmp temp (add-sub-immediate + (dpb (encode-array-rank rank) + (byte 8 array-rank-position) + simple-array-widetag))) + (inst b (if not-p + :ne + :eq) + target) + drop-through)) ;;;; Bounds checking routine. (define-vop (check-bound) @@ -228,12 +262,12 @@ (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) + (index :scs (unsigned-reg) :to :save)) (:arg-types ,type positive-fixnum) - (:results (value :scs (any-reg))) + (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) + (:temporary (:scs (non-descriptor-reg)) temp) (:generator 20 ;; Compute the offset for the word we're interested in. (inst lsr temp index ,bit-shift) @@ -253,9 +287,7 @@ ;; Shift the field we need to the low bits of RESULT. (inst lsr result result temp) ;; Mask out the field we're interested in. - (inst and result result ,(1- (ash 1 bits))) - ;; And fixnum-tag the result. - (inst lsl value result n-fixnum-tag-bits))) + (inst and result result ,(1- (ash 1 bits))))) (define-vop (,(symbolicate "DATA-VECTOR-REF/" type "-C")) (:note "inline array access") (:translate data-vector-ref) @@ -263,9 +295,8 @@ (:args (object :scs (descriptor-reg))) (:info index) (:arg-types ,type (:constant index)) - (:results (value :scs (any-reg))) + (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) result) (:generator 15 (multiple-value-bind (index bit) (floor index ,elements-per-word) (inst ldr result (@ object @@ -273,8 +304,7 @@ (+ (* index n-word-bytes) (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))) - (inst ubfm result result (* bit ,bits) (+ (* bit ,bits) (1- ,bits))) - (inst lsl value result n-fixnum-tag-bits)))) + (inst ubfm result result (* bit ,bits) (+ (* bit ,bits) (1- ,bits)))))) (define-vop (,(symbolicate "DATA-VECTOR-SET/" type "-C")) (:note "inline array store") (:translate data-vector-set) @@ -320,47 +350,75 @@ ,@(unless (= bits 1) '((:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift))) (:generator 25 - (let ((shift ,(if (= bits 1) - 'index - 'shift))) - ;; Compute the offset for the word we're interested in. - (inst lsr temp index ,bit-shift) - ;; Load the word in question. - (inst add lip object (lsl temp word-shift)) - (inst ldr old (@ lip - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))) - ;; Compute the position of the bitfield we need. - ,@(unless (= bits 1) - `((inst and shift index ,(1- elements-per-word)))) - ,@(when (eq *backend-byte-order* :big-endian) - `((inst eor shift ,(1- elements-per-word)))) - ,@(unless (= bits 1) - `((inst lsl shift shift ,(1- (integer-length bits))))) - ;; Clear the target bitfield. - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (inst mov temp ,(1- (ash 1 bits))) - (inst lsl temp temp shift) - (inst bic old old temp)) - (unless (and (sc-is value immediate) - (= (tn-value value) 0)) - ;; LOGIOR in the new value (shifted appropriatly). - (sc-case value - (immediate - (inst mov temp (logand (tn-value value) ,(1- (ash 1 bits)))) - (inst lsl temp temp shift)) - (unsigned-reg - (inst lsl temp value shift))) - (inst orr old old temp)) - ;; Write the altered word back to the array. - (inst str old (@ lip - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)))))))))) + (let ((shift ,(if (= bits 1) + 'index + 'shift))) + ;; Compute the offset for the word we're interested in. + (inst lsr temp index ,bit-shift) + ;; Load the word in question. + (inst add lip object (lsl temp word-shift)) + (inst ldr old (@ lip + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag))) + ;; Compute the position of the bitfield we need. + ,@(unless (= bits 1) + `((inst and shift index ,(1- elements-per-word)))) + ,@(when (eq *backend-byte-order* :big-endian) + `((inst eor shift ,(1- elements-per-word)))) + ,@(unless (= bits 1) + `((inst lsl shift shift ,(1- (integer-length bits))))) + ;; Clear the target bitfield. + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst mov temp ,(1- (ash 1 bits))) + (inst lsl temp temp shift) + (inst bic old old temp)) + (unless (and (sc-is value immediate) + (= (tn-value value) 0)) + ;; LOGIOR in the new value (shifted appropriatly). + (sc-case value + (immediate + (inst mov temp (logand (tn-value value) ,(1- (ash 1 bits)))) + (inst lsl temp temp shift)) + (unsigned-reg + (inst lsl temp value shift))) + (inst orr old old temp)) + ;; Write the altered word back to the array. + (inst str old (@ lip + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag)))))))))) (def-small-data-vector-frobs simple-bit-vector 1) (def-small-data-vector-frobs simple-array-unsigned-byte-2 2) (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)) +(define-vop (data-vector-ref/simple-bit-vector-eq) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (unsigned-reg))) + (:arg-types simple-bit-vector positive-fixnum) + (:conditional :eq) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg)) temp x) + (:generator 20 + (inst lsr temp index 6) + (inst add lip object (lsl temp word-shift)) + (inst ldr x (@ lip (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))) + (inst lsr x x index) + (inst tst x 1))) + +(define-vop (data-vector-ref/simple-bit-vector-c-eq) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-bit-vector (:constant index)) + (:conditional :eq) + (:temporary (:scs (non-descriptor-reg)) x) + (:generator 15 + (multiple-value-bind (index bit) + (floor index 64) + (inst ldr x (@ object (load-store-offset (+ (* index n-word-bytes) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))) + (inst tst x (ash 1 bit))))) + ;;; And the float variants. (define-vop (data-vector-ref/simple-array-single-float) (:note "inline array access") diff -Nru sbcl-2.1.10/src/compiler/arm64/call.lisp sbcl-2.1.11/src/compiler/arm64/call.lisp --- sbcl-2.1.10/src/compiler/arm64/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,51 +14,31 @@ (defconstant arg-count-sc (make-sc+offset immediate-arg-scn nargs-offset)) (defconstant closure-sc (make-sc+offset descriptor-reg-sc-number lexenv-offset)) -;;; Make a passing location TN for a local call return PC. If -;;; standard is true, then use the standard (full call) location, -;;; otherwise use any legal location. Even in the non-standard case, -;;; this may be restricted by a desire to use a subroutine call -;;; instruction. -(defun make-return-pc-passing-location (standard) - (declare (ignore standard)) - (make-wired-tn *backend-t-primitive-type* control-stack-sc-number - lra-save-offset)) - (defconstant return-pc-passing-offset (make-sc+offset control-stack-sc-number lra-save-offset)) -;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a -;;; location to pass OLD-FP in. -;;; -;;; This is wired in both the standard and the local-call conventions, -;;; because we want to be able to assume it's always there. Besides, -;;; the ARM doesn't have enough registers to really make it profitable -;;; to pass it in a register. -(defun make-old-fp-passing-location () - (make-wired-tn *fixnum-primitive-type* control-stack-sc-number - ocfp-save-offset)) - (defconstant old-fp-passing-offset (make-sc+offset control-stack-sc-number ocfp-save-offset)) ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current ;;; function. We treat these specially so that the debugger can find ;;; them at a known location. -(defun make-old-fp-save-location (env) +(defun make-old-fp-save-location () ;; Unlike the other backends, ARM function calling is designed to ;; pass OLD-FP within the stack frame rather than in a register. As ;; such, in order for lifetime analysis not to screw up, we need it ;; to be a stack TN wired to the save offset, not a normal TN with a ;; wired SAVE-TN. - (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset) - env)) -(defun make-return-pc-save-location (physenv) - (physenv-debug-live-tn - (make-wired-tn *backend-t-primitive-type* control-stack-sc-number - lra-save-offset) - physenv)) + (let ((tn (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + ocfp-save-offset))) + (setf (tn-kind tn) :environment) + tn)) +(defun make-return-pc-save-location () + (let ((tn (make-wired-tn *backend-t-primitive-type* control-stack-sc-number + lra-save-offset))) + (setf (tn-kind tn) :environment) + tn)) ;;; Make a TN for the standard argument count passing location. We ;;; only need to make the standard location, since a count is never @@ -143,7 +123,7 @@ (move res csp-tn) (inst add csp-tn csp-tn (add-sub-immediate (* (max 1 (sb-allocated-size 'control-stack)) n-word-bytes))) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (inst sub nfp nsp-tn (add-sub-immediate (bytes-needed-for-non-descriptor-stack-frame))) (inst mov-sp nsp-tn nfp)))) @@ -151,17 +131,21 @@ ;;; Allocate a partial frame for passing stack arguments in a full call. Nargs ;;; is the number of arguments passed. If no stack arguments are passed, then ;;; we don't have to do anything. +;;; LR and CFP are always saved on the stack, but it's safe to have two words above CSP. (define-vop (allocate-full-call-frame) (:info nargs) (:results (res :scs (any-reg))) (:generator 2 - (move res csp-tn) - (let ((size (add-sub-immediate (* (max 2 nargs) n-word-bytes)))) - (cond ((typep size '(signed-byte 9)) - (inst str cfp-tn (@ csp-tn size :post-index))) - (t - (inst add csp-tn csp-tn size) - (storew cfp-tn res ocfp-save-offset)))))) + (if (<= nargs register-arg-count) + ;; Don't touch RES, the call vops would use CSP-TN in this case. + (storew cfp-tn csp-tn ocfp-save-offset) + (let ((size (add-sub-immediate (* nargs n-word-bytes)))) + (move res csp-tn) + (cond ((typep size '(signed-byte 9)) + (inst str cfp-tn (@ csp-tn size :post-index))) + (t + (inst add csp-tn csp-tn size) + (storew cfp-tn res ocfp-save-offset))))))) ;;; Emit code needed at the return-point from an unknown-values call ;;; for a fixed number of values. VALUES is the head of the TN-REF @@ -802,15 +786,15 @@ (:ignore val-locs vals) (:vop-var vop) (:generator 6 - (maybe-load-stack-tn old-fp-temp old-fp) - (maybe-load-stack-tn lip return-pc) - (move csp-tn cfp-tn) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst add nsp-tn cur-nfp (add-sub-immediate - (bytes-needed-for-non-descriptor-stack-frame))))) - (move cfp-tn old-fp-temp) - (lisp-return lip :known))) + (maybe-load-stack-tn old-fp-temp old-fp) + (maybe-load-stack-tn lip return-pc) + (move csp-tn cfp-tn) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp (add-sub-immediate + (bytes-needed-for-non-descriptor-stack-frame))))) + (move cfp-tn old-fp-temp) + (lisp-return lip :known))) ;;;; Full call: ;;; @@ -981,7 +965,12 @@ `((:frob-nfp (store-stack-tn nfp-save cur-nfp)) (:load-fp - (move cfp-tn new-fp)))) + (move cfp-tn (cond ,@(and + (not variable) + '(((<= nargs register-arg-count) + csp-tn))) + (t + new-fp)))))) ((nil))))) (insert-step-instrumenting () ;; Conditionally insert a conditional trap: diff -Nru sbcl-2.1.10/src/compiler/arm64/cell.lisp sbcl-2.1.11/src/compiler/arm64/cell.lisp --- sbcl-2.1.10/src/compiler/arm64/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -24,7 +24,7 @@ (define-vop (set-slot) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) + (value :scs (descriptor-reg any-reg zero))) (:info name offset lowtag) (:ignore name) (:results) @@ -67,13 +67,6 @@ (:policy :fast-safe) (:vop-var vop) (:save-p :compute-only)) -;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) - (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value)) ;;; With Symbol-Value, we check that the value isn't the trap object. So ;;; Symbol-Value of NIL is NIL. @@ -81,7 +74,7 @@ (progn (define-vop (set) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) + (value :scs (descriptor-reg any-reg zero))) (:temporary (:sc any-reg) tls-index) (:generator 4 (inst ldr (32-bit-reg tls-index) (tls-index-of object)) @@ -131,27 +124,17 @@ LOCAL)))) (when check-boundp - (let ((err-lab (generate-error-code vop 'unbound-symbol-error symbol))) - (inst cmp value unbound-marker-widetag) - (inst b :eq err-lab))))) + (assemble () + (let* ((*location-context* (make-restart-location RETRY value)) + (err-lab (generate-error-code vop 'unbound-symbol-error symbol))) + (inst cmp value unbound-marker-widetag) + (inst b :eq err-lab)) + RETRY)))) (define-vop (fast-symbol-value symbol-value) (:policy :fast) (:variant nil) - (:variant-cost 5)) - - (define-vop (boundp boundp-frob) - (:translate boundp) - (:temporary (:sc any-reg) tls-index) - (:generator 9 - (inst ldr (32-bit-reg tls-index) (tls-index-of object)) - (inst ldr value (@ thread-tn tls-index)) - (inst cmp value no-tls-value-marker-widetag) - (inst b :ne LOCAL) - (loadw value object symbol-value-slot other-pointer-lowtag) - LOCAL - (inst cmp value unbound-marker-widetag) - (inst b (if not-p :eq :ne) target)))) + (:variant-cost 5))) #-sb-thread (progn @@ -167,14 +150,30 @@ (define-vop (fast-symbol-value cell-ref) (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) - (:translate symeval)) + (:translate symeval))) - (define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 +(define-vop (boundp) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (descriptor-reg)) value) + (:translate boundp) + #+sb-thread + (:generator 9 + (inst ldr (32-bit-reg value) (tls-index-of object)) + (inst ldr value (@ thread-tn value)) + (inst cmp value no-tls-value-marker-widetag) + (inst b :ne LOCAL) + (loadw value object symbol-value-slot other-pointer-lowtag) + LOCAL + (inst cmp value unbound-marker-widetag) + (inst b (if not-p :eq :ne) target)) + #-sb-thread + (:generator 9 (loadw value object symbol-value-slot other-pointer-lowtag) (inst cmp value unbound-marker-widetag) - (inst b (if not-p :eq :ne) target)))) + (inst b (if not-p :eq :ne) target))) (define-vop (%set-symbol-global-value cell-set) (:variant symbol-value-slot other-pointer-lowtag)) @@ -201,7 +200,7 @@ (:policy :fast-safe) (:translate symbol-hash) (:args (symbol :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) + (:args-var args) (:results (res :scs (any-reg))) (:result-types positive-fixnum) (:generator 2 @@ -209,8 +208,9 @@ ;; car slot, so we have to strip off the fixnum-tag-mask to make sure ;; it is a fixnum. The lowtag selection magic that is required to ;; ensure this is explained in the comment in objdef.lisp - (loadw temp symbol symbol-hash-slot other-pointer-lowtag) - (inst and res temp (bic-mask fixnum-tag-mask)))) + (loadw res symbol symbol-hash-slot other-pointer-lowtag) + (unless (not-nil-tn-ref-p args) + (inst and res res (bic-mask fixnum-tag-mask))))) (define-vop (%compare-and-swap-symbol-value) (:translate %compare-and-swap-symbol-value) @@ -348,15 +348,13 @@ #+sb-thread (progn (define-vop (dynbind) - (:args (value :scs (any-reg descriptor-reg) :to :save) + (:args (value :scs (any-reg descriptor-reg zero) :to :save) (symbol :scs (descriptor-reg) :load-if (not (and (sc-is symbol constant) (or (symbol-always-has-tls-value-p (tn-value symbol)) - (symbol-always-has-tls-index-p (tn-value symbol)) - ))) - )) + (symbol-always-has-tls-index-p (tn-value symbol))))))) (:temporary (:sc descriptor-reg) value-temp) - (:temporary (:sc descriptor-reg :offset r0-offset :from (:argument 1)) alloc-tls-symbol) + (:temporary (:sc descriptor-reg :offset r8-offset :from (:argument 1)) alloc-tls-symbol) (:temporary (:sc non-descriptor-reg :offset nl0-offset) tls-index) (:temporary (:sc non-descriptor-reg :offset nl1-offset) free-tls-index) (:temporary (:sc interior-reg) lip) @@ -478,9 +476,9 @@ closure-info-offset fun-pointer-lowtag (descriptor-reg any-reg) * %closure-index-ref) -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (descriptor-reg any-reg) * %set-funcallable-instance-info) +(define-full-setter %closure-index-set * + closure-info-offset fun-pointer-lowtag + (descriptor-reg any-reg) * %closure-index-set) (define-full-reffer funcallable-instance-info * funcallable-instance-info-offset fun-pointer-lowtag @@ -554,8 +552,39 @@ (descriptor-reg any-reg) * code-header-ref) #-darwin-jit -(define-full-setter code-header-set * 0 other-pointer-lowtag - (descriptor-reg any-reg) * code-header-set) +(define-vop (code-header-set) + (:translate code-header-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp card) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) pa-flag) + (:generator 10 + (load-inline-constant temp `(:fixup "gc_card_table_mask" :foreign-dataref) lip) + (inst ldr temp (@ temp)) + (inst ldr (32-bit-reg temp) (@ temp)) ; 4-byte int + (pseudo-atomic (pa-flag) + ;; Compute card mark index + (inst lsr card object gencgc-card-shift) + (inst and card card temp) + ;; Load mark table base + (load-inline-constant temp `(:fixup "gc_card_mark" :foreign-dataref) lip) + (inst ldr temp (@ temp)) + (inst ldr temp (@ temp)) + ;; Touch the card mark byte. + (inst strb zr-tn (@ temp card)) + ;; set 'written' flag in the code header + ;; If two threads get here at the same time, they'll write the same byte. + (let ((byte (- #+big-endian 4 #+little-endian 3 other-pointer-lowtag))) + (inst ldrb temp (@ object byte)) + (inst orr temp temp #x40) + (inst strb temp (@ object byte))) + (inst lsl temp index (- word-shift n-fixnum-tag-bits)) + (inst sub temp temp other-pointer-lowtag) + (inst str value (@ object temp))))) ;;;; raw instance slot accessors diff -Nru sbcl-2.1.10/src/compiler/arm64/float.lisp sbcl-2.1.11/src/compiler/arm64/float.lisp --- sbcl-2.1.10/src/compiler/arm64/float.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/float.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -144,7 +144,7 @@ (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) (:note "complex single float move") (:generator 0 - (inst s-mov y x))) + (move-complex-double y x))) (define-move-vop complex-single-move :move (complex-single-reg) (complex-single-reg)) @@ -154,7 +154,7 @@ (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) (:note "complex double float move") (:generator 0 - (inst s-mov y x))) + (move-complex-double y x))) (define-move-vop complex-double-move :move (complex-double-reg) (complex-double-reg)) @@ -243,7 +243,7 @@ (:generator 2 (sc-case y (complex-double-reg - (inst s-mov y x)) + (move-complex-double y x)) (complex-double-stack (storew x nfp (tn-offset y)))))) (define-move-vop move-complex-double-float-arg :move-arg diff -Nru sbcl-2.1.10/src/compiler/arm64/insts.lisp sbcl-2.1.11/src/compiler/arm64/insts.lisp --- sbcl-2.1.10/src/compiler/arm64/insts.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -2999,25 +2999,26 @@ (when (and (eql cmp 0) (eq target zr-tn)) (destructuring-bind (flag label) (stmt-operands next) - (when (case flag - (:eq - (setf (stmt-mnemonic stmt) 'cbz - (stmt-operands stmt) - (list value label))) - (:ne - (setf (stmt-mnemonic stmt) 'cbnz - (stmt-operands stmt) - (list value label))) - (:ge - (setf (stmt-mnemonic stmt) 'tbz* - (stmt-operands stmt) - (list value (1- n-word-bits) label))) - (:lt - (setf (stmt-mnemonic stmt) 'tbnz* - (stmt-operands stmt) - (list value (1- n-word-bits) label)))) - (delete-stmt next) - next-next))))))) + (unless (eq (sb-assem::label-comment label) :merged-ifs) + (when (case flag + (:eq + (setf (stmt-mnemonic stmt) 'cbz + (stmt-operands stmt) + (list value label))) + (:ne + (setf (stmt-mnemonic stmt) 'cbnz + (stmt-operands stmt) + (list value label))) + (:ge + (setf (stmt-mnemonic stmt) 'tbz* + (stmt-operands stmt) + (list value (1- n-word-bits) label))) + (:lt + (setf (stmt-mnemonic stmt) 'tbnz* + (stmt-operands stmt) + (list value (1- n-word-bits) label)))) + (delete-stmt next) + next-next)))))))) (defpattern "tst one bit + branch" ((ands) (b)) (stmt next) (let ((next-next (stmt-next next))) @@ -3042,7 +3043,7 @@ next-next))))))) (defun stmt-delete-safe-p (dst1 dst2 &optional safe-translates - safe-vops) + safe-vops) (or (location= dst1 dst2) (and (not (tn-ref-next (sb-c::tn-reads dst1))) @@ -3085,6 +3086,21 @@ (delete-stmt stmt) next)))) +;;; Helps with SBIT +(defpattern "and + lsl -> ubfiz" ((and) (ubfm)) (stmt next) + (destructuring-bind (dst1 src1 mask) (stmt-operands stmt) + (destructuring-bind (dst2 src2 immr imms) (stmt-operands next) + (when (and (location= dst1 src2) + (untagged-mask-p mask) + (= immr 63) + (= imms 62) + (stmt-delete-safe-p dst1 dst2 nil '(sb-vm::move-from-word/fixnum))) + (setf (stmt-mnemonic next) 'ubfm + (stmt-operands next) (list dst2 src1 63 (1- (logcount mask)))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + ;;; If the sign bit gets cut off it can be done with just a logical shift. (defpattern "asr + and -> lsr" ((sbfm) (and)) (stmt next) (destructuring-bind (dst1 src1 immr imms) (stmt-operands stmt) @@ -3174,6 +3190,39 @@ (add-stmt-labels next (stmt-labels stmt)) (delete-stmt stmt) next)))) + +(defpattern "lsl + lsl -> lsl" ((ubfm) (ubfm)) (stmt next) + (destructuring-bind (dst1 src1 immr1 imms1) (stmt-operands stmt) + (destructuring-bind (dst2 src2 immr2 imms2) (stmt-operands next) + (when (and (/= imms1 63) + (/= imms2 63) + (= (1+ imms1) immr1) + (= (1+ imms2) immr2) + (location= dst1 src2) + (stmt-delete-safe-p dst1 dst2 + '(ash + sb-vm::ash-left-mod64 + sb-vm::ash-left-modfx))) + (let ((shift (+ (- 63 imms1) + (- 63 imms2)))) + (when (<= shift 63) + (setf (stmt-operands next) (list dst2 src1 (mod (- shift) 64) (- 63 shift))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))))) + +(defpattern "asr + asr -> asr" ((sbfm) (sbfm)) (stmt next) + (destructuring-bind (dst1 src1 immr1 imms1) (stmt-operands stmt) + (destructuring-bind (dst2 src2 immr2 imms2) (stmt-operands next) + (when (and (= imms1 imms2 63) + (location= dst1 src2) + (stmt-delete-safe-p dst1 dst2 + nil '(sb-vm::move-to-word/fixnum))) + (setf (stmt-operands next) + (list dst2 src1 (min (+ immr1 immr2) 63) 63)) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) ;;; An even number can be shifted right and then negated, ;;; and fixnums are even. diff -Nru sbcl-2.1.10/src/compiler/arm64/macros.lisp sbcl-2.1.11/src/compiler/arm64/macros.lisp --- sbcl-2.1.10/src/compiler/arm64/macros.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -380,14 +380,10 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)) - (value :scs ,scs - :load-if (not (and (sc-is value immediate) - (eql (tn-value value) 0))))) + (value :scs (,@scs zero))) (:arg-types ,type tagged-num ,el-type) (:temporary (:scs (interior-reg)) lip) (:generator 2 - (when (sc-is value immediate) - (setf value zr-tn)) (sc-case index (immediate (inst str value (@ object (load-store-offset diff -Nru sbcl-2.1.10/src/compiler/arm64/move.lisp sbcl-2.1.11/src/compiler/arm64/move.lisp --- sbcl-2.1.10/src/compiler/arm64/move.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/move.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -172,6 +172,7 @@ :scs (any-reg descriptor-reg) :load-if (not (or (location= x y) (and (sc-is x immediate) + (sc-is y control-stack) (eql (tn-value x) 0)))))) (:results (y :scs (any-reg descriptor-reg control-stack) :load-if (not (location= x y)))) @@ -194,7 +195,10 @@ ;;; frame for argument or known value passing. (define-vop (move-arg) (:args (x :target y - :scs (any-reg descriptor-reg)) + :scs (any-reg descriptor-reg) + :load-if (not (and (sc-is x immediate) + (sc-is y control-stack) + (eql (tn-value x) 0)))) (fp :scs (any-reg) :load-if (not (sc-is y any-reg descriptor-reg)))) (:results (y)) @@ -203,7 +207,11 @@ ((any-reg descriptor-reg) (move y x)) (control-stack - (store-stack-offset x fp y))))) + (store-stack-offset (if (and (sc-is x immediate) + (eql (tn-value x) 0)) + zr-tn + x) + fp y))))) ;;; (define-move-vop move-arg :move-arg (any-reg descriptor-reg) diff -Nru sbcl-2.1.10/src/compiler/arm64/nlx.lisp sbcl-2.1.11/src/compiler/arm64/nlx.lisp --- sbcl-2.1.10/src/compiler/arm64/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -140,7 +140,7 @@ (define-vop (nlx-entry) (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. + ; would be inserted before the label. (start) (count)) (:results (values :more t :from :load)) @@ -180,6 +180,19 @@ (store-stack-tn tn move-temp)))))))) (load-stack-tn csp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-label label) + (note-this-location vop :non-local-entry) + (inst mov res value) + (load-stack-tn csp-tn sp))) + (define-vop (nlx-entry-multiple) (:args (top :target result) (src) diff -Nru sbcl-2.1.10/src/compiler/arm64/pred.lisp sbcl-2.1.11/src/compiler/arm64/pred.lisp --- sbcl-2.1.10/src/compiler/arm64/pred.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/pred.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -89,40 +89,28 @@ (:generator 0 (let ((not-p (eq (first flags) 'not))) (when not-p (pop flags)) - (flet ((zr (tn) - (cond ((and (eq (tn-kind tn) :constant) - (eq (tn-value tn) 0)) - zr-tn) - (t - tn)))) - (setf then (zr then) - else (zr else)) - (cond ((null (rest flags)) - (inst csel res then else (if not-p - (negate-condition (car flags)) - (car flags)))) - (not-p - (dolist (flag flags) - (inst csel res else then flag))) - (t - (dolist (flag flags) - (inst csel res then else flag)))))))) + (cond ((null (rest flags)) + (inst csel res then else (if not-p + (negate-condition (car flags)) + (car flags)))) + (not-p + (dolist (flag flags) + (inst csel res else then flag))) + (t + (dolist (flag flags) + (inst csel res then else flag))))))) (macrolet ((def-move-if (name type reg) `(define-vop (,name move-if) - (:args (then :scs ,reg - :load-if (not (and (sc-is then immediate) - (eql (tn-value then) 0)))) - (else :scs ,reg - :load-if (not (and (sc-is else immediate) - (eql (tn-value else) 0))))) + (:args (then :scs ,reg) + (else :scs ,reg)) (:arg-types ,type ,type) (:results (res :scs ,reg)) (:result-types ,type)))) - (def-move-if move-if/descriptor * (descriptor-reg any-reg)) - (def-move-if move-if/word (:or unsigned-num signed-num) (unsigned-reg signed-reg)) - (def-move-if move-if/char character (character-reg)) - (def-move-if move-if/sap system-area-pointer (sap-reg))) + (def-move-if move-if/descriptor * (descriptor-reg any-reg zero)) + (def-move-if move-if/word (:or unsigned-num signed-num) (unsigned-reg signed-reg zero)) + (def-move-if move-if/char character (character-reg zero)) + (def-move-if move-if/sap system-area-pointer (sap-reg zero))) ;;;; Conditional VOPs: @@ -133,17 +121,24 @@ :load-if (sc-case y ((any-reg descriptor-reg)) (immediate - (not (fixnum-add-sub-immediate-p (tn-value y)))) + (not (and (integerp (tn-value y)) + (abs-add-sub-immediate-p (fixnumize (tn-value y)))))) (t t)))) (:conditional :eq) (:policy :fast-safe) (:translate eq) (:generator 6 - (inst cmp x - (sc-case y - (immediate - (fixnumize (tn-value y))) - (t y))))) + (let ((value (sc-case y + (immediate + (fixnumize (tn-value y))) + (t y)))) + (cond ((or (not (integerp value)) + (add-sub-immediate-p value)) + (inst cmp x value)) + ((minusp value) + (inst cmn x (- value))) + (t + (inst cmn x (ldb (byte n-word-bits 0) (- value)))))))) (macrolet ((def (eq-name eql-name cost) `(define-vop (,eq-name ,eql-name) diff -Nru sbcl-2.1.10/src/compiler/arm64/sap.lisp sbcl-2.1.11/src/compiler/arm64/sap.lisp --- sbcl-2.1.10/src/compiler/arm64/sap.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/sap.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -158,31 +158,65 @@ (:results (result :scs (,sc))) (:result-types ,type) (:generator 5 - (inst ,(case size - (:byte (if signed 'ldrsb 'ldrb)) - (:short (if signed 'ldrsh 'ldrh)) - (:word (if signed 'ldrsw 'ldr)) - (t 'ldr)) - ,(if (eq size :word) - '(32-bit-reg result) - 'result) - (@ sap offset)))) + (inst ,(case size + (:byte (if signed 'ldrsb 'ldrb)) + (:short (if signed 'ldrsh 'ldrh)) + (:word (if signed 'ldrsw 'ldr)) + (t 'ldr)) + ,(if (eq size :word) + '(32-bit-reg result) + 'result) + (@ sap offset)))) (define-vop (,set-name) (:translate ,set-name) (:policy :fast-safe) - (:args (value :scs (,sc)) + (:args (value :scs (,sc zero)) (sap :scs (sap-reg)) (offset :scs (signed-reg))) (:arg-types ,type system-area-pointer signed-num) (:generator 5 - (inst ,(case size - (:byte 'strb) - (:short 'strh) - (t 'str)) - ,(if (eq size :word) - '(32-bit-reg value) - 'value) - (@ sap offset))))))) + (inst ,(case size + (:byte 'strb) + (:short 'strh) + (t 'str)) + ,(if (eq size :word) + '(32-bit-reg value) + 'value) + (@ sap offset)))) + (define-vop (,(symbolicate ref-name "-C")) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (satisfies ldr-str-offset-encodable))) + (:RESULTS (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + (inst ,(case size + (:byte (if signed 'ldrsb 'ldrb)) + (:short (if signed 'ldrsh 'ldrh)) + (:word (if signed 'ldrsw 'ldr)) + (t 'ldr)) + ,(if (eq size :word) + '(32-bit-reg result) + 'result) + (@ sap offset)))) + (define-vop (,(symbolicate set-name "-C")) + (:translate ,set-name) + (:policy :fast-safe) + (:args (value :scs (,sc zero)) + (sap :scs (sap-reg))) + (:info offset) + (:arg-types ,type system-area-pointer (:constant (satisfies ldr-str-offset-encodable))) + (:generator 4 + (inst ,(case size + (:byte 'strb) + (:short 'strh) + (t 'str)) + ,(if (eq size :word) + '(32-bit-reg value) + 'value) + (@ sap offset))))))) (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 unsigned-reg positive-fixnum :byte :signed nil) (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 diff -Nru sbcl-2.1.10/src/compiler/arm64/system.lisp sbcl-2.1.11/src/compiler/arm64/system.lisp --- sbcl-2.1.10/src/compiler/arm64/system.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/system.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -225,7 +225,7 @@ (inst add func code ndescr))) ;;; -(defun load-symbol-info-vector (result symbol temp) +(defun load-symbol-dbinfo (result symbol temp) (assemble () (loadw result symbol symbol-info-slot other-pointer-lowtag) ;; If RESULT has list-pointer-lowtag, take its CDR. If not, use it as-is. @@ -235,27 +235,14 @@ (loadw result result cons-cdr-slot list-pointer-lowtag) NE)) -(define-vop (symbol-info-vector) +(define-vop (symbol-dbinfo) (:policy :fast-safe) - (:translate symbol-info-vector) + (:translate symbol-dbinfo) (:args (x :scs (descriptor-reg))) (:results (res :scs (descriptor-reg))) (:temporary (:sc unsigned-reg) temp) (:generator 1 - (load-symbol-info-vector res x temp))) - -(define-vop (symbol-plist) - (:policy :fast-safe) - (:translate symbol-plist) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x) - ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist. - (loadw res res cons-car-slot list-pointer-lowtag) - (inst tst res fixnum-tag-mask) - (inst csel res null-tn res :eq))) + (load-symbol-dbinfo res x temp))) ;;;; other miscellaneous VOPs @@ -288,10 +275,10 @@ (:result-types system-area-pointer) (:translate current-thread-offset-sap) (:info n) - (:arg-types (:constant (satisfies ldr-str-offset-encodable))) + (:arg-types (:constant (satisfies ldr-str-word-offset-encodable))) (:policy :fast-safe) (:generator 1 - (inst ldr sap (@ thread-tn (ash n word-shift))))) + (inst ldr sap (@ thread-tn (ash n word-shift))))) (define-vop (current-thread-offset-sap) (:results (sap :scs (sap-reg))) @@ -301,7 +288,7 @@ (:arg-types signed-num) (:policy :fast-safe) (:generator 2 - (inst ldr sap (@ thread-tn (extend n :lsl word-shift)))))) + (inst ldr sap (@ thread-tn (extend n :lsl word-shift)))))) ;;; Barriers (define-vop (%compiler-barrier) diff -Nru sbcl-2.1.10/src/compiler/arm64/target-insts.lisp sbcl-2.1.11/src/compiler/arm64/target-insts.lisp --- sbcl-2.1.10/src/compiler/arm64/target-insts.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/target-insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -383,8 +383,9 @@ dstate)))) (defun annotate-ldr-str-pair (value stream dstate) - (declare (ignore stream)) + (declare (ignore stream) (ignorable dstate)) (destructuring-bind (reg offset) value + (declare (ignorable offset)) (case reg #+sb-thread (#.sb-vm::thread-offset diff -Nru sbcl-2.1.10/src/compiler/arm64/type-vops.lisp sbcl-2.1.11/src/compiler/arm64/type-vops.lisp --- sbcl-2.1.10/src/compiler/arm64/type-vops.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/type-vops.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -223,14 +223,15 @@ n-positive-fixnum-bits))) n-positive-fixnum-bits)))) -(define-vop (fixnump/signed-byte-64 type-predicate) +(define-vop (fixnump/signed-byte-64) (:args (value :scs (signed-reg))) + (:policy :fast-safe) (:conditional :vc) (:info) (:arg-types signed-num) (:translate fixnump) (:generator 3 - (inst adds temp value value))) + (inst adds zr-tn value value))) ;;; MOD type checks (defun power-of-two-limit-p (x) diff -Nru sbcl-2.1.10/src/compiler/arm64/values.lisp sbcl-2.1.11/src/compiler/arm64/values.lisp --- sbcl-2.1.10/src/compiler/arm64/values.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/values.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -64,19 +64,41 @@ (count :scs (any-reg))) (:info nvals) (:temporary (:scs (descriptor-reg)) temp) + (:vop-var vop) (:generator 20 (move start csp-tn) - (inst add csp-tn csp-tn (* nvals n-word-bytes)) - (do ((val vals (tn-ref-across val)) - (i 0 (1+ i))) - ((null val)) - (let ((tn (tn-ref-tn val))) - (sc-case tn - (descriptor-reg - (storew tn start i)) - (control-stack - (load-stack-tn temp tn) - (storew temp start i))))) + (let (prev-constant) + (flet ((load-tn (tn-ref) + (let ((tn (tn-ref-tn tn-ref))) + (sc-case tn + (descriptor-reg + tn) + ((immediate constant) + (cond ((eql (tn-value tn) 0) + zr-tn) + ((or (eql prev-constant (tn-value tn)) + (progn + (setf prev-constant (tn-value tn)) + nil)) + temp) + ((sc-is tn constant) + (load-constant vop tn temp) + temp) + (t + (load-immediate vop tn temp) + temp))) + (control-stack + (setf prev-constant nil) + (load-stack-tn temp tn) + temp))))) + (cond ((= nvals 1) + (inst str (load-tn vals) (@ csp-tn n-word-bytes :post-index))) + (t + (inst add csp-tn csp-tn (* nvals n-word-bytes)) + (do ((val vals (tn-ref-across val)) + (i 0 (1+ i))) + ((null val)) + (storew (load-tn val) start i)))))) (inst mov count (fixnumize nvals)))) ;;; Push a list of values on the stack, returning Start and Count as used in diff -Nru sbcl-2.1.10/src/compiler/arm64/vm.lisp sbcl-2.1.11/src/compiler/arm64/vm.lisp --- sbcl-2.1.10/src/compiler/arm64/vm.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -219,7 +219,8 @@ :alternate-scs (complex-double-stack)) (catch-block control-stack :element-size catch-block-size) - (unwind-block control-stack :element-size unwind-block-size)) + (unwind-block control-stack :element-size unwind-block-size) + (zero immediate-constant)) ;;;; Make some random tns for important registers. @@ -388,4 +389,5 @@ sb-arm64-asm::fixnum-encode-logical-immediate bic-encode-immediate bic-fixnum-encode-immediate - logical-immediate-or-word-mask)) + logical-immediate-or-word-mask + sb-arm64-asm::ldr-str-offset-encodable)) diff -Nru sbcl-2.1.10/src/compiler/array-tran.lisp sbcl-2.1.11/src/compiler/array-tran.lisp --- sbcl-2.1.10/src/compiler/array-tran.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/array-tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -812,7 +812,7 @@ ;; for the the header word. (header-bits (logior (if (eq has-fill-pointer t) ; (i.e. can't handle :maybe) - (ash sb-vm:+array-fill-pointer-p+ sb-vm:n-widetag-bits) + (ash sb-vm:+array-fill-pointer-p+ sb-vm:array-flags-position) 0) (or (sb-vm:saetp-complex-typecode saetp) sb-vm:complex-vector-widetag))) @@ -832,7 +832,7 @@ (if (eq has-fill-pointer :maybe) `(let ((%array ,array-header)) (when fill-pointer - (logior-header-bits %array sb-vm:+array-fill-pointer-p+)) + (logior-array-flags %array sb-vm:+array-fill-pointer-p+)) %array) array-header)))))) (cond ;; Case (1) - :INITIAL-ELEMENT @@ -1516,8 +1516,10 @@ ;; chances to run. (delay-ir1-transform node :ir1-phases)) (if (vop-existsp :named test-header-bit) - `(test-header-bit array sb-vm:+array-fill-pointer-p+) - `(logtest (get-header-data array) sb-vm:+array-fill-pointer-p+)))))) + `(test-header-bit array + (ash sb-vm:+array-fill-pointer-p+ sb-vm:array-flags-data-position)) + `(logtest (get-header-data array) + (ash sb-vm:+array-fill-pointer-p+ sb-vm:array-flags-data-position))))))) (deftransform %check-bound ((array dimension index) ((simple-array * (*)) t t)) (let ((array-ref (lvar-uses array)) diff -Nru sbcl-2.1.10/src/compiler/assem.lisp sbcl-2.1.11/src/compiler/assem.lisp --- sbcl-2.1.10/src/compiler/assem.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/assem.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -350,7 +350,7 @@ ;; Convert the label positions to a packed integer ;; Utilize PACK-CODE-FIXUP-LOCS to perform compression. (awhen (mapcar 'label-posn (asmstream-alloc-points asmstream)) - (sb-c::pack-code-fixup-locs it nil))) + (sb-c:pack-code-fixup-locs it nil nil))) ;;; Insert STMT after PREDECESSOR. (defun insert-stmt (stmt predecessor) diff -Nru sbcl-2.1.10/src/compiler/callable-args.lisp sbcl-2.1.11/src/compiler/callable-args.lisp --- sbcl-2.1.10/src/compiler/callable-args.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/callable-args.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -414,6 +414,18 @@ "The function ~s is called with odd number of keyword arguments." callee))))))) +(defun disable-arg-count-checking (leaf type arg-count) + (when (lambda-p leaf) + (multiple-value-bind (min max) (fun-type-arg-limits type) + (when (and min + (if max + (<= min arg-count max) + (<= min arg-count))) + (setf (lambda-lexenv leaf) + (make-lexenv :default (lambda-lexenv leaf) + :policy (augment-policy verify-arg-count 0 + (lexenv-policy (lambda-lexenv leaf))))))))) + ;;; This can provide better errors and better handle OR types than a ;;; simple type intersection. (defun check-function-designator-lvar (lvar annotation) @@ -445,6 +457,9 @@ arg-count condition) (let ((param-types (fun-type-n-arg-types arg-count type))) + (unless (and (eq caller 'reduce) + (eql arg-count 2)) + (disable-arg-count-checking leaf type arg-count)) (block nil ;; Need to check each OR seperately, a UNION could ;; intersect with the function parameters diff -Nru sbcl-2.1.10/src/compiler/codegen.lisp sbcl-2.1.11/src/compiler/codegen.lisp --- sbcl-2.1.10/src/compiler/codegen.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/codegen.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,24 +18,22 @@ ;;; the number of bytes used by the code object header -#-sb-xc-host -(defun component-header-length (&optional - (component *component-being-compiled*)) - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp))) - (ash (align-up (length constants) code-boxed-words-align) sb-vm:word-shift))) - -;;; KLUDGE: the assembler can not emit backpatches comprising jump tables without -;;; knowing the boxed code header length. But there is no compiler IR2 metaobject, -;;; for SB-FASL:*ASSEMBLER-ROUTINES*. We have to return a fixed answer for that. -#+sb-xc-host -(defun component-header-length () - (if (boundp '*component-being-compiled*) - (let ((component *component-being-compiled*)) - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp))) - (ash (align-up (length constants) code-boxed-words-align) sb-vm:word-shift))) - (* sb-vm:n-word-bytes 4))) ; FIXME: what is 4 ? +(macrolet ((header-length-in-bytes (comp) + `(let* ((2comp (component-info ,comp)) + (constants (ir2-component-constants 2comp))) + (ash (align-up (length constants) code-boxed-words-align) + sb-vm:word-shift)))) + #-sb-xc-host + (defun component-header-length (&optional (component *component-being-compiled*)) + (header-length-in-bytes component)) + ;; KLUDGE: the assembler can not emit backpatches comprising jump tables without + ;; knowing the boxed code header length. But there is no compiler IR2 metaobject, + ;; for SB-FASL:*ASSEMBLER-ROUTINES*. We have to return a fixed answer for that. + #+sb-xc-host + (defun component-header-length () + (if (boundp '*component-being-compiled*) + (header-length-in-bytes *component-being-compiled*) + (* sb-vm:n-word-bytes (align-up sb-vm:code-constants-offset 2))))) ;;; the size of the NAME'd SB in the currently compiled component. ;;; This is useful mainly for finding the size for allocating stack @@ -48,9 +46,9 @@ (defun current-nfp-tn (vop) (unless (zerop (sb-allocated-size 'non-descriptor-stack)) (let ((block (ir2-block-block (vop-block vop)))) - (when (ir2-physenv-number-stack-p - (physenv-info - (block-physenv block))) + (when (ir2-environment-number-stack-p + (environment-info + (block-environment block))) (ir2-component-nfp (component-info (block-component block))))))) ;;; the TN that is used to hold the number stack frame-pointer in the @@ -58,13 +56,13 @@ ;;; allocated (defun callee-nfp-tn (2env) (unless (zerop (sb-allocated-size 'non-descriptor-stack)) - (when (ir2-physenv-number-stack-p 2env) + (when (ir2-environment-number-stack-p 2env) (ir2-component-nfp (component-info *component-being-compiled*))))) ;;; the TN used for passing the return PC in a local call to the function ;;; designated by 2ENV (defun callee-return-pc-tn (2env) - (ir2-physenv-return-pc-pass 2env)) + (ir2-environment-return-pc-pass 2env)) ;;;; noise to emit an instruction trace @@ -271,9 +269,8 @@ (defun generate-code (component &aux (ir2-component (component-info component))) (declare (type ir2-component ir2-component)) (when *compiler-trace-output* - (format *compiler-trace-output* - "~|~%assembly code for ~S~2%" - component)) + (let ((*print-pretty* nil)) ; force 1 line + (format *compiler-trace-output* "~|~%assembly code for ~S~2%" component))) (let* ((prev-env nil) ;; The first function's alignment word is zero-filled, but subsequent ;; ones can use a NOP which helps the disassembler not lose sync. @@ -330,10 +327,10 @@ (ir2-block-%trampoline-label block) (ir2-block-dropped-thru-to block) alignp))) - (let ((env (block-physenv 1block))) + (let ((env (block-environment 1block))) (unless (eq env prev-env) - (let ((lab (gen-label "physenv elsewhere start"))) - (setf (ir2-physenv-elsewhere-start (physenv-info env)) + (let ((lab (gen-label "environment elsewhere start"))) + (setf (ir2-environment-elsewhere-start (environment-info env)) lab) (emit (asmstream-elsewhere-section asmstream) lab)) (setq prev-env env))))) @@ -370,6 +367,8 @@ ;; Todo: can we implement the flow-based aspect of coverage mark compression ;; in IR2 instead of waiting until assembly generation? #+(or x86 x86-64) (coverage-mark-lowering-pass component asmstream) + ;; The #+(or x86 x86-64) case has _already_ output the mark bytes into + ;; the data section in lowering pass, so we don't do that here. #-(or x86 x86-64) (when coverage-map #+arm64 diff -Nru sbcl-2.1.10/src/compiler/control.lisp sbcl-2.1.11/src/compiler/control.lisp --- sbcl-2.1.10/src/compiler/control.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/control.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -66,15 +66,15 @@ (defun find-rotated-loop-head (block) (declare (type cblock block)) (let* ((num (block-number block)) - (env (block-physenv block)) + (env (block-environment block)) (pred (dolist (pred (block-pred block) nil) (when (and (not (block-flag pred)) - (eq (block-physenv pred) env) + (eq (block-environment pred) env) (< (block-number pred) num)) (return pred))))) (cond ((and pred - (not (physenv-nlx-info env)) + (not (environment-nlx-info env)) (not (eq (lambda-block (block-home-lambda block)) block)) (null (cdr (block-succ pred)))) (let ((current pred) @@ -85,7 +85,7 @@ (when (eq pred block) (return-from DONE)) (when (and (not (block-flag pred)) - (eq (block-physenv pred) env) + (eq (block-environment pred) env) (> (block-number pred) current-num)) (setq current pred current-num (block-number pred)) (return))))) @@ -127,8 +127,8 @@ (let ((last (block-last block))) (cond ((and (combination-p last) (node-tail-p last) (eq (basic-combination-kind last) :local) - (not (eq (node-physenv last) - (lambda-physenv (combination-lambda last))))) + (not (eq (node-environment last) + (lambda-environment (combination-lambda last))))) (combination-lambda last)) (t (let ((component-tail (component-tail (block-component block))) @@ -160,7 +160,7 @@ (prev-block (block-annotation-prev tail-block)) (bind-block (node-block (lambda-bind fun)))) (unless (block-flag bind-block) - (dolist (nlx (physenv-nlx-info (lambda-physenv fun))) + (dolist (nlx (environment-nlx-info (lambda-environment fun))) (control-analyze-block (nlx-info-target nlx) tail-block)) (cond ((block-flag bind-block) diff -Nru sbcl-2.1.10/src/compiler/debug-dump.lisp sbcl-2.1.11/src/compiler/debug-dump.lisp --- sbcl-2.1.10/src/compiler/debug-dump.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/debug-dump.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -77,10 +77,10 @@ (- posn (segment-header-skew segment)))))) (values)) -(declaim (inline ir2-block-physenv)) -(defun ir2-block-physenv (2block) +(declaim (inline ir2-block-environment)) +(defun ir2-block-environment (2block) (declare (type ir2-block 2block)) - (block-physenv (ir2-block-block 2block))) + (block-environment (ir2-block-block 2block))) (defun make-lexenv-var-cache (lexenv) (or (lexenv-var-cache lexenv) @@ -314,13 +314,13 @@ (let ((*previous-location* 0) *previous-live* *previous-form-number* - (physenv (lambda-physenv fun)) + (env (lambda-environment fun)) (byte-buffer *byte-buffer*) prev-block locations elsewhere-locations) (setf (fill-pointer byte-buffer) 0) - (do-physenv-ir2-blocks (2block physenv) + (do-environment-ir2-blocks (2block env) (let ((block (ir2-block-block 2block))) (when (eq (block-info block) 2block) (when prev-block @@ -447,8 +447,8 @@ (info (lambda-var-arg-info var)) (indirect (and (lambda-var-indirect var) (not (lambda-var-explicit-value-cell var)) - (neq (lambda-physenv fun) - (lambda-physenv (lambda-var-home var))))) + (neq (lambda-environment fun) + (lambda-environment (lambda-var-home var))))) ;; Keep this condition in sync with PARSE-COMPILED-DEBUG-VARS (large-fixnums (>= (integer-length most-positive-fixnum) 62)) more) @@ -552,7 +552,7 @@ (frob-leaf leaf (leaf-info leaf) gensym-p)))) (frob-lambda fun t) (when (>= level 1) - (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun)))) + (dolist (x (ir2-environment-closure (environment-info (lambda-environment fun)))) (let ((thing (car x))) (when (lambda-var-p thing) (frob-leaf thing (cdr x) (>= level 2))))) @@ -662,7 +662,7 @@ ;;; Return a C-D-F structure with all the mandatory slots filled in. (defun dfun-from-fun (fun) (declare (type clambda fun)) - (let* ((2env (physenv-info (lambda-physenv fun))) + (let* ((2env (environment-info (lambda-environment fun))) (dispatch (lambda-optional-dispatch fun)) (main-p (and dispatch (eq fun (optional-dispatch-main-entry dispatch)))) @@ -685,26 +685,26 @@ (funcall (compiled-debug-fun-ctor kind) :name name #-fp-and-pc-standard-save :return-pc - #-fp-and-pc-standard-save (tn-sc+offset (ir2-physenv-return-pc 2env)) + #-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-return-pc 2env)) #-fp-and-pc-standard-save :return-pc-pass - #-fp-and-pc-standard-save (tn-sc+offset (ir2-physenv-return-pc-pass 2env)) + #-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-return-pc-pass 2env)) #-fp-and-pc-standard-save :old-fp - #-fp-and-pc-standard-save (tn-sc+offset (ir2-physenv-old-fp 2env)) + #-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-old-fp 2env)) :encoded-locs (cdf-encode-locs - (label-position (ir2-physenv-environment-start 2env)) - (label-position (ir2-physenv-elsewhere-start 2env)) + (label-position (ir2-environment-environment-start 2env)) + (label-position (ir2-environment-elsewhere-start 2env)) (source-path-form-number (node-source-path (lambda-bind fun))) (label-position (block-label (lambda-block fun))) - (when (ir2-physenv-closure-save-tn 2env) - (tn-sc+offset (ir2-physenv-closure-save-tn 2env))) + (when (ir2-environment-closure-save-tn 2env) + (tn-sc+offset (ir2-environment-closure-save-tn 2env))) #+unwind-to-frame-and-call-vop - (when (ir2-physenv-bsp-save-tn 2env) - (tn-sc+offset (ir2-physenv-bsp-save-tn 2env))) + (when (ir2-environment-bsp-save-tn 2env) + (tn-sc+offset (ir2-environment-bsp-save-tn 2env))) #-fp-and-pc-standard-save - (label-position (ir2-physenv-lra-saved-pc 2env)) + (label-position (ir2-environment-lra-saved-pc 2env)) #-fp-and-pc-standard-save - (label-position (ir2-physenv-cfp-saved-pc 2env)))))) + (label-position (ir2-environment-cfp-saved-pc 2env)))))) ;;; Return a complete C-D-F structure for FUN. This involves ;;; determining the DEBUG-INFO level and filling in optional slots as @@ -763,8 +763,8 @@ (eq start (ir2-block-last-vop 2block)) (eq (vop-name start) 'note-environment-start) next - (neq (ir2-block-physenv 2block) - (ir2-block-physenv next))))) + (neq (ir2-block-environment 2block) + (ir2-block-environment next))))) ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be ;;; called after assembly so that source map information is available. diff -Nru sbcl-2.1.10/src/compiler/debug.lisp sbcl-2.1.11/src/compiler/debug.lisp --- sbcl-2.1.10/src/compiler/debug.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/debug.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -498,7 +498,11 @@ (dolist (exit (entry-exits node)) (unless (node-deleted exit) (check-node-reached node)))) - (enclose) + (enclose + (dolist (fun (enclose-funs node)) + (let ((enclose (functional-enclose fun))) + (unless (eq node enclose) + (barf "~S is not the ENCLOSE for its FUN ~S." node enclose))))) (exit (let ((entry (exit-entry node)) (value (exit-value node))) @@ -780,13 +784,13 @@ ;;; TNs to access the full call passing locations. (defun check-environment-lifetimes (component) (dolist (fun (component-lambdas component)) - (let* ((env (lambda-physenv fun)) - (2env (physenv-info env)) + (let* ((env (lambda-environment fun)) + (2env (environment-info env)) (vars (lambda-vars fun)) - (closure (ir2-physenv-closure 2env)) - (pc (ir2-physenv-return-pc-pass 2env)) - (fp (ir2-physenv-old-fp 2env)) - (2block (block-info (lambda-block (physenv-lambda env))))) + (closure (ir2-environment-closure 2env)) + (pc (ir2-environment-return-pc-pass 2env)) + (fp (ir2-environment-old-fp 2env)) + (2block (block-info (lambda-block (environment-lambda env))))) (do ((conf (ir2-block-global-tns 2block) (global-conflicts-next-blockwise conf))) ((null conf)) @@ -915,14 +919,19 @@ (constant (format stream "'~S" (constant-value leaf))) (global-var (format stream "~S {~A}" (leaf-debug-name leaf) (global-var-kind leaf))) + (clambda + (format stream "lambda ~@[~S ~]~:S" + (and (leaf-has-source-name-p leaf) + (functional-debug-name leaf)) + (mapcar #'leaf-debug-name (lambda-vars leaf)))) + (optional-dispatch + (format stream "optional-dispatch ~S" (mapcar #'leaf-debug-name (optional-dispatch-arglist leaf)))) (functional - (format stream "~S ~S ~S" (type-of leaf) (functional-debug-name leaf) - (mapcar #'leaf-debug-name - (typecase leaf - (clambda - (lambda-vars leaf)) - (optional-dispatch - (optional-dispatch-arglist leaf)))))))) + (case (functional-kind leaf) + (:toplevel-xep + (format stream "TL-XEP ~S" (entry-info-name (leaf-info leaf)))) + (t + (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf))))))) ;;; Attempt to find a block given some thing that has to do with it. (declaim (ftype (sfunction (t) cblock) block-or-lose)) @@ -948,7 +957,11 @@ (values)) (defun print-lvar (cont) (declare (type lvar cont)) - (format t "v~D " (cont-num cont)) + (if (and (lvar-info cont) + (eq (ir2-lvar-kind (lvar-info cont)) + :unknown)) + (format t "uv~D " (cont-num cont)) + (format t "v~D " (cont-num cont))) (values)) (defun print-lvar-stack (stack &optional (stream *standard-output*)) @@ -1021,10 +1034,14 @@ ((:dynamic-extent) (format t "entry DX~{ v~D~}" (mapcar (lambda (lvar-or-cell) - (if (consp lvar-or-cell) - (cons (car lvar-or-cell) - (cont-num (cdr lvar-or-cell))) - (cont-num lvar-or-cell))) + (typecase lvar-or-cell + (cons + (cons (car lvar-or-cell) + (cont-num (cdr lvar-or-cell)))) + (enclose + lvar-or-cell) + (t + (cont-num lvar-or-cell)))) (cleanup-info cleanup)))) (t (format t "entry ~S" (entry-exits node)))))) @@ -1037,14 +1054,15 @@ (format t "exit ")) (t (format t "exit "))))) + (delay + (write-string "delay ") + (print-lvar (delay-value node))) (cast (let ((value (cast-value node))) (format t "cast v~D ~A[~S -> ~S]" (cont-num value) (if (cast-%type-check node) #\+ #\-) (cast-type-to-check node) (cast-asserted-type node)))) - (no-op - (princ "no-op")) (enclose (write-string "enclose ") (dolist (leaf (enclose-funs node)) @@ -1127,7 +1145,7 @@ ;; depending on the call context. Resetting depth to 0 seems ;; like the best way to get consistent output. ;; We shouldn't bind the printer limits to NIL, because - ;; hairy internal objects such as PHYSENV can be printed. + ;; hairy internal objects such as ENVIRONMENT can be printed. ;; See also the comment above FUNCALL-WITH-DEBUG-IO-SYNTAX. (let (#-sb-xc-host (*current-level-in-print* 0) (*print-level* 2) @@ -1308,31 +1326,100 @@ (vop (ir2-block-start-vop block) (vop-next vop))) ((= i n) vop)))) +(defun show-transform-p (showp fun-name) + (or (and (listp showp) (member fun-name showp :test 'equal)) + (eq showp t))) + +(defun show-transform (kind name new-form &optional combination) + (let ((*print-length* 100) + (*print-level* 50) + (*print-right-margin* 128)) + (format *trace-output* "~&xform (~a) ~S ~% -> ~S~%" + kind + (if combination + (cons name + (loop for arg in (combination-args combination) + collect (if (constant-lvar-p arg) + (lvar-value arg) + (type-specifier (lvar-type arg))))) + name) + new-form))) + +(defun show-type-derivation (combination type) + (let ((*print-length* 100) + (*print-level* 50) + (*print-right-margin* 128)) + (unless (type= (node-derived-type combination) + (coerce-to-values type)) + (format *trace-output* "~&~a derived to ~a" + (cons (combination-fun-source-name combination) + (loop for arg in (combination-args combination) + collect (if (constant-lvar-p arg) + (lvar-value arg) + (type-specifier (lvar-type arg))))) + (type-specifier type))))) + +;;;; producing a graphviz file + +(defun replace-all (string part replacement &key (test #'char=)) + "Returns a new string in which all the occurences of the part +is replaced with replacement." + (with-output-to-string (out) + (loop with part-length = (length part) + for old-pos = 0 then (+ pos part-length) + for pos = (search part string + :start2 old-pos + :test test) + do (write-string string out + :start old-pos + :end (or pos (length string))) + when pos do (write-string replacement out) + while pos))) + (defun ir1-to-dot (component output-file) (with-open-file (stream output-file :if-exists :supersede :if-does-not-exist :create :direction :output) (write-line "digraph G {" stream) - (do-blocks (block component) - (when (typep (block-out block) '(cons (eql :graph) cons)) - (format stream "~a[style=filled color=~a];~%" - (block-number block) - (case (cadr (block-out block)) - (:marked "green") - (:remarked "aquamarine") - (:start "lightblue") - (:end "red")))) - (let ((succ (block-pred block))) - (when succ - (loop for succ in succ - for attr = "[style=bold]" then "" - do - (format stream "~a -> ~a~a;~%" - (block-number block) - (block-number succ) - attr))) - (when (nle-block-p block) - (format stream "~a -> ~a [style=dotted];~%" - (block-number block) - (block-number (nle-block-entry-block block)))))) + (write-line "node [fontname = \"monospace\"];" stream) + (write-line "node [shape=box];" stream) + ;; Give a unique label to every block, since BLOCK-NUMBERs may be + ;; uninitialized during optimization. + (let ((label 0) + (block-labels (make-hash-table :test #'eq))) + (do-blocks (block component :both) + (setf (gethash block block-labels) label) + (incf label)) + (flet ((block-label (block) + (gethash block block-labels))) + (do-blocks (block component :both) + (cond ((eq block (component-head component)) + (format stream "~a [label=head];" + (block-label block))) + ((eq block (component-tail component)) + (format stream "~a [label=tail];" + (block-label block))) + (t + (format stream "~a [label=\"~a\"];~%" + (block-label block) + (replace-all + (replace-all (with-output-to-string (*standard-output*) + (print-nodes block)) + (string #\Newline) + "\\l") + "\"" + "\\")))) + (let ((succ (block-succ block))) + (when succ + (loop for succ in succ + for attr = "[style=bold]" then "" + do + (format stream "~a -> ~a~a;~%" + (block-label block) + (block-label succ) + attr))) + (when (nle-block-p block) + (format stream "~a -> ~a [style=dotted];~%" + (block-label block) + (block-label (nle-block-entry-block block)))))))) (write-line "}" stream))) diff -Nru sbcl-2.1.10/src/compiler/dfo.lisp sbcl-2.1.11/src/compiler/dfo.lisp --- sbcl-2.1.10/src/compiler/dfo.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/dfo.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -93,7 +93,7 @@ (dolist (succ (block-succ block)) (find-dfo-aux succ head component)) (when (component-nlx-info-generated-p component) - ;; FIXME: We also need (and do) this walk before physenv + ;; FIXME: We also need (and do) this walk before environment ;; analysis, but at that time we are probably not very ;; interested in the actual DF order. ;; @@ -200,10 +200,10 @@ ;;; If CLAMBDA is already in COMPONENT, just return that ;;; component. Otherwise, move the code for CLAMBDA and all lambdas it -;;; physically depends on (either because of calls or because of -;;; closure relationships) into COMPONENT, or possibly into another -;;; COMPONENT that we find to be related. Return whatever COMPONENT we -;;; actually merged into. +;;; depends on (either because of calls or because of closure +;;; relationships) into COMPONENT, or possibly into another COMPONENT +;;; that we find to be related. Return whatever COMPONENT we actually +;;; merged into. ;;; ;;; (Note: The analogous CMU CL code only scavenged call-based ;;; dependencies, not closure dependencies. That seems to've been by @@ -277,8 +277,8 @@ ;; CLAMBDA, then the home lambda should be in the ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU ;; CL, didn't do this, leading to the occasional - ;; failure when physenv analysis, which is local to - ;; each component, would bogusly conclude that a + ;; failure when environment analysis, which is local + ;; to each component, would bogusly conclude that a ;; closed-over variable was unused and thus delete ;; it. See e.g. cmucl-imp 2001-11-29.) (scavenge-closure-var (var) @@ -424,7 +424,7 @@ (setf (functional-kind lambda) :deleted) (dolist (let (lambda-lets lambda)) (setf (lambda-home let) result-lambda) - (setf (lambda-physenv let) (lambda-physenv result-lambda)) + (setf (lambda-environment let) (lambda-environment result-lambda)) (push let (lambda-lets result-lambda))) (setf (lambda-entries result-lambda) (nconc (lambda-entries result-lambda) diff -Nru sbcl-2.1.10/src/compiler/dump.lisp sbcl-2.1.11/src/compiler/dump.lisp --- sbcl-2.1.10/src/compiler/dump.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/dump.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1017,7 +1017,7 @@ (defconstant-eqx +fixup-flavors+ #(:assembly-routine :assembly-routine* :asm-routine-nil-offset - :symbol-tls-index + :gc-barrier :symbol-tls-index :foreign :foreign-dataref :code-object :layout :immobile-symbol :named-call :static-call :symbol-value @@ -1060,7 +1060,7 @@ flavor)) (operand (ecase flavor - (:code-object (the null name)) + ((:code-object :gc-barrier) (the null name)) (:layout (if (symbolp name) name @@ -1168,6 +1168,9 @@ code-length n-fixups) ;; Fasl dumper/loader convention allows at most 3 integer args. ;; Others have to be written with explicit calls. + (dump-integer-as-n-bytes (length (sb-c::ir2-component-entries 2comp)) + 4 ; output 4 bytes + fasl-output) (dump-integer-as-n-bytes (the (unsigned-byte 22) n-named-calls) 4 ; output 4 bytes fasl-output) diff -Nru sbcl-2.1.10/src/compiler/early-c.lisp sbcl-2.1.11/src/compiler/early-c.lisp --- sbcl-2.1.10/src/compiler/early-c.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/early-c.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -315,7 +315,7 @@ (objmap-id-to-ir2block nil :type (or null id-array)) ; number -> IR2-BLOCK (objmap-id-to-tn nil :type (or null id-array)) ; number -> TN (objmap-id-to-label nil :type (or null id-array)) ; number -> LABEL - ) + deleted-source-paths) (declaim (freeze-type compilation)) (sb-impl::define-thread-local *compilation*) diff -Nru sbcl-2.1.10/src/compiler/early-globaldb.lisp sbcl-2.1.11/src/compiler/early-globaldb.lisp --- sbcl-2.1.10/src/compiler/early-globaldb.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/early-globaldb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -35,6 +35,66 @@ #-sb-xc-host (declaim (ftype (sfunction (t) ctype) global-ftype)) +;;; A bit about the physical representation of the packed info format: +;;; With #+compact-instance-header it is possible to represent a vector of N things +;;; in a structure using (ALIGN-UP (1+ N) 2) words of memory. This is a saving +;;; of 1 word on average when compared to SIMPLE-VECTOR which needs +;;; (ALIGN-UP (+ N 2) 2) words. Granted that either might have a padding word, +;;; but I've observed 5% to 10% space reduction by eliminating one slot. +;;; Without compact-instance-header, we'e indifferent, in terms of space, +;;; as to whether this is an INSTANCE or a SIMPLE-VECTOR. For consistency, +;;; we use an INSTANCE regardless of presence of the compact-header feature. +;;; This makes assembly routines (e.g. CALL-SYMBOL) slightly less sensitive +;;; to the feature's absence. + +;;; Since variable-length instances aren't portably a thing, +;;; we use a structure of one slot holding a vector. +#+sb-xc-host (defstruct (packed-info + (:constructor %make-packed-info (cells)) + (:copier nil)) + ;; These objects are immutable. + (cells #() :type simple-vector :read-only t)) +;;; Some abstractions for host/target compatibility of all the defuns. +#+sb-xc-host +(progn + (defmacro make-packed-info (n) `(%make-packed-info (make-array ,n))) + (defmacro copy-packed-info (info) + `(%make-packed-info (copy-seq (packed-info-cells ,info)))) + (defmacro packed-info-len (info) + `(length (packed-info-cells ,info))) + (defmacro %info-ref (info index) `(svref (packed-info-cells ,info) ,index))) +#-sb-xc-host +(progn + #+nil + (defmethod print-object ((obj packed-info) stream) + (format stream "[~{~W~^ ~}]" + (loop for i below (%instance-length obj) + collect (%instance-ref obj i)))) + (defmethod print-object ((self sb-int:packed-info) stream) + (print-unreadable-object (self stream :type t :identity t) + (format stream "len=~d" (sb-kernel:%instance-length self)))) + (eval-when (:compile-toplevel) + (sb-xc:defmacro make-packed-info (n) + ;; this file is earlier than early-vm, so we have to take + ;; INSTANCE-DATA-START from the value set in make-host-1. + `(let ((new (%make-instance (+ ,n #.sb-vm:instance-data-start)))) + (setf (%instance-wrapper new) #.(find-layout 'packed-info)) + new)) + ;; We can't merely call COPY-STRUCTURE due to two issues: + ;; 1. bootstrapping- the DEFSTRUCT-DESCRIPTION is not available + ;; in cold-init by the first call to COPY-PACKED-INFO, + ;; but COPY-STRUCTURE needs it, because of raw slots. + ;; 2. the transform for COPY-STRUCTURE would think that + ;; it needs to copy exactly 1 slot. Well, it would think that, + ;; if the FREEZE-TYPE wasn't commented out. + (sb-xc:defmacro copy-packed-info (info) + ;; not bothering with ONCE-ONLY here (doesn't matter) + `(%copy-instance (%make-instance (%instance-length ,info)) ,info))) + (defmacro packed-info-len (info) + `(- (%instance-length ,info) sb-vm:instance-data-start)) + (defmacro %info-ref (v i) + `(%instance-ref ,v (+ ,i #.sb-vm:instance-data-start)))) + ;;; At run time, we represent the type of a piece of INFO in the globaldb ;;; by a small integer between 1 and 63. [0 is reserved for internal use.] ;;; CLISP, and maybe others, need EVAL-WHEN because without it, the constant @@ -85,25 +145,26 @@ ;;; presented at the definition of SYMBOL-PLIST, if the object in SYMBOL's ;;; info slot is LISTP, it is in state 1 or 3. Either way, take the CDR. ;;; Otherwise, it is in state 2 so return the value as-is. -;;; In terms of this function being named "-vector", implying always a vector, -;;; it is understood that NIL is a proxy for +NIL-PACKED-INFOS+, a vector. +;;; NIL is an acceptable substitute for +NIL-PACKED-INFOS+, +;;; but I might change that. ;;; -;;; Define SYMBOL-INFO-VECTOR as an inline function unless a vop translates it. +;;; Define SYMBOL-INFO as an inline function unless a vop translates it. ;;; (Inlining occurs first, which would cause the vop not to be used.) #-sb-xc-host -(sb-c::unless-vop-existsp (:translate sb-kernel:symbol-info-vector) - (declaim (inline symbol-info-vector)) - (defun symbol-info-vector (symbol) - (let ((info-holder (symbol-info symbol))) - (truly-the (or null simple-vector) +(sb-c::unless-vop-existsp (:translate sb-kernel:symbol-dbinfo) + (declaim (inline symbol-dbinfo)) + (defun symbol-dbinfo (symbol) + (let ((info-holder (symbol-%info symbol))) + (truly-the (or null instance) (if (listp info-holder) (cdr info-holder) info-holder))))) -;;; SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp' -;;; But in the host Lisp, there is no such thing as a symbol-info slot. -;;; Instead, symbol-info is kept in the host symbol's plist. -;;; This must be a SETFable place. +;;; %SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp' +;;; But in the host Lisp, there is no such thing. Instead, SYMBOL-%INFO +;;; is kept as a property on the host symbol. +;;; The compatible "primitive" accessor must be a SETFable place. #+sb-xc-host -(defmacro symbol-info-vector (symbol) `(get ,symbol :sb-xc-globaldb-info)) +(progn (defmacro symbol-%info (symbol) `(get ,symbol :sb-xc-globaldb-info)) + (defun symbol-dbinfo (symbol) (symbol-%info symbol))) ;; Perform the equivalent of (GET-INFO-VALUE KIND +INFO-METAINFO-TYPE-NUM+) ;; but skipping the defaulting logic. @@ -111,19 +172,21 @@ ;; - though not always - a unique identifier for the (:TYPE :KIND) pair. ;; Note that bypassing of defaults is critical for bootstrapping, ;; since INFO is used to retrieve its own META-INFO at system-build time. -(defmacro !get-meta-infos (kind) - `(let* ((info-vector (symbol-info-vector ,kind)) - (index (if info-vector - (packed-info-value-index info-vector +no-auxiliary-key+ +(defmacro get-meta-infos (kind) + `(let* ((packed-info (symbol-dbinfo ,kind)) + (index (if packed-info + (packed-info-value-index packed-info +no-auxiliary-key+ +info-metainfo-type-num+)))) - (if index (svref info-vector index)))) + (if index (%info-ref packed-info index)))) -;; (UNSIGNED-BYTE 16) is an arbitrarily generous limit on the number of -;; cells in an info-vector. Most vectors have a fewer than a handful of things, +;; (UNSIGNED-BYTE 11) is an arbitrarily generous limit on the number of +;; cells in a packed-info. Most packed-infos have fewer than a handful of things, ;; and performance would need to be re-thought if more than about a dozen ;; cells were in use. (It would want to become hash-based probably) -(declaim (ftype (function (simple-vector (or (eql 0) symbol) info-number) - (or null (unsigned-byte 16))) +;; It has to be smaller than INSTANCE_LENGTH_MASK certainly, +;; plus leaving room for a layout slot if #-compact-instance-header. +(declaim (ftype (function (packed-info (or (eql 0) symbol) info-number) + (or null (unsigned-byte 11))) packed-info-value-index)) ;; Return the META-INFO object for CATEGORY and KIND, signaling an error @@ -136,7 +199,7 @@ ;; through, whereas typically no more than 3 or 4 items have the same KIND. ;; (defun meta-info (category kind &optional (errorp t)) - (or (let ((metadata (!get-meta-infos kind))) + (or (let ((metadata (get-meta-infos kind))) (cond ((listp metadata) ; conveniently handles NIL (dolist (info metadata nil) ; FIND is slower :-( (when (eq (meta-info-category (truly-the meta-info info)) @@ -144,7 +207,7 @@ (return info)))) ((eq (meta-info-category (truly-the meta-info metadata)) category) metadata))) - ;; !GET-META-INFOS enforces that KIND is a symbol, therefore + ;; GET-META-INFOS enforces that KIND is a symbol, therefore ;; if a metaobject was found, CATEGORY was necessarily a symbol too. ;; Otherwise, if the caller wants no error to be signaled on missing info, ;; we must nevertheless enforce that CATEGORY was actually a symbol. diff -Nru sbcl-2.1.10/src/compiler/entry.lisp sbcl-2.1.11/src/compiler/entry.lisp --- sbcl-2.1.10/src/compiler/entry.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/entry.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -52,7 +52,7 @@ (let ((bind (lambda-bind fun)) (internal-fun (functional-entry-fun fun))) (setf (entry-info-closure-tn info) - (if (physenv-closure (lambda-physenv fun)) + (if (environment-closure (lambda-environment fun)) (make-normal-tn *backend-t-primitive-type*) nil)) (setf (entry-info-offset info) (gen-label)) @@ -156,7 +156,7 @@ ;; It may have been deleted due to none of ;; the optional entries reaching it. (neq (functional-kind main-entry) :deleted) - (physenv-closure (lambda-physenv main-entry))))) + (environment-closure (lambda-environment main-entry))))) (dolist (ref (leaf-refs lambda)) (let ((ref-component (node-component ref))) (cond ((eq ref-component component)) diff -Nru sbcl-2.1.10/src/compiler/envanal.lisp sbcl-2.1.11/src/compiler/envanal.lisp --- sbcl-2.1.10/src/compiler/envanal.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/compiler/envanal.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,595 @@ +;;;; This file implements the environment analysis phase for the +;;;; compiler. This phase annotates IR1 with a hierarchy environment +;;;; structures, determining the environment that each LAMBDA +;;;; allocates its variables and finding what values are closed over +;;;; by each environment. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-C") + +;;; Do environment analysis on the code in COMPONENT. This involves +;;; various things: +;;; 1. Make an ENVIRONMENT structure for each non-LET LAMBDA, assigning +;;; the LAMBDA-ENVIRONMENT for all LAMBDAs. +;;; 2. Find all values that need to be closed over by each +;;; environment. +;;; 3. Scan the blocks in the component closing over non-local-exit +;;; continuations. +;;; 4. Delete all non-top-level functions with no references. This +;;; should only get functions with non-NULL kinds, since normal +;;; functions are deleted when their references go to zero. +(defun environment-analyze (component) + (declare (type component component)) + (aver (every (lambda (x) + (eq (functional-kind x) :deleted)) + (component-new-functionals component))) + (setf (component-new-functionals component) ()) + (mapc #'add-lambda-vars-and-let-vars-to-closures + (component-lambdas component)) + + (find-non-local-exits component) + (recheck-dynamic-extent-lvars component) + (find-cleanup-points component) + (tail-annotate component) + (analyze-indirect-lambda-vars component) + + (dolist (fun (component-lambdas component)) + (when (null (leaf-refs fun)) + (let ((kind (functional-kind fun))) + (unless (or (eq kind :toplevel) + (functional-has-external-references-p fun)) + (aver (member kind '(:optional :cleanup :escape))) + (setf (functional-kind fun) nil) + (delete-functional fun))))) + + (setf (component-nlx-info-generated-p component) t) + (values)) + +;;; If FUN has an environment, return it, otherwise assign an empty +;;; one and return that. +(defun get-lambda-environment (fun) + (declare (type clambda fun)) + (let ((fun (lambda-home fun))) + (or (lambda-environment fun) + (let ((res (make-environment :lambda fun))) + (setf (lambda-environment fun) res) + (dolist (lambda (lambda-lets fun)) + (setf (lambda-environment lambda) res)) + res)))) + +;;; Get NODE's environment, assigning one if necessary. +(defun get-node-environment (node) + (declare (type node node)) + (get-lambda-environment (node-home-lambda node))) + +;;; private guts of ADD-LAMBDA-VARS-AND-LET-VARS-TO-CLOSURES +;;; +;;; This is the old CMU CL COMPUTE-CLOSURE, which only works on +;;; LAMBDA-VARS directly, not on the LAMBDA-VARS of LAMBDA-LETS. It +;;; seems never to be valid to use this operation alone, so in SBCL, +;;; it's private, and the public interface, +;;; ADD-LAMBDA-VARS-AND-LET-VARS-TO-CLOSURES, always runs over all the +;;; variables, not only the LAMBDA-VARS of CLAMBDA itself but also +;;; the LAMBDA-VARS of CLAMBDA's LAMBDA-LETS. +(defun %add-lambda-vars-to-closures (clambda) + (let ((env (get-lambda-environment clambda)) + (did-something nil)) + (note-unreferenced-fun-vars clambda) + (dolist (var (lambda-vars clambda)) + (dolist (ref (leaf-refs var)) + (let ((ref-env (get-node-environment ref))) + (unless (eq ref-env env) + (when (lambda-var-sets var) + (setf (lambda-var-indirect var) t)) + (setq did-something t) + (close-over var ref-env env)))) + (dolist (set (basic-var-sets var)) + + ;; Variables which are set but never referenced can be + ;; optimized away, and closing over them here would just + ;; interfere with that. (In bug 147, it *did* interfere with + ;; that, causing confusion later. This UNLESS solves that + ;; problem, but I (WHN) am not 100% sure it's best to solve + ;; the problem this way instead of somehow solving it + ;; somewhere upstream and just doing (AVER (LEAF-REFS VAR)) + ;; here.) + (unless (null (leaf-refs var)) + + (let ((set-env (get-node-environment set))) + (unless (eq set-env env) + (setf did-something t + (lambda-var-indirect var) t) + (close-over var set-env env)))))) + did-something)) + +;;; Find any variables in CLAMBDA -- either directly in LAMBDA-VARS or +;;; in the LAMBDA-VARS of elements of LAMBDA-LETS -- with references +;;; outside of the home environment and close over them. If a +;;; closed-over variable is set, then we set the INDIRECT flag so that +;;; we will know the closed over value is really a pointer to the +;;; value cell. We also warn about unreferenced variables here, just +;;; because it's a convenient place to do it. We return true if we +;;; close over anything. +(defun add-lambda-vars-and-let-vars-to-closures (clambda) + (declare (type clambda clambda)) + (let ((did-something nil)) + (when (%add-lambda-vars-to-closures clambda) + (setf did-something t)) + (dolist (lambda-let (lambda-lets clambda)) + ;; There's no need to recurse through full COMPUTE-CLOSURE + ;; here, since LETS only go one layer deep. + (aver (null (lambda-lets lambda-let))) + (when (%add-lambda-vars-to-closures lambda-let) + (setf did-something t))) + did-something)) + +(defun xep-enclose (xep) + (let ((entry (functional-entry-fun xep))) + (functional-enclose entry))) + +;;; Make sure that THING is closed over in REF-ENV and in all +;;; environments for the functions that reference REF-ENV's function +;;; (not just calls). HOME-ENV is THING's home environment. When we +;;; reach the home environment, we stop propagating the closure. +(defun close-over (thing ref-env home-env) + (declare (type environment ref-env home-env)) + (let ((flooded-envs nil)) + (labels ((flood (flooded-env) + (unless (or (eql flooded-env home-env) + (member flooded-env flooded-envs)) + (push flooded-env flooded-envs) + (unless (memq thing (environment-closure flooded-env)) + (push thing (environment-closure flooded-env)) + (let ((lambda (environment-lambda flooded-env))) + (cond ((eq (functional-kind lambda) :external) + (let ((enclose-env (get-node-environment (xep-enclose lambda)))) + (flood enclose-env) + (dolist (ref (leaf-refs lambda)) + (close-over lambda + (get-node-environment ref) enclose-env)))) + (t (dolist (ref (leaf-refs lambda)) + ;; FIXME: This assertion looks + ;; reasonable, but does not work for + ;; :CLEANUPs. + #+nil + (let ((dest (node-dest ref))) + (aver (basic-combination-p dest)) + (aver (eq (basic-combination-kind dest) :local))) + (flood (get-node-environment ref)))))))))) + (flood ref-env))) + (values)) + +;;; Find LAMBDA-VARs that are marked as needing to support indirect +;;; access (SET at some point after initial creation) that are present +;;; in CLAMBDAs not marked as being DYNAMIC-EXTENT (meaning that the +;;; value-cell involved must be able to survive past the extent of the +;;; allocating frame), and mark them (the LAMBDA-VARs) as needing +;;; explicit value-cells. Because they are already closed-over, the +;;; LAMBDA-VARs already appear in the closures of all of the CLAMBDAs +;;; that need checking. +(defun analyze-indirect-lambda-vars (component) + (dolist (fun (component-lambdas component)) + (let ((entry-fun (functional-entry-fun fun))) + ;; We also check the ENTRY-FUN, as XEPs for LABELS or FLET + ;; functions aren't set to be DX even if their underlying + ;; CLAMBDAs are, and if we ever get LET-bound anonymous function + ;; DX working, it would mark the XEP as being DX but not the + ;; "real" CLAMBDA. This works because a FUNCTIONAL-ENTRY-FUN is + ;; either NULL, a self-pointer (for :TOPLEVEL functions), a + ;; pointer from an XEP to its underlying function (for :EXTERNAL + ;; functions), or a pointer from an underlying function to its + ;; XEP (for non-:TOPLEVEL functions with XEPs). + (unless (or (leaf-dynamic-extent fun) + ;; Functions without XEPs can be treated as if they + ;; are DYNAMIC-EXTENT, even without being so + ;; declared, as any escaping closure which /isn't/ + ;; DYNAMIC-EXTENT but calls one of these functions + ;; will also close over the required variables, thus + ;; forcing the allocation of value cells. Since the + ;; XEP is stored in the ENTRY-FUN slot, we can pick + ;; off the non-XEP case here. + (not entry-fun) + (leaf-dynamic-extent entry-fun)) + (let ((closure (environment-closure (lambda-environment fun)))) + (dolist (var closure) + (when (and (lambda-var-p var) + (lambda-var-indirect var)) + (setf (lambda-var-explicit-value-cell var) t)))))))) + +;;;; non-local exit + +(defvar *functional-escape-info*) + +(defun functional-may-escape-p (functional) + (binding* ((functional (if (lambda-p functional) + (lambda-home functional) + functional)) + (table (or *functional-escape-info* + ;; Many components have no escapes, so we + ;; allocate it lazily. + (setf *functional-escape-info* + (make-hash-table :test #'eq)))) + ((bool ok) (gethash functional table))) + (if ok + bool + (let ((entry (functional-entry-fun functional))) + ;; First stick a NIL in there: break cycles. + (setf (gethash functional table) nil) + ;; Then compute the real value. + (setf (gethash functional table) + (and + ;; ESCAPE functionals would never escape from their target + (neq (functional-kind functional) :escape) + (or + ;; If the functional has a XEP, it's kind is :EXTERNAL -- + ;; which means it may escape. ...but if it + ;; HAS-EXTERNAL-REFERENCES-P, then that XEP is actually a + ;; TL-XEP, which means it's a toplevel function -- which in + ;; turn means our search has bottomed out without an escape + ;; path. AVER just to make sure, though. + (and (eq :external (functional-kind functional)) + (if (functional-has-external-references-p functional) + (aver (eq 'tl-xep (car (functional-debug-name functional)))) + t)) + ;; If it has an entry point that may escape, that just as bad. + (and entry (functional-may-escape-p entry)) + ;; If it has references to it in functions that may escape, that's bad + ;; too. + (dolist (ref (functional-refs functional) nil) + (binding* ((lvar (ref-lvar ref) :exit-if-null) + (dest (lvar-dest lvar) :exit-if-null)) + (when (functional-may-escape-p (node-home-lambda dest)) + (return t))))))))))) + +(defun exit-should-check-tag-p (exit) + (declare (type exit exit)) + (let ((exit-lambda (lexenv-lambda (node-lexenv exit)))) + (unless (or + ;; Unsafe but fast... + (policy exit (zerop check-tag-existence)) + ;; Dynamic extent is a promise things won't escape -- + ;; and an explicit request to avoid heap consing. + (member (lambda-extent exit-lambda) '(truly-dynamic-extent dynamic-extent)) + ;; If the exit lambda cannot escape, then we should be safe. + ;; ...since the escape analysis is kinda new, and not particularly + ;; exhaustively tested, let alone proven, disable it for SAFETY 3. + (and (policy exit (< safety 3)) + (not (functional-may-escape-p exit-lambda)))) + (when (policy exit (> speed safety)) + (let ((*compiler-error-context* (exit-entry exit))) + (compiler-notify "~@" + (node-source-form exit)))) + t))) + +;;; Insert the entry stub before the original exit target, and add a +;;; new entry to the ENVIRONMENT-NLX-INFO. The %NLX-ENTRY call in the +;;; stub is passed the NLX-INFO as an argument so that the back end +;;; knows what entry is being done. +;;; +;;; The link from the EXIT block to the entry stub is changed to be a +;;; link from the component head. Similarly, the EXIT block is linked +;;; to the component tail. This leaves the entry stub reachable, but +;;; makes the flow graph less confusing to flow analysis. +;;; +;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the +;;; last node in the cleanup code to be the enclosing environment, to +;;; represent the fact that the binding was undone as a side effect of +;;; the exit. This will cause a lexical exit to be broken up if we are +;;; actually exiting the scope (i.e. a BLOCK), and will also do any +;;; other cleanups that may have to be done on the way. +(defun insert-nlx-entry-stub (exit env) + (declare (type environment env) (type exit exit)) + (let* ((exit-block (node-block exit)) + (next-block (first (block-succ exit-block))) + (entry (exit-entry exit)) + (cleanup (entry-cleanup entry)) + (info (make-nlx-info cleanup (first (block-succ exit-block)))) + (new-block (insert-cleanup-code (list exit-block) next-block + entry + `(%nlx-entry ,(opaquely-quote info)) + cleanup)) + (component (block-component new-block))) + (unlink-blocks exit-block new-block) + (link-blocks exit-block (component-tail component)) + (link-blocks (component-head component) new-block) + + (setf (exit-nlx-info exit) info) + (setf (nlx-info-target info) new-block) + (setf (nlx-info-safe-p info) (exit-should-check-tag-p exit)) + (push info (environment-nlx-info env)) + (push info (cleanup-info cleanup)) + (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) + (setf (node-lexenv (block-last new-block)) + (node-lexenv entry)))) + + (values)) + +;;; Do stuff necessary to represent a non-local exit from the node +;;; EXIT into ENV. This is called for each non-local exit node, of +;;; which there may be several per exit continuation. This is what we +;;; do: +;;; -- If there isn't any NLX-INFO entry in the environment, make +;;; an entry stub, otherwise just move the exit block link to +;;; the component tail. +;;; -- Close over the NLX-INFO in the exit environment. +;;; -- If the exit is from an :ESCAPE function, then substitute a +;;; constant reference to NLX-INFO structure for the escape +;;; function reference. This will cause the escape function to +;;; be deleted (although not removed from the DFO.) The escape +;;; function is no longer needed, and we don't want to emit code +;;; for it. +;;; -- Change the %NLX-ENTRY call to use the NLX lvar so that 1) there +;;; will be a use to represent the NLX use; 2) make life easier for +;;; the stack analysis. +(defun note-non-local-exit (env exit) + (declare (type environment env) (type exit exit)) + (let ((lvar (node-lvar exit)) + (exit-fun (node-home-lambda exit)) + (info (find-nlx-info exit))) + (cond (info + (let ((block (node-block exit))) + (aver (= (length (block-succ block)) 1)) + (unlink-blocks block (first (block-succ block))) + (link-blocks block (component-tail (block-component block))) + (setf (exit-nlx-info exit) info) + (unless (nlx-info-safe-p info) + (setf (nlx-info-safe-p info) + (exit-should-check-tag-p exit))))) + (t + (insert-nlx-entry-stub exit env) + (setq info (exit-nlx-info exit)) + (aver info))) + (close-over info (node-environment exit) env) + (when (eq (functional-kind exit-fun) :escape) + (mapc (lambda (x) + (setf (node-derived-type x) *wild-type*)) + (leaf-refs exit-fun)) + (substitute-leaf (find-constant (opaquely-quote info)) exit-fun)) + (when lvar + (let ((node (block-last (nlx-info-target info)))) + (unless (node-lvar node) + (aver (eq lvar (node-lvar exit))) + (setf (node-derived-type node) (lvar-derived-type lvar)) + (add-lvar-use node lvar))))) + (values)) + +;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT +;;; when we find a block that ends in a non-local EXIT node. +(defun find-non-local-exits (component) + (declare (type component component)) + (let ((*functional-escape-info* nil)) + (dolist (lambda (component-lambdas component)) + (dolist (entry (lambda-entries lambda)) + (let ((target-env (node-environment entry))) + (dolist (exit (entry-exits entry)) + (aver (neq (node-environment exit) target-env)) + (note-non-local-exit target-env exit)))))) + (values)) + +;;;; final decision on stack allocation of dynamic-extent structures +(defun recheck-dynamic-extent-lvars (component) + (declare (type component component)) + (let (*dx-combination-p-check-local*) ;; catch unconverted combinations + (dolist (lambda (component-lambdas component)) + (dolist (entry (lambda-entries lambda)) + (let ((cleanup (entry-cleanup entry))) + (when (eq (cleanup-kind cleanup) :dynamic-extent) + (let ((real-dx-lvars '())) + (dolist (what (cleanup-info cleanup)) + (etypecase what + (cons + (let ((dx (car what)) + (lvar (cdr what))) + (cond ((lvar-good-for-dx-p lvar dx) + ;; Since the above check does deep + ;; checks. we need to deal with the deep + ;; results in here as well. + (dolist (cell (handle-nested-dynamic-extent-lvars + dx lvar)) + (let ((real (principal-lvar (cdr cell)))) + (setf (lvar-dynamic-extent real) cleanup) + (pushnew real real-dx-lvars)))) + (t + (note-no-stack-allocation lvar) + (setf (lvar-dynamic-extent lvar) nil))))) + (enclose ; DX closure + (let* ((funs (enclose-funs what)) + (dx nil)) + (dolist (fun funs) + (when (leaf-dynamic-extent fun) + (let ((xep (functional-entry-fun fun))) + (when xep + (cond ((environment-closure (get-lambda-environment xep)) + (setq dx t)) + (t + (setf (leaf-extent fun) nil))))))) + (when dx + (let ((lvar (make-lvar))) + (use-lvar what lvar) + (setf (lvar-dynamic-extent lvar) cleanup) + (push lvar real-dx-lvars))))))) + (setf (cleanup-info cleanup) real-dx-lvars) + (setf (component-dx-lvars component) + (append real-dx-lvars (component-dx-lvars component))))))))) + (values)) + +;;;; cleanup emission + +;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating +;;; cleanup code as we go. When we are done, convert the cleanup code +;;; in an implicit MV-PROG1. We have to force local call analysis of +;;; new references to UNWIND-PROTECT cleanup functions. If we don't +;;; actually have to do anything, then we don't insert any cleanup +;;; code. (FIXME: There's some confusion here, left over from CMU CL +;;; comments. CLEANUP1 isn't mentioned in the code of this function. +;;; It is in code elsewhere, but if the comments for this function +;;; mention it they should explain the relationship to the other code.) +;;; +;;; If we do insert cleanup code, we check that BLOCK1 doesn't end in +;;; a "tail" local call. +;;; +;;; We don't need to adjust the ending cleanup of the cleanup block, +;;; since the cleanup blocks are inserted at the start of the DFO, and +;;; are thus never scanned. +(defun emit-cleanups (pred-blocks succ-block) + (collect ((code) + (reanalyze-funs)) + (let ((succ-cleanup (block-start-cleanup succ-block))) + (do-nested-cleanups (cleanup (block-end-lexenv (car pred-blocks))) + (when (eq cleanup succ-cleanup) + (return)) + (let* ((node (cleanup-mess-up cleanup)) + (args (when (basic-combination-p node) + (basic-combination-args node)))) + (ecase (cleanup-kind cleanup) + (:special-bind + (code `(%special-unbind ',(lvar-value (car args))))) + (:catch + (code `(%catch-breakup ,(opaquely-quote (car (cleanup-info cleanup)))))) + (:unwind-protect + (code `(%unwind-protect-breakup ,(opaquely-quote (car (cleanup-info cleanup))))) + (let ((fun (ref-leaf (lvar-uses (second args))))) + (when (functional-p fun) + (reanalyze-funs fun) + (code `(%funcall ,fun))))) + ((:block :tagbody) + (dolist (nlx (cleanup-info cleanup)) + (code `(%lexical-exit-breakup ,(opaquely-quote nlx))))) + (:dynamic-extent + (when (cleanup-info cleanup) + (code `(%cleanup-point)))) + (:restore-nsp + (code `(%primitive set-nsp ,(ref-leaf node)))))))) + (flet ((coalesce-unbinds (code) + (if (vop-existsp :named sb-c:unbind-n) + (loop with cleanup + while code + do (setf cleanup (pop code)) + collect (if (eq (car cleanup) '%special-unbind) + `(%special-unbind + ,(cadr cleanup) + ,@(loop while (eq (caar code) '%special-unbind) + collect (cadar code) + do (pop code))) + cleanup)) + code))) + (when (code) + (aver (not (node-tail-p (block-last (car pred-blocks))))) + (insert-cleanup-code + pred-blocks succ-block (block-last (car pred-blocks)) + `(progn ,@(coalesce-unbinds (code)))) + (dolist (fun (reanalyze-funs)) + (locall-analyze-fun-1 fun))))) + (values)) + +;;; Loop over the blocks in COMPONENT, calling EMIT-CLEANUPS when we +;;; see a successor in the same environment with a different cleanup. +;;; We ignore the cleanup transition if it is to a cleanup enclosed by +;;; the current cleanup, since in that case we are just messing up the +;;; environment, hence this is not the place to clean it. +(defun find-cleanup-points (component) + (declare (type component component)) + (do-blocks (block1 component) + (unless (block-to-be-deleted-p block1) + (let ((env1 (block-environment block1)) + (cleanup1 (block-end-cleanup block1))) + (dolist (block2 (block-succ block1)) + (when (block-start block2) + (let ((env2 (block-environment block2)) + (cleanup2 (block-start-cleanup block2))) + (unless (or (not (eq env2 env1)) + (eq cleanup1 cleanup2) + (and cleanup2 + (eq (node-enclosing-cleanup + (cleanup-mess-up cleanup2)) + cleanup1))) + ;; If multiple blocks with the same cleanups end up at the same block + ;; issue only one cleanup, e.g. (let (*) (if x 1 2)) + ;; + ;; Possible improvement: (let (*) (if x (let (**) 1) 2)) + ;; unbinding * only once. + (emit-cleanups (loop for pred in (block-pred block2) + when (or (eq pred block1) + (and + (block-start pred) + (eq (block-end-cleanup pred) cleanup1) + (eq (block-environment pred) env2))) + collect pred) + block2)))))))) + (values)) + +;;; Mark optimizable tail-recursive uses of function result +;;; continuations with the corresponding TAIL-SET. +;;; +;;; Regarding the suppression of TAIL-P for nil-returning calls, +;;; a partial history of the changes affecting this is as follows: +;;; +;;; WHN said [in 85f9c92558538b85540ff420fa8970af91e241a2] +;;; ;; Nodes whose type is NIL (i.e. don't return) such as calls to +;;; ;; ERROR are never annotated as TAIL-P, in order to preserve +;;; ;; debugging information. +;;; +;;; NS added [in bea5b384106a6734a4b280a76e8ebdd4d51b5323] +;;; ;; Why is that bad? Because this non-elimination of +;;; ;; non-returning tail calls causes the XEP for FOO [to] appear in +;;; ;; backtrace for (defun foo (x) (error "foo ~S" x)) w[h]ich seems +;;; ;; less then optimal. --NS 2005-02-28 +;;; (not considering that the point of non-elimination was specifically +;;; to allow FOO to appear in the backtrace?) +;;; +(defun tail-annotate (component) + (declare (type component component)) + (dolist (fun (component-lambdas component)) + (let ((ret (lambda-return fun))) + ;; The code below assumes that a lambda whose final node is a call to + ;; a non-returning function gets a lambda-return. But it doesn't always, + ;; and it's not clear whether that means "always doesn't". + ;; If it never does, then (WHEN RET ..) will never execute, so we won't + ;; even see the call that might be be annotated as tail-p, regardless + ;; of whether we *want* to annotate it as such. + (when ret + (let ((result (return-result ret))) + (do-uses (use result) + (when (and (basic-combination-p use) + (immediately-used-p result use) + (or (eq (basic-combination-kind use) :local) + ;; Nodes whose type is NIL (i.e. don't return) such + ;; as calls to ERROR are never annotated as TAIL-P, + ;; in order to preserve debugging information, so that + ;; + ;; We spread this net wide enough to catch + ;; untrusted NIL return types as well, so that + ;; frames calling functions such as FOO-ERROR are + ;; kept in backtraces: + ;; + ;; (defun foo-error (x) (error "oops: ~S" x)) + ;; + (not (or (eq *empty-type* (node-derived-type use)) + (eq *empty-type* (combination-defined-type use)))))) + (setf (node-tail-p use) t))))))) + ;; The above loop does not find all calls to ERROR. + (do-blocks (block component) + (do-nodes (node nil block) + ;; CAUTION: This looks scary because it affects all known nil-returning + ;; calls even if not in tail position. Use of the policy quality which + ;; enables tail-p must be confined to a very restricted lexical scope. + ;; This might be better implemented as a local declaration about + ;; function names at the call site: (declare (uninhibit-tco error)) + ;; but adding new kinds of declarations is fairly invasive surgery. + (when (and (combination-p node) + (combination-fun-info node) ; must be a known fun + (eq (combination-defined-type node) *empty-type*) + (policy node (= allow-non-returning-tail-call 3))) + (setf (node-tail-p node) t)))) + (values)) diff -Nru sbcl-2.1.10/src/compiler/float-tran.lisp sbcl-2.1.11/src/compiler/float-tran.lisp --- sbcl-2.1.10/src/compiler/float-tran.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/float-tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -844,7 +844,7 @@ (list (interval-expt-> x y-) (interval-expt-> x y+)))))) -;;; Handle the case when x <= 1 +;;; Handle the case when 0 <= x <= 1 (defun interval-expt-< (x y) (case (interval-range-info x $0d0) (+ @@ -875,9 +875,13 @@ (interval-expt-< x y+)))))) (- ;; The case where x <= 0. Y MUST be an INTEGER for this to work! - ;; The calling function must insure this! For now we'll just - ;; return the appropriate unbounded float type. - (list (make-interval :low nil :high nil))) + ;; The calling function must insure this! + (loop for interval in (flatten-list (interval-expt (interval-neg x) y)) + for low = (interval-low interval) + for high = (interval-high interval) + collect interval + when (or high low) + collect (interval-neg interval))) (t (destructuring-bind (neg pos) (interval-split 0 x t t) @@ -1673,7 +1677,7 @@ (values (complex re im) (locally (declare (notinline complex)) (complex re im))))) -#+(and (not sb-xc-host) (not riscv)) ; broken on riscv +#-sb-xc-host (dolist (test '(try-folding-complex-single try-folding-complex-double)) (multiple-value-bind (a b) (funcall test) (assert (eql a b))) diff -Nru sbcl-2.1.10/src/compiler/fndb.lisp sbcl-2.1.11/src/compiler/fndb.lisp --- sbcl-2.1.10/src/compiler/fndb.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/fndb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1865,9 +1865,9 @@ (defknown (%check-bound check-bound) (array index t) index (dx-safe)) (defknown data-vector-ref (simple-array index) t - (foldable unsafely-flushable always-translatable)) + (foldable flushable always-translatable)) (defknown data-vector-ref-with-offset (simple-array fixnum fixnum) t - (foldable unsafely-flushable always-translatable)) + (foldable flushable always-translatable)) (defknown data-nil-vector-ref (simple-array index) nil (always-translatable)) ;;; The lowest-level vector SET operators should not return a value. @@ -1990,8 +1990,11 @@ (defknown %scharset ((modifying simple-string) index character) character ()) (defknown %set-symbol-value (symbol t) t ()) (defknown (setf symbol-function) (function symbol) function ()) -(defknown %set-symbol-plist (symbol list) list () - :derive-type #'result-type-last-arg) +;; Does this really need a type deriver? It's inline, and returns its 1st arg, +;; i.e. we know exactly what object it returns, which is more precise than +;; just knowing the type. +(defknown (setf symbol-plist) (list symbol) list () + :derive-type #'result-type-first-arg) (defknown %setnth (unsigned-byte (modifying list) t) t () :derive-type #'result-type-last-arg) (defknown %set-fill-pointer ((modifying complex-vector) index) index () diff -Nru sbcl-2.1.10/src/compiler/generic/early-objdef.lisp sbcl-2.1.11/src/compiler/generic/early-objdef.lisp --- sbcl-2.1.10/src/compiler/generic/early-objdef.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/early-objdef.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -310,10 +310,17 @@ ;;; Byte index: 3 2 1 0 ;;; +-----------------------------------+-----------+ -;;; | unused | rank | flags | widetag | +;;; | unused | rank <|> flags | widetag | ;;; +-----------+-----------+-----------+-----------+ ;;; |<---------- HEADER DATA ---------->| +;;; Having contiguous rank and widetag allows +;;; SIMPLE-ARRAY-HEADER-OF-RANK-P to be done with just one comparison. +;;; Other backends may not be ready to switch the order yet. +(defconstant array-rank-position #-arm64 16 #+arm64 8) +(defconstant array-flags-position #-arm64 8 #+arm64 16) + +(defconstant array-flags-data-position (- array-flags-position n-widetag-bits)) (defconstant +array-fill-pointer-p+ #x80) (defconstant +vector-dynamic-extent+ #x40) diff -Nru sbcl-2.1.10/src/compiler/generic/early-vm.lisp sbcl-2.1.11/src/compiler/generic/early-vm.lisp --- sbcl-2.1.10/src/compiler/generic/early-vm.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/early-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -77,7 +77,10 @@ (ldb (byte (- n-word-bits n-widetag-bits 1) 0) -1)) ;;; The ANSI-specified minimum is 8. -(defconstant array-rank-limit 256 +;;; Since the array rank is stored as rank-1 in the array header, +;;; having it stop at 128 ensures that adding 1 produces an unsigned +;;; result. +(defconstant array-rank-limit 129 "the exclusive upper bound on the rank of an array") ;;; FIXME: these limits are wrong at the most basic level according to the spec, diff -Nru sbcl-2.1.10/src/compiler/generic/genesis.lisp sbcl-2.1.11/src/compiler/generic/genesis.lisp --- sbcl-2.1.10/src/compiler/generic/genesis.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/genesis.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1477,7 +1477,7 @@ (defun set-readonly (vector) (write-wordindexed/raw vector 0 (logior (read-bits-wordindexed vector 0) (ash sb-vm:+vector-shareable+ - sb-vm:n-widetag-bits))) + sb-vm:array-flags-position))) vector) (defun initialize-packages () @@ -1929,7 +1929,7 @@ (sort (%hash-table-alist *cold-package-symbols*) #'string< :key #'car)))) ; Sort by package-name - (dump-symbol-info-vectors + (dump-symbol-infos (attach-fdefinitions-to-symbols (attach-classoid-cells-to-symbols (make-hash-table :test #'eq)))) @@ -2101,7 +2101,7 @@ ;; (defun attach-fdefinitions-to-symbols (hashtable) ;; Collect fdefinitions that go with one symbol, e.g. CAR and (SETF CAR), - ;; using the host's code for manipulating a packed info-vector. + ;; using the host's code for manipulating a packed-info. (maphash (lambda (warm-name cold-fdefn) (with-globaldb-name (key1 key2) warm-name :hairy (error "Hairy fdefn name in genesis: ~S" warm-name) @@ -2113,24 +2113,33 @@ *cold-fdefn-objects*) hashtable) -(defun dump-symbol-info-vectors (hashtable) - ;; Emit in the same order symbols reside in core to avoid - ;; sensitivity to the iteration order of host's maphash. - (loop for (warm-sym . info) +(defun dump-packed-info (list) + ;; Payload length is the element count + LAYOUT slot if necessary. + ;; Header word is added automatically by ALLOCATE-STRUCT + (let ((s (allocate-struct (+ sb-vm:instance-data-start (length list)) + (cold-layout-descriptor (gethash 'packed-info *cold-layouts*))))) + (loop for i from (+ sb-vm:instance-slots-offset sb-vm:instance-data-start) + for elt in list do (write-wordindexed s i elt)) + s)) +(defun dump-symbol-infos (hashtable) + (cold-set 'sb-impl::+nil-packed-infos+ + (dump-packed-info (list (make-fixnum-descriptor 0)))) + ;; Emit in the same order symbols reside in core to avoid + ;; sensitivity to the iteration order of host's maphash. + (loop for (warm-sym . info) in (sort (%hash-table-alist hashtable) #'< :key (lambda (x) (descriptor-bits (cold-intern (car x))))) do (write-wordindexed (cold-intern warm-sym) sb-vm:symbol-info-slot - ;; Each vector will have one fixnum, possibly the symbol SETF, + (dump-packed-info + ;; Each packed-info will have one fixnum, possibly the symbol SETF, ;; and one or two # objects in it, and/or a classoid-cell. - (vector-in-core (map 'list (lambda (elt) (etypecase elt (symbol (cold-intern elt)) - (fixnum (make-fixnum-descriptor elt)) + (sb-xc:fixnum (make-fixnum-descriptor elt)) (descriptor elt))) - info))))) - + (sb-impl::packed-info-cells info)))))) ;;;; fixups and related stuff @@ -2216,9 +2225,11 @@ descriptor) cold-fixup)) (defun cold-fixup (code-object after-header value kind flavor) - (when (sb-vm:fixup-code-object code-object after-header value kind flavor) - (push (cons kind after-header) - (gethash (descriptor-bits code-object) *code-fixup-notes*))) + (let ((classification + (sb-vm:fixup-code-object code-object after-header value kind flavor))) + (when classification + (push (cons classification after-header) + (gethash (descriptor-bits code-object) *code-fixup-notes*)))) code-object) (defun resolve-static-call-fixups () @@ -2228,16 +2239,17 @@ (cold-fun-entry-addr (cold-symbol-function name)) kind :static-call)))) -;;; Save packed lists of absolute and relative fixups. +;;; Save packed lists of fixups. ;;; (cf. FINISH-FIXUPS in generic/target-core.) (defun repack-fixups (list) - (collect ((relative) (absolute)) + (collect ((immediate) (relative) (absolute)) (dolist (item list) (ecase (car item) ;; There should be no absolute64 fixups to preserve + (:immediate (immediate (cdr item))) (:relative (relative (cdr item))) (:absolute (absolute (cdr item))))) - (number-to-core (sb-c:pack-code-fixup-locs (absolute) (relative))))) + (number-to-core (sb-c:pack-code-fixup-locs (absolute) (relative) (immediate))))) (defun linkage-table-note-symbol (symbol-name datap) "Register a symbol and return its address in proto-linkage-table." @@ -2591,7 +2603,8 @@ #-untagged-fdefns (write-wordindexed code index fdefn)) (define-cold-fop (fop-load-code (header code-size n-fixups)) - (let* ((n-named-calls (read-unsigned-byte-32-arg (fasl-input-stream))) + (let* ((n-entries (read-unsigned-byte-32-arg (fasl-input-stream))) + (n-named-calls (read-unsigned-byte-32-arg (fasl-input-stream))) (immobile (oddp header)) ; decode the representation used by dump ;; The number of constants is rounded up to even (if required) ;; to ensure that the code vector will be properly aligned. @@ -2612,6 +2625,7 @@ (end (+ start code-size))) (read-bigvec-as-sequence-or-die (descriptor-mem des) (fasl-input-stream) :start start :end end) + (aver (= (code-n-entries des) n-entries)) (let ((jumptable-word (read-bits-wordindexed des aligned-n-boxed-words))) (aver (zerop (ash jumptable-word -14))) ;; assign serialno @@ -2758,6 +2772,8 @@ (:layout-id ; SYM is a # (cold-layout-id (gethash (descriptor-bits (->layout sym)) *cold-layout-by-addr*))) + ;; The machine-dependent code decides how to patch in 'nbits' + #+gencgc (:gc-barrier sb-vm::gencgc-card-table-index-nbits) (:immobile-symbol ;; an interned symbol is represented by its host symbol, ;; but an uninterned symbol is a descriptor. @@ -2932,8 +2948,11 @@ sb-vm:n-lowtag-bits sb-vm:lowtag-mask sb-vm:n-widetag-bits sb-vm:widetag-mask sb-vm:n-fixnum-tag-bits sb-vm:fixnum-tag-mask + sb-vm:instance-length-mask sb-vm:dsd-raw-type-mask - sb-vm:short-header-max-words)) + sb-vm:short-header-max-words + sb-vm:array-flags-position + sb-vm:array-rank-position)) (push (list (c-symbol-name c) -1 ; invent a new priority (symbol-value c) @@ -3333,7 +3352,8 @@ (dotimes (i (length sections)) (format t "~4<~@R~>. ~A~%" (1+ i) (nth i sections)))) (format t "=================~2%") - (format t "I. assembler routines defined in core image:~2%") + (format t "I. assembler routines defined in core image: (base=~x)~2%" + (descriptor-bits *cold-assembler-obj*)) (dolist (routine *cold-assembler-routines*) (let ((name (car routine))) (format t "~8,'0X: ~S~%" (lookup-assembler-reference name) name))) @@ -3400,7 +3420,7 @@ (dolist (classoid dumped-classoids) (let ((nwords (logand (ash (read-bits-wordindexed classoid 0) (- sb-vm:instance-length-shift)) - sb-vm::instance-length-mask))) + sb-vm:instance-length-mask))) (format t "Classoid @ ~x, ~d words:~%" (descriptor-bits classoid) (1+ nwords)) (dotimes (i (1+ nwords)) ; include the header word in output (format t "~2d: ~10x~%" i (read-bits-wordindexed classoid i))) @@ -3543,8 +3563,10 @@ (write-bigvec-as-sequence ptes core-file :end pte-bytes) (force-output core-file) (file-position core-file posn)) - (mapc write-word ; 5 = number of words in this core header entry - `(,page-table-core-entry-type-code 5 ,n-ptes ,pte-bytes ,data-page)))) + (mapc write-word + `(,page-table-core-entry-type-code + 6 ; = number of words in this core header entry + ,sb-vm::gencgc-card-table-index-nbits ,n-ptes ,pte-bytes ,data-page)))) ;;; Create a core file created from the cold loaded image. (This is ;;; the "initial core file" because core files could be created later @@ -3823,7 +3845,6 @@ (resolve-deferred-known-funs) (resolve-static-call-fixups) (foreign-symbols-to-core) - #+(or x86 immobile-space) (dolist (pair (sort (%hash-table-alist *code-fixup-notes*) #'< :key #'car)) (write-wordindexed (make-random-descriptor (car pair)) sb-vm::code-fixups-slot (repack-fixups (cdr pair)))) diff -Nru sbcl-2.1.10/src/compiler/generic/late-objdef.lisp sbcl-2.1.11/src/compiler/generic/late-objdef.lisp --- sbcl-2.1.10/src/compiler/generic/late-objdef.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/late-objdef.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,13 +18,7 @@ (defknown symbol-extra (t) t (flushable)) (def-reffer 'symbol-extra symbol-size other-pointer-lowtag) (defknown (setf symbol-extra) (t t) t ()) - (def-setter '(setf symbol-extra) symbol-size other-pointer-lowtag) - ;; I don't feel a pressing need to add even more syntax to DEFINE-PRIMITIVE-OBJECT - ;; informing it not to generate code automatically for :SET-KNOWN on these two code slots. - ;; Just clear the IR2-CONVERT handler. - #+(or x86 x86-64) - (dolist (slot '(%code-debug-info %code-fixups)) - (setf (sb-c::fun-info-ir2-convert (info :function :info `(setf ,slot))) nil))) + (def-setter '(setf symbol-extra) symbol-size other-pointer-lowtag)) (defconstant extended-symbol-size (1+ symbol-size)) @@ -35,10 +29,13 @@ (ash (slot-offset slot) word-shift)))) #+gencgc -(defconstant large-object-size - (* 4 (max +backend-page-bytes+ gencgc-card-bytes - gencgc-alloc-granularity))) - +(progn +;;; don't change allocation granularity +(assert (= gencgc-alloc-granularity 0)) +;;; cards are not larger than pages +(assert (<= gencgc-card-bytes +backend-page-bytes+)) +;;; largeness does not depend on the hardware page size +(defconstant large-object-size (* 4 gencgc-card-bytes))) ;;; Keep this (mostly) lined up with 'early-objdef' for sanity's sake! #+sb-xc-host diff -Nru sbcl-2.1.10/src/compiler/generic/layout-ids.lisp sbcl-2.1.11/src/compiler/generic/layout-ids.lisp --- sbcl-2.1.10/src/compiler/generic/layout-ids.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/layout-ids.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -71,7 +71,7 @@ SB-C::ABSTRACT-LEXENV SB-KERNEL:UNKNOWN-TYPE SB-KERNEL:CONS-TYPE -SB-C::IR2-PHYSENV +SB-C::IR2-ENVIRONMENT SB-C::BASIC-VAR SB-KERNEL:FUN-DESIGNATOR-TYPE SB-PRETTY::QUEUED-OP diff -Nru sbcl-2.1.10/src/compiler/generic/objdef.lisp sbcl-2.1.11/src/compiler/generic/objdef.lisp --- sbcl-2.1.10/src/compiler/generic/objdef.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/objdef.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -180,7 +180,7 @@ ;;; hidden dependencies on primitive object sizes for the most part, ;;; 'ppc-assem.S' contains a literal constant that relies on knowing ;;; the precise size of a code object. Yes, there is a FIXME there :-) -;;; So, if you touch this, then fix that. +;;; So, if you touch this, then fix that. REALLY REALLY. (define-primitive-object (code :type code-component :lowtag other-pointer-lowtag :widetag code-header-widetag) @@ -196,21 +196,15 @@ ;; for the assembler code component, a cons holding a hash-table. ;; (the cons points from read-only to static space, but the hash-table ;; wants to be in dynamic space) + ;; The corresponding SETF function is defined using code-header-set + ;; on the slot index; and there's a special variant if #+darwin-jit. (debug-info :type t :ref-known (flushable) - :ref-trans %%code-debug-info - :set-known () - :set-trans (setf #-darwin-jit %code-debug-info - #+darwin-jit %%code-debug-info)) - ;; Define this slot if the architecture might ever use fixups. - ;; x86-64 doesn't necessarily use them, depending on the feature set, - ;; but this keeps things consistent. - #+(or x86 x86-64) - (fixups :type t - :ref-known (flushable) - :ref-trans %code-fixups - :set-known () - :set-trans (setf %code-fixups)) + :ref-trans %%code-debug-info) + ;; Not all architectures use fixups. The slot is always present for consistency. + ;; The corresponding SETF function is defined using code-header-set + ;; on the slot index. + (fixups :type t :ref-known (flushable) :ref-trans %code-fixups) (constants :rest-p t)) (define-primitive-object (fdefn :type fdefn @@ -380,11 +374,20 @@ :set-trans %set-symbol-global-value :set-known ()) - (info :ref-trans symbol-info :ref-known (flushable) - :set-trans (setf symbol-info) + ;; The private accessor for INFO reads the slot verbatim. + ;; In contrast, the SYMBOL-INFO function always returns a PACKED-INFO + ;; instance (see info-vector.lisp) or NIL. The slot itself may hold a cons + ;; of the user's PLIST and a PACKED-INFO or just a PACKED-INFO. + ;; It can't hold a PLIST alone without wrapping in an extra cons cell. + (info :ref-trans symbol-%info :ref-known (flushable) + :set-trans (setf symbol-%info) :set-known () - :cas-trans %compare-and-swap-symbol-info - :type (or simple-vector list) + ;; IR2-CONVERT-CASSER only knows the arg order as (OBJECT OLD NEW), + ;; so as much as I'd like to name this (CAS SYMBOL-%INFO), + ;; it can't be that, because it'd need args of (OLD NEW OBJECT). + ;; This is a pretty close approximation of the desired name. + :cas-trans sb-impl::cas-symbol-%info + :type (or instance list) :init :null) (name :ref-trans symbol-name :init :arg) (package :ref-trans sb-xc:symbol-package @@ -520,10 +523,6 @@ #+gencgc (unboxed-tlab :c-type "struct alloc_region" :length 4) ;; END of slots to keep near the beginning. - (dynspace-addr) - (dynspace-card-count) - (dynspace-pte-base) - ;; This is the original address at which the memory was allocated, ;; which may have different alignment then what we prefer to use. ;; Kept here so that when the thread dies we can release the whole @@ -568,6 +567,7 @@ (control-stack-pointer :c-type "lispobj *") #+mach-exception-handler (mach-port-name :c-type "mach_port_name_t") + #+ppc64 (card-table) ;; allocation instrumenting (tot-bytes-alloc-boxed) diff -Nru sbcl-2.1.10/src/compiler/generic/parms.lisp sbcl-2.1.11/src/compiler/generic/parms.lisp --- sbcl-2.1.10/src/compiler/generic/parms.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/parms.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -131,7 +131,20 @@ (or ,(or (!read-dynamic-space-size) dynamic-space-size*) (ecase n-word-bits (32 (expt 2 29)) - (64 (expt 2 30))))))))) + (64 (expt 2 30))))) + (defconstant gencgc-card-shift + (integer-length (1- sb-vm:gencgc-card-bytes))) + ;; This is a constant during build, but a different value + ;; can be patched directly into the affected machine code + ;; when the core is loaded based on dynamic-space-size. + ;; I think the C runtime does a floor operation rather than ceiling, + ;; but firstly there's probably no difference, and secondly it's better + ;; to be safe than sorry - using too many bits rather than too few. + (defconstant gencgc-card-table-index-nbits + (integer-length (1- (ceiling sb-vm::default-dynamic-space-size + sb-vm::gencgc-card-bytes)))) + (defconstant gencgc-card-table-index-mask + (1- (ash 1 gencgc-card-table-index-nbits))))))) (defconstant-eqx +c-callable-fdefns+ '(sub-gc diff -Nru sbcl-2.1.10/src/compiler/generic/target-core.lisp sbcl-2.1.11/src/compiler/generic/target-core.lisp --- sbcl-2.1.10/src/compiler/generic/target-core.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/target-core.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -71,52 +71,63 @@ (* sb-vm:simple-fun-self-slot sb-vm:n-word-bytes)) (get-lisp-obj-address self)))) -(flet ((fixup (code-obj offset sym kind flavor preserved-lists statically-link-p) +(flet ((fixup (code-obj offset name kind flavor preserved-lists statically-link-p) (declare (ignorable statically-link-p)) + ;; NAME depends on the kind and flavor of fixup. ;; PRESERVED-LISTS is a vector of lists of locations (by kind) ;; at which fixup must be re-applied after code movement. ;; CODE-OBJ must already be pinned in order to legally call this. ;; One call site that reaches here is below at MAKE-CORE-COMPONENT ;; and the other is LOAD-CODE, both of which pin the code. - ;; SYM is a little bit of a misnomer - it may be a generalized function name. - (when (sb-vm:fixup-code-object + (ecase + (sb-vm:fixup-code-object code-obj offset (ecase flavor ((:assembly-routine :assembly-routine* :asm-routine-nil-offset) - (- (or (get-asm-routine sym (eq flavor :assembly-routine*)) - (error "undefined assembler routine: ~S" sym)) + (- (or (get-asm-routine name (eq flavor :assembly-routine*)) + (error "undefined assembler routine: ~S" name)) (if (eq flavor :asm-routine-nil-offset) sb-vm:nil-value 0))) - (:foreign (foreign-symbol-address sym)) - (:foreign-dataref (foreign-symbol-address sym t)) + (:foreign (foreign-symbol-address name)) + (:foreign-dataref (foreign-symbol-address name t)) (:code-object (get-lisp-obj-address code-obj)) - #+sb-thread (:symbol-tls-index (ensure-symbol-tls-index sym)) + #+sb-thread (:symbol-tls-index (ensure-symbol-tls-index name)) (:layout (get-lisp-obj-address - (wrapper-friend (if (symbolp sym) (find-layout sym) sym)))) - (:layout-id (layout-id sym)) - (:immobile-symbol (get-lisp-obj-address sym)) - (:symbol-value (get-lisp-obj-address (symbol-global-value sym))) + (wrapper-friend (if (symbolp name) (find-layout name) name)))) + (:layout-id (layout-id name)) + #+gencgc (:gc-barrier (extern-alien "gc_card_table_nbits" int)) + (:immobile-symbol (get-lisp-obj-address name)) + ;; It is legal to take the address of symbol-value only if the + ;; value is known to be an immobile object + ;; (whose address we don't want to wire in). + (:symbol-value (get-lisp-obj-address (symbol-global-value name))) #+immobile-code (:named-call - (prog1 (sb-vm::fdefn-entry-address sym) ; creates if didn't exist + (prog1 (sb-vm::fdefn-entry-address name) ; creates if didn't exist (when statically-link-p - (push (cons offset (find-fdefn sym)) (elt preserved-lists 0))))) - #+immobile-code (:static-call (sb-vm::function-raw-address sym))) + (push (cons offset (find-fdefn name)) (elt preserved-lists 0))))) + #+immobile-code (:static-call (sb-vm::function-raw-address name))) kind flavor) - (ecase kind - (:relative (push offset (elt preserved-lists 1))) - (:absolute (push offset (elt preserved-lists 2))) - (:absolute64 (push offset (elt preserved-lists 3)))))) + ((nil)) ; don't need to save it in the code-fixups, otherwise do + (:relative (push offset (elt preserved-lists 1))) + (:absolute (push offset (elt preserved-lists 2))) + (:immediate (push offset (elt preserved-lists 3))) + (:absolute64 (push offset (elt preserved-lists 4))))) (finish-fixups (code-obj preserved-lists) (declare (ignorable code-obj preserved-lists)) - #+(or x86 x86-64) + ;; PRESERVED-LISTS are somewhat backend-dependent, but essentially + ;; you get to store three lists that might as well have been named + ;; Larry, Moe, and Curly. (let ((rel-fixups (elt preserved-lists 1)) (abs-fixups (elt preserved-lists 2)) - (abs64-fixups (elt preserved-lists 3))) - (aver (not abs64-fixups)) ; no preserved 64-bit fixups - (when (or abs-fixups rel-fixups) + (gc-barrier-fixups (elt preserved-lists 3)) + (abs64-fixups (elt preserved-lists 4))) + ;; the fixup list packer only preserves at most 3 lists. + ;; And it's not clear that this is the best way to represent them. + (aver (not abs64-fixups)) + (when (or abs-fixups rel-fixups gc-barrier-fixups) (setf (sb-vm::%code-fixups code-obj) - (sb-c:pack-code-fixup-locs abs-fixups rel-fixups)))) + (sb-c:pack-code-fixup-locs abs-fixups rel-fixups gc-barrier-fixups)))) ;; Assign all SIMPLE-FUN-SELF slots (dotimes (i (code-n-entries code-obj)) @@ -134,7 +145,7 @@ (aref preserved-lists 0))) (defun apply-fasl-fixups (fop-stack code-obj n-fixups &aux (top (svref fop-stack 0))) - (dx-let ((preserved (make-array 4 :initial-element nil))) + (dx-let ((preserved (make-array 5 :initial-element nil))) (macrolet ((pop-fop-stack () `(prog1 (svref fop-stack top) (decf top)))) (binding* ((alloc-points (pop-fop-stack) :exit-if-null)) (setf (gethash code-obj *allocation-patch-points*) alloc-points)) @@ -261,11 +272,25 @@ (2comp (component-info component)) (constants (ir2-component-constants 2comp)) (nboxed (align-up (length constants) sb-c::code-boxed-words-align)) - (code-obj (allocate-code-object - (component-mem-space component) - (count-if (lambda (x) (typep x '(cons (eql :named-call)))) - constants) - nboxed length)) + (n-named-calls + ;; Pre-scan for fdefinitions to ensure their existence. + ;; Doing so guarantees that storing them into the boxed header now + ;; can't create any old->young pointer, which is important since gencgc + ;; does not deal with untagged pointers when looking for old->young. + (do ((count 0) + (index (+ sb-vm:code-constants-offset + (* (length (ir2-component-entries 2comp)) + sb-vm:code-slots-per-simple-fun)) + (1+ index))) + ((>= index (length constants)) count) + (let* ((const (aref constants index)) + (kind (if (listp const) (car const) const))) + (case kind + ((member :named-call :fdefinition) + (setf (second const) (find-or-create-fdefn (second const))) + (when (eq kind :named-call) (incf count))))))) + (code-obj (allocate-code-object (component-mem-space component) + n-named-calls nboxed length)) (named-call-fixups ;; The following operations need the code pinned: ;; 1. copying into code-instructions (a SAP) @@ -344,8 +369,7 @@ (t (let ((referent (etypecase kind - ((member :named-call :fdefinition) - (find-or-create-fdefn (cadr const))) + ((member :named-call :fdefinition) (cadr const)) ((eql :known-fun) (%coerce-name-to-fun (cadr const))) (constant diff -Nru sbcl-2.1.10/src/compiler/generic/utils.lisp sbcl-2.1.11/src/compiler/generic/utils.lisp --- sbcl-2.1.10/src/compiler/generic/utils.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/utils.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -130,7 +130,7 @@ ;;; Make an environment-live stack TN for saving the SP for NLX entry. (defun make-nlx-sp-tn (env) - (physenv-live-tn + (environment-live-tn (make-representation-tn *fixnum-primitive-type* any-reg-sc-number) env)) @@ -210,12 +210,90 @@ (not (types-equal-or-intersect (tn-ref-type tn-ref) (specifier-type '(eql nil)))))) +(defun stack-consed-p (object) + (let ((write (sb-c::tn-writes object))) ; list of write refs + (when (or (not write) ; grrrr, the only write is from a LOAD tn + ; and we don't know the corresponding normal TN? + (tn-ref-next write)) ; can't determine if > 1 write + (return-from stack-consed-p nil)) + (let ((vop (tn-ref-vop write))) + (when (not vop) ; wat? + (return-from stack-consed-p nil)) + (when (eq (vop-name vop) 'allocate-vector-on-stack) + (return-from stack-consed-p t)) + (when (and (eq (vop-name vop) 'fixed-alloc) + (fifth (vop-codegen-info vop))) ; STACK-ALLOCATE-P + (return-from stack-consed-p t)) + ;; Should we try to detect a stack-consed LIST also? + ;; I don't think that will work. + ;; (And is there anything else interesting to try?) + (unless (member (vop-name vop) '(splat-word splat-small splat-any)) + (return-from stack-consed-p nil)) + (let* ((splat-input (vop-args vop)) + (splat-input-source + (tn-ref-vop (sb-c::tn-writes (tn-ref-tn splat-input))))) + ;; How in the heck can there NOT be a vop??? Well, sometimes there isn't. + (when (and splat-input-source + (eq (vop-name splat-input-source) + 'allocate-vector-on-stack)) + (return-from stack-consed-p t))))) + nil) + +;;; Just gathering some data to see where we can improve +(define-load-time-global *store-barriers-potentially-emitted* 0) +(define-load-time-global *store-barriers-emitted* 0) + +(defun require-gc-store-barrier-p (object value-tn-ref value-tn) + (incf *store-barriers-potentially-emitted*) + ;; If OBJECT is stack-allocated, elide the barrier + (when (stack-consed-p object) + (return-from require-gc-store-barrier-p nil)) + (flet ((potential-heap-pointer-p (tn tn-ref) + (when (sc-is tn any-reg) ; must be fixnum + (return-from potential-heap-pointer-p nil)) + ;; If stack-allocated, elide the barrier + (when (stack-consed-p tn) + (return-from potential-heap-pointer-p nil)) + ;; If immediate non-pointer, elide the barrier + (when (sc-is tn immediate) + (let ((value (tn-value tn))) + (when (sb-xc:typep value '(or character sb-xc:fixnum boolean + #+64-bit single-float)) + (return-from potential-heap-pointer-p nil)))) + (when (sb-c::unbound-marker-tn-p tn) + (return-from potential-heap-pointer-p nil)) + ;; And elide for things like (OR FIXNUM NULL) + (let ((type (tn-ref-type tn-ref))) + (when (csubtypep type (specifier-type '(or character sb-xc:fixnum boolean + #+64-bit single-float))) + (return-from potential-heap-pointer-p nil))) + t)) + (cond (value-tn + (unless (eq (tn-ref-tn value-tn-ref) value-tn) + (aver (eq (tn-ref-load-tn value-tn-ref) value-tn))) + (unless (potential-heap-pointer-p value-tn value-tn-ref) + (return-from require-gc-store-barrier-p nil))) + (value-tn-ref ; a list of refs linked through TN-REF-ACROSS + ;; (presumably from INSTANCE-SET-MULTIPLE) + (let ((any-pointer + (do ((ref value-tn-ref (tn-ref-across ref))) + ((null ref)) + (when (potential-heap-pointer-p (tn-ref-tn ref) ref) + (return t))))) + (unless any-pointer + (return-from require-gc-store-barrier-p nil)))))) + (incf *store-barriers-emitted*) + t) + +(defun vop-nth-arg (n vop) + (let ((ref (vop-args vop))) + (dotimes (i n ref) (setq ref (tn-ref-across ref))))) + (defun length-field-shift (widetag) (if (= widetag instance-widetag) instance-length-shift n-widetag-bits)) -(defconstant array-rank-byte-pos 16) (defconstant array-rank-mask 255) ;;; Rank is encoded as a (UNSIGNED-BYTE 8) minus one. ;;; Initialization of simple rank 1 array header words is completely unaffected- @@ -232,7 +310,7 @@ (>= widetag complex-base-string-widetag)))) (logior (if array-header-p (let ((rank (- nwords array-dimensions-offset))) - (ash (encode-array-rank rank) array-rank-byte-pos)) + (ash (encode-array-rank rank) array-rank-position)) (case widetag (#.fdefn-widetag 0) (t (ash (1- nwords) (length-field-shift widetag))))) diff -Nru sbcl-2.1.10/src/compiler/generic/vm-fndb.lisp sbcl-2.1.11/src/compiler/generic/vm-fndb.lisp --- sbcl-2.1.10/src/compiler/generic/vm-fndb.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-fndb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -123,7 +123,12 @@ (defknown %set-symbol-hash (symbol hash-code) t ()) -(defknown symbol-info-vector (symbol) (or null simple-vector)) +;;; TODOD: I'd like to eliminate the (OR NULL) from this return type. +;;; For that to happen, I probably need +nil-packed-infos+ to become +;;; placed in static space because assembly routines may need it. +;;; On the other hand, they may not, because there is no special case +;;; code needed when reading from it, which is entire point. +(defknown symbol-dbinfo (symbol) (or null packed-info)) (defknown initialize-vector ((simple-array * (*)) &rest t) (simple-array * (*)) @@ -168,7 +173,7 @@ ;;; ASSIGN-VECTOR-FLAGSS assign all and only the flags byte. ;;; RESET- performs LOGANDC2 and returns no value. (defknown (assign-vector-flags reset-header-bits) - (t (unsigned-byte 8)) (values) + (t (unsigned-byte 16)) (values) (#+x86-64 always-translatable)) (defknown (test-header-bit) (t (unsigned-byte #.(- sb-vm:n-word-bits sb-vm:n-widetag-bits))) (boolean) @@ -181,10 +186,12 @@ (defknown %array-rank (array) array-rank (flushable)) -#+(or x86 x86-64) +#+(or x86 x86-64 arm64) (defknown (%array-rank= widetag=) (t t) boolean (flushable)) +(defknown simple-array-header-of-rank-p (t array-rank) boolean + (flushable)) (defknown sb-kernel::check-array-shape (simple-array list) (simple-array) (flushable) @@ -208,7 +215,6 @@ (foldable flushable)) (defknown %set-instance-layout (instance sb-vm:layout) (values) ()) ;;; %SET-FUN-LAYOUT should only called on FUNCALLABLE-INSTANCE -;;; (but %set-funcallable-instance-layout is too long a name) (defknown %set-fun-layout (funcallable-instance sb-vm:layout) (values) ()) ;;; Layout getter that accepts any object, and if it has INSTANCE- or FUN- ;;; POINTER-LOWTAG returns the layout, otherwise some agreed-upon layout. @@ -256,8 +262,7 @@ ;;; These two are mostly used for bit-bashing operations. (defknown %vector-raw-bits (t index) sb-vm:word (flushable)) -(defknown (%set-vector-raw-bits) (t index sb-vm:word) sb-vm:word - ()) +(defknown (%set-vector-raw-bits) (t index sb-vm:word) (values) ()) ;;; Allocate an unboxed, non-fancy vector with type code TYPE, length LENGTH, @@ -274,7 +279,7 @@ ;;; vector type will usuallly end up calling allocate-vector-with-widetag ;;; via %MAKE-ARRAY. (defknown allocate-vector (#+ubsan boolean - (unsigned-byte 9) index + word index ;; The number of words is later converted ;; to bytes, make sure it fits. (and index @@ -595,6 +600,7 @@ (defknown %closure-index-ref (function index) t (flushable)) +(defknown %closure-index-set (function index t) (values) ()) ;; T argument is for the 'fun' slot. (defknown sb-vm::%alloc-closure (index t) function (flushable)) @@ -605,7 +611,8 @@ ()) (defknown %funcallable-instance-info (function index) t (flushable)) -(defknown %set-funcallable-instance-info (function index t) t ()) +(defknown (setf %funcallable-instance-info) (t function index) t ()) +(defknown %set-funcallable-instance-info (function index t) (values) ()) #+sb-fasteval (defknown sb-interpreter:fun-proto-fn (interpreted-function) diff -Nru sbcl-2.1.10/src/compiler/generic/vm-ir2tran.lisp sbcl-2.1.11/src/compiler/generic/vm-ir2tran.lisp --- sbcl-2.1.10/src/compiler/generic/vm-ir2tran.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-ir2tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -150,6 +150,13 @@ (unless (null args) (bug "Leftover args: ~S" args))) +(defun unbound-marker-tn-p (tn) + (let ((writes (tn-writes tn))) + (and writes + (not (tn-ref-next writes)) ; is never changed + (let ((vop (tn-ref-vop writes))) + (and vop (eq (vop-name vop) 'make-unbound-marker)))))) + (defun emit-fixed-alloc (node block name words type lowtag result lvar) (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar)))) (when stack-allocate-p diff -Nru sbcl-2.1.10/src/compiler/generic/vm-tran.lisp sbcl-2.1.11/src/compiler/generic/vm-tran.lisp --- sbcl-2.1.10/src/compiler/generic/vm-tran.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -37,7 +37,7 @@ (define-source-transform %make-symbol (kind string) (declare (ignore kind)) ;; Set "logically read-only" bit in pname. - `(sb-vm::%%make-symbol (logior-header-bits ,string ,sb-vm:+vector-shareable+))) + `(sb-vm::%%make-symbol (logior-array-flags ,string ,sb-vm:+vector-shareable+))) ;;; We don't want to clutter the bignum code. #+(and (or x86 x86-64) (not bignum-assertions)) diff -Nru sbcl-2.1.10/src/compiler/globaldb.lisp sbcl-2.1.11/src/compiler/globaldb.lisp --- sbcl-2.1.10/src/compiler/globaldb.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/globaldb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -51,9 +51,9 @@ ;;; sources partway through bootstrapping, tch tch, overwriting its ;;; version with our version would be unlikely to help, because that ;;; would make the cross-compiler very confused.) -(defun !register-meta-info (metainfo) +(defun register-meta-info (metainfo) (let* ((name (meta-info-kind metainfo)) - (list (!get-meta-infos name))) + (list (get-meta-infos name))) (set-info-value name +info-metainfo-type-num+ (cond ((not list) metainfo) ; unique, just store it ((listp list) (cons metainfo list)) ; prepend to the list @@ -67,7 +67,7 @@ (return-from !%define-info-type it)) ; do nothing (let ((id (or id (position nil *info-types* :start 1) (error "no more INFO type numbers available")))) - (!register-meta-info + (register-meta-info (setf (aref *info-types* id) (!make-meta-info id category kind type-spec type-checker validate-function default))))) @@ -107,7 +107,7 @@ '#'identity `(named-lambda "check-type" (x) (the ,type-spec x))) ,validate-function ,default - ;; Rationale for hardcoding here is explained at INFO-VECTOR-FDEFN. + ;; Rationale for hardcoding here is explained at PACKED-INFO-FDEFN. ,(or (and (eq category :function) (eq kind :definition) +fdefn-info-num+) #+sb-xc (meta-info-number (meta-info category kind)))))) @@ -204,18 +204,18 @@ (hookp (and (and hook (not (eql 0 (car hook))) (logbitp info-number (car hook)))))) - (multiple-value-bind (vector aux-key) + (multiple-value-bind (packed-info aux-key) (let ((name (uncross name))) (with-globaldb-name (key1 key2) name ;; In the :simple branch, KEY1 is no doubt a symbol, ;; but constraint propagation isn't informing the compiler here. - :simple (values (symbol-info-vector (truly-the symbol key1)) key2) + :simple (values (symbol-dbinfo (truly-the symbol key1)) key2) :hairy (values (info-gethash name *info-environment*) +no-auxiliary-key+))) - (when vector - (let ((index (packed-info-value-index vector aux-key info-number))) + (when packed-info + (let ((index (packed-info-value-index packed-info aux-key info-number))) (when index - (let ((answer (svref vector index))) + (let ((answer (%info-ref packed-info index))) (when hookp (funcall (truly-the function (cdr hook)) name info-number answer t)) @@ -583,7 +583,7 @@ ;; This is for the SB-INTROSPECT contrib module, and debugging. (defun call-with-each-info (function symbol) - (awhen (symbol-info-vector symbol) + (awhen (symbol-dbinfo symbol) (%call-with-each-info function it symbol))) ;; This is for debugging at the REPL. diff -Nru sbcl-2.1.10/src/compiler/gtn.lisp sbcl-2.1.11/src/compiler/gtn.lisp --- sbcl-2.1.10/src/compiler/gtn.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/gtn.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,9 +18,15 @@ ;;; passing locations and return conventions and TNs for local variables. (defun gtn-analyze (component) (setf (component-info component) (make-ir2-component)) - (let ((funs (component-lambdas component))) + (let ((funs (component-lambdas component)) + #+fp-and-pc-standard-save + (old-fp (make-old-fp-save-location)) + #+fp-and-pc-standard-save + (old-pc (make-return-pc-save-location))) (dolist (fun funs) - (assign-ir2-physenv fun) + (assign-ir2-environment fun + #+fp-and-pc-standard-save old-fp + #+fp-and-pc-standard-save old-pc) (assign-ir2-nlx-info fun) (assign-lambda-var-tns fun nil) (dolist (let (lambda-lets fun)) @@ -29,7 +35,7 @@ (values)) ;;; We have to allocate the home TNs for variables before we can call -;;; ASSIGN-IR2-PHYSENV so that we can close over TNs that haven't +;;; ASSIGN-IR2-ENVIRONMENT so that we can close over TNs that haven't ;;; had their home environment assigned yet. Here we evaluate the ;;; DEBUG-INFO/SPEED tradeoff to determine how variables are ;;; allocated. If SPEED is 3, then all variables are subject to @@ -59,29 +65,36 @@ (not (lambda-var-explicit-value-cell var))) ;; Force closed-over indirect LAMBDA-VARs without explicit ;; VALUE-CELLs to the stack, and make sure that they are - ;; live over the dynamic contour of the physenv. + ;; live over the dynamic contour of the environment. (setf (tn-sc res) (if ptype-info (second ptype-info) (sc-or-lose 'sb-vm::control-stack))) - (physenv-live-tn res (lambda-physenv fun))) + (environment-live-tn res (lambda-environment fun))) (debug-variable-p - (physenv-debug-live-tn res (lambda-physenv fun)))) + ;; If it's a constant it may end up being never read, + ;; replaced by COERCE-FROM-CONSTANT. + ;; Yet it might get saved on the stack, but since it's + ;; never read no stack space is allocated for it in the + ;; callee frame. + (unless (type-singleton-p (leaf-type var)) + (environment-debug-live-tn res (lambda-environment fun))))) (setf (tn-leaf res) var) (setf (tn-type res) (leaf-type var)) (setf (leaf-info var) res)))) (values)) -;;; Give CLAMBDA an IR2-PHYSENV structure. (And in order to +;;; Give CLAMBDA an IR2-ENVIRONMENT structure. (And in order to ;;; properly initialize the new structure, we make the TNs which hold ;;; environment values and the old-FP/return-PC.) -(defun assign-ir2-physenv (clambda) +(defun assign-ir2-environment (clambda #+fp-and-pc-standard-save old-fp + #+fp-and-pc-standard-save old-pc) (declare (type clambda clambda)) - (let* ((lambda-physenv (lambda-physenv clambda)) + (let* ((lambda-environment (lambda-environment clambda)) (indirect-fp-tns) - (ir2-physenv-alist - (loop for thing in (physenv-closure lambda-physenv) + (ir2-environment-alist + (loop for thing in (environment-closure lambda-environment) collect (cons thing (etypecase thing @@ -90,11 +103,11 @@ (make-normal-tn (primitive-type (leaf-type thing)))) ((not (lambda-var-explicit-value-cell thing)) - (let ((physenv (lambda-physenv (lambda-var-home thing)))) - (or (getf indirect-fp-tns physenv) + (let ((env (lambda-environment (lambda-var-home thing)))) + (or (getf indirect-fp-tns env) (let ((tn (make-normal-tn *backend-t-primitive-type*))) (push tn indirect-fp-tns) - (push physenv indirect-fp-tns) + (push env indirect-fp-tns) tn)))) (t (make-normal-tn *backend-t-primitive-type*)))) @@ -102,15 +115,27 @@ (make-normal-tn *backend-t-primitive-type*)) (clambda (make-normal-tn *backend-t-primitive-type*))))))) - (let ((res (make-ir2-physenv - :closure ir2-physenv-alist - :return-pc-pass (make-return-pc-passing-location - (xep-p clambda))))) - (setf (physenv-info lambda-physenv) res) - (setf (ir2-physenv-old-fp res) - (make-old-fp-save-location lambda-physenv)) - (setf (ir2-physenv-return-pc res) - (make-return-pc-save-location lambda-physenv)))) + (let ((res (make-ir2-environment + :closure ir2-environment-alist + :return-pc-pass #+fp-and-pc-standard-save + old-pc + #-fp-and-pc-standard-save + (make-return-pc-passing-location (xep-p clambda))))) + (setf (environment-info lambda-environment) res) + (setf (ir2-environment-old-fp res) + #-fp-and-pc-standard-save + (make-old-fp-save-location lambda-environment) + #+fp-and-pc-standard-save + old-fp) + (setf (ir2-environment-return-pc res) + #-fp-and-pc-standard-save + (make-return-pc-save-location lambda-environment) + #+fp-and-pc-standard-save + old-pc) + #+fp-and-pc-standard-save + (progn + (push old-fp (ir2-environment-live-tns (environment-info lambda-environment))) + (push old-pc (ir2-environment-live-tns (environment-info lambda-environment)))))) (values)) @@ -226,8 +251,8 @@ ;;; isn't live afterwards. (defun assign-ir2-nlx-info (fun) (declare (type clambda fun)) - (let ((physenv (lambda-physenv fun))) - (dolist (nlx (physenv-nlx-info physenv)) + (let ((env (lambda-environment fun))) + (dolist (nlx (environment-nlx-info env)) (setf (nlx-info-info nlx) (make-ir2-nlx-info :home (when (member (cleanup-kind (nlx-info-cleanup nlx)) @@ -237,8 +262,8 @@ (make-stack-pointer-tn))) :save-sp (unless (eq (cleanup-kind (nlx-info-cleanup nlx)) :unwind-protect) - (make-nlx-sp-tn physenv)) - :block-tn (physenv-live-tn + (make-nlx-sp-tn env)) + :block-tn (environment-live-tn (make-normal-tn (primitive-type-or-lose (ecase (cleanup-kind (nlx-info-cleanup nlx)) @@ -246,5 +271,5 @@ 'catch-block) ((:unwind-protect :block :tagbody) 'unwind-block)))) - physenv))))) + env))))) (values)) diff -Nru sbcl-2.1.10/src/compiler/info-vector.lisp sbcl-2.1.11/src/compiler/info-vector.lisp --- sbcl-2.1.10/src/compiler/info-vector.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/info-vector.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -44,31 +44,31 @@ ;;; * Names which are lists of length other than 2, or improper lists, ;;; or whose elements are not both symbols, are disqualified. -;;; Packed vector layout -;;; -------------------- +;;; Packed format +;;; ------------- ;;; Because the keys to the inner lists are integers in the range 0 to 63, ;;; either 5 or 10 keys will fit into a fixnum depending on word size. ;;; This permits one memory read to retrieve a collection of keys. In packed ;;; format, an ordered set of keys ("fields") is called a "descriptor". ;;; -;;; Descriptors are stored from element 0 upward in the packed vector, -;;; and data are indexed downward from the last element of the vector. +;;; Descriptors are stored from element 0 upward in the packed-info, +;;; and data are indexed downward from the last element. ;;; -;;; #(descriptor0 descriptor1 ... descriptorN valueN ... value1 value0) +;;; [descriptor0 descriptor1 ... descriptorN valueN ... value1 value0] ;;; -;;; e.g. The field at absolute index 3 - vector element 0, bit position 18 - +;;; e.g. The field at absolute index 3 (physical element 0, bit position 18) ;;; will find its data at index (- END 3). In this manner, it doesn't matter ;;; how many more descriptors exist. ;;; A "group" comprises all the info for a particular Name, and its list ;;; of types may may span descriptors, though rarely. ;;; An "auxiliary key" is the first element of a 2-list Name. It is interposed -;;; within the data portion of the vector after the preceding info group. +;;; within the data portion of the packed-info after the preceding info group. ;;; Descriptors are self-delimiting in that the first field in a group ;;; indicates the number of additional fields in the group. -;;; Unpacked vector layout -;;; ---------------------- +;;; Unpacked format +;;; --------------- ;;; This representation is used transiently during insertion/deletion. ;;; It is a concatenation of plists as a vector, interposing at the splice ;;; points the auxiliary key for the group, except for the root name which @@ -85,10 +85,14 @@ ;;; One can envision that the first info group stores its auxiliary key ;;; at vector index -1 when thinking about the correctness of algorithms ;;; that process unpacked info-vectors. -;;; See !TEST-PACKIFY-INFOS for examples of each format. +;;; See TEST-PACKIFY-INFOS for examples of each format. ;;;;; Some stuff moved from 'globaldb.lisp': +;;; The structure constructor is never called +(sb-xc:defstruct (packed-info (:predicate nil) (:constructor nil) (:copier nil)) + cells) +;;(declaim (freeze-type packed-info)) ; crashes? (defconstant info-num-mask (ldb (byte info-number-bits 0) -1)) ; #b111111 ;; Using 6 bits per packed field, 5 infos can be described in a 30-bit fixnum, @@ -101,20 +105,25 @@ (deftype info-descriptor () `(signed-byte ,sb-vm:n-fixnum-bits)) ;; An empty info-vector. Its 0th field describes that there are no more fields. -(defconstant-eqx +nil-packed-infos+ #(0) #'equalp) +(defglobal +nil-packed-infos+ + (let ((v (make-packed-info 1))) + (setf (%info-ref v 0) 0) + v)) ;; FDEFINITIONs have an info-number that admits slightly clever logic -;; for INFO-VECTOR-FDEFN. Do not change this constant without +;; for PACKED-INFO-FDEFN. Do not change this constant without ;; careful examination of that function. (defconstant +fdefn-info-num+ info-num-mask) ;; Extract a field from a packed info descriptor. ;; A field is either a count of info-numbers, or an info-number. (declaim (inline packed-info-field)) -(defun packed-info-field (vector desc-index field-index) +(defun packed-info-field (packed-info desc-index field-index) + ;; (declare (optimize (safety 0))) ; comment out when debugging (ldb (byte info-number-bits (* (the (mod #.+infos-per-word+) field-index) info-number-bits)) - (the info-descriptor (svref vector desc-index)))) + (the info-descriptor + (%info-ref (the packed-info packed-info) desc-index)))) ;; Compute the number of elements needed to hold unpacked VECTOR after packing. ;; This is not "compute-packed-info-size" since that could be misconstrued @@ -159,10 +168,10 @@ ;; (defun packify-infos (input &optional (end (length input))) (declare (simple-vector input)) - (let* ((output (make-array (compute-packified-info-size input end))) + (let* ((output (make-packed-info (compute-packified-info-size input end))) (i -1) ; input index: pre-increment to read the next datum (j -1) ; descriptor index: pre-increment to write - (k (length output)) ; data index: pre-decrement to write + (k (packed-info-len output)) ; data index: pre-decrement to write (field-shift 0) (word 0)) (declare (type index-or-minus-1 i j k end) @@ -174,19 +183,19 @@ (setq word (logior (make-info-descriptor val field-shift) word)) (if (< field-shift (* (1- +infos-per-word+) info-number-bits)) (incf field-shift info-number-bits) - (setf (svref output (incf j)) word field-shift 0 word 0)))) + (setf (%info-ref output (incf j)) word field-shift 0 word 0)))) ;; Truncating divide by 2: count = n-elements in the group @ 2 per entry, ;; +1 for count itself but not including its aux-key. (loop (let ((count (ash (the index (svref input (incf i))) -1))) (put-field count) ; how many infos to follow (dotimes (iter count) (put-field (svref input (incf i))) ; an info-number - (setf (svref output (decf k)) (svref input (incf i)))) ; value + (setf (%info-ref output (decf k)) (svref input (incf i)))) ; value (when (>= (incf i) end) (return)) - (setf (svref output (decf k)) (svref input i))))) ; an aux-key + (setf (%info-ref output (decf k)) (svref input i))))) ; an aux-key (unless (zerop field-shift) ; store the final descriptor word - (setf (svref output (incf j)) word)) + (setf (%info-ref output (incf j)) word)) (aver (eql (1+ j) k)) ; last descriptor must be adjacent final data cell output)) @@ -194,11 +203,11 @@ ;; returns the next field from a descriptor in INPUT-VAR, a packed vector. ;; The generator uses DESCRIPTOR-INDEX and updates it as a side-effect. ;; -(defmacro !with-packed-info-iterator ((generator input-var +(defmacro with-packed-info-iterator ((generator input-var &key descriptor-index) &body body) (with-unique-names (input word count) - `(let* ((,input (the simple-vector ,input-var)) + `(let* ((,input (the packed-info ,input-var)) (,descriptor-index -1) (,count 0) (,word 0)) @@ -208,21 +217,21 @@ (flet ((,generator () (when (zerop ,count) (incf ,descriptor-index) - (setq ,word (svref ,input ,descriptor-index) + (setq ,word (%info-ref ,input ,descriptor-index) ,count +infos-per-word+)) (prog1 (logand ,word info-num-mask) (setq ,word (ash ,word (- info-number-bits))) (decf ,count)))) ,@body)))) -;; Iterate over VECTOR, binding DATA-INDEX to the index of each aux-key in turn. +;; Iterate over PACKED-INFO, binding DATA-INDEX to the index of each aux-key in turn. ;; TOTAL-N-FIELDS is deliberately exposed to invoking code. ;; -(defmacro !do-packed-info-vector-aux-key ((vector &optional (data-index (gensym))) +(defmacro do-packed-info-aux-key ((packed-info &optional (data-index (gensym))) step-form &optional result-form) - (with-unique-names (descriptor-idx field-idx) - (once-only ((vector vector)) - `(let ((,data-index (length ,vector)) + (with-unique-names (descriptor-idx field-idx info) + `(let* ((,info ,packed-info) + (,data-index (packed-info-len ,info)) (,descriptor-idx 0) (,field-idx 0) (total-n-fields 0)) @@ -231,8 +240,7 @@ ;; Loop through the descriptors in random-access fashion. ;; Skip 1+ n-infos each time, because the 'n-infos' is itself a field ;; that is not accounted for in its own value. - (loop (let ((n (1+ (packed-info-field ,vector - ,descriptor-idx ,field-idx)))) + (loop (let ((n (1+ (packed-info-field ,info ,descriptor-idx ,field-idx)))) (incf total-n-fields n) (multiple-value-setq (,descriptor-idx ,field-idx) (floor total-n-fields +infos-per-word+)) @@ -240,36 +248,21 @@ ;; Done when the ascending index and descending index meet (unless (< ,descriptor-idx ,data-index) (return ,result-form)) - ,@(if step-form (list step-form))))))) + ,@(if step-form (list step-form)))))) -;; Return all function names that are stored in SYMBOL's info-vector. -;; As an example, (INFO-VECTOR-NAME-LIST 'SB-PCL::DIRECT-SUPERCLASSES) => -;; ((SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::READER) -;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES BOUNDP) -;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::WRITER)) -(defun info-vector-name-list (symbol) - (let ((vector (symbol-info-vector symbol)) - (list)) - (when vector - (!do-packed-info-vector-aux-key (vector key-index) - (push (construct-globaldb-name (svref vector key-index) symbol) - list)) - (nconc (and (plusp (packed-info-field vector 0 0)) (list symbol)) - (nreverse list))))) - -;; Compute the number of elements needed to hold packed VECTOR after unpacking. +;; Compute the number of elements needed to hold PACKED-INFO after unpacking. ;; The unpacked size is the number of auxiliary keys plus the number of entries ;; @ 2 cells per entry, plus the number of length cells which indicate the ;; number of data cells used (including length cells but not aux key cells). ;; Equivalently, it's the number of packed fields times 2 minus 1. ;; -(defun compute-unpackified-info-size (vector) - (declare (simple-vector vector)) - (!do-packed-info-vector-aux-key (vector) () +(defun compute-unpackified-info-size (packed-info) + (declare (packed-info packed-info)) + (do-packed-info-aux-key (packed-info) () ;; off-by-one: the first info group's auxiliary key is imaginary (1- (truly-the fixnum (ash total-n-fields 1))))) -;; Convert packed INPUT vector to unpacked. +;; Convert packed INPUT to unpacked. ;; If optional OUTPUT is supplied, it is used, otherwise output is allocated. ;; For efficiency the OUTPUT should be provided as a dynamic-extent array. ;; @@ -277,19 +270,19 @@ (make-array (compute-unpackified-info-size input)) output-supplied-p)) - (declare (simple-vector input output)) - (let ((i (length input)) (j -1)) ; input index and output index respectively + (declare (type packed-info input) (simple-vector output)) + (let ((i (packed-info-len input)) (j -1)) ; input index and output index respectively (declare (type index-or-minus-1 i j)) - (!with-packed-info-iterator (next-field input :descriptor-index desc-idx) + (with-packed-info-iterator (next-field input :descriptor-index desc-idx) (loop ; over name (let ((n-infos (next-field))) ;; store the info group length, including the length cell in the length (setf (svref output (incf j)) (1+ (ash n-infos 1))) (dotimes (iter n-infos) ; over info-types (setf (svref output (incf j)) (next-field) ; type-num - (svref output (incf j)) (svref input (decf i))))) ; value + (svref output (incf j)) (%info-ref input (decf i))))) ; value (if (< desc-idx (decf i)) ; as long as the indices haven't met - (setf (svref output (incf j)) (svref input i)) ; copy next aux-key + (setf (svref output (incf j)) (%info-ref input i)) ; copy next aux-key (return (if output-supplied-p nil output))))))) ; else done ;; Return the index of the 'length' item for an info group having @@ -311,20 +304,20 @@ ((eq (svref vector (1- index)) key) (return index))))))) -;; In packed info VECTOR try to find the auxiliary key SYMBOL. +;; Try to find the auxiliary key SYMBOL in PACKED-INFO. ;; If found, return indices of its data, info descriptor word, and field. ;; If not found, the first value is NIL and the descriptor indices ;; arbitrarily point to the next available descriptor field. ;; -(defun info-find-aux-key/packed (vector symbol) +(defun info-find-aux-key/packed (packed-info symbol) ;; explicit bounds checking is done by the code below - (declare (optimize (safety 0))) - (aver (simple-vector-p vector)) - (let ((descriptor-idx 0) ; physical index to vector +; (declare (optimize (safety 0))) + (aver (typep packed-info 'packed-info)) + (let ((descriptor-idx 0) ; physical index to packed-info (field-idx 0) ; relative index within current descriptor ;; On each iteration DATA-IDX points to an aux-key cell ;; The first group's imaginary aux-key cell is past the end. - (data-idx (length (the simple-vector vector)))) + (data-idx (packed-info-len (the packed-info packed-info)))) (declare (type index descriptor-idx data-idx) (fixnum field-idx)) ; can briefly exceed +infos-per-word+ ;; Efficiently skip past N-INFOS infos. If decrementing the data index @@ -343,28 +336,28 @@ (declare (inline skip)) ;; While this could compare aux-keys with #'EQUAL, it is not obvious how ;; in general one would pick a symbol from the name as that which - ;; is delegated as the one to hold the info-vector. - (values (cond ((not (skip (packed-info-field vector 0 0))) nil) + ;; is delegated as the one to hold the packed-info + (values (cond ((not (skip (packed-info-field packed-info 0 0))) nil) ;; At least one aux key is present. - ((eq (aref vector data-idx) symbol) data-idx) ; yay + ((eq (%info-ref packed-info data-idx) symbol) data-idx) ; yay ;; aux-key order invariant allows early fail on SETF ((eq symbol 'setf) nil) (t (loop - (cond ((not (skip (packed-info-field vector descriptor-idx + (cond ((not (skip (packed-info-field packed-info descriptor-idx field-idx))) (return nil)) - ((eq (aref vector data-idx) symbol) + ((eq (%info-ref packed-info data-idx) symbol) (return data-idx)))))) descriptor-idx field-idx)))) ; can be ignored if 1st val is nil -;; Take a packed info-vector INPUT and insert (AUX-KEY,INFO-NUMBER,VALUE). +;; Take a packed-info INPUT and insert (AUX-KEY,INFO-NUMBER,VALUE). ;; Packed info-vectors are immutable. Any alteration must create a copy. ;; This is done by unpacking/repacking - it's easy enough and fairly ;; efficient since the temporary vector is stack-allocated. ;; (defun %packed-info-insert (input aux-key info-number value) - (declare (simple-vector input) (type info-number info-number)) + (declare (type packed-info input) (type info-number info-number)) (let* ((n-extra-elts ;; Test if the aux-key has been seen before or needs to be added. (if (and (not (eql aux-key +no-auxiliary-key+)) @@ -410,15 +403,15 @@ ;; exactly one descriptor for the root name, space for >= 1 more field, ;; and no aux-keys. (declaim (inline info-quickly-insertable-p)) -(defun info-quickly-insertable-p (input) - (let ((n-infos (packed-info-field input 0 0))) +(defun info-quickly-insertable-p (packed-info) + (let ((n-infos (packed-info-field packed-info 0 0))) ;; We can easily determine if the no-aux-keys constraint is satisfied, ;; because a secondary name's info occupies at least two cells, ;; one for its aux-key and >= 1 for info values. (and (< n-infos (1- +infos-per-word+)) - (eql n-infos (1- (length input)))))) + (eql n-infos (1- (packed-info-len packed-info)))))) -;; Take a packed info-vector INPUT and return a new one with INFO-NUMBER/VALUE +;; Take a packed-info INPUT and return a new one with INFO-NUMBER/VALUE ;; added for the root name. The vector must satisfy INFO-QUICKLY-INSERTABLE-P. ;; This code is separate from PACKED-INFO-INSERT to facilitate writing ;; a unit test of this logic against the complete logic. @@ -426,57 +419,57 @@ (defun quick-packed-info-insert (input info-number value) ;; Because INPUT contains 1 descriptor and its corresponding values, ;; the current length is exactly NEW-N, the new number of fields. - (let* ((descriptor (svref input 0)) - (new-n (truly-the info-number (length input))) - (new-vect (make-array (1+ new-n)))) + (let* ((descriptor (%info-ref input 0)) + (new-n (truly-the info-number (packed-info-len input))) + (output (make-packed-info (1+ new-n)))) ;; Two cases: we're either inserting info for the fdefn, or not. (cond ((eq info-number +fdefn-info-num+) ;; fdefn, if present, must remain the first packed field. ;; Replace the lowest field (the count) with +fdefn-info-num+, ;; shift everything left 6 bits, then OR in the new count. - (setf (svref new-vect 0) + (setf (%info-ref output 0) (logior (make-info-descriptor (dpb +fdefn-info-num+ (byte info-number-bits 0) descriptor) info-number-bits) new-n) ;; Packed vectors are indexed "backwards". The first ;; field's info is in the highest numbered cell. - (svref new-vect new-n) value) + (%info-ref output new-n) value) (loop for i from 1 below new-n - do (setf (svref new-vect i) (svref input i)))) + do (setf (%info-ref output i) (%info-ref input i)))) (t ;; Add a field on the high end and increment the count. - (setf (svref new-vect 0) + (setf (%info-ref output 0) (logior (make-info-descriptor info-number (* info-number-bits new-n)) (1+ descriptor)) - (svref new-vect 1) value) + (%info-ref output 1) value) ;; Slide the old data up 1 cell. (loop for i from 2 to new-n - do (setf (svref new-vect i) (svref input (1- i)))))) - new-vect)) + do (setf (%info-ref output i) (%info-ref input (1- i)))))) + output)) (declaim (maybe-inline packed-info-insert)) -(defun packed-info-insert (vector aux-key info-number newval) +(defun packed-info-insert (packed-info aux-key info-number newval) (if (and (eql aux-key +no-auxiliary-key+) - (info-quickly-insertable-p vector)) - (quick-packed-info-insert vector info-number newval) - (%packed-info-insert vector aux-key info-number newval))) + (info-quickly-insertable-p packed-info)) + (quick-packed-info-insert packed-info info-number newval) + (%packed-info-insert packed-info aux-key info-number newval))) ;; Search packed VECTOR for AUX-KEY and INFO-NUMBER, returning ;; the index of the data if found, or NIL if not found. ;; -(defun packed-info-value-index (vector aux-key type-num) - (declare (optimize (safety 0))) ; vector bounds are AVERed - (let ((data-idx (length vector)) (descriptor-idx 0) (field-idx 0)) +(defun packed-info-value-index (packed-info aux-key type-num) + ;;(declare (optimize (safetya 0))) ; bounds are AVERed + (let ((data-idx (packed-info-len packed-info)) (descriptor-idx 0) (field-idx 0)) (declare (type index descriptor-idx) (type (mod #.+infos-per-word+) field-idx)) (unless (eql aux-key +no-auxiliary-key+) (multiple-value-setq (data-idx descriptor-idx field-idx) - (info-find-aux-key/packed vector aux-key)) + (info-find-aux-key/packed packed-info aux-key)) (unless data-idx (return-from packed-info-value-index nil))) ;; Fetch a descriptor and shift out trailing bits that won't be scanned. - (let* ((descriptor (ash (the info-descriptor (aref vector descriptor-idx)) + (let* ((descriptor (ash (the info-descriptor (%info-ref packed-info descriptor-idx)) (* (- info-number-bits) field-idx))) (n-infos (logand descriptor info-num-mask)) ;; Compute n things in this descriptor after extracting one field. e.g. @@ -500,11 +493,11 @@ (incf descriptor-idx) (decf data-idx swath) (aver (< descriptor-idx data-idx)) - (setq descriptor (svref vector descriptor-idx) + (setq descriptor (%info-ref packed-info descriptor-idx) swath (min n-infos +infos-per-word+)))))) ;; Helper for CLEAR-INFO-VALUES when Name has the efficient form. -;; Given packed info-vector INPUT and auxiliary key KEY2 +;; Given packed-info INPUT and auxiliary key KEY2 ;; return a new vector in which TYPE-NUMS are absent. ;; When none of TYPE-NUMs were present to begin with, return NIL. ;; @@ -512,8 +505,8 @@ ;; clearing does not happen often enough to warrant the pre-check. ;; (defun packed-info-remove (input key2 type-nums) - (declare (simple-vector input)) - (when (or (eql (length input) (length +nil-packed-infos+)) + (declare (type packed-info input)) + (when (or (eql (packed-info-len input) #.(packed-info-len +nil-packed-infos+)) (and (not (eql key2 +no-auxiliary-key+)) (not (info-find-aux-key/packed input key2)))) (return-from packed-info-remove nil)) ; do nothing @@ -602,27 +595,27 @@ ;; Call FUNCTION with each piece of info in packed VECT using ROOT-SYMBOL ;; as the primary name. FUNCTION must accept 3 values (NAME INFO-NUMBER VALUE). -(defun %call-with-each-info (function vect root-symbol) +(defun %call-with-each-info (function packed-info root-symbol) (let ((name root-symbol) - (data-idx (length vect))) + (data-idx (packed-info-len packed-info))) (declare (type index data-idx)) - (!with-packed-info-iterator (next-field vect :descriptor-index desc-idx) + (with-packed-info-iterator (next-field packed-info :descriptor-index desc-idx) (loop ; over name (dotimes (i (next-field)) ; number of infos for this name - (funcall function name (next-field) (svref vect (decf data-idx)))) + (funcall function name (next-field) (%info-ref packed-info (decf data-idx)))) (if (< desc-idx (decf data-idx)) (setq name - (construct-globaldb-name (svref vect data-idx) root-symbol)) + (construct-globaldb-name (%info-ref packed-info data-idx) root-symbol)) (return)))))) #| Info packing example. This example has 2 auxiliary-keys: SETF and CAS. -(!test-packify-infos '(13 :XYZ 18 "nine" 28 :BAR 7 T) - '(SETF 8 NIL 17 :FGX) - '(CAS 6 :MUMBLE 2 :BAZ 47 :FOO)) +(test-packify-infos '(13 :XYZ 18 "nine" 28 :BAR 7 T) + '(SETF 8 NIL 17 :FGX) + '(CAS 6 :MUMBLE 2 :BAZ 47 :FOO)) => -#(109006134805865284 3010 :FOO :BAZ :MUMBLE CAS :FGX NIL SETF T :BAR "nine" :XYZ) +[109006134805865284 3010 :FOO :BAZ :MUMBLE CAS :FGX NIL SETF T :BAR "nine" :XYZ] (format nil "~4,'0o ~20,'0o" 3010 109006134805865284) => "5702 06032110020734221504" @@ -633,7 +626,7 @@ 2 infos for SETF auxiliary-key. type numbers: 8, 17 3 infos for CAS auxiliary-key. type numbers: 6, 2, 47 -(unpackify-infos (!test-packify-infos ...)) ; same input +(unpackify-infos (test-packify-infos ...)) ; same input => #(9 13 :XYZ 18 "nine" 28 :BAR 7 T SETF 5 8 NIL 17 :FGX CAS 7 6 :MUMBLE 2 :BAZ 47 :FOO) @@ -647,8 +640,7 @@ ;; The info for a symbol's fdefn must precede other info-numbers. ;; and SETF must be the first aux key if other aux keys are present. ;; The test function does not enforce these invariants. -#+nil ; for debugging only -(defun !test-packify-infos (&rest lists) +(defun test-packify-infos (&rest lists) (flet ((check (plist) (and (evenp (length plist)) (loop for (indicator value) on plist by #'cddr @@ -705,10 +697,9 @@ (defun update-symbol-info (symbol update-fn) ;; Never pass NIL to an update-fn. Pass the minimal info-vector instead, ;; a vector describing 0 infos and 0 auxiliary keys. - (let ((newval (funcall update-fn (or (symbol-info-vector symbol) - +nil-packed-infos+)))) + (let ((newval (funcall update-fn (or (symbol-%info symbol) +nil-packed-infos+)))) (when newval - (setf (symbol-info-vector symbol) newval)) + (setf (symbol-%info symbol) newval)) (values))) ;;; The current *INFO-ENVIRONMENT*, a structure of type INFO-HASHTABLE. @@ -779,14 +770,14 @@ (let ((name (uncross name))) ;; If the INFO-NUMBER already exists in VECT, then copy it and ;; alter one cell; otherwise unpack it, grow the vector, and repack. - (dx-flet ((augment (vect aux-key) ; VECT is a packed vector, never NIL - (declare (simple-vector vect)) + (dx-flet ((augment (packed-info aux-key) ; PACKED-INFO must not be NIL + (declare (type packed-info packed-info)) (let ((index - (packed-info-value-index vect aux-key info-number))) + (packed-info-value-index packed-info aux-key info-number))) (if (not index) - (packed-info-insert vect aux-key info-number new-value) - (let ((copy (copy-seq vect))) - (setf (svref copy index) new-value) + (packed-info-insert packed-info aux-key info-number new-value) + (let ((copy (copy-packed-info packed-info))) + (setf (%info-ref copy index) new-value) copy))))) (with-globaldb-name (key1 key2) name :simple @@ -796,8 +787,7 @@ :hairy ;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent. (dx-flet ((hairy-name (old-info) - (augment (or old-info +nil-packed-infos+) - +no-auxiliary-key+))) + (augment (or old-info +nil-packed-infos+) +no-auxiliary-key+))) (info-puthash *info-environment* name #'hairy-name))))) new-value) @@ -813,20 +803,20 @@ (when (pcl-methodfn-name-p name) (error "Can't SET-INFO-VALUE on PCL-internal function")) (let ((name (uncross name)) new-value) - (dx-flet ((augment (vect aux-key) ; VECT is a packed vector, never NIL - (declare (simple-vector vect)) + (dx-flet ((augment (packed-info aux-key) ; PACKED-INFO must not be NIL + (declare (type packed-info packed-info)) (let ((index - (packed-info-value-index vect aux-key info-number))) + (packed-info-value-index packed-info aux-key info-number))) (if (not index) (packed-info-insert - vect aux-key info-number + packed-info aux-key info-number (setq new-value (funcall new-value-fun nil nil))) - (let ((oldval (svref vect index))) + (let ((oldval (%info-ref packed-info index))) (setq new-value (funcall new-value-fun oldval t)) (if (eq new-value oldval) - vect ; return the old vector - (let ((copy (copy-seq vect))) - (setf (svref copy index) new-value) + packed-info ; return the old packed-info + (let ((copy (copy-packed-info packed-info))) + (setf (%info-ref copy index) new-value) copy))))))) (with-globaldb-name (key1 key2) name :simple @@ -855,19 +845,19 @@ (error "~D is not a legal INFO name." name)) (let ((name (uncross name)) result) - (dx-flet ((get-or-set (info-vect aux-key) + (dx-flet ((get-or-set (packed-info aux-key) (let ((index - (packed-info-value-index info-vect aux-key info-number))) + (packed-info-value-index packed-info aux-key info-number))) (cond (index - (setq result (svref info-vect index)) - nil) ; no update to info-vector + (setq result (%info-ref packed-info index)) + nil) ; no update (t ;; Update conflicts possibly for unrelated info-number ;; can force re-execution. (UNLESS result ...) tries ;; to avoid calling the thunk more than once. (unless result (setq result (funcall creation-thunk))) - (packed-info-insert info-vect aux-key info-number + (packed-info-insert packed-info aux-key info-number result)))))) (with-globaldb-name (key1 key2) name :simple @@ -877,8 +867,7 @@ :hairy ;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent. (dx-flet ((hairy-name (old-info) - (or (get-or-set (or old-info +nil-packed-infos+) - +no-auxiliary-key+) + (or (get-or-set (or old-info +nil-packed-infos+) +no-auxiliary-key+) ;; Return OLD-INFO to elide writeback. Unlike for ;; UPDATE-SYMBOL-INFO, NIL is not a no-op marker. old-info))) diff -Nru sbcl-2.1.10/src/compiler/ir1opt.lisp sbcl-2.1.11/src/compiler/ir1opt.lisp --- sbcl-2.1.10/src/compiler/ir1opt.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1opt.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -389,7 +389,6 @@ ;;;; IR1-OPTIMIZE -#-sb-devel (declaim (start-block ir1-optimize ir1-optimize-last-effort)) ;;; Do one forward pass over COMPONENT, deleting unreachable blocks @@ -542,7 +541,9 @@ ;; type. (let ((value (exit-value node))) (when value - (derive-node-type node (lvar-derived-type value))))) + (derive-node-type node (if (lvar-single-value-p (node-lvar node)) + (lvar-type value) + (lvar-derived-type value)))))) (cset ;; PROPAGATE-FROM-SETS can do a better job if NODE-REOPTIMIZE ;; is accurate till the node actually has been reoptimized. @@ -692,7 +693,6 @@ ;;;; IF optimization -#-sb-devel (declaim (start-block ir1-optimize-if)) ;;; Check whether the predicate is known to be true or false, @@ -987,9 +987,7 @@ ;;;; combination IR1 optimization -#-sb-devel (declaim (start-block ir1-optimize-combination maybe-terminate-block - system-inline-fun-p validate-call-type)) (defun check-important-result (node info) @@ -1129,8 +1127,8 @@ combination info))) ;;; Do IR1 optimizations on a COMBINATION node. -(declaim (ftype (function (combination) (values)) ir1-optimize-combination)) (defun ir1-optimize-combination (node &aux (show *show-transforms-p*)) + (declare (type combination node)) (when (lvar-reoptimize (basic-combination-fun node)) (propagate-fun-change node) (when (node-deleted node) @@ -1277,11 +1275,18 @@ (succ (first (block-succ block)))) (declare (ignore lvar)) (unless (or (and (eq node (block-last block)) (eq succ tail)) - (block-delete-p block)) - ;; Even if the combination will never return, don't terminate if this - ;; is the tail call of a XEP: doing that would inhibit TCO. - (when (and (eq (node-derived-type node) *empty-type*) - (not (xep-tail-combination-p node))) + (block-delete-p block) + ;; Even if the combination will never return, don't + ;; terminate if this is the tail call of a XEP: doing + ;; that would inhibit TCO. + (xep-tail-combination-p node) + ;; Do not consider the block for termination if this + ;; is a LET-like combination, since the successor of + ;; this node is the body of the LET. + (and (combination-p node) + (eq (combination-kind node) :local) + (functional-somewhat-letlike-p (combination-lambda node)))) + (when (eq (node-derived-type node) *empty-type*) (cond (ir1-converting-not-optimizing-p (cond ((block-last block) @@ -1308,13 +1313,6 @@ (mark-for-deletion succ))))) t)))) -(defun system-inline-fun-p (name) - (and (symbolp name) - (let ((package (cl:symbol-package name))) - (and package - (or (eq package *cl-package*) - (system-package-p package)))))) - ;;; This is called both by IR1 conversion and IR1 optimization when ;;; they have verified the type signature for the call, and are ;;; wondering if something should be done to special-case the call. If @@ -1374,19 +1372,19 @@ ;; It has already been processed by locall, ;; inline again. (functional-kind fun)) + (when (eq (car *current-path*) 'original-source-start) + (setf (ctran-source-path (node-prev call)) *current-path*)) ;; Convert. (let* ((name (leaf-source-name leaf)) (*inline-expansions* (register-inline-expansion leaf call)) - (*transforming* (if (system-inline-fun-p name) - (1+ *transforming*) - *transforming*)) (res (ir1-convert-inline-expansion name (defined-fun-inline-expansion leaf) leaf inlinep (info :function :info name)))) + ;; Allow backward references to this function from following ;; forms. (Reused only if policy matches.) (push res (defined-fun-functionals leaf)) @@ -1476,7 +1474,8 @@ (case (combination-kind call) (:local (let ((fun (combination-lambda call))) - (maybe-let-convert fun) + (or (maybe-let-convert fun) + (maybe-convert-to-assignment fun)) (unless (member (functional-kind fun) '(:let :assignment :deleted)) (derive-node-type call (tail-set-type (lambda-tail-set fun)))))) (:full @@ -1706,6 +1705,9 @@ (with-ir1-environment-from-node call (with-component-last-block (*current-component* (block-next (node-block call))) + (unless (or (memq 'transformed *current-path*) + (memq 'inlined *current-path*)) + (setf (ctran-source-path (node-prev call)) *current-path*)) (let* ((*transforming* (1+ *transforming*)) (new-fun (ir1-convert-inline-lambda res @@ -1829,7 +1831,6 @@ ;;;; local call optimization -#-sb-devel (declaim (start-block ir1-optimize-set constant-reference-p delete-let propagate-let-args propagate-local-call-args propagate-to-refs propagate-from-sets @@ -2190,10 +2191,14 @@ (declare (type clambda clambda)) (aver (functional-letlike-p clambda)) (note-unreferenced-fun-vars clambda) - (let ((call (let-combination clambda))) + (let ((call (let-combination clambda)) + (bind (lambda-bind clambda))) (flush-dest (basic-combination-fun call)) + (when (eq (car (node-source-path bind)) 'original-source-start) + (setf (ctran-source-path (node-prev (car (leaf-refs clambda)))) + (node-source-path bind))) (unlink-node call) - (unlink-node (lambda-bind clambda)) + (unlink-node bind) (setf (lambda-bind clambda) nil)) (setf (functional-kind clambda) :zombie) (let ((home (lambda-home clambda))) @@ -2347,7 +2352,8 @@ (let ((lambda (combination-lambda node))) (when (lvar-reoptimize fun) (setf (lvar-reoptimize fun) nil) - (maybe-let-convert lambda)) + (or (maybe-let-convert lambda) + (maybe-convert-to-assignment lambda))) (cond ((neq (functional-kind lambda) :mv-let) (loop for arg in (basic-combination-args node) do @@ -2370,7 +2376,8 @@ (when (and (ref-p use) (functional-p (ref-leaf use))) (convert-call-if-possible use node) (when (eq (basic-combination-kind node) :local) - (maybe-let-convert (ref-leaf use)))))) + (or (maybe-let-convert (ref-leaf use)) + (maybe-convert-to-assignment (ref-leaf use))))))) (unless (or (eq (basic-combination-kind node) :local) (eq (lvar-fun-name fun) '%throw)) (ir1-optimize-mv-call node)))) @@ -2716,8 +2723,7 @@ (defun may-delete-cast (cast) (typecase cast - (vestigial-exit-cast - nil) + (delay nil) (bound-cast (may-delete-bound-cast cast)) (t t))) diff -Nru sbcl-2.1.10/src/compiler/ir1report.lisp sbcl-2.1.11/src/compiler/ir1report.lisp --- sbcl-2.1.10/src/compiler/ir1report.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1report.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -112,7 +112,7 @@ ;;; If true, this is the node which is used as context in compiler warning ;;; messages. (declaim (type (or null compiler-error-context node - lvar-annotation) *compiler-error-context*)) + lvar-annotation ctran) *compiler-error-context*)) (defvar *compiler-error-context* nil) ;;; a plist mapping macro names to source context parsers. Each parser @@ -256,6 +256,8 @@ (node-source-path context)) ((lvar-annotation-p context) (lvar-annotation-source-path context)) + ((ctran-p context) + (ctran-source-path context)) ((boundp '*current-path*) *current-path*))) (old @@ -490,8 +492,11 @@ (defun compiler-notify (datum &rest args) (unless (if *compiler-error-context* - (policy *compiler-error-context* (= inhibit-warnings 3)) - (policy *lexenv* (= inhibit-warnings 3))) + (policy (if (ctran-p *compiler-error-context*) + (ctran-next *compiler-error-context*) + *compiler-error-context*) + (= inhibit-warnings 3)) + (policy *lexenv* (= inhibit-warnings 3))) (with-condition (condition datum args) (incf *compiler-note-count*) (print-compiler-message diff -Nru sbcl-2.1.10/src/compiler/ir1tran-lambda.lisp sbcl-2.1.11/src/compiler/ir1tran-lambda.lisp --- sbcl-2.1.10/src/compiler/ir1tran-lambda.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1tran-lambda.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -20,7 +20,6 @@ ;;;; Note: Take a look at the compiler-overview.tex section on "Hairy ;;;; function representation" before you seriously mess with this ;;;; stuff. -#-sb-devel (declaim (start-block ir1-convert-lambda ir1-convert-lambda-body ir1-convert-aux-bindings varify-lambda-arg ir1-convert-lambdalike)) @@ -201,7 +200,8 @@ debug-name (note-lexical-bindings t) post-binding-lexenv - system-lambda) + system-lambda + local-policy) (declare (list body vars aux-vars aux-vals)) ;; We're about to try to put new blocks into *CURRENT-COMPONENT*. @@ -209,10 +209,13 @@ (let* ((bind (make-bind)) (lambda (make-lambda :vars vars - :bind bind - :%source-name source-name - :%debug-name debug-name - :system-lambda-p system-lambda)) + :bind bind + :%source-name source-name + :%debug-name debug-name + :system-lambda-p system-lambda + :lexenv (if local-policy + (make-lexenv :policy local-policy) + *lexenv*))) (result-ctran (make-ctran)) (result-lvar (make-lvar))) ;; just to check: This function should fail internal assertions if @@ -895,7 +898,8 @@ (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) (make-lambda-vars (cadr form)) (binding* (((*lexenv* result-type post-binding-lexenv - lambda-list explicit-check source-form) + lambda-list explicit-check source-form + local-policy) (process-decls decls (append aux-vars vars) nil :binding-form-p t :allow-lambda-list t)) (debug-catch-p (and maybe-add-debug-catch @@ -924,7 +928,8 @@ :post-binding-lexenv post-binding-lexenv :source-name source-name :debug-name debug-name - :system-lambda system-lambda))))) + :system-lambda system-lambda + :local-policy local-policy))))) (when explicit-check (setf (getf (functional-plist res) 'explicit-check) explicit-check)) (setf (functional-inline-expansion res) (or source-form form)) @@ -1066,7 +1071,6 @@ (allow (when (ll-kwds-allowp llks) '(&allow-other-keys)))) (careful-specifier-type `(function (,@reqs ,@opts ,@rest ,@keys ,@allow) *)))))) -#-sb-devel (declaim (start-block maybe-inline-syntactic-closure)) ;;; Take the lexenv surrounding an inlined function and extract things @@ -1181,7 +1185,6 @@ (declaim (end-block)) -#-sb-devel (declaim (start-block ir1-convert-inline-lambda)) ;;; Convert the forms produced by RECONSTRUCT-LEXENV to LEXENV diff -Nru sbcl-2.1.10/src/compiler/ir1tran.lisp sbcl-2.1.11/src/compiler/ir1tran.lisp --- sbcl-2.1.10/src/compiler/ir1tran.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -168,7 +168,54 @@ ;; If ANSWER is NIL, go for the global value (eq (or answer (info :function :inlinep name)) 'notinline))) -#-sb-devel + +;;;; code coverage + +;;; Check the policy for whether we should generate code coverage +;;; instrumentation. If not, just return the original START +;;; ctran. Otherwise insert code coverage instrumentation after +;;; START, and return the new ctran. +(defun instrument-coverage (start mode form + &aux (metadata (coverage-metadata *compilation*))) + ;; We don't actually use FORM for anything, it's just convenient to + ;; have around when debugging the instrumentation. + (declare (ignore form)) + (if (and metadata + (policy *lexenv* (> store-coverage-data 0)) + *allow-instrumenting*) + (let ((path (source-path-original-source *current-path*))) + (when mode + (push mode path)) + (if (member (ctran-block start) + (gethash path (code-coverage-blocks metadata))) + ;; If this source path has already been instrumented in + ;; this block, don't instrument it again. + start + (let ((next (make-ctran)) + (*allow-instrumenting* nil)) + (ensure-gethash path (code-coverage-records metadata) + (cons path +code-coverage-unmarked+)) + (push (ctran-block start) + (gethash path (code-coverage-blocks metadata))) + (ir1-convert start next nil `(%primitive mark-covered ',path)) + next))) + start)) + +;;; In contexts where we don't have a source location for FORM +;;; e.g. due to it not being a cons, but where we have a source +;;; location for the enclosing cons, use the latter source location if +;;; available. This works pretty well in practice, since many PROGNish +;;; macroexpansions will just directly splice a block of forms into +;;; some enclosing form with `(progn ,@body), thus retaining the +;;; EQness of the conses. +(defun maybe-instrument-progn-like (start forms form) + (or (when (and *allow-instrumenting* + (not (get-source-path form))) + (let ((*current-path* (get-source-path forms))) + (when *current-path* + (instrument-coverage start nil form)))) + start)) + (declaim (start-block find-free-fun find-lexically-apparent-fun ;; needed by ir1-translators find-global-fun)) @@ -459,6 +506,23 @@ ;;;; some flow-graph hacking utilities +;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws out of the +;; body and converts a condition signalling form instead. The source +;; form is converted to a string since it may contain arbitrary +;; non-externalizable objects. +(defmacro ir1-error-bailout ((start next result form) &body body) + (with-unique-names (skip condition) + `(block ,skip + (let ((,condition (catch 'ir1-error-abort + (let ((*compiler-error-bailout* + (lambda (&optional e) + (throw 'ir1-error-abort e)))) + ,@body + (return-from ,skip nil))))) + (ir1-convert ,start ,next ,result + (make-compiler-error-form ,condition + ,form)))))) + ;;; This function sets up the back link between the node and the ;;; ctran which continues at it. (defun link-node-to-previous-ctran (node ctran) @@ -503,6 +567,7 @@ (setf (ctran-next prev) nil) (link-node-to-previous-ctran new prev) (use-ctran new temp) + (setf (ctran-source-path temp) (ctran-source-path prev)) (link-node-to-previous-ctran old temp)) (values)) @@ -617,65 +682,55 @@ (frob) (frob) (setq trail (cdr trail))))))) + ;;;; IR1-CONVERT, macroexpansion and special form dispatching -(declaim (ftype (sfunction (ctran ctran (or lvar null) t) - (values)) - ir1-convert)) -(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws - ;; out of the body and converts a condition signalling form - ;; instead. The source form is converted to a string since it - ;; may contain arbitrary non-externalizable objects. - (ir1-error-bailout ((start next result form) &body body) - (with-unique-names (skip condition) - `(block ,skip - (let ((,condition (catch 'ir1-error-abort - (let ((*compiler-error-bailout* - (lambda (&optional e) - (throw 'ir1-error-abort e)))) - ,@body - (return-from ,skip nil))))) - (ir1-convert ,start ,next ,result - (make-compiler-error-form ,condition - ,form))))))) - - ;; Translate FORM into IR1. The code is inserted as the NEXT of the - ;; CTRAN START. RESULT is the LVAR which receives the value of the - ;; FORM to be translated. The translators call this function - ;; recursively to translate their subnodes. - ;; - ;; As a special hack to make life easier in the compiler, a LEAF - ;; IR1-converts into a reference to that LEAF structure. This allows - ;; the creation using backquote of forms that contain leaf - ;; references, without having to introduce dummy names into the - ;; namespace. - (defun ir1-convert (start next result form) - (let* ((*current-path* (ensure-source-path form)) - (start (instrument-coverage start nil form))) - (ir1-error-bailout (start next result form) - (cond ((atom form) - (cond ((and (symbolp form) (not (keywordp form))) - (ir1-convert-var start next result form)) - ((leaf-p form) - (reference-leaf start next result form)) - (t - (reference-constant start next result form)))) - (t - (ir1-convert-functoid start next result form))))) - (values)) - - ;; Generate a reference to a manifest constant, creating a new leaf - ;; if necessary. - (defun reference-constant (start next result value) - (declare (type ctran start next) - (type (or lvar null) result)) - (ir1-error-bailout (start next result value) - (let* ((leaf (find-constant value)) - (res (make-ref leaf))) - (push res (leaf-refs leaf)) - (link-node-to-previous-ctran res start) - (use-continuation res next result))) - (values))) + +(declaim (start-block ir1-convert ir1-convert-progn-body + ir1-convert-combination-args reference-leaf + reference-constant + expand-compiler-macro + maybe-reanalyze-functional)) + +;;; Translate FORM into IR1. The code is inserted as the NEXT of the +;;; CTRAN START. RESULT is the LVAR which receives the value of the +;;; FORM to be translated. The translators call this function +;;; recursively to translate their subnodes. +;;; +;;; As a special hack to make life easier in the compiler, a LEAF +;;; IR1-converts into a reference to that LEAF structure. This allows +;;; the creation using backquote of forms that contain leaf +;;; references, without having to introduce dummy names into the +;;; namespace. +(defun ir1-convert (start next result form) + (declare (type ctran start next) + (type (or lvar null) result)) + (let* ((*current-path* (ensure-source-path form)) + (start (instrument-coverage start nil form))) + (ir1-error-bailout (start next result form) + (cond ((atom form) + (cond ((and (symbolp form) (not (keywordp form))) + (ir1-convert-var start next result form)) + ((leaf-p form) + (reference-leaf start next result form)) + (t + (reference-constant start next result form)))) + (t + (ir1-convert-functoid start next result form))))) + (values)) + +;;; Generate a reference to a manifest constant, creating a new leaf +;;; if necessary. +(defun reference-constant (start next result value) + (declare (type ctran start next) + (type (or lvar null) result)) + (ir1-error-bailout (start next result value) + (let* ((leaf (find-constant value)) + (res (make-ref leaf))) + (push res (leaf-refs leaf)) + (link-node-to-previous-ctran res start) + (use-continuation res next result))) + (values)) ;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's ;;; some trivial type for which reanalysis is a trivial no-op. @@ -963,9 +1018,10 @@ ;;; Convert a bunch of forms, discarding all the values except the ;;; last. If there aren't any forms, then translate a NIL. -(declaim (ftype (sfunction (ctran ctran (or lvar null) list) (values)) - ir1-convert-progn-body)) (defun ir1-convert-progn-body (start next result body) + (declare (type ctran start next) + (type (or lvar null) result) + (type list body)) (if (endp body) (reference-constant start next result nil) (let ((this-start start) @@ -984,53 +1040,6 @@ (values)) -;;;; code coverage - -;;; Check the policy for whether we should generate code coverage -;;; instrumentation. If not, just return the original START -;;; ctran. Otherwise insert code coverage instrumentation after -;;; START, and return the new ctran. -(defun instrument-coverage (start mode form - &aux (metadata (coverage-metadata *compilation*))) - ;; We don't actually use FORM for anything, it's just convenient to - ;; have around when debugging the instrumentation. - (declare (ignore form)) - (if (and metadata - (policy *lexenv* (> store-coverage-data 0)) - *allow-instrumenting*) - (let ((path (source-path-original-source *current-path*))) - (when mode - (push mode path)) - (if (member (ctran-block start) - (gethash path (code-coverage-blocks metadata))) - ;; If this source path has already been instrumented in - ;; this block, don't instrument it again. - start - (let ((next (make-ctran)) - (*allow-instrumenting* nil)) - (ensure-gethash path (code-coverage-records metadata) - (cons path +code-coverage-unmarked+)) - (push (ctran-block start) - (gethash path (code-coverage-blocks metadata))) - (ir1-convert start next nil `(%primitive mark-covered ',path)) - next))) - start)) - -;;; In contexts where we don't have a source location for FORM -;;; e.g. due to it not being a cons, but where we have a source -;;; location for the enclosing cons, use the latter source location if -;;; available. This works pretty well in practice, since many PROGNish -;;; macroexpansions will just directly splice a block of forms into -;;; some enclosing form with `(progn ,@body), thus retaining the -;;; EQness of the conses. -(defun maybe-instrument-progn-like (start forms form) - (or (when (and *allow-instrumenting* - (not (get-source-path form))) - (let ((*current-path* (get-source-path forms))) - (when *current-path* - (instrument-coverage start nil form)))) - start)) - ;;;; converting combinations ;;; Does this form look like something that we should add single-stepping @@ -1059,9 +1068,12 @@ ;;; Convert a function call where the function FUN is a LEAF. FORM is ;;; the source for the call. We return the COMBINATION node so that ;;; the caller can poke at it if it wants to. -(declaim (ftype (sfunction (ctran ctran (or lvar null) list leaf) combination) - ir1-convert-combination)) (defun ir1-convert-combination (start next result form fun) + (declare (type ctran start next) + (type (or lvar null) result) + (type list form) + (type leaf fun) + #-sb-xc-host (values combination)) (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun)) @@ -1088,7 +1100,7 @@ (declare (type ctran start next) (type lvar fun-lvar) (type (or lvar null) result) - (list args)) + (type list args)) (let ((node (make-combination fun-lvar))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) @@ -1113,38 +1125,6 @@ (setf (combination-args node) (arg-lvars)))) node)) -(defun show-transform-p (showp fun-name) - (or (and (listp showp) (member fun-name showp :test 'equal)) - (eq showp t))) -(defun show-transform (kind name new-form &optional combination) - (let ((*print-length* 100) - (*print-level* 50) - (*print-right-margin* 128)) - (format *trace-output* "~&xform (~a) ~S ~% -> ~S~%" - kind - (if combination - (cons name - (loop for arg in (combination-args combination) - collect (if (constant-lvar-p arg) - (lvar-value arg) - (type-specifier (lvar-type arg))))) - name) - new-form))) - -(defun show-type-derivation (combination type) - (let ((*print-length* 100) - (*print-level* 50) - (*print-right-margin* 128)) - (unless (type= (node-derived-type combination) - (coerce-to-values type)) - (format *trace-output* "~&~a derived to ~a" - (cons (combination-fun-source-name combination) - (loop for arg in (combination-args combination) - collect (if (constant-lvar-p arg) - (lvar-value arg) - (type-specifier (lvar-type arg))))) - (type-specifier type))))) - ;;; Convert a call to a global function. If not NOTINLINE, then we do ;;; source transforms and try out any inline expansion. If there is no ;;; expansion, but is INLINE, then give an efficiency note (unless a @@ -1175,6 +1155,8 @@ (when (show-transform-p *show-transforms-p* name) (show-transform "src" name transformed)) (let ((*transforming* (1+ *transforming*))) + (when (eq (car *current-path*) 'original-source-start) + (setf (ctran-source-path start) *current-path*)) (ir1-convert start next result transformed))))) (ir1-convert-maybe-predicate start next result (proper-list form) @@ -1244,7 +1226,6 @@ ;;;; PROCESS-DECLS -#-sb-devel (declaim (start-block process-decls make-new-inlinep find-in-bindings process-muffle-decls @@ -1254,9 +1235,9 @@ ;;; LAMBDA-VAR for that name, or NIL if it isn't found. We return the ;;; *last* variable with that name, since LET* bindings may be ;;; duplicated, and declarations always apply to the last. -(declaim (ftype (sfunction (list symbol) (or lambda-var list)) - find-in-bindings)) (defun find-in-bindings (vars name) + (declare (list vars) (symbol name) + #-sb-xc-host (values (or lambda-var list))) (let ((found nil)) (dolist (var vars) (cond ((leaf-p var) @@ -1770,6 +1751,7 @@ (allow-explicit-check allow-lambda-list) (lambda-list (if allow-lambda-list :unspecified nil)) (optimize-qualities) + (local-optimize) source-form (post-binding-lexenv (if binding-form-p (list nil)))) ; dummy cell (flet ((process-it (spec decl) @@ -1812,6 +1794,12 @@ ((equal spec '(top-level-form))) ; ignore ((typep spec '(cons (eql source-form))) (setf source-form (cadr spec))) + ;; Used only for the current function. + ;; E.g. suppressing argument checking without doing + ;; so in all the subforms. + ((typep spec '(cons (eql local-optimize))) + (setf local-optimize spec) + (setf source-form (cadr spec))) (t (multiple-value-bind (new-env new-qualities) (process-1-decl spec lexenv vars fvars @@ -1827,8 +1815,11 @@ ;; Kludge: EVAL calls this function to deal with LOCALLY. (process-it spec decl))))) (warn-repeated-optimize-qualities (lexenv-policy lexenv) optimize-qualities) + (values lexenv result-type (cdr post-binding-lexenv) - lambda-list explicit-check source-form))) + lambda-list explicit-check source-form + (when local-optimize + (process-optimize-decl local-optimize (lexenv-policy lexenv)))))) (defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun) (multiple-value-bind (*lexenv* result-type post-binding-lexenv) diff -Nru sbcl-2.1.10/src/compiler/ir1-translators.lisp sbcl-2.1.11/src/compiler/ir1-translators.lisp --- sbcl-2.1.10/src/compiler/ir1-translators.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1-translators.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -102,7 +102,6 @@ RETURN-FROM can be used to exit the form." (unless (symbolp name) (compiler-error "The block name ~S is not a symbol." name)) - (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) (entry (make-entry)) @@ -116,7 +115,6 @@ (let* ((env-entry (list entry next result)) (*lexenv* (make-lexenv :blocks (list (cons name env-entry)) :cleanup cleanup))) - (push env-entry (ctran-entries next)) (ir1-convert-progn-body dummy next result forms)))) (def-ir1-translator return-from ((name &optional value) start next result) @@ -201,7 +199,6 @@ within the lexical scope of the form, then control is transferred to the next statement following that tag. A TAG must be an integer or a symbol. A STATEMENT must be a list. Other objects are illegal within the body." - (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) (entry (make-entry)) @@ -1294,16 +1291,13 @@ ;; We represent the possibility of the control transfer by making an ;; "escape function" that does a lexical exit, and instantiate the ;; cleanup using %WITHIN-CLEANUP. - (let* ((tag-ctran (make-ctran)) - (tag-lvar (make-lvar))) - (ir1-convert start tag-ctran tag-lvar tag) - (ir1-convert - tag-ctran next result - (with-unique-names (exit-block) - `(block ,exit-block - (%within-cleanup - :catch (%catch (%escape-fun ,exit-block) ,tag-lvar) - ,@body)))))) + (ir1-convert + start next result + (with-unique-names (exit-block) + `(block ,exit-block + (%within-cleanup + :catch (%catch (%escape-fun ,exit-block) ,tag) + ,@body))))) ;;; Since NSP is restored on unwind we only need to protect against ;;; local transfers of control, basically the same as special @@ -1473,6 +1467,15 @@ (use-continuation node next result) (setf (basic-combination-args node) (arg-lvars)))))) +;;; MULTIPLE-VALUE-PROG1 is represented in IR1 by having the +;;; VALUES-FORM code use a VALUE lvar that gets handed off to +;;; RESULT. In other words, as the result continuation isn't +;;; IMMEDIATELY-USED-P by the nodes that compute the result, we have +;;; to interpose a DELAY node using RESULT immediately so that the +;;; result continuation can assume that it is immediately used. This +;;; is important here because MULTIPLE-VALUE-PROG1 is the only special +;;; form which receives unknown values with multiple uses, some (in +;;; this case one) of which are not immediate. (def-ir1-translator multiple-value-prog1 ((values-form &rest forms) start next result) "MULTIPLE-VALUE-PROG1 values-form form* @@ -1482,17 +1485,13 @@ (let* ((value-ctran (make-ctran)) (forms-ctran (make-ctran)) (value-lvar (make-lvar)) - ;; This is to avoid writing in the RESULT LVAR before the - ;; body is executed, because the body may overwrite it. - ;; See MAY-DELETE-VESTIGIAL-EXIT. - (cast (make-vestigial-exit-cast - :value value-lvar))) + (delay (make-delay :value value-lvar))) (ctran-starts-block value-ctran) (ir1-convert start value-ctran value-lvar values-form) (ir1-convert-progn-body value-ctran forms-ctran nil forms) - (link-node-to-previous-ctran cast forms-ctran) - (setf (lvar-dest value-lvar) cast) - (use-continuation cast next result))) + (link-node-to-previous-ctran delay forms-ctran) + (setf (lvar-dest value-lvar) delay) + (use-continuation delay next result))) ;;;; interface to defining macros diff -Nru sbcl-2.1.10/src/compiler/ir1util.lisp sbcl-2.1.11/src/compiler/ir1util.lisp --- sbcl-2.1.10/src/compiler/ir1util.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1util.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -453,24 +453,6 @@ (node-ends-block (ctran-use ctran))))) (values)) -;;; CTRAN must be the last ctran in an incomplete block; finish the -;;; block and start a new one if necessary. -(defun start-block (ctran) - (declare (type ctran ctran)) - (aver (not (ctran-next ctran))) - (ecase (ctran-kind ctran) - (:inside-block - (let ((block (ctran-block ctran)) - (node (ctran-use ctran))) - (aver (not (block-last block))) - (aver node) - (setf (block-last block) node) - (setf (node-next node) nil) - (setf (ctran-use ctran) nil) - (setf (ctran-kind ctran) :unused) - (setf (ctran-block ctran) nil) - (link-blocks block (ctran-starts-block ctran)))) - (:block-start))) ;;;; @@ -567,6 +549,7 @@ ;;; the LEXENV-LAMBDA may be deleted, we must chain up the ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't ;;; deleted, and then return its home. +(declaim (maybe-inline node-home-lambda)) (defun node-home-lambda (node) (declare (type node node)) (do ((fun (lexenv-lambda (node-lexenv node)) @@ -579,12 +562,14 @@ (defun lambda-parent (lambda) (lexenv-lambda (lambda-lexenv lambda))) -(declaim (ftype (sfunction (node) component) node-component)) (defun node-component (node) - (block-component (node-block node))) -(declaim (ftype (sfunction (node) physenv) node-physenv)) -(defun node-physenv (node) - (lambda-physenv (node-home-lambda node))) + (declare (type node node)) + (the component (block-component (node-block node)))) + +(declaim (maybe-inline node-environment)) +(defun node-environment (node) + (declare (type node node) #-sb-xc-host (inline node-home-lambda)) + (the environment (lambda-environment (node-home-lambda node)))) (declaim (inline node-stack-allocate-p)) (defun node-stack-allocate-p (node) @@ -666,6 +651,7 @@ ;;; actually correspond to code which will be written anywhere. (declaim (ftype (sfunction (cblock) (or clambda null)) block-home-lambda-or-null)) (defun block-home-lambda-or-null (block) + #-sb-xc-host (declare (inline node-home-lambda)) (if (node-p (block-last block)) ;; This is the old CMU CL way of doing it. (node-home-lambda (block-last block)) @@ -695,14 +681,14 @@ nil)))) ;;; Return the non-LET LAMBDA that holds BLOCK's code. -(declaim (ftype (sfunction (cblock) clambda) block-home-lambda)) (defun block-home-lambda (block) - (block-home-lambda-or-null block)) + (declare (type cblock block)) + (the clambda (block-home-lambda-or-null block))) -;;; Return the IR1 physical environment for BLOCK. -(declaim (ftype (sfunction (cblock) physenv) block-physenv)) -(defun block-physenv (block) - (lambda-physenv (block-home-lambda block))) +;;; Return the IR1 environment for BLOCK. +(defun block-environment (block) + (declare (type cblock block)) + (lambda-environment (block-home-lambda block))) ;;;; DYNAMIC-EXTENT related @@ -760,35 +746,28 @@ (compiler-notify "~@" (find-original-source (node-source-path use))))))))) -(defun use-good-for-dx-p (use dx &optional component) - ;; FIXME: Can casts point to LVARs in other components? - ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the - ;; PRINCIPAL-LVAR is always in the same component as the original one. It - ;; would be either good to have an explanation of why casts don't point - ;; across components, or an explanation of when they do it. ...in the - ;; meanwhile AVER that our assumption holds true. - (aver (or (not component) (eq component (node-component use)))) +(defun use-good-for-dx-p (use dx) (and (not (node-to-be-deleted-p use)) (or (dx-combination-p use dx) (and (cast-p use) (not (cast-type-check use)) - (lvar-good-for-dx-p (cast-value use) dx component)) + (lvar-good-for-dx-p (cast-value use) dx)) (and (trivial-lambda-var-ref-p use) (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use)))) (or (eq use uses) - (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx component))))))) + (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx))))))) -(defun lvar-good-for-dx-p (lvar dx &optional component) +(defun lvar-good-for-dx-p (lvar dx) (let ((uses (lvar-uses lvar))) (cond ((null uses) nil) ((consp uses) (every (lambda (use) - (use-good-for-dx-p use dx component)) + (use-good-for-dx-p use dx)) uses)) (t - (use-good-for-dx-p uses dx component))))) + (use-good-for-dx-p uses dx))))) (defun known-dx-combination-p (use dx) (and (eq (combination-kind use) :known) @@ -922,7 +901,7 @@ return arg)))))) ;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends. -(defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component) +(defun handle-nested-dynamic-extent-lvars (dx lvar) (let ((uses (lvar-uses lvar))) ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS. ;; Uses of mupltiple-use LVARs already end their blocks, so we just need @@ -937,25 +916,25 @@ (etypecase use (cast (handle-nested-dynamic-extent-lvars - dx (cast-value use) recheck-component)) + dx (cast-value use))) (combination (loop for arg in (combination-args use) ;; deleted args show up as NIL here when (and arg - (lvar-good-for-dx-p arg dx recheck-component)) + (lvar-good-for-dx-p arg dx)) append (handle-nested-dynamic-extent-lvars - dx arg recheck-component))) + dx arg))) (ref (let* ((other (trivial-lambda-var-ref-lvar use))) (unless (eq other lvar) (handle-nested-dynamic-extent-lvars - dx other recheck-component))))))) + dx other))))))) (cons (cons dx lvar) (if (listp uses) (loop for use in uses - when (use-good-for-dx-p use dx recheck-component) + when (use-good-for-dx-p use dx) nconc (recurse use)) - (when (use-good-for-dx-p uses dx recheck-component) + (when (use-good-for-dx-p uses dx) (recurse uses))))))) ;;; Return the Top Level Form number of PATH, i.e. the ordinal number @@ -1076,7 +1055,9 @@ (defun %lvar-single-value-p (lvar) (let ((dest (lvar-dest lvar))) (typecase dest - ((or creturn exit) + (exit + (lvar-single-value-p (node-lvar dest))) + (creturn nil) (mv-combination (eq (basic-combination-fun dest) lvar)) @@ -1095,11 +1076,12 @@ (defun principal-lvar-single-valuify (lvar) (loop for prev = lvar then (node-lvar dest) for dest = (and prev (lvar-dest prev)) - while (cast-p dest) + while (or (cast-p dest) + (exit-p dest)) do (setf (node-derived-type dest) (make-short-values-type (list (single-value-type (node-derived-type dest))))) - (reoptimize-lvar prev))) + (reoptimize-lvar prev))) ;;; Return a new LEXENV just like DEFAULT except for the specified ;;; slot values. Values for the alist slots are APPENDed to the @@ -1246,9 +1228,8 @@ ;;; otherwise false. (defun join-successor-if-possible (block) (declare (type cblock block)) - (let* ((next (first (block-succ block))) - (start (block-start next))) - (when start ; NEXT is not an END-OF-COMPONENT marker + (let ((next (first (block-succ block)))) + (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker (cond ( ;; We cannot combine with a successor block if: (or ;; the successor has more than one predecessor; @@ -1264,28 +1245,20 @@ ;; thus the control transfer is a non-local exit. (not (eq (block-home-lambda block) (block-home-lambda next))) - ;; Stack analysis phase wants ENTRY to start a block... - (entry-p (block-start-node next)) + ;; Stack analysis phase wants DX ENTRYs to start their + ;; blocks... + (let ((entry (block-start-node next))) + (and (entry-p entry) + (eq (cleanup-kind (entry-cleanup entry)) + :dynamic-extent))) (let ((last (block-last block))) (and (valued-node-p last) (awhen (node-lvar last) - (or - ;; ... and a DX-allocator to end a block. - (lvar-dynamic-extent it) - ;; ... and for there to be no chance of there - ;; being two successive USEs of the same - ;; multi-valued LVAR in the same block (since - ;; we can only insert cleanup code at block - ;; boundaries, but need to discard - ;; multi-valued LVAR contents before they are - ;; overwritten). - (and (consp (lvar-uses it)) - (not (lvar-single-value-p it))))))) + ;; ...and DX-allocators to end + ;; their blocks. + (lvar-dynamic-extent it)))) (neq (block-type-check block) - (block-type-check next)) - ;; This ctran is a destination of an EXIT, - ;; a later inlined function may want to use it. - (ctran-entries start)) + (block-type-check next))) nil) (t (join-blocks block next) @@ -1536,7 +1509,6 @@ ;;;; deleting stuff -#-sb-devel (declaim (start-block delete-ref delete-functional flush-node flush-dest delete-lvar delete-block delete-block-lazily delete-lambda mark-for-deletion)) @@ -1899,8 +1871,7 @@ (delete node (basic-var-sets var))))) (cast (flush-dest (cast-value node))) - (enclose) - (no-op))) + (enclose))) (remove-from-dfo block) (values)) @@ -1910,14 +1881,13 @@ ;;; Do stuff to indicate that the return node NODE is being deleted. (defun delete-return (node) (declare (type creturn node)) - (let ((fun (return-lambda node))) - (when fun ;; could become replaced by MOVE-RETURN-STUFF - (let ((tail-set (lambda-tail-set fun))) - (aver (lambda-return fun)) - (setf (lambda-return fun) nil) - (when (and tail-set (not (find-if #'lambda-return - (tail-set-funs tail-set)))) - (setf (tail-set-type tail-set) *empty-type*))))) + (let* ((fun (return-lambda node)) + (tail-set (lambda-tail-set fun))) + (aver (lambda-return fun)) + (setf (lambda-return fun) nil) + (when (and tail-set (not (find-if #'lambda-return + (tail-set-funs tail-set)))) + (setf (tail-set-type tail-set) *empty-type*))) (values)) ;;; If any of the VARS in FUN was never referenced and was not @@ -2008,20 +1978,9 @@ (unless (eq (functional-kind home) :deleted) (do-nodes (node nil block) (let* ((path (node-source-path node)) - (first (first path))) - (when (and (not (return-p node)) - ;; CASTs are just value filters and do not - ;; represent code and they can be moved around - ;; making CASTs from the original source code - ;; appear in code inserted by the compiler, generating - ;; false deletion notes. - ;; And if a block with the original source gets - ;; deleted the node that produces the value for - ;; the CAST will get a note, no need to note - ;; twice. - (not (cast-p node)) - ;; Nothing interesting in BIND nodes - (not (bind-p node)) + (ctran-path (ctran-source-path (node-prev node)))) + (flet ((visible-p (path) + (let ((first (first path))) (or (eq first 'original-source-start) (and (atom first) (or (not (symbolp first)) @@ -2034,14 +1993,63 @@ (present-in-form first x 0)) (source-path-forms path)) (present-in-form first (find-original-source path) - 0)))) - (let ((*compiler-error-context* node)) - (compiler-notify 'code-deletion-note - :format-control "deleting unreachable code" - :format-arguments nil)) - (return)))))) - (values)) - + 0)))))) + (cond ((and ctran-path + (visible-p ctran-path)) + (push (cons ctran-path (node-lexenv node)) + (deleted-source-paths *compilation*)) + (return)) + ((and (not (return-p node)) + ;; CASTs are just value filters and do not + ;; represent code and they can be moved around + ;; making CASTs from the original source code + ;; appear in code inserted by the compiler, generating + ;; false deletion notes. + ;; And if a block with the original source gets + ;; deleted the node that produces the value for + ;; the CAST will get a note, no need to note + ;; twice. + (not (cast-p node)) + ;; Nothing interesting in BIND nodes + (not (bind-p node)) + ;; Try to get the outer deleted node. + (not (and (valued-node-p node) + (let ((dest (node-dest node))) + (and dest + (node-to-be-deleted-p dest) + (node-source-inside-p node dest))))) + (visible-p path)) + (push (cons path (node-lexenv node)) + (deleted-source-paths *compilation*)) + (return)))))))) + (values)) + +(defun node-source-inside-p (inner-node outer-node) + (tailp (source-path-original-source (node-source-path outer-node)) + (source-path-original-source (node-source-path inner-node)))) + +(defun report-code-deletion () + (let ((forms (make-hash-table :test #'equal)) + (reversed-path)) + ;; Report only the outermost form + (loop for pair in (shiftf (deleted-source-paths *compilation*) nil) + for (path) = pair + do + (when (eq (car path) 'original-source-start) + (setf (gethash (source-path-original-source path) forms) path)) + (push pair reversed-path)) + (loop for (path . lexenv) in reversed-path + for original = (source-path-original-source path) + when (loop for outer on (if (eq (car path) 'original-source-start) + (cdr original) + original) + never (gethash outer forms)) + do + (let ((*current-path* path) + (*lexenv* lexenv)) + (compiler-notify 'code-deletion-note + :format-control "deleting unreachable code" + :format-arguments nil))))) ;;; Delete a node from a block, deleting the block if there are no ;;; nodes left. We remove the node from the uses of its LVAR. ;;; @@ -2056,7 +2064,6 @@ (declare (type node node)) (when (valued-node-p node) (delete-lvar-use node)) - (let* ((ctran (node-next node)) (next (and ctran (ctran-next ctran))) (prev (node-prev node)) @@ -2072,7 +2079,9 @@ (t (setf (ctran-next prev) next) (setf (node-prev next) prev) - (when (if-p next) ; AOP wanted + (unless (ctran-source-path prev) + (setf (ctran-source-path prev) (ctran-source-path ctran))) + (when (if-p next) (reoptimize-lvar (if-test next))))) (setf (node-prev node) nil) nil) @@ -2080,15 +2089,8 @@ (aver (eq prev-kind :block-start)) (aver (eq node last)) (let* ((succ (block-succ block)) - (next (first succ)) - (next-ctran (block-start next))) + (next (first succ))) (aver (singleton-p succ)) - ;; Update the ctran used by EXITs from BLOCKs. - (when next-ctran - (loop for entry in (ctran-entries prev) - do (setf (second entry) next-ctran)) - (setf (ctran-entries next-ctran) - (ctran-entries prev))) (cond ((eq block (first succ)) (with-ir1-environment-from-node node @@ -2515,7 +2517,7 @@ (let* ((entry (exit-entry exit)) (cleanup (entry-cleanup entry)) (block (first (block-succ (node-block exit))))) - (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) + (dolist (nlx (environment-nlx-info (node-environment entry)) nil) (when (and (eq (nlx-info-block nlx) block) (eq (nlx-info-cleanup nlx) cleanup)) (return nlx))))) @@ -2917,6 +2919,7 @@ ;;; from system lambdas. (defun preserve-single-use-debug-var-p (call var) (and (policy call (eql preserve-single-use-debug-variables 3)) + (not (lambda-var-specvar var)) (or (not (lambda-var-p var)) (not (lambda-system-lambda-p (lambda-var-home var)))))) diff -Nru sbcl-2.1.10/src/compiler/ir2opt.lisp sbcl-2.1.11/src/compiler/ir2opt.lisp --- sbcl-2.1.10/src/compiler/ir2opt.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir2opt.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -143,7 +143,8 @@ (flet ((reuse-if-eq-arg (value-if vop) ;; Most of the time this means: ;; if X is already NIL, don't load it again. - (when (and (eq (vop-name vop) 'if-eq) + (when (and vop + (eq (vop-name vop) 'if-eq) (constant-tn-p value-if)) (let* ((args (vop-args vop)) (x-tn (tn-ref-tn args)) @@ -175,63 +176,53 @@ (vop branch node 2block label) (update-block-succ 2block (list label))) -;; Since conditional branches are always at the end of blocks, -;; it suffices to look at the last VOP in each block. -(defun maybe-convert-one-cmov (2block) - (let ((vop (or (ir2-block-last-vop 2block) - (return-from maybe-convert-one-cmov)))) - (unless (eq (vop-name vop) 'branch-if) - (return-from maybe-convert-one-cmov)) - ;; The test and branch-if may be split between two IR1 blocks - ;; due to cleanups, can't use bloc-succ of the ir2-block-block - (let* ((node (vop-node vop)) - (succ (block-succ (node-block node))) - (a (first succ)) - (b (second succ))) - - (destructuring-bind (jump-target not-p flags) (vop-codegen-info vop) - (multiple-value-bind (label target value-a value-b) - (cmovp jump-target a b) - (unless label +(defun maybe-convert-one-cmov (vop) + ;; The test and branch-if may be split between two IR1 blocks + ;; due to cleanups, can't use bloc-succ of the ir2-block-block + (let* ((node (vop-node vop)) + (succ (block-succ (node-block node))) + (a (first succ)) + (b (second succ))) + + (destructuring-bind (jump-target not-p flags) (vop-codegen-info vop) + (multiple-value-bind (label target value-a value-b) + (cmovp jump-target a b) + (unless label + (return-from maybe-convert-one-cmov)) + (multiple-value-bind (cmove-vop arg-a arg-b res info) + (convert-conditional-move-p node target value-a value-b) + (unless cmove-vop (return-from maybe-convert-one-cmov)) - (multiple-value-bind (cmove-vop arg-a arg-b res info) - (convert-conditional-move-p node target value-a value-b) - (unless cmove-vop - (return-from maybe-convert-one-cmov)) - (when not-p - (rotatef value-a value-b) - (rotatef arg-a arg-b)) - (flet ((safe-coercion-p (from to) - (let ((from (tn-primitive-type from)) - (to (tn-primitive-type to))) - ;; These moves will be repositioned before the test VOP, - ;; which may be restricting their type. - ;; Avoid the moves that may touch memory and - ;; thus fail on immediate values. - (not (and (eq from *backend-t-primitive-type*) - (memq (primitive-type-name to) - '(#+64-bit sb-vm::unsigned-byte-64 - #+64-bit sb-vm::unsigned-byte-63 - #+64-bit sb-vm::signed-byte-64 - #-64-bit sb-vm::unsigned-byte-32 - #-64-bit sb-vm::unsigned-byte-31 - #-64-bit sb-vm::signed-byte-32 - #-64-bit single-float - double-float - complex-single-float - complex-double-float - system-area-pointer))))))) - (if (and (safe-coercion-p value-a arg-a) + (when not-p + (rotatef value-a value-b) + (rotatef arg-a arg-b)) + (flet ((safe-coercion-p (from to) + (let ((from (tn-primitive-type from)) + (to (tn-primitive-type to))) + ;; These moves will be repositioned before the test VOP, + ;; which may be restricting their type. + ;; Avoid the moves that may touch memory and + ;; thus fail on immediate values. + (not (and (eq from *backend-t-primitive-type*) + (memq (primitive-type-name to) + '(#+64-bit sb-vm::unsigned-byte-64 + #+64-bit sb-vm::unsigned-byte-63 + #+64-bit sb-vm::signed-byte-64 + #-64-bit sb-vm::unsigned-byte-32 + #-64-bit sb-vm::unsigned-byte-31 + #-64-bit sb-vm::signed-byte-32 + #-64-bit single-float + double-float + complex-single-float + complex-double-float + system-area-pointer))))))) + (when (and (safe-coercion-p value-a arg-a) (safe-coercion-p value-b arg-b)) - (convert-one-cmov cmove-vop value-a arg-a - value-b arg-b - target res - flags info - label vop node 2block))))))))) - -(defun convert-cmovs (component) - (do-ir2-blocks (2block component (values)) - (maybe-convert-one-cmov 2block))) + (convert-one-cmov cmove-vop value-a arg-a + value-b arg-b + target res + flags info + label vop node (vop-block vop))))))))) (defun delete-unused-ir2-blocks (component) (declare (type component component)) @@ -461,6 +452,18 @@ ((ir2-block-start-vop 2block) (return (ir2-block-start-vop 2block))))))) +(defun prev-vop (vop) + (or (vop-prev vop) + (do* ((2block (vop-block vop) prev) + (prev (ir2-block-prev 2block) + (ir2-block-prev 2block))) + ((null prev) nil) + (cond ((or (ir2-block-%trampoline-label 2block) + (ir2-block-%label 2block)) + (return)) + ((ir2-block-last-vop prev) + (return (ir2-block-last-vop prev))))))) + (defun immediate-templates (fun &optional (constants t)) (let ((primitive-types (list (primitive-type-or-lose 'character) (primitive-type-or-lose 'fixnum) @@ -519,30 +522,36 @@ args1) args2))) -;;; Turn CMP X,Y BRANCH-IF M CMP X,Y BRANCH-IF N -;;; into CMP X,Y BRANCH-IF M BRANCH-IF N -;; while it's portable the VOPs are not validated for -;; compatibility on other backends yet. -#+(or arm arm64 x86 x86-64) (defoptimizer (vop-optimize branch-if) (branch-if) - (let ((prev (vop-prev branch-if))) - (when (and prev - (memq (vop-name prev) *comparison-vops*)) - (let ((next (next-vop branch-if)) - transpose) - (when (and next - (memq (vop-name next) *comparison-vops*) - (or (vop-args-equal prev next) - (and (or (setf transpose - (memq (vop-name prev) *commutative-comparison-vops*)) - (memq (vop-name next) *commutative-comparison-vops*)) - (vop-args-equal prev next t)))) - (when transpose - ;; Could flip the flags for non-commutative operations - (loop for tn-ref = (vop-args prev) then (tn-ref-across tn-ref) - for arg in (nreverse (vop-arg-list prev)) - do (change-tn-ref-tn tn-ref arg))) - (delete-vop next)))))) + (cond ((boundp '*2block-info*) + (maybe-convert-one-cmov branch-if)) + #+(or arm arm64 x86 x86-64) + (t + ;; Turn CMP X,Y BRANCH-IF M CMP X,Y BRANCH-IF N + ;; into CMP X,Y BRANCH-IF M BRANCH-IF N + ;; Run it after CMOVs are converted. + ;; While it's portable the VOPs are not validated for + ;; compatibility on other backends yet. + (let ((prev (vop-prev branch-if))) + (when (and prev + (memq (vop-name prev) *comparison-vops*)) + (let ((next (next-vop branch-if)) + transpose) + (when (and next + (memq (vop-name next) *comparison-vops*) + (or (vop-args-equal prev next) + (and (or (setf transpose + (memq (vop-name prev) *commutative-comparison-vops*)) + (memq (vop-name next) *commutative-comparison-vops*)) + (vop-args-equal prev next t)))) + (when transpose + ;; Could flip the flags for non-commutative operations + (loop for tn-ref = (vop-args prev) then (tn-ref-across tn-ref) + for arg in (nreverse (vop-arg-list prev)) + do (change-tn-ref-tn tn-ref arg))) + (setf (sb-assem::label-comment (car (vop-codegen-info branch-if))) + :merged-ifs) + (delete-vop next)))))))) (defun next-start-vop (block) (loop for 2block = block then (ir2-block-next 2block) @@ -926,6 +935,78 @@ (vop-codegen-info vop)) (delete-vop vop))))) +#+(or arm64 x86-64) +(defoptimizer (vop-optimize #+arm64 + (sb-vm::data-vector-ref/simple-bit-vector-c + sb-vm::data-vector-ref/simple-bit-vector) + #+x86-64 + (sb-vm::data-vector-ref-with-offset/simple-bit-vector-c + sb-vm::data-vector-ref-with-offset/simple-bit-vector)) + (vop) + (let* ((next (next-vop vop)) + (branch (and next + (next-vop next))) + plusp) + (when (and branch + (or + (eq (vop-name next) 'sb-vm::fast-if-eq-fixnum/c) + (and (eq (vop-name next) 'sb-vm::fast-if->-c/fixnum) + (equal (vop-codegen-info next) '(0)) + (setf plusp t))) + (eq (vop-name branch) + 'branch-if)) + (let* ((result (tn-ref-tn (vop-results vop))) + (value (if plusp + 1 + (car (vop-codegen-info next))))) + (when (and (not (tn-ref-next (tn-reads result))) + (eq result (tn-ref-tn (vop-args next)))) + (check-type value bit) + (let ((template (template-or-lose #+arm64 + (if (eq (vop-name vop) 'sb-vm::data-vector-ref/simple-bit-vector) + 'sb-vm::data-vector-ref/simple-bit-vector-eq + 'sb-vm::data-vector-ref/simple-bit-vector-c-eq) + #+x86-64 + (if (eq (vop-name vop) 'sb-vm::data-vector-ref-with-offset/simple-bit-vector) + 'sb-vm::data-vector-ref-with-offset/simple-bit-vector-eq + 'sb-vm::data-vector-ref-with-offset/simple-bit-vector-c-eq)))) + (prog1 + (emit-and-insert-vop (vop-node vop) + (vop-block vop) + template + (reference-tn-refs (vop-args vop) nil) + nil + vop + (vop-codegen-info vop)) + ;; copy the condition flag + (setf (third (vop-codegen-info branch)) + (cdr (template-result-types template))) + (when (eq value 1) + (setf (second (vop-codegen-info branch)) + (not (second (vop-codegen-info branch))))) + (delete-vop vop) + (delete-vop next)))))))) + +;;; No need to reset the stack pointer just before returning. +(defoptimizer (vop-optimize reset-stack-pointer) (vop) + (loop for next = (next-vop vop) then (next-vop next) + do (cond ((not next) + (return)) + ((eq (vop-name next) 'move)) + ((memq (vop-name next) '(return-single return known-return + tail-call tail-call-named + static-tail-call-named)) + (delete-vop vop) + ;; Delete the VOP that saves the stack pointer too. + (let ((tn (tn-ref-tn (vop-args vop)))) + (unless (tn-reads tn) + (aver (eq (vop-name (tn-ref-vop (tn-writes tn))) + 'current-stack-pointer)) + (delete-vop (tn-ref-vop (tn-writes tn))))) + (return)) + (t + (return))))) + (defun very-temporary-p (tn) (let ((writes (tn-writes tn)) (reads (tn-reads tn))) @@ -989,6 +1070,52 @@ (funcall it vop)) (vop-next vop))))))) +(defun merge-instance-set-vops (vop) + (let ((instance (tn-ref-tn (vop-args vop))) + (this vop) + (pairs)) + (loop + (let ((index (tn-ref-tn (tn-ref-across (vop-args this))))) + (unless (constant-tn-p index) (return)) + (push (cons (tn-value index) (tn-ref-tn (sb-vm::vop-nth-arg 2 this))) + pairs)) + (let ((next (vop-next this))) + (unless (and next + (eq (vop-name next) 'sb-vm::instance-index-set) + (eq (tn-ref-tn (vop-args next)) instance)) + (return)) + (setq this next))) + (unless (cdr pairs) ; if at least 2 + (return-from merge-instance-set-vops nil)) + (setq pairs (nreverse pairs)) + (let ((new (emit-and-insert-vop + (vop-node vop) (vop-block vop) + (template-or-lose 'sb-vm::instance-set-multiple) + (reference-tn-list (cons instance (mapcar #'cdr pairs)) nil) + nil vop (list (mapcar #'car pairs))))) + (loop (let ((next (vop-next vop))) + (delete-vop vop) + (pop pairs) + (setq vop next)) + (unless pairs (return))) + new))) + +(defun ir2-optimize-stores (component) + ;; This runs after representation selection. It's the same as RUN-VOP-OPTIMIZERS, + ;; but with hardcoded vop names and function to call. + ;; It seems like this should also supplant the #+arm64 hack in GENERATE-CODE. + (do-ir2-blocks (block component) + (let ((vop (ir2-block-start-vop block))) + (loop (unless vop (return)) + (let ((optimizer + (case (vop-name vop) + (sb-vm::instance-index-set + (when (gethash 'sb-vm::instance-set-multiple + *backend-parsed-vops*) + 'merge-instance-set-vops))))) + (setq vop (or (awhen optimizer (funcall it vop)) + (vop-next vop)))))))) + (defun ir2-optimize (component) (let ((*2block-info* (make-hash-table :test #'eq))) (initialize-ir2-blocks-flow-info component) @@ -1002,8 +1129,22 @@ ;; Look for if/else chains before cmovs, because a cmov ;; affects whether the last if/else is recognizable. #+(or ppc ppc64 x86 x86-64) (convert-if-else-chains component) - (convert-cmovs component) (run-vop-optimizers component) (delete-unused-ir2-blocks component)) (values)) + +(defun delete-unnecessary-move (vop) + (when (and (vop-next vop) + (eq (vop-name (vop-next vop)) 'move) + ;; the source of the move is the result of this + (eq (tn-ref-tn (vop-args (vop-next vop))) + (tn-ref-tn (vop-results vop))) + ;; the destination of the move is the same as the input of this + (eq (tn-ref-tn (vop-results (vop-next vop))) + (tn-ref-tn (vop-args vop))) + ;; there is exactly one write and one read of the intermediate TN + (very-temporary-p (tn-ref-tn (vop-results vop)))) + ;; Change my result ref to the same TN as the input and delete the MOVE + (change-tn-ref-tn (vop-results vop) (tn-ref-tn (vop-args vop))) + (delete-vop (vop-next vop)))) diff -Nru sbcl-2.1.10/src/compiler/ir2tran.lisp sbcl-2.1.11/src/compiler/ir2tran.lisp --- sbcl-2.1.10/src/compiler/ir2tran.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir2tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -40,43 +40,31 @@ ;;;; leaf reference ;;; Return the TN that holds the value of THING in the environment ENV. -(declaim (ftype (sfunction ((or nlx-info lambda-var clambda) physenv) tn) - find-in-physenv)) -(defun find-in-physenv (thing physenv) - (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv)))) +(defun find-in-environment (thing env) + (declare (type (or nlx-info lambda-var clambda) thing) (type environment env) + #-sb-xc-host (values tn)) + (or (cdr (assoc thing (ir2-environment-closure (environment-info env)))) (etypecase thing (lambda-var - ;; I think that a failure of this assertion means that we're - ;; trying to access a variable which was improperly closed - ;; over. The PHYSENV describes a physical environment. Every - ;; variable that a form refers to should either be in its - ;; physical environment directly, or grabbed from a - ;; surrounding physical environment when it was closed over. - ;; The ASSOC expression above finds closed-over variables, so - ;; if we fell through the ASSOC expression, it wasn't closed - ;; over. Therefore, it must be in our physical environment - ;; directly. If instead it is in some other physical - ;; environment, then it's bogus for us to reference it here - ;; without it being closed over. -- WHN 2001-09-29 - (aver (eq physenv (lambda-physenv (lambda-var-home thing)))) + (aver (eq env (lambda-environment (lambda-var-home thing)))) (leaf-info thing)) (nlx-info - (aver (eq physenv (block-physenv (nlx-info-target thing)))) + (aver (eq env (block-environment (nlx-info-target thing)))) (ir2-nlx-info-home (nlx-info-info thing))) (clambda (aver (xep-p thing)) (entry-info-closure-tn (lambda-info thing)))) - (bug "~@<~2I~_~S ~_not found in ~_~S~:>" thing physenv))) + (bug "~@<~2I~_~S ~_not found in ~_~S~:>" thing env))) ;;; Return a TN that represents the value of LEAF, or NIL if LEAF ;;; isn't directly represented by a TN. ENV is the environment that ;;; the reference is done in. (defun leaf-tn (leaf env) - (declare (type leaf leaf) (type physenv env)) + (declare (type leaf leaf) (type environment env)) (typecase leaf (lambda-var (unless (lambda-var-indirect leaf) - (find-in-physenv leaf env))) + (find-in-environment leaf env))) (constant (make-constant-tn leaf)) (t nil))) @@ -95,15 +83,15 @@ (res (first locs))) (etypecase leaf (lambda-var - (let ((tn (find-in-physenv leaf (node-physenv node))) + (let ((tn (find-in-environment leaf (node-environment node))) (indirect (lambda-var-indirect leaf)) (explicit (lambda-var-explicit-value-cell leaf))) (cond ((and indirect explicit) (vop value-cell-ref node block tn res)) ((and indirect - (not (eq (node-physenv node) - (lambda-physenv (lambda-var-home leaf))))) + (not (eq (node-environment node) + (lambda-environment (lambda-var-home leaf))))) (let ((reffer (third (primitive-type-indirect-cell-type (primitive-type (leaf-type leaf)))))) (if reffer @@ -170,13 +158,6 @@ ;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE (defun assertions-on-ir2-converted-clambda (clambda) - ;; This assertion was sort of an experiment. It would be nice and - ;; sane and easier to understand things if it were *always* true, - ;; but experimentally I observe that it's only *almost* always - ;; true. -- WHN 2001-01-02 - #+nil - (aver (eql (lambda-component clambda) - (block-component (ir2-block-block ir2-block)))) ;; Check for some weirdness which came up in bug ;; 138, 2002-01-02. ;; @@ -229,15 +210,15 @@ (let ((closure (etypecase functional (clambda (assertions-on-ir2-converted-clambda functional) - (physenv-closure (get-lambda-physenv functional))) + (environment-closure (get-lambda-environment functional))) (functional (aver (eq (functional-kind functional) :toplevel-xep)) nil))) global-var) (cond (closure (prepare) - (let* ((physenv (node-physenv ref)) - (tn (find-in-physenv functional physenv))) + (let* ((this-env (node-environment ref)) + (tn (find-in-environment functional this-env))) (emit-move ref ir2-block tn res))) ;; we're about to emit a reference to a "closure" that's actually ;; an inlinable global function. @@ -257,7 +238,7 @@ (defun closure-initial-value (what this-env current-fp) (declare (type (or nlx-info lambda-var clambda) what) - (type physenv this-env) + (type environment this-env) (type (or tn null) current-fp)) ;; If we have an indirect LAMBDA-VAR that does not require an ;; EXPLICIT-VALUE-CELL, and is from this environment (not from being @@ -265,10 +246,10 @@ (if (and (lambda-var-p what) (lambda-var-indirect what) (not (lambda-var-explicit-value-cell what)) - (eq (lambda-physenv (lambda-var-home what)) + (eq (lambda-environment (lambda-var-home what)) this-env)) current-fp - (find-in-physenv what this-env))) + (find-in-environment what this-env))) ;;; Emit code to create function objects implementing the FUNCTIONALs ;;; of the enclose node. This gets interesting when the functions are @@ -292,13 +273,13 @@ ;; If there is no XEP then no closure needs to be created. (when (and xep (not (eq (functional-kind xep) :deleted))) (aver (xep-p xep)) - (let ((closure (physenv-closure (get-lambda-physenv xep)))) + (let ((closure (environment-closure (get-lambda-environment xep)))) (when closure (let* ((entry-info (lambda-info xep)) (tn (entry-info-closure-tn entry-info)) #-x86-64 (entry (make-load-time-constant-tn :entry xep)) - (env (node-physenv node)) + (env (node-environment node)) (leaf-dx-p (and lvar (leaf-dynamic-extent fun)))) (aver (entry-info-offset entry-info)) (vop make-closure node ir2-block #-x86-64 entry @@ -308,7 +289,7 @@ (unless (and (lambda-var-p what) (null (leaf-refs what))) (if (lambda-p what) - (delayed (list tn (find-in-physenv what env) n)) + (delayed (list tn (find-in-environment what env) n)) (let ((initial-value (closure-initial-value what env nil))) (if initial-value (vop closure-init node ir2-block tn initial-value n) @@ -335,15 +316,15 @@ (etypecase leaf (lambda-var (when (leaf-refs leaf) - (let ((tn (find-in-physenv leaf (node-physenv node))) + (let ((tn (find-in-environment leaf (node-environment node))) (indirect (lambda-var-indirect leaf)) (explicit (lambda-var-explicit-value-cell leaf))) (cond ((and indirect explicit) (vop value-cell-set node block tn val)) ((and indirect - (not (eq (node-physenv node) - (lambda-physenv (lambda-var-home leaf))))) + (not (eq (node-environment node) + (lambda-environment (lambda-var-home leaf))))) (let ((setter (fourth (primitive-type-indirect-cell-type (primitive-type (leaf-type leaf)))))) (if setter @@ -383,7 +364,7 @@ (ecase (ir2-lvar-kind 2lvar) (:delayed (let ((ref (lvar-uses lvar))) - (leaf-tn (ref-leaf ref) (node-physenv ref)))) + (leaf-tn (ref-leaf ref) (node-environment ref)))) (:fixed (aver (= (length (ir2-lvar-locs 2lvar)) 1)) (first (ir2-lvar-locs 2lvar))))) @@ -464,7 +445,9 @@ for i from 0 for loc = (pop locs) collect (cond ((and loc - (eq (tn-primitive-type loc) prim-type)) + (if (eq (tn-kind loc) :unused) + (member i optional) + (eq (tn-primitive-type loc) prim-type))) loc) ((and (not loc) (member i optional)) @@ -546,13 +529,14 @@ (move-results-coerced node block results locs)))) (:unknown (let ((locs (loop for tn in results - collect (cond #+(or x86 x86-64) + collect (cond #+(or x86 x86-64 arm64) ((eq (tn-kind tn) :constant) tn) ((and - #-(or x86 x86-64) + #-(or x86 x86-64 arm64) (neq (tn-kind tn) :constant) - (eq (tn-primitive-type tn) *backend-t-primitive-type*)) + (equal (primitive-type-scs (tn-primitive-type tn)) + `(,sb-vm:descriptor-reg-sc-number))) tn) ((let ((new (make-normal-tn *backend-t-primitive-type*))) (emit-move node block tn new) @@ -571,7 +555,7 @@ (2lvar (lvar-info lvar)) (value (cast-value node)) (2value (lvar-info value))) - (when 2lvar ;; the cast can be unused but not deleted to due vestigial exits + (when 2lvar ;; the cast can be unused but not deleted due to DELAY (ecase (ir2-lvar-kind 2lvar) (:unused) ((:unknown :fixed) @@ -847,10 +831,10 @@ (locs loc)))) (when old-fp - (let ((this-1env (node-physenv node)) - (called-env (physenv-info (lambda-physenv fun))) + (let ((this-1env (node-environment node)) + (called-env (environment-info (lambda-environment fun))) passed) - (dolist (thing (ir2-physenv-closure called-env)) + (dolist (thing (ir2-environment-closure called-env)) (let ((value (closure-initial-value (car thing) this-1env closure-fp)) (loc (cdr thing))) ;; Don't pass the FP for indirect variables multiple times @@ -859,7 +843,7 @@ (temps value) (locs loc)))) (temps old-fp) - (locs (ir2-physenv-old-fp called-env)))) + (locs (ir2-environment-old-fp called-env)))) (values (temps) (locs))))) @@ -869,11 +853,11 @@ ;;; function's passing location. (defun ir2-convert-tail-local-call (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) - (let ((this-env (physenv-info (node-physenv node))) + (let ((this-env (environment-info (node-environment node))) (current-fp (make-stack-pointer-tn))) (multiple-value-bind (temps locs) (emit-psetq-moves node block fun - (ir2-physenv-old-fp this-env) current-fp) + (ir2-environment-old-fp this-env) current-fp) ;; If we're about to emit a move from CURRENT-FP then we need to ;; initialize it. @@ -883,12 +867,12 @@ (mapc (lambda (temp loc) (emit-move node block temp loc)) temps locs)) - + #-fp-and-pc-standard-save (emit-move node block - (ir2-physenv-return-pc this-env) - (ir2-physenv-return-pc-pass - (physenv-info - (lambda-physenv fun))))) + (ir2-environment-return-pc this-env) + (ir2-environment-return-pc-pass + (environment-info + (lambda-environment fun))))) (values)) @@ -923,7 +907,7 @@ (emit-psetq-moves node block fun old-fp) (vop current-fp node block old-fp) (vop allocate-frame node block - (physenv-info (lambda-physenv fun)) + (environment-info (lambda-environment fun)) fp nfp) (values fp nfp temps (mapcar #'make-alias-tn locs))))) @@ -939,7 +923,7 @@ (vop* known-call-local node block (fp nfp (reference-tn-list temps nil)) ((reference-tn-list locs t)) - arg-locs (physenv-info (lambda-physenv fun)) start) + arg-locs (environment-info (lambda-environment fun)) start) (move-lvar-result node block locs lvar))) (values)) @@ -959,7 +943,7 @@ (multiple-value-bind (fp nfp temps arg-locs) (ir2-convert-local-call-args node block fun) (let ((2lvar (and lvar (lvar-info lvar))) - (env (physenv-info (lambda-physenv fun))) + (env (environment-info (lambda-environment fun))) (temp-refs (reference-tn-list temps nil))) (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown)) (vop* multiple-call-local node block (fp nfp temp-refs) @@ -1066,12 +1050,12 @@ ;;; named) tail call. (defun ir2-convert-tail-full-call (node block) (declare (type combination node) (type ir2-block block)) - (let* ((env (physenv-info (node-physenv node))) + (let* ((env (environment-info (node-environment node))) (args (basic-combination-args node)) (nargs (length args)) (pass-refs (move-tail-full-call-args node block)) - (old-fp (ir2-physenv-old-fp env)) - (return-pc (ir2-physenv-return-pc env)) + (old-fp (ir2-environment-old-fp env)) + (return-pc (ir2-environment-return-pc env)) (fun-lvar (basic-combination-fun node))) (multiple-value-bind (fun-tn named) (fun-lvar-tn node block fun-lvar) @@ -1336,7 +1320,7 @@ (defun init-xep-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) (let ((start-label (entry-info-offset (leaf-info fun))) - (env (physenv-info (node-physenv node))) + (env (environment-info (node-environment node))) arg-count-tn) (let ((ef (functional-entry-fun fun))) (vop xep-allocate-frame node block start-label) @@ -1363,7 +1347,7 @@ #+x86-64 verified)) (t (vop xep-setup-sp node block)))) - (when (ir2-physenv-closure env) + (when (ir2-environment-closure env) (let ((closure (make-normal-tn *backend-t-primitive-type*))) (when (policy fun (> store-closure-debug-pointer 1)) ;; Save the closure pointer on the stack. @@ -1372,11 +1356,11 @@ sb-vm:control-stack-sc-number))) (vop setup-closure-environment node block start-label closure-save) - (setf (ir2-physenv-closure-save-tn env) closure-save) + (setf (ir2-environment-closure-save-tn env) closure-save) (component-live-tn closure-save))) (vop setup-closure-environment node block start-label closure) (let ((n -1)) - (dolist (loc (ir2-physenv-closure env)) + (dolist (loc (ir2-environment-closure env)) (vop closure-ref node block closure (incf n) (cdr loc))))))) (unless (eq (functional-kind fun) :toplevel) (let ((vars (lambda-vars fun)) @@ -1392,9 +1376,9 @@ (emit-make-value-cell node block pass home) (emit-move node block pass home)))) (incf n)))) - + #-fp-and-pc-standard-save (emit-move node block (make-old-fp-passing-location) - (ir2-physenv-old-fp env))) + (ir2-environment-old-fp env))) (values)) @@ -1423,13 +1407,13 @@ (let ((bsp-save-tn (make-representation-tn *backend-t-primitive-type* sb-vm:control-stack-sc-number))) (vop current-binding-pointer node block bsp-save-tn) - (setf (ir2-physenv-bsp-save-tn env) bsp-save-tn) + (setf (ir2-environment-bsp-save-tn env) bsp-save-tn) (component-live-tn bsp-save-tn))) (defun ir2-convert-bind (node block) (declare (type bind node) (type ir2-block block)) (let* ((fun (bind-lambda node)) - (env (physenv-info (lambda-physenv fun)))) + (env (environment-info (lambda-environment fun)))) (aver (member (functional-kind fun) '(nil :external :optional :toplevel :cleanup))) @@ -1445,10 +1429,10 @@ ;; handles closures inside closures correctly). [remark by JES] (let* ((entry-fun (lambda-entry-fun fun))) (when entry-fun - (let ((2env (physenv-info (lambda-physenv fun))) - (entry-2env (physenv-info (lambda-physenv entry-fun)))) - (setf (ir2-physenv-closure-save-tn 2env) - (ir2-physenv-closure-save-tn entry-2env))))))) + (let ((2env (environment-info (lambda-environment fun))) + (entry-2env (environment-info (lambda-environment entry-fun)))) + (setf (ir2-environment-closure-save-tn 2env) + (ir2-environment-closure-save-tn entry-2env))))))) #-fp-and-pc-standard-save (let ((lab (gen-label))) ;; KLUDGE: Technically, we should be doing this before VOP @@ -1456,16 +1440,17 @@ ;; expected to work anyway, so there's no real window to worry ;; about. (vop emit-label node block lab) - (setf (ir2-physenv-cfp-saved-pc env) lab)) + (setf (ir2-environment-cfp-saved-pc env) lab)) + #-fp-and-pc-standard-save (emit-move node block - (ir2-physenv-return-pc-pass env) - (ir2-physenv-return-pc env)) + (ir2-environment-return-pc-pass env) + (ir2-environment-return-pc env)) #-fp-and-pc-standard-save (let ((lab (gen-label))) (vop emit-label node block lab) - (setf (ir2-physenv-lra-saved-pc env) lab)) + (setf (ir2-environment-lra-saved-pc env) lab)) #+unwind-to-frame-and-call-vop (when (and (lambda-allow-instrumenting fun) @@ -1474,7 +1459,7 @@ (save-bsp node block env)) (let ((lab (gen-label))) - (setf (ir2-physenv-environment-start env) lab) + (setf (ir2-environment-environment-start env) lab) (vop note-environment-start node block lab) #+sb-safepoint (when (policy fun (/= insert-safepoints 0)) @@ -1497,9 +1482,9 @@ (2lvar (lvar-info lvar)) (lvar-kind (ir2-lvar-kind 2lvar)) (fun (return-lambda node)) - (env (physenv-info (lambda-physenv fun))) - (old-fp (ir2-physenv-old-fp env)) - (return-pc (ir2-physenv-return-pc env)) + (env (environment-info (lambda-environment fun))) + (old-fp (ir2-environment-old-fp env)) + (return-pc (ir2-environment-return-pc env)) (returns (tail-set-info (lambda-tail-set fun)))) (cond ((and (eq (return-info-kind returns) :fixed) @@ -1541,15 +1526,15 @@ ;;;; function as multiple values. (defoptimizer (%caller-frame ir2-convert) (() node block) - (let ((ir2-physenv (physenv-info (node-physenv node)))) + (let ((ir2-environment (environment-info (node-environment node)))) (move-lvar-result node block - (list (ir2-physenv-old-fp ir2-physenv)) + (list (ir2-environment-old-fp ir2-environment)) (node-lvar node)))) (defoptimizer (%caller-pc ir2-convert) (() node block) - (let ((ir2-physenv (physenv-info (node-physenv node)))) + (let ((ir2-environment (environment-info (node-environment node)))) (move-lvar-result node block - (list (ir2-physenv-return-pc ir2-physenv)) + (list (ir2-environment-return-pc ir2-environment)) (node-lvar node)))) ;;;; multiple values @@ -1610,10 +1595,10 @@ (eq (ir2-lvar-kind start-lvar) :unknown))) (cond (tails - (let ((env (physenv-info (node-physenv node)))) + (let ((env (environment-info (node-environment node)))) (vop tail-call-variable node block start fun - (ir2-physenv-old-fp env) - (ir2-physenv-return-pc env) + (ir2-environment-old-fp env) + (ir2-environment-return-pc env) #+call-symbol (fun-tn-type fun-lvar fun)))) ((and 2lvar @@ -1738,16 +1723,11 @@ (loop for loc in (ir2-lvar-locs 2lvar) for idx upfrom 0 unless (eq (tn-kind loc) :unused) - 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)))) + do (vop sb-vm::more-arg-or-nil node block + (lvar-tn node block context) + (lvar-tn node block count) + idx + loc))) (:unknown (let ((locs (ir2-lvar-locs 2lvar))) (vop* %more-arg-values node block @@ -1849,7 +1829,7 @@ (defun ir2-convert-exit (node block) (declare (type exit node) (type ir2-block block)) (let* ((nlx (exit-nlx-info node)) - (loc (find-in-physenv nlx (node-physenv node))) + (loc (find-in-environment nlx (node-environment node))) (temp (make-stack-pointer-tn)) (value (exit-value node))) (if (nlx-info-safe-p nlx) @@ -1857,7 +1837,10 @@ (emit-move node block loc temp)) (if value (let ((locs (ir2-lvar-locs (lvar-info value)))) - (vop unwind node block temp (first locs) (second locs))) + (vop unwind node block temp (first locs) + (or (second locs) + ;; FIXME: avoid writing this TN + (emit-constant 0)))) (let ((0-tn (emit-constant 0))) (vop unwind node block temp 0-tn 0-tn)))) @@ -1874,7 +1857,7 @@ (let ((nlx (lvar-value info))) (when (nlx-info-safe-p nlx) (vop value-cell-set node block - (find-in-physenv nlx (node-physenv node)) + (find-in-environment nlx (node-environment node)) (emit-constant 0))))) ;;; We have to do a spurious move of no values to the result lvar so @@ -1977,9 +1960,10 @@ (let* ((info (lvar-value info-lvar)) (lvar (node-lvar node)) (2info (nlx-info-info info)) - (target (ir2-nlx-info-target 2info))) + (target (ir2-nlx-info-target 2info)) + (kind (cleanup-kind (nlx-info-cleanup info)))) - (ecase (cleanup-kind (nlx-info-cleanup info)) + (ecase kind ((:catch :block :tagbody) (let ((top-loc (ir2-nlx-info-save-sp 2info)) (start-loc (make-nlx-entry-arg-start-location)) @@ -1991,11 +1975,19 @@ ((reference-tn-list (ir2-lvar-locs 2lvar) t)) target) (let ((locs (standard-result-tns lvar))) - (vop* nlx-entry node block - (top-loc start-loc count-loc nil) - ((reference-tn-list locs t)) - target - (length locs)) + (if (and (= (length locs) 1) + (memq kind '(:block :tagbody)) + lvar + (lvar-single-value-p lvar)) + (vop* nlx-entry-single node block + (top-loc start-loc nil) + ((reference-tn-list locs t)) + target) + (vop* nlx-entry node block + (top-loc start-loc count-loc nil) + ((reference-tn-list locs t)) + target + (length locs))) (move-lvar-result node block locs lvar))))) #-no-continue-unwind ((:unwind-protect) @@ -2079,10 +2071,26 @@ args) nil)) (lvar (node-lvar node)) - (res (lvar-result-tns lvar (list (specifier-type 'list))))) + (res (lvar-result-tns lvar (list (specifier-type 'list)))) + (num-conses (- (length args) (if star 1 0)))) (when (and lvar (lvar-dynamic-extent lvar)) (vop current-stack-pointer node block (ir2-lvar-stack-pointer (lvar-info lvar)))) - (vop* list node block (refs) ((first res) nil) star (- (length args) (if star 1 0))) + ;;; This COND-like expression is unfortunate, but the VOP* macro chokes if the name + ;;; doesn't exist. This was the best workaround I found, short of using #+. + (or (when-vop-existsp (:named cons) + (when (= num-conses 1) + (unless star + (setf (tn-ref-across refs) (reference-tn (emit-constant nil) nil))) + (vop* cons node block (refs) ((first res) nil)) + t)) + (when-vop-existsp (:named sb-vm::cons-2) + (when (= num-conses 2) + (unless star + (setf (tn-ref-across (tn-ref-across refs)) + (reference-tn (emit-constant nil) nil))) + (vop* sb-vm::cons-2 node block (refs) ((first res) nil)) + t)) + (vop* list node block (refs) ((first res) nil) star num-conses)) (move-lvar-result node block res lvar)))) (setf (fun-info-ir2-convert (fun-info-or-lose 'list*)) #'list-ir2-convert-optimizer) diff -Nru sbcl-2.1.10/src/compiler/life.lisp sbcl-2.1.11/src/compiler/life.lisp --- sbcl-2.1.10/src/compiler/life.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/life.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -52,19 +52,19 @@ (do-packed-tns (tn component) (setf (tn-current-conflict tn) (tn-global-conflicts tn)))) -;;; Cache the results of BLOCK-PHYSENV during lifetime analysis. +;;; Cache the results of BLOCK-ENVIRONMENT during lifetime analysis. ;;; -;;; Fetching the home-lambda of a block (needed in block-physenv) can +;;; Fetching the home-lambda of a block (needed in block-environment) can ;;; be an expensive operation under some circumstances, and it needs ;;; to be done a lot during lifetime analysis when compiling with high ;;; DEBUG (e.g. 30% of the total compilation time for CL-PPCRE with ;;; DEBUG 3 just for that). -(defun cached-block-physenv (block) - (let ((physenv (block-physenv-cache block))) - (if (eq physenv :none) - (setf (block-physenv-cache block) - (block-physenv block)) - physenv))) +(defun cached-block-environment (block) + (let ((env (block-environment-cache block))) + (if (eq env :none) + (setf (block-environment-cache block) + (block-environment block)) + env))) ;;;; pre-pass @@ -434,14 +434,14 @@ ;;; TN. We make the TN global if it isn't already. The TN must have at ;;; least one reference. (defun setup-environment-tn-conflicts (component tn env debug-p) - (declare (type component component) (type tn tn) (type physenv env)) + (declare (type component component) (type tn tn) (type environment env)) (when (and debug-p (not (tn-global-conflicts tn)) (tn-local tn)) (convert-to-global tn)) (setf (tn-current-conflict tn) (tn-global-conflicts tn)) (do-blocks-backwards (block component) - (when (eq (cached-block-physenv block) env) + (when (eq (cached-block-environment block) env) (let* ((2block (block-info block)) (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) (prev 2block b)) @@ -455,14 +455,14 @@ ;;; Implicit value cells are allocated on the stack and local ;;; functions can access closed over values of the parent function ;;; that way, but when the parent function tail calls a local function -;;; its physenv ceases to exist, yet the indirect TNs should still be -;;; accessible within the tail-called function. -;;; Find all the users of the TN, returning their physenvs, in wich -;;; the TN should be marked as live. +;;; its environment ceases to exist, yet the indirect TNs should still +;;; be accessible within the tail-called function. Find all the users +;;; of the TN, returning their environments, in which the TN should be +;;; marked as live. (defun find-implicit-value-cell-users (home-env tn) (let (result) (labels ((recur (lambda) - (let ((env (lambda-physenv lambda))) + (let ((env (lambda-environment lambda))) (unless (or (eq env home-env) (memq env result)) (push env result) @@ -479,39 +479,39 @@ (defun setup-environment-live-conflicts (component) (declare (type component component)) (dolist (fun (component-lambdas component)) - (let* ((env (lambda-physenv fun)) - (2env (physenv-info env))) - (dolist (tn (ir2-physenv-live-tns 2env)) + (let* ((env (lambda-environment fun)) + (2env (environment-info env))) + (dolist (tn (ir2-environment-live-tns 2env)) (setup-environment-tn-conflicts component tn env nil) (when (implicit-value-cell-tn-p tn) (loop for env in (find-implicit-value-cell-users env tn) ;; See the comment above FIND-IMPLICIT-VALUE-CELL-USERS - when (memq (physenv-lambda env) + when (memq (environment-lambda env) (tail-set-funs (lambda-tail-set fun))) do (setup-environment-tn-conflicts component tn env nil)))) - (dolist (tn (ir2-physenv-debug-live-tns 2env)) + (dolist (tn (ir2-environment-debug-live-tns 2env)) (setup-environment-tn-conflicts component tn env t)))) (values)) ;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN. -;;; This requires adding :LIVE conflicts to all blocks in TN-PHYSENV. -(defun convert-to-environment-tn (tn tn-physenv) - (declare (type tn tn) (type physenv tn-physenv)) +;;; This requires adding :LIVE conflicts to all blocks in TN-ENV. +(defun convert-to-environment-tn (tn tn-env) + (declare (type tn tn) (type environment tn-env)) (aver (member (tn-kind tn) '(:normal :debug-environment))) (ecase (tn-kind tn) (:debug-environment - (setq tn-physenv (tn-physenv tn)) - (let* ((2env (physenv-info tn-physenv))) - (setf (ir2-physenv-debug-live-tns 2env) - (delete tn (ir2-physenv-debug-live-tns 2env))))) + (setq tn-env (tn-environment tn)) + (let* ((2env (environment-info tn-env))) + (setf (ir2-environment-debug-live-tns 2env) + (delete tn (ir2-environment-debug-live-tns 2env))))) (:normal (setf (tn-local tn) nil) (setf (tn-local-number tn) nil))) - (setup-environment-tn-conflicts *component-being-compiled* tn tn-physenv nil) + (setup-environment-tn-conflicts *component-being-compiled* tn tn-env nil) (setf (tn-kind tn) :environment) - (setf (tn-physenv tn) tn-physenv) - (push tn (ir2-physenv-live-tns (physenv-info tn-physenv))) + (setf (tn-environment tn) tn-env) + (push tn (ir2-environment-live-tns (environment-info tn-env))) (values)) ;;;; flow analysis @@ -699,7 +699,7 @@ (num (global-conflicts-number conf))) (when (and num (zerop (sbit live-bits num)) (eq (tn-kind tn) :debug-environment) - (eq (tn-physenv tn) (cached-block-physenv 1block)) + (eq (tn-environment tn) (cached-block-environment 1block)) (saved-after-read tn block)) (note-conflicts live-bits live-list tn num) (setf (sbit live-bits num) 1) @@ -771,7 +771,7 @@ (unless (eq (tn-kind tn) :environment) (convert-to-environment-tn tn - (cached-block-physenv (ir2-block-block block)))))))) + (cached-block-environment (ir2-block-block block)))))))) (values)) ;;; This is used in SCAN-VOP-REFS to simultaneously do something to @@ -1017,16 +1017,16 @@ (values)) ;;; On high debug levels, for all variables that a lambda closes over -;;; convert the TNs to :ENVIRONMENT TNs (in the physical environment -;;; of that lambda). This way the debugger can display the variables. +;;; convert the TNs to :ENVIRONMENT TNs (in the environment of that +;;; lambda). This way the debugger can display the variables. (defun maybe-environmentalize-closure-tns (component) (dolist (lambda (component-lambdas component)) (when (policy lambda (>= debug 2)) - (let ((physenv (lambda-physenv lambda))) - (dolist (closure-var (physenv-closure physenv)) - (let ((tn (find-in-physenv closure-var physenv))) + (let ((env (lambda-environment lambda))) + (dolist (closure-var (environment-closure env)) + (let ((tn (find-in-environment closure-var env))) (when (member (tn-kind tn) '(:normal :debug-environment)) - (convert-to-environment-tn tn physenv)))))))) + (convert-to-environment-tn tn env)))))))) (defun lifetime-analyze (component) diff -Nru sbcl-2.1.10/src/compiler/locall.lisp sbcl-2.1.11/src/compiler/locall.lisp --- sbcl-2.1.10/src/compiler/locall.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/locall.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -53,34 +53,43 @@ (setf (car args) nil))) (values)) +;;; Given a local call CALL to FUN, find the associated argument LVARs +;;; of CALL corresponding to declared dynamic extent LAMBDA-VARs and +;;; note them as dynamic extent LVARs. This operation is transitive, +;;; because dynamic extent is contagious. In particular, the arguments +;;; of any COMBINATIONs returning a stack-allocatable object in a +;;; dynamic extent LVAR are dynamic extent as well if the argument +;;; LVARs contain otherwise-inaccessible stack-allocatable subobjects +;;; themselves. (defun recognize-dynamic-extent-lvars (call fun) (declare (type combination call) (type clambda fun)) - (loop for arg in (basic-combination-args call) - for var in (lambda-vars fun) - for dx = (leaf-dynamic-extent var) - when (and dx arg (not (lvar-dynamic-extent arg))) - append (handle-nested-dynamic-extent-lvars dx arg) into dx-lvars - ;; The block may end up being deleted due to cast optimization - ;; caused by USE-GOOD-FOR-DX-P - when (node-to-be-deleted-p call) return nil - finally (when dx-lvars - ;; Stack analysis requires that the CALL ends the block, so - ;; that MAP-BLOCK-NLXES sees the cleanup we insert here. - (node-ends-block call) - (let* ((entry (with-ir1-environment-from-node call - (make-entry))) - (cleanup (make-cleanup :kind :dynamic-extent - :mess-up entry - :info dx-lvars))) - (setf (entry-cleanup entry) cleanup) - (insert-node-before call entry) - (ensure-block-start (node-prev entry)) - (setf (node-lexenv call) - (make-lexenv :default (node-lexenv call) - :cleanup cleanup)) - (push entry (lambda-entries (node-home-lambda entry))) - (dolist (cell dx-lvars) - (setf (lvar-dynamic-extent (cdr cell)) cleanup))))) + ;; The block may end up being deleted due to cast optimization + ;; caused by USE-GOOD-FOR-DX-P + (unless (node-to-be-deleted-p call) + (let ((dx-lvars + (loop for arg in (basic-combination-args call) + for var in (lambda-vars fun) + for dx = (leaf-dynamic-extent var) + when (and dx arg (not (lvar-dynamic-extent arg))) + append (handle-nested-dynamic-extent-lvars dx arg)))) + (when dx-lvars + ;; Stack analysis requires that the CALL ends the block, so + ;; that MAP-BLOCK-NLXES sees the cleanup we insert here. + (node-ends-block call) + (let* ((entry (with-ir1-environment-from-node call + (make-entry))) + (cleanup (make-cleanup :kind :dynamic-extent + :mess-up entry + :info dx-lvars))) + (setf (entry-cleanup entry) cleanup) + (insert-node-before call entry) + (ensure-block-start (node-prev entry)) + (setf (node-lexenv call) + (make-lexenv :default (node-lexenv call) + :cleanup cleanup)) + (push entry (lambda-entries (node-home-lambda entry))) + (dolist (cell dx-lvars) + (setf (lvar-dynamic-extent (cdr cell)) cleanup)))))) (values)) ;;; This function handles merging the tail sets if CALL is potentially @@ -272,10 +281,14 @@ (declare (type functional fun)) (aver (null (functional-entry-fun fun))) (with-ir1-environment-from-node (lambda-bind (main-entry fun)) - (let ((xep (ir1-convert-lambda (make-xep-lambda-expression fun) - :debug-name (debug-name - 'xep (leaf-debug-name fun)) - :system-lambda t))) + (let* ((*lexenv* (if (neq (lexenv-policy (functional-lexenv fun)) + (lexenv-policy *lexenv*)) + (make-lexenv :policy (lexenv-policy (functional-lexenv fun))) + *lexenv*)) + (xep (ir1-convert-lambda (make-xep-lambda-expression fun) + :debug-name (debug-name + 'xep (leaf-debug-name fun)) + :system-lambda t))) (setf (functional-kind xep) :external (leaf-ever-used xep) t (functional-entry-fun xep) fun @@ -388,7 +401,8 @@ (push fun (component-lambdas component))) (locall-analyze-fun-1 fun) (when (lambda-p fun) - (maybe-let-convert fun component))))))) + (or (maybe-let-convert fun component) + (maybe-convert-to-assignment fun)))))))) (values)) (defun locall-analyze-clambdas-until-done (clambdas) @@ -427,12 +441,7 @@ (with-ir1-environment-from-node call (let* ((*inline-expansions* (register-inline-expansion original-functional call)) - (*lexenv* (functional-lexenv original-functional)) - (*transforming* - (if (and (functional-inline-expanded original-functional) - (system-inline-fun-p (leaf-source-name original-functional))) - (1+ *transforming*) - *transforming*))) + (*lexenv* (functional-lexenv original-functional))) (values nil (ir1-convert-lambda (functional-inline-expansion original-functional) @@ -512,7 +521,7 @@ (setq fun (maybe-expand-local-inline fun ref call))) (aver (member (functional-kind fun) - '(nil :escape :cleanup :optional))) + '(nil :escape :cleanup :optional :assignment))) (cond ((mv-combination-p call) (convert-mv-call ref call fun)) ((lambda-p fun) @@ -942,10 +951,10 @@ ;; information. (setf (tail-set-info (lambda-tail-set clambda)) nil)) -;;; Handle the PHYSENV semantics of LET conversion. We add CLAMBDA and -;;; its LETs to LETs for the CALL's home function. We merge the calls -;;; for CLAMBDA with the calls for the home function, removing CLAMBDA -;;; in the process. We also merge the ENTRIES. +;;; Handle the environment semantics of LET conversion. We add CLAMBDA +;;; and its LETs to LETs for the CALL's home function. We merge the +;;; calls for CLAMBDA with the calls for the home function, removing +;;; CLAMBDA in the process. We also merge the ENTRIES. ;;; ;;; We also unlink the function head from the component head and set ;;; COMPONENT-REANALYZE to true to indicate that the DFO should be @@ -964,28 +973,28 @@ (depart-from-tail-set clambda) (let* ((home (node-home-lambda call)) - (home-physenv (lambda-physenv home)) - (physenv (lambda-physenv clambda))) + (home-env (lambda-environment home)) + (env (lambda-environment clambda))) (aver (not (eq home clambda))) ;; CLAMBDA belongs to HOME now. (push clambda (lambda-lets home)) (setf (lambda-home clambda) home) - (setf (lambda-physenv clambda) home-physenv) + (setf (lambda-environment clambda) home-env) - (when physenv - (unless home-physenv - (setf home-physenv (get-lambda-physenv home))) - (setf (physenv-nlx-info home-physenv) - (nconc (physenv-nlx-info physenv) - (physenv-nlx-info home-physenv)))) + (when env + (unless home-env + (setf home-env (get-lambda-environment home))) + (setf (environment-nlx-info home-env) + (nconc (environment-nlx-info env) + (environment-nlx-info home-env)))) ;; All of CLAMBDA's LETs belong to HOME now. (let ((lets (lambda-lets clambda))) (dolist (let lets) (setf (lambda-home let) home) - (setf (lambda-physenv let) home-physenv)) + (setf (lambda-environment let) home-env)) (setf (lambda-lets home) (nconc lets (lambda-lets home)))) ;; CLAMBDA no longer has an independent existence as an entity ;; which has LETs. @@ -1126,13 +1135,8 @@ (block-delete-p (node-block call-return))) (flush-dest (return-result call-return)) (delete-return call-return) - ;; A new return will be put into that lambda, don't want - ;; DELETE-RETURN called by DELETE-BLOCK to delete the new return - ;; from the lambda. - ;; (Previously, UNLINK-NODE was called on the return, but it - ;; doesn't work well on deleted blocks) - (setf (return-lambda call-return) nil - call-return nil)) + (unlink-node call-return) + (setq call-return nil)) (cond ((not return)) ((or next-block call-return) (unless (block-delete-p (node-block return)) @@ -1164,11 +1168,7 @@ next-block))) (move-return-stuff fun call next-block) (merge-lets fun call) - (setf (node-tail-p call) nil) - ;; If CALL has a derive type NIL, it means that "its return" is - ;; unreachable, but the next BIND is still reachable; in order to - ;; not confuse MAYBE-TERMINATE-BLOCK... - (setf (node-derived-type call) *wild-type*))) + (setf (node-tail-p call) nil))) ;;; Reoptimize all of CALL's args and its result. (defun reoptimize-call (call) @@ -1373,53 +1373,123 @@ (values t (maybe-convert-to-assignment fun)))))) ;;; This is called when we believe it might make sense to convert -;;; CLAMBDA to an assignment. All this function really does is +;;; FUN to an assignment. All this function really does is ;;; determine when a function with more than one call can still be ;;; combined with the calling function's environment. We can convert ;;; when: ;;; -- The function is a normal, non-entry function, and -;;; -- Except for one call, all calls must be tail recursive calls -;;; in the called function (i.e. are self-recursive tail calls) +;;; -- All calls must return to the same place, so some +;;; may be tail recursive calls in the called function (i.e. are +;;; self-recursive tail calls) ;;; -- OK-INITIAL-CONVERT-P is true. ;;; -;;; There may be one outside call, and it need not be tail-recursive. -;;; Since all tail local calls have already been converted to direct -;;; transfers, the only control semantics needed are to splice in the -;;; body at the non-tail call. If there is no non-tail call, then we -;;; need only merge the environments. Both cases are handled by -;;; LET-CONVERT. +;;; There may be any number of outside calls, and they need not be +;;; tail-recursive. The only constraint is that they return to the +;;; same place (taking into account cleanup actions). Note that in +;;; particular, this is also satisfied when the calls to FUN are +;;; derived to not return at all. Since all tail local calls have +;;; already been converted to direct transfers, the only control +;;; semantics needed are to splice in the body at some non-tail +;;; call. If there is no non-tail call, then we need only merge the +;;; environments. Both cases are handled by LET-CONVERT. ;;; ;;; ### It would actually be possible to allow any number of outside ;;; calls as long as they all return to the same place (i.e. have the -;;; same conceptual continuation.) A special case of this would be -;;; when all of the outside calls are tail recursive. -(defun maybe-convert-to-assignment (clambda) - (declare (type clambda clambda)) - (when (and (not (functional-kind clambda)) - (not (functional-entry-fun clambda)) - (not (functional-has-external-references-p clambda))) - (let ((outside-non-tail-call nil) - (outside-call nil)) - (when (and (dolist (ref (leaf-refs clambda) t) +;;; same conceptual continuation.) Some currently unhandled cases of +;;; this are outside tail calls from multiple functions which +;;; themselves return to the same place transitively. The paper +;;; "Contification using dominators" by Fluet and Weeks describes a +;;; maximal algorithm for detecting all such calls returning to the +;;; same place. +(defun maybe-convert-to-assignment (fun) + (declare (type clambda fun)) + (when (and (not (functional-kind fun)) + (not (functional-entry-fun fun)) + (not (functional-has-external-references-p fun)) + ;; If a functional is explicitly inlined, we don't want + ;; to assignment convert it, as more call-site + ;; specialization can be done with inlining. + (not (functional-inlinep fun)) + (not (block-delete-p (lambda-block fun)))) + (let ((outside-calls nil) + (outside-calls-ctran nil) + (outside-calls-env nil) + (outside-calls-cleanup nil)) + (when (and (dolist (ref (leaf-refs fun) t) (let ((dest (node-dest ref))) (when (or (not dest) (node-to-be-deleted-p ref) (node-to-be-deleted-p dest)) (return nil)) (let ((home (node-home-lambda ref))) - (unless (eq home clambda) - (when outside-call - (return nil)) - (setq outside-call dest)) - (unless (node-tail-p dest) - (when (or outside-non-tail-call (eq home clambda)) - (return nil)) - (setq outside-non-tail-call dest))))) - (ok-initial-convert-p clambda)) - (cond (outside-call (setf (functional-kind clambda) :assignment) - (let-convert clambda outside-call) - (when outside-non-tail-call - (reoptimize-call outside-non-tail-call)) - t) - (t (delete-lambda clambda) - nil)))))) + (if (eq home fun) + (unless (node-tail-p dest) + (return nil)) + (let ((dest-ctran + (or (node-next dest) + (block-start (first (block-succ (node-block dest)))))) + (dest-env + (node-home-lambda dest)) + (dest-cleanup + (node-enclosing-cleanup dest))) + (aver dest-env) + (cond (outside-calls-env + ;; We can only convert multiple + ;; outside calls when they are all + ;; in the same environment, so we + ;; don't muck up tail sets. This + ;; is not a conceptual restriction + ;; though; it may be possible to + ;; lift this if things are + ;; reworked. The cleanup checking + ;; here is also overly + ;; conservative. A better approach + ;; would be to check for harmful + ;; cleanups with respect to the + ;; messiest common ancestor. + (unless (and (or (eq (node-derived-type dest) *empty-type*) + (and (eq outside-calls-ctran dest-ctran))) + (eq outside-calls-env dest-env) + (eq outside-calls-cleanup dest-cleanup)) + (return nil))) + (t + (setq outside-calls-env dest-env) + (setq outside-calls-ctran dest-ctran) + (setq outside-calls-cleanup dest-cleanup))) + (push dest outside-calls)))))) + (ok-initial-convert-p fun)) + (cond (outside-calls + (setf (functional-kind fun) :assignment) + ;; The only time OUTSIDE-CALLS contains a mix of both + ;; tail and non-tail calls is when calls to FUN are + ;; derived to not return, in which case it doesn't + ;; matter whether a given call is tail, so there is no + ;; harm in the arbitrary choice here. + (let ((first-outside-call (first outside-calls))) + (let ((original-tail-p (node-tail-p first-outside-call))) + (let-convert fun first-outside-call) + (unless original-tail-p + (reoptimize-call first-outside-call))) + (dolist (outside-call outside-calls) + ;; Splice in the other calls, without the rest of + ;; the let converting return semantics machinery, + ;; since we've already let converted the function. + (unless (eq outside-call first-outside-call) + (insert-let-body fun outside-call)) + (delete-lvar-use outside-call) + ;; Make sure these calls are local converted as + ;; soon as possible, to avoid having a window of + ;; time where there are :ASSIGNMENT lambdas + ;; floating around which are still called by :FULL + ;; combinations, as this confuses stuff like + ;; MAYBE-TERMINATE-BLOCK. + (convert-call-if-possible (lvar-use (combination-fun outside-call)) + outside-call) + (unless (or (eq outside-call first-outside-call) + (node-tail-p outside-call)) + (reoptimize-call first-outside-call)) + (setf (node-tail-p outside-call) nil))) + t) + (t + (delete-lambda fun) + nil)))))) diff -Nru sbcl-2.1.10/src/compiler/ltn.lisp sbcl-2.1.11/src/compiler/ltn.lisp --- sbcl-2.1.10/src/compiler/ltn.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ltn.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -475,7 +475,9 @@ (setf (node-tail-p node) nil) (let ((value (exit-value node))) (when value - (annotate-unknown-values-lvar value))) + (if (lvar-single-value-p (node-lvar node)) + (annotate-fixed-values-lvar value (list *backend-t-primitive-type*)) + (annotate-unknown-values-lvar value)))) (values)) (defun ltn-analyze-enclose (node) @@ -913,7 +915,7 @@ ;; transforms or VOPs or whatever. (unless template (ltn-default-call call) - (when (let ((funleaf (physenv-lambda (node-physenv call))) + (when (let ((funleaf (environment-lambda (node-environment call))) (name (lvar-fun-name (combination-fun call)))) (and (leaf-has-source-name-p funleaf) (eq name (leaf-source-name funleaf)) diff -Nru sbcl-2.1.10/src/compiler/ltv.lisp sbcl-2.1.11/src/compiler/ltv.lisp --- sbcl-2.1.10/src/compiler/ltv.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ltv.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -86,7 +86,10 @@ ;; (LET ((X 3)) (MACROLET ((M () (HAIR))) (LOAD-TIME-VALUE (THING))) ;; can make use of M. We choose to say that it can't. (let ((value (let ((thunk ; Pass T for the EPHEMERAL flag. - (compile-in-lexenv `(lambda () ,form) (make-null-lexenv) + (compile-in-lexenv `(lambda () + (declare (local-optimize (verify-arg-count 0))) + ,form) + (make-null-lexenv) nil nil nil t nil))) (handler-case (funcall thunk) (error (condition) diff -Nru sbcl-2.1.10/src/compiler/macros.lisp sbcl-2.1.11/src/compiler/macros.lisp --- sbcl-2.1.10/src/compiler/macros.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -384,8 +384,7 @@ ,@body) ,@(loop for vop-name in (ensure-list (second what)) collect - `(setf (vop-info-optimizer (template-or-lose ',vop-name)) - #',name))) + `(set-vop-optimizer (template-or-lose ',vop-name) #',name))) (binding* (((forms decls) (parse-body body nil)) ((var-decls more-decls) (extract-var-decls decls vars)) ;; In case the BODY declares IGNORE of the formal NODE var, diff -Nru sbcl-2.1.10/src/compiler/main.lisp sbcl-2.1.11/src/compiler/main.lisp --- sbcl-2.1.10/src/compiler/main.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/main.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -24,14 +24,9 @@ ;;; Set to NIL to disable loop analysis for register allocation. (defvar *loop-analyze* t) -;;; The current non-macroexpanded toplevel form as printed when -;;; *compile-print* is true. -;;; FIXME: should probably have no value outside the compiler. -(defvar *top-level-form-noted* nil) - (defvar *compile-verbose* t "The default for the :VERBOSE argument to COMPILE-FILE.") -(defvar *compile-print* t +(defvar *compile-print* nil "The default for the :PRINT argument to COMPILE-FILE.") (defvar *compile-progress* nil "When this is true, the compiler prints to *STANDARD-OUTPUT* progress @@ -65,9 +60,7 @@ ;;; Mumble conditional on *COMPILE-PROGRESS*. (defun maybe-mumble (&rest foo) (when *compile-progress* - (compiler-mumble "~&") - (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") - (apply #'compiler-mumble foo)))) + (apply #'compiler-mumble foo))) (deftype object () '(or fasl-output core-object null)) @@ -414,37 +407,37 @@ (cleared-reanalyze nil) (fastp nil)) (loop - (when (component-reanalyze component) - (setf count 0 - fastp nil - cleared-reanalyze t - (component-reanalyze component) nil)) - (setf (component-reoptimize component) nil) - (ir1-optimize component fastp) - (cond ((component-reoptimize component) - (incf count) - (when (and (>= count *max-optimize-iterations*) - (not (component-reanalyze component)) - (eq (component-reoptimize component) :maybe)) - (maybe-mumble "*") - (cond ((retry-delayed-ir1-transforms :optimize) - (maybe-mumble "+") - (setq count 0)) - (t - (event ir1-optimize-maxed-out) - (ir1-optimize-last-effort component) - (return))))) - ((retry-delayed-ir1-transforms :optimize) - (setf count 0) - (maybe-mumble "+")) - (t - (maybe-mumble " ") - (return))) - (when (setq fastp (>= count *max-optimize-iterations*)) - (ir1-optimize-last-effort component)) - (maybe-mumble (if fastp "-" "."))) + (when (component-reanalyze component) + (setf count 0 + fastp nil + cleared-reanalyze t + (component-reanalyze component) nil)) + (setf (component-reoptimize component) nil) + (ir1-optimize component fastp) + (cond ((component-reoptimize component) + (incf count) + (when (and (>= count *max-optimize-iterations*) + (not (component-reanalyze component)) + (eq (component-reoptimize component) :maybe)) + (maybe-mumble "*") + (cond ((retry-delayed-ir1-transforms :optimize) + (maybe-mumble "+") + (setq count 0)) + (t + (event ir1-optimize-maxed-out) + (ir1-optimize-last-effort component) + (return))))) + ((retry-delayed-ir1-transforms :optimize) + (setf count 0) + (maybe-mumble "+")) + (t + (return))) + (when (setq fastp (>= count *max-optimize-iterations*)) + (ir1-optimize-last-effort component)) + (maybe-mumble (if fastp "-" "."))) (when cleared-reanalyze - (setf (component-reanalyze component) t))) + (setf (component-reanalyze component) t)) + (maybe-mumble " ")) (values)) (defparameter *constraint-propagate* t) @@ -580,6 +573,8 @@ (maybe-mumble "Control ") (control-analyze component) + (report-code-deletion) + (when (or (ir2-component-values-receivers (component-info component)) (component-dx-lvars component)) (maybe-mumble "Stack ") @@ -604,12 +599,15 @@ (maybe-mumble "Copy ") (copy-propagate component)) - (when *compiler-trace-output* - (format *compiler-trace-output* - "~|~%;;;; component: ~S~2%" (component-name component))) (ir2-optimize component) (select-representations component) + ;; Try to combine consecutive uses of %INSTANCE-SET. + ;; This can't be done prior to selecting representations + ;; because SELECT-REPRESENTATIONS might insert some + ;; things like MOVE-FROM-DOUBLE which makes the + ;; "consecutive" vops no longer consecutive. + (ir2-optimize-stores component) (when *check-consistency* (maybe-mumble "Check2 ") @@ -640,10 +638,9 @@ (optimize-constant-loads component) (when *compiler-trace-output* (when (memq :ir1 *compile-trace-targets*) - (let ((*standard-output* *compiler-trace-output*)) - (print-all-blocks component))) + (describe-component component *compiler-trace-output*)) (when (memq :ir2 *compile-trace-targets*) - (describe-ir2-component component *compiler-trace-output*))) + (describe-ir2-component component *compiler-trace-output*))) (maybe-mumble "Code ") (multiple-value-bind (segment text-length fun-table @@ -724,9 +721,11 @@ (aver (eql (node-component (lambda-bind lambda)) component))) (let* ((*component-being-compiled* component)) - (when (and *compile-print* (block-compile *compilation*)) - (with-compiler-io-syntax - (compiler-mumble "~&; compiling ~A" (component-name component)))) + + (when *compile-progress* + (compiler-mumble "~&") + (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") + (compiler-mumble "Compiling ~A: " (component-name component)))) ;; Record xref information before optimization. This way the ;; stored xref data reflects the real source as closely as @@ -735,9 +734,9 @@ (ir1-phases component) - ;; This should happen at some point before PHYSENV-ANALYZE, and - ;; after RECORD-COMPONENT-XREFS. Beyond that, I haven't really - ;; thought things through. -- AJB, 2014-Jun-08 + ;; This should happen at some point before ENVIRONMENT-ANALYZE, + ;; and after RECORD-COMPONENT-XREFS. Beyond that, I haven't + ;; really thought things through. -- AJB, 2014-Jun-08 (eliminate-dead-code component) (when *loop-analyze* @@ -762,14 +761,15 @@ |# (maybe-mumble "Env ") - (physenv-analyze component) + (environment-analyze component) (dfo-as-needed component) (delete-if-no-entries component) - (unless (eq (block-next (component-head component)) - (component-tail component)) - (%compile-component component)) + (if (eq (block-next (component-head component)) + (component-tail component)) + (report-code-deletion) + (%compile-component component)) (when *compile-component-hook* (funcall *compile-component-hook* component))) @@ -826,6 +826,13 @@ ;;;; trace output +;;; Print out some useful info about COMPONENT to STREAM. +(defun describe-component (component *standard-output*) + (declare (type component component)) + (format t "~|~%;;;; component: ~S~2%" (component-name component)) + (print-all-blocks component) + (values)) + (defun describe-ir2-component (component *standard-output*) (format t "~%~|~%;;;; IR2 component: ~S~2%" (component-name component)) (format t "entries:~%") @@ -1036,34 +1043,33 @@ #+sb-xc-host (when sb-cold::*compile-for-effect-only* (return-from convert-and-maybe-compile)) - (let ((*top-level-form-noted* (note-top-level-form form t))) - ;; Don't bother to compile simple objects that just sit there. - (when (and form (or (symbolp form) (consp form))) - (if (and #-sb-xc-host - (policy *policy* - ;; FOP-compiled code is harder to debug. - (or (< debug 2) - (> space debug))) - (not (eq (block-compile *compilation*) t)) - (fopcompilable-p form expand)) - (let ((*fopcompile-label-counter* 0)) - (fopcompile form path nil expand)) - (let ((*lexenv* (make-lexenv - :policy *policy* - :handled-conditions *handled-conditions* - :disabled-package-locks *disabled-package-locks*)) - (tll (ir1-toplevel form path nil))) - (if (eq (block-compile *compilation*) t) - (push tll (toplevel-lambdas *compilation*)) - (compile-toplevel (list tll) nil)) - (when (consp form) - (case (car form) - ;; Block compilation can cause packages to be defined after - ;; they are referenced at load time, so we have to delimit the - ;; current block compilation. - ((sb-impl::%defpackage) - (delimit-block-compilation)))) - nil))))) + ;; Don't bother to compile simple objects that just sit there. + (when (and form (or (symbolp form) (consp form))) + (if (and #-sb-xc-host + (policy *policy* + ;; FOP-compiled code is harder to debug. + (or (< debug 2) + (> space debug))) + (not (eq (block-compile *compilation*) t)) + (fopcompilable-p form expand)) + (let ((*fopcompile-label-counter* 0)) + (fopcompile form path nil expand)) + (let ((*lexenv* (make-lexenv + :policy *policy* + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) + (tll (ir1-toplevel form path nil))) + (if (eq (block-compile *compilation*) t) + (push tll (toplevel-lambdas *compilation*)) + (compile-toplevel (list tll) nil)) + (when (consp form) + (case (car form) + ;; Block compilation can cause packages to be defined after + ;; they are referenced at load time, so we have to delimit the + ;; current block compilation. + ((sb-impl::%defpackage) + (delimit-block-compilation)))) + nil)))) ;;; Macroexpand FORM in the current environment with an error handler. ;;; We only expand one level, so that we retain all the intervening @@ -1283,26 +1289,14 @@ (mapc #'clear-ir1-info components-from-dfo) result)))))) -(defun note-top-level-form (form &optional finalp) +;;; Print some noise about FORM if *COMPILE-PRINT* is true. +(defun note-top-level-form (form) (when *compile-print* - (cond ((not *top-level-form-noted*) - (let ((*print-length* 2) - (*print-level* 2) - (*print-pretty* nil)) - (with-compiler-io-syntax - (compiler-mumble "~&; processing ~S" form))) - form) - ((and finalp - (eq :top-level-forms *compile-print*) - (neq form *top-level-form-noted*)) - (let ((*print-length* 1) - (*print-level* 1) - (*print-pretty* nil)) - (with-compiler-io-syntax - (compiler-mumble "~&; ... top level ~S" form))) - form) - (t - *top-level-form-noted*)))) + (let ((*print-length* 2) + (*print-level* 2) + (*print-pretty* nil)) + (with-compiler-io-syntax + (compiler-mumble "~&; processing ~S" form))))) ;;; Handle the evaluation the a :COMPILE-TOPLEVEL body during ;;; compilation. Normally just evaluate in the appropriate @@ -1405,8 +1399,7 @@ ((progn) (process-toplevel-progn (rest form) path compile-time-too)) (t - (let ((*top-level-form-noted* (note-top-level-form form)) - (expanded (preprocessor-macroexpand-1 form))) + (let ((expanded (preprocessor-macroexpand-1 form))) (cond ((neq expanded form) ; macro -> take it from the top (process-toplevel-form expanded path compile-time-too)) (t @@ -1731,7 +1724,7 @@ (compiler-error-context-handled-conditions ctxt)) ;; Is this right? I would think that if lexenv is null ;; we should look at *HANDLED-CONDITIONS*. - (null (lexenv-handled-conditions *lexenv*)))) + ((or ctran null) (lexenv-handled-conditions *lexenv*)))) *handled-conditions*)) (handle-p (condition type) #+sb-xc-host (cl:typep condition type) ; TYPE is a sexpr @@ -1817,6 +1810,8 @@ (with-source-paths (find-source-paths form current-index) (let ((*gensym-counter* 0)) + (when *compile-print* + (note-top-level-form form)) (process-toplevel-form form `(original-source-start 0 ,current-index) nil)))) (let ((*source-info* info)) diff -Nru sbcl-2.1.10/src/compiler/meta-vmdef.lisp sbcl-2.1.11/src/compiler/meta-vmdef.lisp --- sbcl-2.1.10/src/compiler/meta-vmdef.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/meta-vmdef.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1241,7 +1241,9 @@ (when (sc-allowed-by-primitive-type (sc-or-lose sc) (primitive-type-or-lose ptype)) - (return t)))) + (return t))) + #+arm64 + (eq sc 'sb-vm::zero)) (warn "~:[Result~;Argument~] ~A to VOP ~S~@ has SC restriction ~S which is ~ not allowed by the operand type:~% ~S" @@ -1999,17 +2001,18 @@ (when (and ,tn-var (not (eq ,tn-var :more))) (,bod ,tn-var))))))))))) -;;; Iterate over all the IR2 blocks in PHYSENV, in emit order. -(defmacro do-physenv-ir2-blocks ((block-var physenv &optional result) - &body body) - (once-only ((n-physenv physenv)) - (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv)))) +;;; Iterate over all the IR2 blocks in the environment ENV, in emit +;;; order. +(defmacro do-environment-ir2-blocks ((block-var env &optional result) + &body body) + (once-only ((n-env env)) + (once-only ((n-first `(lambda-block (environment-lambda ,n-env)))) (once-only ((n-tail `(block-info (component-tail (block-component ,n-first))))) `(do ((,block-var (block-info ,n-first) (ir2-block-next ,block-var))) ((or (eq ,block-var ,n-tail) - (not (eq (ir2-block-physenv ,block-var) ,n-physenv))) + (not (eq (ir2-block-environment ,block-var) ,n-env))) ,result) ,@body))))) diff -Nru sbcl-2.1.10/src/compiler/mips/array.lisp sbcl-2.1.11/src/compiler/mips/array.lisp --- sbcl-2.1.10/src/compiler/mips/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/mips/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -29,7 +29,7 @@ ;; 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 sll header header array-rank-position) (inst or header type) ;; Remove the extraneous fixnum tag bits because TYPE and RANK ;; were fixnums diff -Nru sbcl-2.1.10/src/compiler/mips/call.lisp sbcl-2.1.11/src/compiler/mips/call.lisp --- sbcl-2.1.10/src/compiler/mips/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/mips/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -39,7 +39,7 @@ ;;; 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) + (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) (make-wired-tn *fixnum-primitive-type* control-stack-arg-scn ocfp-save-offset))) @@ -47,7 +47,7 @@ (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) + (environment-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 @@ -148,7 +148,7 @@ (move res csp-tn) (inst addu csp-tn csp-tn (* n-word-bytes (sb-allocated-size 'control-stack))) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (inst addu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame))) (move nfp nsp-tn)))) @@ -1126,6 +1126,23 @@ (:generator 4 (loadw value context index))) +(define-vop (more-arg-or-nil) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1)) + (count :scs (any-reg) :to (:result 1))) + (:temporary (:scs (any-reg)) temp) + (:info index) + (:results (value :scs (descriptor-reg any-reg))) + (:result-types *) + (:generator 3 + (cond ((zerop index) + (inst beq count done)) + (t + (inst subu temp (fixnumize index) count) + (inst bgez temp done))) + (move value null-tn) + (loadw value object index) + done)) ;;; Turn more arg (context, count) into a list. (define-vop () diff -Nru sbcl-2.1.10/src/compiler/mips/c-call.lisp sbcl-2.1.11/src/compiler/mips/c-call.lisp --- sbcl-2.1.10/src/compiler/mips/c-call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/mips/c-call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -231,10 +231,9 @@ (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) - (:temporary (:scs (non-descriptor-reg)) addr) (:generator 2 - (inst li addr (make-fixup foreign-symbol :foreign-dataref)) - (loadw res addr))) + (inst li res (make-fixup foreign-symbol :foreign-dataref)) + (loadw res res))) (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) diff -Nru sbcl-2.1.10/src/compiler/mips/cell.lisp sbcl-2.1.11/src/compiler/mips/cell.lisp --- sbcl-2.1.10/src/compiler/mips/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/mips/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -63,19 +63,18 @@ (inst nop)))) ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) +(define-vop (boundp) (:args (object :scs (descriptor-reg))) (:conditional) (:info target not-p) (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value) - (:temporary (:scs (non-descriptor-reg)) temp)) - -(define-vop (boundp boundp-frob) + (:temporary (:scs (non-descriptor-reg)) temp) (:translate boundp) (:generator 9 - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst xor temp value unbound-marker-widetag) + (inst lb temp object (+ (- (ash symbol-value-slot word-shift) other-pointer-lowtag) + #+big-endian 3)) + (inst nop) + (inst xor temp temp unbound-marker-widetag) (if not-p (inst beq temp target) (inst bne temp target)) @@ -236,9 +235,9 @@ closure-info-offset fun-pointer-lowtag (descriptor-reg any-reg) * %closure-index-ref) -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (descriptor-reg any-reg null zero) * %set-funcallable-instance-info) +(define-full-setter %closure-index-set * + closure-info-offset fun-pointer-lowtag + (descriptor-reg any-reg null zero) * %closure-index-set) (define-full-reffer funcallable-instance-info * funcallable-instance-info-offset fun-pointer-lowtag diff -Nru sbcl-2.1.10/src/compiler/mips/nlx.lisp sbcl-2.1.11/src/compiler/mips/nlx.lisp --- sbcl-2.1.10/src/compiler/mips/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/mips/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -196,6 +196,18 @@ (inst nop)))))) (load-stack-tn csp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (move res value) + (load-stack-tn csp-tn sp))) (define-vop (nlx-entry-multiple) (:args (top :target dst) (start :target src) (count :target num)) diff -Nru sbcl-2.1.10/src/compiler/mips/parms.lisp sbcl-2.1.11/src/compiler/mips/parms.lisp --- sbcl-2.1.10/src/compiler/mips/parms.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/mips/parms.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -80,10 +80,6 @@ ;;;; Other non-type constants. -(defenum () - atomic-flag - interrupted-flag) - (defenum (:start 8) halt-trap pending-interrupt-trap diff -Nru sbcl-2.1.10/src/compiler/node.lisp sbcl-2.1.11/src/compiler/node.lisp --- sbcl-2.1.10/src/compiler/node.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/node.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -164,8 +164,9 @@ ;; the basic block this continuation is in. This is null only in ;; :UNUSED continuations. (block nil :type (or cblock null)) - ;; Entries created by the BLOCK special operator - (entries nil :type list)) + ;; Use for reporting notes for the following node, + ;; which can be transformed and lose its original source code. + (source-path nil :type list)) (defmethod print-object ((x ctran) stream) (print-unreadable-object (x stream :type t :identity t) @@ -323,9 +324,9 @@ ;; top level form containing the original source. (source-path *current-path* :type list) ;; If this node is in a tail-recursive position, then this is set to - ;; T. At the end of IR1 (in physical environment analysis) this is - ;; computed for all nodes (after cleanup code has been emitted). - ;; Before then, a non-null value indicates that IR1 optimization has + ;; T. At the end of IR1 (in environment analysis) this is computed + ;; for all nodes (after cleanup code has been emitted). Before + ;; then, a non-null value indicates that IR1 optimization has ;; converted a tail local call to a direct transfer. ;; ;; If the back-end breaks tail-recursion for some reason, then it @@ -496,9 +497,9 @@ ;; what macroexpansions and source transforms happened "in" this block, used ;; for xref (xrefs nil :type list) - ;; Cache the physenv of a block during lifetime analysis. :NONE if - ;; no cached value has been stored yet. - (physenv-cache :none :type (or null physenv (member :none)))) + ;; Cache the environment of a block during lifetime analysis. :NONE + ;; if no cached value has been stored yet. + (environment-cache :none :type (or null environment (member :none)))) (defmethod print-object ((cblock cblock) stream) (if (boundp '*compilation*) (print-unreadable-object (cblock stream :type t :identity t) @@ -577,9 +578,9 @@ ;; Entry/exit points have these blocks as their ;; predecessors/successors. The start and return from each ;; non-deleted function is linked to the component head and - ;; tail. Until physical environment analysis links NLX entry stubs - ;; to the component head, every successor of the head is a function - ;; start (i.e. begins with a BIND node.) + ;; tail. Until environment analysis links NLX entry stubs to the + ;; component head, every successor of the head is a function start + ;; (i.e. begins with a BIND node.) (head (missing-arg) :type cblock) (tail (missing-arg) :type cblock) ;; New blocks are inserted before this. @@ -631,7 +632,7 @@ (reanalyze-functionals nil :type list) (delete-blocks nil :type list) (nlx-info-generated-p nil :type boolean) - ;; this is filled by physical environment analysis + ;; this is filled by environment analysis (dx-lvars nil :type list) ;; The default LOOP in the component. (outer-loop (missing-arg) :type cloop) @@ -683,59 +684,38 @@ (mess-up nil :type (or node null)) ;; For all kinds, except :DYNAMIC-EXTENT: a list of all the NLX-INFO ;; structures whose NLX-INFO-CLEANUP is this cleanup. This is filled - ;; in by physical environment analysis. + ;; in by environment analysis. ;; ;; For :DYNAMIC-EXTENT: a list of all DX LVARs, preserved by this ;; cleanup. This is filled when the cleanup is created (now by - ;; locall call analysis) and is rechecked by physical environment + ;; locall call analysis) and is rechecked by environment ;; analysis. (For closures this is a list of the enclose node during - ;; IR1, and a list of the LVAR of the enclose after physical - ;; environment analysis.) + ;; IR1, and a list of the LVAR of the enclose after environment + ;; analysis.) (info nil :type list)) (defprinter (cleanup :identity t) kind mess-up (info :test info)) -;;; A PHYSENV represents the result of physical environment analysis. -;;; -;;; As far as I can tell from reverse engineering, this IR1 structure -;;; represents the physical environment (which is probably not the -;;; standard Lispy term for this concept, but I dunno what is the -;;; standard term): those things in the lexical environment which a -;;; LAMBDA actually interacts with. Thus in -;;; (DEFUN FROB-THINGS (THINGS) -;;; (DOLIST (THING THINGS) -;;; (BLOCK FROBBING-ONE-THING -;;; (MAPCAR (LAMBDA (PATTERN) -;;; (WHEN (FITS-P THING PATTERN) -;;; (RETURN-FROM FROB-THINGS (LIST :FIT THING PATTERN)))) -;;; *PATTERNS*)))) -;;; the variables THINGS, THING, and PATTERN and the block names -;;; FROB-THINGS and FROBBING-ONE-THING are all in the inner LAMBDA's -;;; lexical environment, but of those only THING, PATTERN, and -;;; FROB-THINGS are in its physical environment. In IR1, we largely -;;; just collect the names of these things; in IR2 an IR2-PHYSENV -;;; structure is attached to INFO and used to keep track of -;;; associations between these names and less-abstract things (like -;;; TNs, or eventually stack slots and registers). -- WHN 2001-09-29 -(defstruct (physenv (:copier nil)) - ;; the function that allocates this physical environment +;;; The ENVIRONMENT structure represents the result of environment analysis. +(defstruct (environment (:copier nil)) + ;; the function that allocates this environment (lambda (missing-arg) :type clambda :read-only t) ;; This ultimately converges to a list of all the LAMBDA-VARs and ;; NLX-INFOs needed from enclosing environments by code in this - ;; physical environment. In the meantime, it may be + ;; environment. In the meantime, it may be ;; * NIL at object creation time ;; * a superset of the correct result, generated somewhat later ;; * smaller and smaller sets converging to the correct result as ;; we notice and delete unused elements in the superset (closure nil :type list) ;; a list of NLX-INFO structures describing all the non-local exits - ;; into this physical environment + ;; into this environment (nlx-info nil :type list) ;; some kind of info used by the back end (info nil)) -(defprinter (physenv :identity t) +(defprinter (environment :identity t) lambda (closure :test closure) (nlx-info :test nlx-info)) @@ -770,11 +750,10 @@ ;;; An NLX-INFO structure is used to collect various information about ;;; non-local exits. This is effectively an annotation on the ;;; continuation, although it is accessed by searching in the -;;; PHYSENV-NLX-INFO. +;;; ENVIRONMENT-NLX-INFO. (defstruct (nlx-info (:copier nil) - (:constructor make-nlx-info - (cleanup exit &aux (block (first (block-succ (node-block exit))))))) + (:constructor make-nlx-info (cleanup block))) ;; the cleanup associated with this exit. In a catch or ;; unwind-protect, this is the :CATCH or :UNWIND-PROTECT cleanup, ;; and not the cleanup for the escape block. The CLEANUP-KIND of @@ -783,7 +762,7 @@ (cleanup (missing-arg) :type cleanup) ;; the ``continuation'' exited to (the block, succeeding the EXIT ;; nodes). If this exit is from an escape function (CATCH or - ;; UNWIND-PROTECT), then physical environment analysis deletes the + ;; UNWIND-PROTECT), then environment analysis deletes the ;; escape function and instead has the %NLX-ENTRY use this ;; continuation. ;; @@ -792,9 +771,9 @@ ;; ENTRY must also be used to disambiguate, since exits to different ;; places may deliver their result to the same continuation. (block (missing-arg) :type cblock) - ;; the entry stub inserted by physical environment analysis. This is - ;; a block containing a call to the %NLX-ENTRY funny function that - ;; has the original exit destination as its successor. Null only + ;; the entry stub inserted by environment analysis. This is a block + ;; containing a call to the %NLX-ENTRY funny function that has the + ;; original exit destination as its successor. Null only ;; temporarily. (target nil :type (or cblock null)) ;; for a lexical exit it determines whether tag existence check is @@ -1028,8 +1007,8 @@ ;; ;; :ASSIGNMENT ;; similar to a LET (as per FUNCTIONAL-SOMEWHAT-LETLIKE-P), but - ;; can have other than one call as long as there is at most - ;; one non-tail call. + ;; can have more than one call as long as the calls all return to + ;; the same place. ;; ;; :OPTIONAL ;; a lambda that is an entry point for an OPTIONAL-DISPATCH. @@ -1103,7 +1082,7 @@ ;; INLINEP will always be NIL as well.) (inline-expansion nil :type list) ;; the lexical environment that the INLINE-EXPANSION should be converted in - (lexenv *lexenv* :type lexenv :read-only t) + (lexenv *lexenv* :type lexenv) ;; the original function or macro lambda list, or :UNSPECIFIED if ;; this is a compiler created function (arg-documentation nil :type (or list (member :unspecified))) @@ -1236,9 +1215,9 @@ (tail-set nil :type (or tail-set null)) ;; the structure which represents the phsical environment that this ;; function's variables are allocated in. This is filled in by - ;; physical environment analysis. In a LET, this is EQ to our home's - ;; physical environment. - (physenv nil :type (or physenv null)) + ;; environment analysis. In a LET, this is EQ to our home's + ;; environment. + (environment nil :type (or environment null)) ;; In a LET, this is the NODE-LEXENV of the combination node. We ;; retain it so that if the LET is deleted (due to a lack of vars), ;; we will still have caller's lexenv to figure out which cleanup is @@ -1387,26 +1366,26 @@ ;;; lambda arguments which may ultimately turn out not to be simple ;;; and lexical. ;;; -;;; LAMBDA-VARs with no REFs are considered to be deleted; physical -;;; environment analysis isn't done on these variables, so the back -;;; end must check for and ignore unreferenced variables. Note that a -;;; deleted LAMBDA-VAR may have sets; in this case the back end is -;;; still responsible for propagating the SET-VALUE to the set's CONT. +;;; LAMBDA-VARs with no REFs are considered to be deleted; environment +;;; analysis isn't done on these variables, so the back end must check +;;; for and ignore unreferenced variables. Note that a deleted +;;; LAMBDA-VAR may have sets; in this case the back end is still +;;; responsible for propagating the SET-VALUE to the set's CONT. (!def-boolean-attribute lambda-var ;; true if this variable has been declared IGNORE ignore - ;; This is set by physical environment analysis if it chooses an - ;; indirect (value cell) representation for this variable because it - ;; is both set and closed over. + ;; This is set by environment analysis if it chooses an indirect + ;; (value cell) representation for this variable because it is both + ;; set and closed over. indirect ;; true if the last reference has been deleted (and new references ;; should not be made) deleted - ;; This is set by physical environment analysis if, should it be an - ;; indirect lambda-var, an actual value cell object must be - ;; allocated for this variable because one or more of the closures - ;; that refer to it are not dynamic-extent. Note that both - ;; attributes must be set for the value-cell object to be created. + ;; This is set by environment analysis if, should it be an indirect + ;; lambda-var, an actual value cell object must be allocated for + ;; this variable because one or more of the closures that refer to + ;; it are not dynamic-extent. Note that both attributes must be set + ;; for the value-cell object to be created. explicit-value-cell ;; Do not propagate constraints for this var no-constraints @@ -1658,12 +1637,16 @@ asserted-type type-to-check) -;;; A filter to help order the value semantics of MULTIPLE-VALUE-PROG1 -(defstruct (vestigial-exit-cast (:include cast - (%type-check nil) - (asserted-type *wild-type*) - (type-to-check *wild-type*)) - (:copier nil))) +;;; The DELAY node is interposed between a VALUE's USE and its DEST in +;;; order to allow the value to be immediately used. This is necessary +;;; for implementing multiple-use unknown values LVARs, as otherwise, +;;; a non-moveable dynamic extent object may be allocated between the +;;; DEST and one of the LVAR's uses but not the others. +(defstruct (delay (:include cast + (%type-check nil) + (asserted-type *wild-type*) + (type-to-check *wild-type*)) + (:copier nil))) ;;; A cast that always follows %check-bound and they are deleted together. ;;; Created via BOUND-CAST ir1-translator by chaining it together with %check-bound. @@ -1705,8 +1688,8 @@ ;;; continuation and the exit continuation's DEST. Instead of using ;;; the returned value being delivered directly to the exit ;;; continuation, it is delivered to our VALUE lvar. The original exit -;;; lvar is the exit node's LVAR; physenv analysis also makes it the -;;; lvar of %NLX-ENTRY call. +;;; lvar is the exit node's LVAR; environment analysis also makes it +;;; the lvar of %NLX-ENTRY call. (defstruct (exit (:include valued-node) (:copier nil)) ;; the ENTRY node that this is an exit for. If null, this is a @@ -1722,9 +1705,6 @@ (entry :test entry) (value :test value)) -(defstruct (no-op (:include node) - (:copier nil))) - ;;; The ENCLOSE node marks the place at which closure allocation code ;;; would be emitted, if necessary. (defstruct (enclose (:include valued-node) ; this node uses a dummy lvar for dx analysis @@ -1793,4 +1773,4 @@ ;;;; Freeze some structure types to speed type testing. (declaim (freeze-type node lexenv ctran lvar cblock component cleanup - physenv tail-set nlx-info leaf)) + environment tail-set nlx-info leaf)) diff -Nru sbcl-2.1.10/src/compiler/pack.lisp sbcl-2.1.11/src/compiler/pack.lisp --- sbcl-2.1.10/src/compiler/pack.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/pack.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -418,7 +418,6 @@ ;;;; register saving -#-sb-devel (declaim (start-block optimized-emit-saves emit-saves assign-tn-costs pack-save-tn)) @@ -841,7 +840,6 @@ ;;;; load TN packing -#-sb-devel (declaim (start-block pack-load-tns load-tn-conflicts-in-sc)) ;;; These variables indicate the last location at which we computed @@ -1211,7 +1209,8 @@ (let ((target (tn-ref-target op)) (tn (tn-ref-tn op))) (when (and target - (not (eq (tn-kind tn) :unused))) + (not (eq (tn-kind tn) :unused)) + (tn-primitive-type tn)) (let* ((load-tn (tn-ref-load-tn op)) (load-scs (svref (car scs) (sc-number @@ -1228,7 +1227,8 @@ (let ((target (tn-ref-target op)) (tn (tn-ref-tn op))) (unless (or target - (eq (tn-kind tn) :unused)) + (eq (tn-kind tn) :unused) + (not (tn-primitive-type tn))) (let* ((load-tn (tn-ref-load-tn op)) (load-scs (svref (car scs) (sc-number @@ -1259,7 +1259,6 @@ ;;;; targeting -#-sb-devel (declaim (start-block pack pack-tn target-if-desirable ;; needed for pack-iterative pack-wired-tn)) @@ -1479,43 +1478,29 @@ ;; For non-x86 ports the presence of a save-tn associated with a ;; tn is used to identify the old-fp and return-pc tns. It depends ;; on the old-fp and return-pc being passed in registers. - #-fp-and-pc-standard-save - (when (and (not (eq (tn-kind tn) :specified-save)) + (when (and #-fp-and-pc-standard-save + (not (eq (tn-kind tn) :specified-save)) (conflicts-in-sc original sc offset)) - (error "~S is wired to a location that it conflicts with." tn)) + (error "~S is wired to location ~D in SC ~A of kind ~S that it conflicts with." + tn offset sc (tn-kind tn))) ;; Use the above check, but only print a verbose warning. This can ;; be helpful for debugging the x86 port. #+nil (when (and (not (eq (tn-kind tn) :specified-save)) (conflicts-in-sc original sc offset)) - (format t "~&* Pack-wired-tn possible conflict:~% ~ + (format t "~&* Pack-wired-tn possible conflict:~% ~ tn: ~S; tn-kind: ~S~% ~ sc: ~S~% ~ sb: ~S; sb-name: ~S; sb-kind: ~S~% ~ offset: ~S; end: ~S~% ~ original ~S~% ~ tn-save-tn: ~S; tn-kind of tn-save-tn: ~S~%" - tn (tn-kind tn) sc - sb (sb-name sb) (sb-kind sb) - offset end - original - (tn-save-tn tn) (tn-kind (tn-save-tn tn)))) - - ;; On the x86 ports the old-fp and return-pc are often passed on - ;; the stack so the above hack for the other ports does not always - ;; work. Here the old-fp and return-pc tns are identified by being - ;; on the stack in their standard save locations. - #+fp-and-pc-standard-save - (when (and (not (and - (= (sc-number sc) #.(sc+offset-scn old-fp-passing-offset)) - (= offset #.(sc+offset-offset old-fp-passing-offset)))) - (not (and - (= (sc-number sc) #.(sc+offset-scn return-pc-passing-offset)) - (= offset #.(sc+offset-offset return-pc-passing-offset)))) - (conflicts-in-sc original sc offset)) - (error "~S is wired to location ~D in SC ~A of kind ~S that it conflicts with." - tn offset sc (tn-kind tn))) + tn (tn-kind tn) sc + sb (sb-name sb) (sb-kind sb) + offset end + original + (tn-save-tn tn) (tn-kind (tn-save-tn tn)))) (unless (eq (sb-kind sb) :unbounded) (setf (ldb (byte 1 (truly-the sb-vm:finite-sc-offset offset)) diff -Nru sbcl-2.1.10/src/compiler/physenvanal.lisp sbcl-2.1.11/src/compiler/physenvanal.lisp --- sbcl-2.1.10/src/compiler/physenvanal.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/physenvanal.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,601 +0,0 @@ -;;;; This file implements the environment analysis phase for the -;;;; compiler. This phase annotates IR1 with a hierarchy environment -;;;; structures, determining the physical environment that each LAMBDA -;;;; allocates its variables and finding what values are closed over -;;;; by each physical environment. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-C") - -;;; Do environment analysis on the code in COMPONENT. This involves -;;; various things: -;;; 1. Make a PHYSENV structure for each non-LET LAMBDA, assigning -;;; the LAMBDA-PHYSENV for all LAMBDAs. -;;; 2. Find all values that need to be closed over by each -;;; physical environment. -;;; 3. Scan the blocks in the component closing over non-local-exit -;;; continuations. -;;; 4. Delete all non-top-level functions with no references. This -;;; should only get functions with non-NULL kinds, since normal -;;; functions are deleted when their references go to zero. -(defun physenv-analyze (component) - (declare (type component component)) - (aver (every (lambda (x) - (eq (functional-kind x) :deleted)) - (component-new-functionals component))) - (setf (component-new-functionals component) ()) - (mapc #'add-lambda-vars-and-let-vars-to-closures - (component-lambdas component)) - - (find-non-local-exits component) - (recheck-dynamic-extent-lvars component) - (find-cleanup-points component) - (tail-annotate component) - (analyze-indirect-lambda-vars component) - - (dolist (fun (component-lambdas component)) - (when (null (leaf-refs fun)) - (let ((kind (functional-kind fun))) - (unless (or (eq kind :toplevel) - (functional-has-external-references-p fun)) - (aver (member kind '(:optional :cleanup :escape))) - (setf (functional-kind fun) nil) - (delete-functional fun))))) - - (setf (component-nlx-info-generated-p component) t) - (values)) - -;;; If CLAMBDA has a PHYSENV, return it, otherwise assign an empty one -;;; and return that. -(defun get-lambda-physenv (clambda) - (declare (type clambda clambda)) - (let ((homefun (lambda-home clambda))) - (or (lambda-physenv homefun) - (let ((res (make-physenv :lambda homefun))) - (setf (lambda-physenv homefun) res) - ;; All the LETLAMBDAs belong to HOMEFUN, and share the same - ;; PHYSENV. Thus, (1) since HOMEFUN's PHYSENV was NIL, - ;; theirs should be NIL too, and (2) since we're modifying - ;; HOMEFUN's PHYSENV, we should modify theirs, too. - (dolist (letlambda (lambda-lets homefun)) - (aver (eql (lambda-home letlambda) homefun)) - (aver (null (lambda-physenv letlambda))) - (setf (lambda-physenv letlambda) res)) - res)))) - -;;; Get NODE's environment, assigning one if necessary. -(defun get-node-physenv (node) - (declare (type node node)) - (get-lambda-physenv (node-home-lambda node))) - -;;; private guts of ADD-LAMBDA-VARS-AND-LET-VARS-TO-CLOSURES -;;; -;;; This is the old CMU CL COMPUTE-CLOSURE, which only works on -;;; LAMBDA-VARS directly, not on the LAMBDA-VARS of LAMBDA-LETS. It -;;; seems never to be valid to use this operation alone, so in SBCL, -;;; it's private, and the public interface, -;;; ADD-LAMBDA-VARS-AND-LET-VARS-TO-CLOSURES, always runs over all the -;;; variables, not only the LAMBDA-VARS of CLAMBDA itself but also -;;; the LAMBDA-VARS of CLAMBDA's LAMBDA-LETS. -(defun %add-lambda-vars-to-closures (clambda) - (let ((physenv (get-lambda-physenv clambda)) - (did-something nil)) - (note-unreferenced-fun-vars clambda) - (dolist (var (lambda-vars clambda)) - (dolist (ref (leaf-refs var)) - (let ((ref-physenv (get-node-physenv ref))) - (unless (eq ref-physenv physenv) - (when (lambda-var-sets var) - (setf (lambda-var-indirect var) t)) - (setq did-something t) - (close-over var ref-physenv physenv)))) - (dolist (set (basic-var-sets var)) - - ;; Variables which are set but never referenced can be - ;; optimized away, and closing over them here would just - ;; interfere with that. (In bug 147, it *did* interfere with - ;; that, causing confusion later. This UNLESS solves that - ;; problem, but I (WHN) am not 100% sure it's best to solve - ;; the problem this way instead of somehow solving it - ;; somewhere upstream and just doing (AVER (LEAF-REFS VAR)) - ;; here.) - (unless (null (leaf-refs var)) - - (let ((set-physenv (get-node-physenv set))) - (unless (eq set-physenv physenv) - (setf did-something t - (lambda-var-indirect var) t) - (close-over var set-physenv physenv)))))) - did-something)) - -;;; Find any variables in CLAMBDA -- either directly in LAMBDA-VARS or -;;; in the LAMBDA-VARS of elements of LAMBDA-LETS -- with references -;;; outside of the home environment and close over them. If a -;;; closed-over variable is set, then we set the INDIRECT flag so that -;;; we will know the closed over value is really a pointer to the -;;; value cell. We also warn about unreferenced variables here, just -;;; because it's a convenient place to do it. We return true if we -;;; close over anything. -(defun add-lambda-vars-and-let-vars-to-closures (clambda) - (declare (type clambda clambda)) - (let ((did-something nil)) - (when (%add-lambda-vars-to-closures clambda) - (setf did-something t)) - (dolist (lambda-let (lambda-lets clambda)) - ;; There's no need to recurse through full COMPUTE-CLOSURE - ;; here, since LETS only go one layer deep. - (aver (null (lambda-lets lambda-let))) - (when (%add-lambda-vars-to-closures lambda-let) - (setf did-something t))) - did-something)) - -(defun xep-enclose (xep) - (let ((entry (functional-entry-fun xep))) - (functional-enclose entry))) - -;;; Make sure that THING is closed over in REF-PHYSENV and in all -;;; PHYSENVs for the functions that reference REF-PHYSENV's function -;;; (not just calls). HOME-PHYSENV is THING's home environment. When we -;;; reach the home environment, we stop propagating the closure. -(defun close-over (thing ref-physenv home-physenv) - (declare (type physenv ref-physenv home-physenv)) - (let ((flooded-physenvs nil)) - (labels ((flood (flooded-physenv) - (unless (or (eql flooded-physenv home-physenv) - (member flooded-physenv flooded-physenvs)) - (push flooded-physenv flooded-physenvs) - (unless (memq thing (physenv-closure flooded-physenv)) - (push thing (physenv-closure flooded-physenv)) - (let ((lambda (physenv-lambda flooded-physenv))) - (cond ((eq (functional-kind lambda) :external) - (let ((enclose-physenv (get-node-physenv (xep-enclose lambda)))) - (flood enclose-physenv) - (dolist (ref (leaf-refs lambda)) - (close-over lambda - (get-node-physenv ref) enclose-physenv)))) - (t (dolist (ref (leaf-refs lambda)) - ;; FIXME: This assertion looks - ;; reasonable, but does not work for - ;; :CLEANUPs. - #+nil - (let ((dest (node-dest ref))) - (aver (basic-combination-p dest)) - (aver (eq (basic-combination-kind dest) :local))) - (flood (get-node-physenv ref)))))))))) - (flood ref-physenv))) - (values)) - -;;; Find LAMBDA-VARs that are marked as needing to support indirect -;;; access (SET at some point after initial creation) that are present -;;; in CLAMBDAs not marked as being DYNAMIC-EXTENT (meaning that the -;;; value-cell involved must be able to survive past the extent of the -;;; allocating frame), and mark them (the LAMBDA-VARs) as needing -;;; explicit value-cells. Because they are already closed-over, the -;;; LAMBDA-VARs already appear in the closures of all of the CLAMBDAs -;;; that need checking. -(defun analyze-indirect-lambda-vars (component) - (dolist (fun (component-lambdas component)) - (let ((entry-fun (functional-entry-fun fun))) - ;; We also check the ENTRY-FUN, as XEPs for LABELS or FLET - ;; functions aren't set to be DX even if their underlying - ;; CLAMBDAs are, and if we ever get LET-bound anonymous function - ;; DX working, it would mark the XEP as being DX but not the - ;; "real" CLAMBDA. This works because a FUNCTIONAL-ENTRY-FUN is - ;; either NULL, a self-pointer (for :TOPLEVEL functions), a - ;; pointer from an XEP to its underlying function (for :EXTERNAL - ;; functions), or a pointer from an underlying function to its - ;; XEP (for non-:TOPLEVEL functions with XEPs). - (unless (or (leaf-dynamic-extent fun) - ;; Functions without XEPs can be treated as if they - ;; are DYNAMIC-EXTENT, even without being so - ;; declared, as any escaping closure which /isn't/ - ;; DYNAMIC-EXTENT but calls one of these functions - ;; will also close over the required variables, thus - ;; forcing the allocation of value cells. Since the - ;; XEP is stored in the ENTRY-FUN slot, we can pick - ;; off the non-XEP case here. - (not entry-fun) - (leaf-dynamic-extent entry-fun)) - (let ((closure (physenv-closure (lambda-physenv fun)))) - (dolist (var closure) - (when (and (lambda-var-p var) - (lambda-var-indirect var)) - (setf (lambda-var-explicit-value-cell var) t)))))))) - -;;;; non-local exit - -(defvar *functional-escape-info*) - -(defun functional-may-escape-p (functional) - (binding* ((functional (if (lambda-p functional) - (lambda-home functional) - functional)) - (table (or *functional-escape-info* - ;; Many components have no escapes, so we - ;; allocate it lazily. - (setf *functional-escape-info* - (make-hash-table :test #'eq)))) - ((bool ok) (gethash functional table))) - (if ok - bool - (let ((entry (functional-entry-fun functional))) - ;; First stick a NIL in there: break cycles. - (setf (gethash functional table) nil) - ;; Then compute the real value. - (setf (gethash functional table) - (and - ;; ESCAPE functionals would never escape from their target - (neq (functional-kind functional) :escape) - (or - ;; If the functional has a XEP, it's kind is :EXTERNAL -- - ;; which means it may escape. ...but if it - ;; HAS-EXTERNAL-REFERENCES-P, then that XEP is actually a - ;; TL-XEP, which means it's a toplevel function -- which in - ;; turn means our search has bottomed out without an escape - ;; path. AVER just to make sure, though. - (and (eq :external (functional-kind functional)) - (if (functional-has-external-references-p functional) - (aver (eq 'tl-xep (car (functional-debug-name functional)))) - t)) - ;; If it has an entry point that may escape, that just as bad. - (and entry (functional-may-escape-p entry)) - ;; If it has references to it in functions that may escape, that's bad - ;; too. - (dolist (ref (functional-refs functional) nil) - (binding* ((lvar (ref-lvar ref) :exit-if-null) - (dest (lvar-dest lvar) :exit-if-null)) - (when (functional-may-escape-p (node-home-lambda dest)) - (return t))))))))))) - -(defun exit-should-check-tag-p (exit) - (declare (type exit exit)) - (let ((exit-lambda (lexenv-lambda (node-lexenv exit)))) - (unless (or - ;; Unsafe but fast... - (policy exit (zerop check-tag-existence)) - ;; Dynamic extent is a promise things won't escape -- - ;; and an explicit request to avoid heap consing. - (member (lambda-extent exit-lambda) '(truly-dynamic-extent dynamic-extent)) - ;; If the exit lambda cannot escape, then we should be safe. - ;; ...since the escape analysis is kinda new, and not particularly - ;; exhaustively tested, let alone proven, disable it for SAFETY 3. - (and (policy exit (< safety 3)) - (not (functional-may-escape-p exit-lambda)))) - (when (policy exit (> speed safety)) - (let ((*compiler-error-context* (exit-entry exit))) - (compiler-notify "~@" - (node-source-form exit)))) - t))) - -;;; Insert the entry stub before the original exit target, and add a -;;; new entry to the PHYSENV-NLX-INFO. The %NLX-ENTRY call in the -;;; stub is passed the NLX-INFO as an argument so that the back end -;;; knows what entry is being done. -;;; -;;; The link from the EXIT block to the entry stub is changed to be a -;;; link from the component head. Similarly, the EXIT block is linked -;;; to the component tail. This leaves the entry stub reachable, but -;;; makes the flow graph less confusing to flow analysis. -;;; -;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the -;;; last node in the cleanup code to be the enclosing environment, to -;;; represent the fact that the binding was undone as a side effect of -;;; the exit. This will cause a lexical exit to be broken up if we are -;;; actually exiting the scope (i.e. a BLOCK), and will also do any -;;; other cleanups that may have to be done on the way. -(defun insert-nlx-entry-stub (exit env) - (declare (type physenv env) (type exit exit)) - (let* ((exit-block (node-block exit)) - (next-block (first (block-succ exit-block))) - (entry (exit-entry exit)) - (cleanup (entry-cleanup entry)) - (info (make-nlx-info cleanup exit)) - (new-block (insert-cleanup-code (list exit-block) next-block - entry - `(%nlx-entry ,(opaquely-quote info)) - cleanup)) - (component (block-component new-block))) - (unlink-blocks exit-block new-block) - (link-blocks exit-block (component-tail component)) - (link-blocks (component-head component) new-block) - - (setf (exit-nlx-info exit) info) - (setf (nlx-info-target info) new-block) - (setf (nlx-info-safe-p info) (exit-should-check-tag-p exit)) - (push info (physenv-nlx-info env)) - (push info (cleanup-info cleanup)) - (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) - (setf (node-lexenv (block-last new-block)) - (node-lexenv entry)))) - - (values)) - -;;; Do stuff necessary to represent a non-local exit from the node -;;; EXIT into ENV. This is called for each non-local exit node, of -;;; which there may be several per exit continuation. This is what we -;;; do: -;;; -- If there isn't any NLX-INFO entry in the environment, make -;;; an entry stub, otherwise just move the exit block link to -;;; the component tail. -;;; -- Close over the NLX-INFO in the exit environment. -;;; -- If the exit is from an :ESCAPE function, then substitute a -;;; constant reference to NLX-INFO structure for the escape -;;; function reference. This will cause the escape function to -;;; be deleted (although not removed from the DFO.) The escape -;;; function is no longer needed, and we don't want to emit code -;;; for it. -;;; -- Change the %NLX-ENTRY call to use the NLX lvar so that 1) there -;;; will be a use to represent the NLX use; 2) make life easier for -;;; the stack analysis. -(defun note-non-local-exit (env exit) - (declare (type physenv env) (type exit exit)) - (let ((lvar (node-lvar exit)) - (exit-fun (node-home-lambda exit)) - (info (find-nlx-info exit))) - (cond (info - (let ((block (node-block exit))) - (aver (= (length (block-succ block)) 1)) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block))) - (setf (exit-nlx-info exit) info) - (unless (nlx-info-safe-p info) - (setf (nlx-info-safe-p info) - (exit-should-check-tag-p exit))))) - (t - (insert-nlx-entry-stub exit env) - (setq info (exit-nlx-info exit)) - (aver info))) - (close-over info (node-physenv exit) env) - (when (eq (functional-kind exit-fun) :escape) - (mapc (lambda (x) - (setf (node-derived-type x) *wild-type*)) - (leaf-refs exit-fun)) - (substitute-leaf (find-constant (opaquely-quote info)) exit-fun)) - (when lvar - (let ((node (block-last (nlx-info-target info)))) - (unless (node-lvar node) - (aver (eq lvar (node-lvar exit))) - (setf (node-derived-type node) (lvar-derived-type lvar)) - (add-lvar-use node lvar))))) - (values)) - -;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT -;;; when we find a block that ends in a non-local EXIT node. -(defun find-non-local-exits (component) - (declare (type component component)) - (let ((*functional-escape-info* nil)) - (dolist (lambda (component-lambdas component)) - (dolist (entry (lambda-entries lambda)) - (let ((target-physenv (node-physenv entry))) - (dolist (exit (entry-exits entry)) - (aver (neq (node-physenv exit) target-physenv)) - (note-non-local-exit target-physenv exit)))))) - (values)) - -;;;; final decision on stack allocation of dynamic-extent structures -(defun recheck-dynamic-extent-lvars (component) - (declare (type component component)) - (let (*dx-combination-p-check-local*) ;; catch unconverted combinations - (dolist (lambda (component-lambdas component)) - (dolist (entry (lambda-entries lambda)) - (let ((cleanup (entry-cleanup entry))) - (when (eq (cleanup-kind cleanup) :dynamic-extent) - (let ((real-dx-lvars '())) - (dolist (what (cleanup-info cleanup)) - (etypecase what - (cons - (let ((dx (car what)) - (lvar (cdr what))) - (cond ((lvar-good-for-dx-p lvar dx component) - ;; Since the above check does deep - ;; checks. we need to deal with the deep - ;; results in here as well. - (dolist (cell (handle-nested-dynamic-extent-lvars - dx lvar component)) - (let ((real (principal-lvar (cdr cell)))) - (setf (lvar-dynamic-extent real) cleanup) - (pushnew real real-dx-lvars)))) - (t - (note-no-stack-allocation lvar) - (setf (lvar-dynamic-extent lvar) nil))))) - (enclose ; DX closure - (let* ((funs (enclose-funs what)) - (dx nil)) - (dolist (fun funs) - (when (leaf-dynamic-extent fun) - (let ((xep (functional-entry-fun fun))) - (when xep - (cond ((physenv-closure (get-lambda-physenv xep)) - (setq dx t)) - (t - (setf (leaf-extent fun) nil))))))) - (when dx - (let ((lvar (make-lvar))) - (use-lvar what lvar) - (setf (lvar-dynamic-extent lvar) cleanup) - (push lvar real-dx-lvars))))))) - (setf (cleanup-info cleanup) real-dx-lvars) - (setf (component-dx-lvars component) - (append real-dx-lvars (component-dx-lvars component))))))))) - (values)) - -;;;; cleanup emission - -;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating -;;; cleanup code as we go. When we are done, convert the cleanup code -;;; in an implicit MV-PROG1. We have to force local call analysis of -;;; new references to UNWIND-PROTECT cleanup functions. If we don't -;;; actually have to do anything, then we don't insert any cleanup -;;; code. (FIXME: There's some confusion here, left over from CMU CL -;;; comments. CLEANUP1 isn't mentioned in the code of this function. -;;; It is in code elsewhere, but if the comments for this function -;;; mention it they should explain the relationship to the other code.) -;;; -;;; If we do insert cleanup code, we check that BLOCK1 doesn't end in -;;; a "tail" local call. -;;; -;;; We don't need to adjust the ending cleanup of the cleanup block, -;;; since the cleanup blocks are inserted at the start of the DFO, and -;;; are thus never scanned. -(defun emit-cleanups (pred-blocks succ-block) - (collect ((code) - (reanalyze-funs)) - (let ((succ-cleanup (block-start-cleanup succ-block))) - (do-nested-cleanups (cleanup (block-end-lexenv (car pred-blocks))) - (when (eq cleanup succ-cleanup) - (return)) - (let* ((node (cleanup-mess-up cleanup)) - (args (when (basic-combination-p node) - (basic-combination-args node)))) - (ecase (cleanup-kind cleanup) - (:special-bind - (code `(%special-unbind ',(lvar-value (car args))))) - (:catch - (code `(%catch-breakup ,(opaquely-quote (car (cleanup-info cleanup)))))) - (:unwind-protect - (code `(%unwind-protect-breakup ,(opaquely-quote (car (cleanup-info cleanup))))) - (let ((fun (ref-leaf (lvar-uses (second args))))) - (when (functional-p fun) - (reanalyze-funs fun) - (code `(%funcall ,fun))))) - ((:block :tagbody) - (dolist (nlx (cleanup-info cleanup)) - (code `(%lexical-exit-breakup ,(opaquely-quote nlx))))) - (:dynamic-extent - (when (cleanup-info cleanup) - (code `(%cleanup-point)))) - (:restore-nsp - (code `(%primitive set-nsp ,(ref-leaf node)))))))) - (flet ((coalesce-unbinds (code) - (if (vop-existsp :named sb-c:unbind-n) - (loop with cleanup - while code - do (setf cleanup (pop code)) - collect (if (eq (car cleanup) '%special-unbind) - `(%special-unbind - ,(cadr cleanup) - ,@(loop while (eq (caar code) '%special-unbind) - collect (cadar code) - do (pop code))) - cleanup)) - code))) - (when (code) - (aver (not (node-tail-p (block-last (car pred-blocks))))) - (insert-cleanup-code - pred-blocks succ-block (block-last (car pred-blocks)) - `(progn ,@(coalesce-unbinds (code)))) - (dolist (fun (reanalyze-funs)) - (locall-analyze-fun-1 fun))))) - (values)) - -;;; Loop over the blocks in COMPONENT, calling EMIT-CLEANUPS when we -;;; see a successor in the same environment with a different cleanup. -;;; We ignore the cleanup transition if it is to a cleanup enclosed by -;;; the current cleanup, since in that case we are just messing up the -;;; environment, hence this is not the place to clean it. -(defun find-cleanup-points (component) - (declare (type component component)) - (do-blocks (block1 component) - (unless (block-to-be-deleted-p block1) - (let ((env1 (block-physenv block1)) - (cleanup1 (block-end-cleanup block1))) - (dolist (block2 (block-succ block1)) - (when (block-start block2) - (let ((env2 (block-physenv block2)) - (cleanup2 (block-start-cleanup block2))) - (unless (or (not (eq env2 env1)) - (eq cleanup1 cleanup2) - (and cleanup2 - (eq (node-enclosing-cleanup - (cleanup-mess-up cleanup2)) - cleanup1))) - ;; If multiple blocks with the same cleanups end up at the same block - ;; issue only one cleanup, e.g. (let (*) (if x 1 2)) - ;; - ;; Possible improvement: (let (*) (if x (let (**) 1) 2)) - ;; unbinding * only once. - (emit-cleanups (loop for pred in (block-pred block2) - when (or (eq pred block1) - (and - (block-start pred) - (eq (block-end-cleanup pred) cleanup1) - (eq (block-physenv pred) env2))) - collect pred) - block2)))))))) - (values)) - -;;; Mark optimizable tail-recursive uses of function result -;;; continuations with the corresponding TAIL-SET. -;;; -;;; Regarding the suppression of TAIL-P for nil-returning calls, -;;; a partial history of the changes affecting this is as follows: -;;; -;;; WHN said [in 85f9c92558538b85540ff420fa8970af91e241a2] -;;; ;; Nodes whose type is NIL (i.e. don't return) such as calls to -;;; ;; ERROR are never annotated as TAIL-P, in order to preserve -;;; ;; debugging information. -;;; -;;; NS added [in bea5b384106a6734a4b280a76e8ebdd4d51b5323] -;;; ;; Why is that bad? Because this non-elimination of -;;; ;; non-returning tail calls causes the XEP for FOO [to] appear in -;;; ;; backtrace for (defun foo (x) (error "foo ~S" x)) w[h]ich seems -;;; ;; less then optimal. --NS 2005-02-28 -;;; (not considering that the point of non-elimination was specifically -;;; to allow FOO to appear in the backtrace?) -;;; -(defun tail-annotate (component) - (declare (type component component)) - (dolist (fun (component-lambdas component)) - (let ((ret (lambda-return fun))) - ;; The code below assumes that a lambda whose final node is a call to - ;; a non-returning function gets a lambda-return. But it doesn't always, - ;; and it's not clear whether that means "always doesn't". - ;; If it never does, then (WHEN RET ..) will never execute, so we won't - ;; even see the call that might be be annotated as tail-p, regardless - ;; of whether we *want* to annotate it as such. - (when ret - (let ((result (return-result ret))) - (do-uses (use result) - (when (and (basic-combination-p use) - (immediately-used-p result use) - (or (eq (basic-combination-kind use) :local) - ;; Nodes whose type is NIL (i.e. don't return) such - ;; as calls to ERROR are never annotated as TAIL-P, - ;; in order to preserve debugging information, so that - ;; - ;; We spread this net wide enough to catch - ;; untrusted NIL return types as well, so that - ;; frames calling functions such as FOO-ERROR are - ;; kept in backtraces: - ;; - ;; (defun foo-error (x) (error "oops: ~S" x)) - ;; - (not (or (eq *empty-type* (node-derived-type use)) - (eq *empty-type* (combination-defined-type use)))))) - (setf (node-tail-p use) t))))))) - ;; The above loop does not find all calls to ERROR. - (do-blocks (block component) - (do-nodes (node nil block) - ;; CAUTION: This looks scary because it affects all known nil-returning - ;; calls even if not in tail position. Use of the policy quality which - ;; enables tail-p must be confined to a very restricted lexical scope. - ;; This might be better implemented as a local declaration about - ;; function names at the call site: (declare (uninhibit-tco error)) - ;; but adding new kinds of declarations is fairly invasive surgery. - (when (and (combination-p node) - (combination-fun-info node) ; must be a known fun - (eq (combination-defined-type node) *empty-type*) - (policy node (= allow-non-returning-tail-call 3))) - (setf (node-tail-p node) t)))) - (values)) diff -Nru sbcl-2.1.10/src/compiler/policy.lisp sbcl-2.1.11/src/compiler/policy.lisp --- sbcl-2.1.10/src/compiler/policy.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/policy.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -202,11 +202,10 @@ (defun policy-quality-deprecation-warning (quality) (case quality ((stack-allocate-dynamic-extent stack-allocate-vector stack-allocate-value-cells) - (deprecation-warn :late "SBCL" "1.0.19.7" 'policy quality '*stack-allocate-dynamic-extent* - :runtime-error nil) + (deprecation-warn :final "SBCL" "1.0.19.7" 'policy quality '*stack-allocate-dynamic-extent*) t) ((merge-tail-calls) - (deprecation-warn :early "SBCL" "1.0.53.74" 'policy quality nil :runtime-error nil) + (deprecation-warn :late "SBCL" "1.0.53.74" 'policy quality nil :runtime-error nil) t) (otherwise nil))) diff -Nru sbcl-2.1.10/src/compiler/ppc/arith.lisp sbcl-2.1.11/src/compiler/ppc/arith.lisp --- sbcl-2.1.10/src/compiler/ppc/arith.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc/arith.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -502,7 +502,7 @@ (inst cmpwi amount 0) (inst neg ndesc amount) (inst bge positive) - (inst cmpwi ndesc 31) + (inst cmplwi ndesc 31) (inst srw result number ndesc) (inst ble done) (move result zero-tn) @@ -549,7 +549,7 @@ (inst cmpwi amount 0) (inst neg ndesc amount) (inst bge positive) - (inst cmpwi ndesc 31) + (inst cmplwi ndesc 31) (inst sraw result number ndesc) (inst ble done) (inst srawi result number 31) @@ -1013,7 +1013,7 @@ (:results (value :scs (unsigned-reg))) (:result-types unsigned-num)) -(define-vop (bignum-set word-index-set-nr) +(define-vop (bignum-set word-index-set) (:variant bignum-digits-offset other-pointer-lowtag) (:translate #+bignum-assertions sb-bignum:%%bignum-set #-bignum-assertions sb-bignum:%bignum-set) diff -Nru sbcl-2.1.10/src/compiler/ppc/array.lisp sbcl-2.1.11/src/compiler/ppc/array.lisp --- sbcl-2.1.10/src/compiler/ppc/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -38,7 +38,7 @@ ;; 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 slwi ndescr ndescr array-rank-position) (inst or ndescr ndescr type) (inst srwi ndescr ndescr n-fixnum-tag-bits) (storew ndescr header 0 other-pointer-lowtag)) @@ -51,7 +51,7 @@ (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) -(define-vop (%set-array-dimension word-index-set-nr) +(define-vop (%set-array-dimension word-index-set) (:translate %set-array-dimension) (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) @@ -104,7 +104,7 @@ (:results (value :scs ,scs)) (:result-types ,element-type)) (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type)) - ,(symbolicate (string variant) "-SET-NR")) + ,(symbolicate (string variant) "-SET")) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) @@ -452,7 +452,7 @@ (:result-types unsigned-num) (:variant vector-data-offset other-pointer-lowtag)) -(define-vop (set-vector-raw-bits word-index-set-nr) +(define-vop (set-vector-raw-bits word-index-set) (:note "setf vector-raw-bits VOP") (:translate %set-vector-raw-bits) (:args (object :scs (descriptor-reg)) @@ -471,7 +471,7 @@ (:results (value :scs (signed-reg))) (:result-types tagged-num)) -(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set-nr) +(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) @@ -489,7 +489,7 @@ (:results (value :scs (signed-reg))) (:result-types tagged-num)) -(define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set-nr) +(define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) diff -Nru sbcl-2.1.10/src/compiler/ppc/call.lisp sbcl-2.1.11/src/compiler/ppc/call.lisp --- sbcl-2.1.10/src/compiler/ppc/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -39,13 +39,13 @@ ;;; 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) + (environment-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) (specify-save-tn - (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) + (environment-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) (make-wired-tn *backend-t-primitive-type* control-stack-arg-scn lra-save-offset))) @@ -142,7 +142,7 @@ (move res csp-tn) (inst addi csp-tn csp-tn (* n-word-bytes (sb-allocated-size 'control-stack))) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) (when (> nbytes number-stack-displacement) (inst stwu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame))) @@ -1129,7 +1129,7 @@ (inst cmpwi count (fixnumize index)) (move value null-tn) (inst ble done) - (inst lwz value object (ash index word-shift)) + (loadw value object index) done)) ;;; Turn more arg (context, count) into a list. diff -Nru sbcl-2.1.10/src/compiler/ppc/c-call.lisp sbcl-2.1.11/src/compiler/ppc/c-call.lisp --- sbcl-2.1.10/src/compiler/ppc/c-call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc/c-call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -384,10 +384,9 @@ (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) - (:temporary (:scs (non-descriptor-reg)) addr) (:generator 2 - (inst lr addr (make-fixup foreign-symbol :foreign-dataref)) - (loadw res addr))) + (inst lr res (make-fixup foreign-symbol :foreign-dataref)) + (loadw res res))) (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) diff -Nru sbcl-2.1.10/src/compiler/ppc/cell.lisp sbcl-2.1.11/src/compiler/ppc/cell.lisp --- sbcl-2.1.10/src/compiler/ppc/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -184,16 +184,14 @@ ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell ;;; is bound. -(define-vop (boundp-frob) +(define-vop (boundp) (:args (object :scs (descriptor-reg))) (:conditional) (:info target not-p) (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value)) - -#+sb-thread -(define-vop (boundp boundp-frob) + (:temporary (:scs (descriptor-reg)) value) (:translate boundp) + #+sb-thread (:generator 9 (loadw value object symbol-tls-index-slot other-pointer-lowtag) (inst lwzx value thread-base-tn value) @@ -202,11 +200,8 @@ (loadw value object symbol-value-slot other-pointer-lowtag) CHECK-UNBOUND (inst cmpwi value unbound-marker-widetag) - (inst b? (if not-p :eq :ne) target))) - -#-sb-thread -(define-vop (boundp boundp-frob) - (:translate boundp) + (inst b? (if not-p :eq :ne) target)) + #-sb-thread (:generator 9 (loadw value object symbol-value-slot other-pointer-lowtag) (inst cmpwi value unbound-marker-widetag) @@ -374,14 +369,14 @@ (:variant closure-info-offset fun-pointer-lowtag) (:translate %closure-index-ref)) +(define-vop (%closure-index-set word-index-set) + (:variant closure-info-offset fun-pointer-lowtag) + (:translate %closure-index-set)) + (define-vop (funcallable-instance-info word-index-ref) (:variant funcallable-instance-info-offset fun-pointer-lowtag) (:translate %funcallable-instance-info)) -(define-vop (set-funcallable-instance-info word-index-set-nr) - (:variant funcallable-instance-info-offset fun-pointer-lowtag) - (:translate %set-funcallable-instance-info)) - (define-vop (closure-ref) (:args (object :scs (descriptor-reg))) (:results (value :scs (descriptor-reg any-reg))) @@ -430,7 +425,7 @@ (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types instance positive-fixnum)) -(define-vop (instance-index-set word-index-set-nr) +(define-vop (instance-index-set word-index-set) (:policy :fast-safe) (:translate %instance-set) (:variant instance-slots-offset instance-pointer-lowtag) @@ -459,12 +454,39 @@ (:policy :fast-safe) (:variant 0 other-pointer-lowtag)) -(define-vop (code-header-set word-index-set-nr) +(define-vop (code-header-set) (:translate code-header-set) (:policy :fast-safe) - (:variant 0 other-pointer-lowtag)) - - + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp card) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:generator 10 + ;; Load the card mask + (inst lr temp (make-fixup "gc_card_table_mask" :foreign-dataref)) ; address of linkage entry + (loadw temp temp) ; address of gc_card_table_mask + (inst lwz temp temp 0) ; value of gc_card_table_mask + (pseudo-atomic (pa-flag) + ;; Compute card mark index + ;; Maybe these 2 steps should be one RLWINM, but I'm not that clever. + (inst srawi card object gencgc-card-shift) + (inst and card card temp) + ;; Load mark table base + (inst lr temp (make-fixup "gc_card_mark" :foreign-dataref)) ; address of linkage entry + (loadw temp temp) ; address of gc_card_mark + (loadw temp temp) ; value of gc_card_mark + ;; Touch the card mark byte. + (inst stbx zero-tn temp card) + ;; set 'written' flag in the code header + ;; If two threads get here at the same time, they'll write the same byte. + (let ((byte #+big-endian (- other-pointer-lowtag) #+little-endian (bug "Wat"))) + (inst lbz temp object byte) + (inst ori temp temp #x40) + (inst stb temp object byte)) + (inst addi temp index (- other-pointer-lowtag)) + (inst stwx value object temp)))) ;;;; raw instance slot accessors @@ -481,7 +503,7 @@ (:arg-types instance positive-fixnum) (:results (value :scs (,sc))) (:result-types ,primtype)) - (define-vop (,(symbolicate "%RAW-INSTANCE-SET/" suffix) word-index-set-nr) + (define-vop (,(symbolicate "%RAW-INSTANCE-SET/" suffix) word-index-set) (:policy :fast-safe) (:translate ,(symbolicate "%RAW-INSTANCE-SET/" suffix)) (:variant instance-slots-offset instance-pointer-lowtag) diff -Nru sbcl-2.1.10/src/compiler/ppc/memory.lisp sbcl-2.1.11/src/compiler/ppc/memory.lisp --- sbcl-2.1.10/src/compiler/ppc/memory.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc/memory.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -34,17 +34,15 @@ ;;;; Indexed references: ;;; Define some VOPs for indexed memory reference. -(defmacro define-indexer (name write-p ri-op rr-op shift &key sign-extend-byte - (result t)) +(defmacro define-indexer (name write-p ri-op rr-op shift &key sign-extend-byte) `(define-vop (,name) (:args (object :scs (descriptor-reg)) (index :scs (any-reg zero immediate)) - ,@(when write-p - `((value :scs (any-reg descriptor-reg) ,@(when result '(:target result)))))) + ,@(when write-p '((value :scs (any-reg descriptor-reg))))) (:arg-types * tagged-num ,@(when write-p '(*))) (:temporary (:scs (non-descriptor-reg)) temp) - ,@(when result - `((:results (,(if write-p 'result 'value) :scs (any-reg descriptor-reg))) + ,@(unless write-p + `((:results (value :scs (any-reg descriptor-reg))) (:result-types *))) (:variant-vars offset lowtag) (:policy :fast-safe) @@ -70,9 +68,7 @@ (- (ash offset word-shift) lowtag)) (inst ,rr-op value object temp))) ,@(when sign-extend-byte - `((inst extsb value value))) - ,@(when (and write-p result) - '((move result value)))))) + `((inst extsb value value)))))) (define-indexer word-index-ref nil lwz lwzx 0) (define-indexer halfword-index-ref nil lhz lhzx 1) @@ -83,10 +79,6 @@ (define-indexer word-index-set t stw stwx 0) (define-indexer halfword-index-set t sth sthx 1) (define-indexer byte-index-set t stb stbx 2) -;; the -NR setters yield no result -(define-indexer word-index-set-nr t stw stwx 0 :result nil) -(define-indexer halfword-index-set-nr t sth sthx 1 :result nil) -(define-indexer byte-index-set-nr t stb stbx 2 :result nil) (define-vop (word-index-cas) (:args (object :scs (descriptor-reg)) diff -Nru sbcl-2.1.10/src/compiler/ppc/nlx.lisp sbcl-2.1.11/src/compiler/ppc/nlx.lisp --- sbcl-2.1.10/src/compiler/ppc/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -214,6 +214,18 @@ (inst b defaulting-done)))))) (load-stack-tn csp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (move res value) + (load-stack-tn csp-tn sp))) (define-vop (nlx-entry-multiple) (:args (top :target result) (src) (count)) diff -Nru sbcl-2.1.10/src/compiler/ppc64/arith.lisp sbcl-2.1.11/src/compiler/ppc64/arith.lisp --- sbcl-2.1.10/src/compiler/ppc64/arith.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/arith.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -300,7 +300,7 @@ (inst cmpdi amount 0) (inst neg ndesc amount) (inst bge positive) - (inst cmpdi ndesc 63) + (inst cmpldi ndesc 63) (inst srd result number ndesc) (inst ble done) (inst li result 0) @@ -347,7 +347,7 @@ (inst cmpdi amount 0) (inst neg ndesc amount) (inst bge positive) - (inst cmpdi ndesc 63) + (inst cmpldi ndesc 63) (inst srad result number ndesc) (inst ble done) ;; smear the sign bit into all bits @@ -869,7 +869,7 @@ (:results (value :scs (unsigned-reg))) (:result-types unsigned-num)) -(define-vop (bignum-set word-index-set-nr) +(define-vop (bignum-set word-index-set) (:variant bignum-digits-offset other-pointer-lowtag) (:translate sb-bignum:%bignum-set) (:args (object :scs (descriptor-reg)) diff -Nru sbcl-2.1.10/src/compiler/ppc64/array.lisp sbcl-2.1.11/src/compiler/ppc64/array.lisp --- sbcl-2.1.10/src/compiler/ppc64/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -40,7 +40,7 @@ ;; 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 slwi ndescr ndescr array-rank-position) (inst or ndescr ndescr type) (inst srwi ndescr ndescr n-fixnum-tag-bits) (storew ndescr header 0 other-pointer-lowtag)) @@ -53,7 +53,7 @@ (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) -(define-vop (%set-array-dimension word-index-set-nr) +(define-vop (%set-array-dimension word-index-set) (:translate %set-array-dimension) (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) @@ -106,15 +106,48 @@ (:arg-types ,type positive-fixnum) (:results (value :scs ,scs)) (:result-types ,element-type)) - (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type)) - ,(symbolicate (string variant) "-SET-NR")) + ,(if (eq type 'simple-vector) + `(define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))) + (:note "inline array store") + (:translate data-vector-set) + (:arg-types ,type positive-fixnum ,element-type) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs ,scs)) + (:arg-types simple-vector positive-fixnum *) + (:policy :fast-safe) + (:temporary (:scs (non-descriptor-reg)) ea t1) + (:vop-var vop) + (:generator 5 + ;; To ensure the right card gets marked, the exact element address must + ;; be computed. Alternatively, we could allow some leeway in which card(s) + ;; we look at in GC to decide whether a vector page was touched. + ;; i.e there are games that could be played to make the boundaries fuzzy + ;; which might obviate the need to perform two ADDs here, + ;; at the expense of some precision in which cards to re-protect. + ;; Probably better to just compute effective address precisely. + (cond ((sc-is index immediate) + (let ((disp (- (ash (+ vector-data-offset (tn-value index)) word-shift) + other-pointer-lowtag))) + (cond ((typep disp '(signed-byte 16)) + (inst addi ea object disp)) + (t ; doesn't fit in ADDI + (inst lr ea disp) + (inst add ea object ea))))) + (t + (inst addi ea index (- (ash vector-data-offset word-shift) other-pointer-lowtag)) + (inst add ea object ea))) + (emit-gc-store-barrier object ea (list t1) (vop-nth-arg 2 vop) value) + (inst std value ea 0))) + `(define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type)) + ,(symbolicate (string variant) "-SET")) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) (:arg-types ,type positive-fixnum ,element-type) (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)) - (value :scs ,scs)))))) + (value :scs ,scs))))))) (def-data-vector-frobs simple-base-string byte-index character character-reg) #+sb-unicode @@ -472,7 +505,7 @@ (:result-types unsigned-num) (:variant vector-data-offset other-pointer-lowtag)) -(define-vop (set-vector-raw-bits word-index-set-nr) +(define-vop (set-vector-raw-bits word-index-set) (:note "setf vector-raw-bits VOP") (:translate %set-vector-raw-bits) (:args (object :scs (descriptor-reg)) @@ -491,7 +524,7 @@ (:results (value :scs (signed-reg))) (:result-types tagged-num)) -(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set-nr) +(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) @@ -509,7 +542,7 @@ (:results (value :scs (signed-reg))) (:result-types tagged-num)) -(define-vop (data-vector-set/simple-array-signed-byte-16 16-bits-index-set-nr) +(define-vop (data-vector-set/simple-array-signed-byte-16 16-bits-index-set) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) @@ -527,7 +560,7 @@ (:results (value :scs (signed-reg))) (:result-types tagged-num)) -(define-vop (data-vector-set/simple-array-signed-byte-32 32-bits-index-set-nr) +(define-vop (data-vector-set/simple-array-signed-byte-32 32-bits-index-set) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) diff -Nru sbcl-2.1.10/src/compiler/ppc64/call.lisp sbcl-2.1.11/src/compiler/ppc64/call.lisp --- sbcl-2.1.10/src/compiler/ppc64/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -39,13 +39,13 @@ ;;; 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) + (environment-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) (specify-save-tn - (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) + (environment-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) (make-wired-tn *backend-t-primitive-type* control-stack-arg-scn lra-save-offset))) @@ -142,7 +142,7 @@ (move res csp-tn) (inst addi csp-tn csp-tn (* n-word-bytes (sb-allocated-size 'control-stack))) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) (when (> nbytes number-stack-displacement) (inst stdu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame))) @@ -741,9 +741,6 @@ ;; Conditionally insert a conditional trap: (when step-instrumenting ;; Get the symbol-value of SB-IMPL::*STEPPING* - #-sb-thread - (load-symbol-value stepping sb-impl::*stepping*) - #+sb-thread (loadw stepping thread-base-tn thread-stepping-slot) (inst cmpwi stepping 0) ;; If it's not null, trap. @@ -1133,6 +1130,20 @@ (:variant 0 0) (:translate %more-arg)) +(define-vop (more-arg-or-nil) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1)) + (count :scs (any-reg))) + (:info index) + (:results (value :scs (descriptor-reg any-reg))) + (:result-types *) + (:generator 3 + (inst cmpwi count (fixnumize index)) + (move value null-tn) + (inst ble done) + (loadw value object index) + done)) + ;;; Turn more arg (context, count) into a list. (define-vop () (:translate %listify-rest-args) @@ -1251,9 +1262,6 @@ (:vop-var vop) (:generator 3 ;; Get the symbol-value of SB-IMPL::*STEPPING* - #-sb-thread - (load-symbol-value stepping sb-impl::*stepping*) - #+sb-thread (loadw stepping thread-base-tn thread-stepping-slot) (inst cmpwi stepping 0) ;; If it's not zero, trap. diff -Nru sbcl-2.1.10/src/compiler/ppc64/c-call.lisp sbcl-2.1.11/src/compiler/ppc64/c-call.lisp --- sbcl-2.1.10/src/compiler/ppc64/c-call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/c-call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -172,10 +172,9 @@ (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) - (:temporary (:scs (non-descriptor-reg)) addr) (:generator 2 - (inst lr addr (make-fixup foreign-symbol :foreign-dataref)) - (loadw res addr))) + (inst lr res (make-fixup foreign-symbol :foreign-dataref)) + (loadw res res))) (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) @@ -413,9 +412,7 @@ ;; And make the call. (load-address-into r0 - (foreign-symbol-address - #-sb-thread "funcall3" - #+sb-thread "callback_wrapper_trampoline")) + (foreign-symbol-address "callback_wrapper_trampoline")) (inst mtlr r0) (inst blrl) diff -Nru sbcl-2.1.10/src/compiler/ppc64/cell.lisp sbcl-2.1.11/src/compiler/ppc64/cell.lisp --- sbcl-2.1.10/src/compiler/ppc64/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,14 +18,13 @@ ;;; temp-reg-tn to access symbol slots. ;;; Since the NIL-as-CONS is necessary, and efficient accessor to lists and ;;; instances is desirable, we lose a little on symbol access by being forced -;;; to pre-check for NIL. There is trick that can get back some performance -;;; on SYMBOL-VALUE which I plan to implement after this much works right. +;;; to pre-check for NIL. (define-vop (slot) (:args (object :scs (descriptor-reg))) (:info name offset lowtag) (:results (result :scs (descriptor-reg any-reg))) (:generator 1 - (cond ((member name '(symbol-name symbol-info sb-xc:symbol-package)) + (cond ((member name '(symbol-name symbol-%info sb-xc:symbol-package)) (let ((null-label (gen-label)) (done-label (gen-label))) (inst cmpld object null-tn) @@ -42,9 +41,13 @@ (:args (object :scs (descriptor-reg)) (value :scs (descriptor-reg any-reg))) (:info name offset lowtag) - (:ignore name) - (:results) + (:temporary (:scs (non-descriptor-reg)) t1) + (:vop-var vop) (:generator 1 + ;; gencgc does not need to emit the barrier for constructors + (unless (member name '(%make-structure-instance make-weak-pointer + %make-ratio %make-complex)) + (emit-gc-store-barrier object nil (list t1) (vop-nth-arg 1 vop) value)) (storew value object offset lowtag))) (define-vop (compare-and-swap-slot) @@ -55,7 +58,9 @@ (:info name offset lowtag) (:ignore name) (:results (result :scs (descriptor-reg) :from :load)) + (:vop-var vop) (:generator 5 + (emit-gc-store-barrier object nil (list temp) (vop-nth-arg 2 vop) new) (inst sync) (inst li temp (- (* offset n-word-bytes) lowtag)) LOOP @@ -80,19 +85,17 @@ (:policy :fast-safe) (:vop-var vop) (:generator 15 + (emit-gc-store-barrier symbol nil (list temp) (vop-nth-arg 2 vop) new) (inst sync) - #+sb-thread - (assemble () - (load-tls-index temp symbol) - ;; Thread-local area, no synchronization needed. - (inst ldx result thread-base-tn temp) - (inst cmpd result old) - (inst bne DONT-STORE-TLS) - (inst stdx new thread-base-tn temp) - DONT-STORE-TLS - - (inst cmpdi result no-tls-value-marker-widetag) - (inst bne CHECK-UNBOUND)) + (load-tls-index temp symbol) + ;; Thread-local area, no synchronization needed. + (inst ldx result thread-base-tn temp) + (inst cmpd result old) + (inst bne DONT-STORE-TLS) + (inst stdx new thread-base-tn temp) + DONT-STORE-TLS + (inst cmpdi result no-tls-value-marker-widetag) + (inst bne CHECK-UNBOUND) (inst li temp (- (* symbol-value-slot n-word-bytes) other-pointer-lowtag)) @@ -153,89 +156,78 @@ (move value object) DONE)) -#+sb-thread -(progn - (define-vop (set) - (:args (symbol :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:temporary (:sc any-reg) tls-slot temp) - (:generator 4 - (load-tls-index tls-slot symbol) - (inst ldx temp thread-base-tn tls-slot) - (inst cmpdi temp no-tls-value-marker-widetag) - (inst beq GLOBAL-VALUE) - (inst stdx value thread-base-tn tls-slot) - (inst b DONE) - GLOBAL-VALUE - (storew value symbol symbol-value-slot other-pointer-lowtag) - DONE)) +(define-vop (set) + (:args (symbol :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:temporary (:sc non-descriptor-reg) tls-slot) + (:temporary (:sc any-reg) temp) + (:vop-var vop) + (:generator 4 + (load-tls-index tls-slot symbol) + (inst ldx temp thread-base-tn tls-slot) + (inst cmpdi temp no-tls-value-marker-widetag) + (inst beq GLOBAL-VALUE) + (inst stdx value thread-base-tn tls-slot) + (inst b DONE) + GLOBAL-VALUE + (emit-gc-store-barrier symbol nil (list tls-slot) (vop-nth-arg 1 vop) value) + (storew value symbol symbol-value-slot other-pointer-lowtag) + DONE)) - ;; With Symbol-Value, we check that the value isn't the trap object. So - ;; Symbol-Value of NIL is NIL. - (define-vop (symbol-value) - (:translate symeval) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:result 1))) - (:results (value :scs (descriptor-reg any-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 9 - (inst cmpld object null-tn) - (inst beq NULL) - (load-tls-index value object) - (inst ldx value thread-base-tn value) - (inst cmpdi value no-tls-value-marker-widetag) - (inst bne CHECK-UNBOUND) - (loadw value object symbol-value-slot other-pointer-lowtag) - CHECK-UNBOUND - (inst cmpdi value unbound-marker-widetag) - (inst beq (generate-error-code vop 'unbound-symbol-error object)) - (inst b DONE) - NULL - (move value object) - DONE)) +;; With Symbol-Value, we check that the value isn't the trap object. So +;; Symbol-Value of NIL is NIL. +(define-vop (symbol-value) + (:translate symeval) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (inst cmpld object null-tn) + (inst beq NULL) + (load-tls-index value object) + (inst ldx value thread-base-tn value) + (inst cmpdi value no-tls-value-marker-widetag) + (inst bne CHECK-UNBOUND) + (loadw value object symbol-value-slot other-pointer-lowtag) + CHECK-UNBOUND + (inst cmpdi value unbound-marker-widetag) + (inst beq (generate-error-code vop 'unbound-symbol-error object)) + (inst b DONE) + NULL + (move value object) + DONE)) - (define-vop (fast-symbol-value symbol-value) - ;; KLUDGE: not really fast, in fact, because we're going to have to - ;; do a full lookup of the thread-local area anyway. But half of - ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if - ;; unbound", which is used in the implementation of COPY-SYMBOL. -- - ;; CSR, 2003-04-22 - (:policy :fast) - (:translate symeval) - (:generator 8 - (inst cmpld object null-tn) - (inst beq NULL) - (load-tls-index value object) - (inst ldx value thread-base-tn value) - (inst cmpdi value no-tls-value-marker-widetag) - (inst bne DONE) - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst b DONE) - NULL - (move value object) - DONE))) - -;;; On unithreaded builds these are just copies of the global versions. -#-sb-thread -(progn - (define-vop (symbol-value symbol-global-value) - (:translate symeval)) - (define-vop (fast-symbol-value fast-symbol-global-value) - (:translate symeval)) - (define-vop (set %set-symbol-global-value))) +(define-vop (fast-symbol-value symbol-value) + ;; KLUDGE: not really fast, in fact, because we're going to have to + ;; do a full lookup of the thread-local area anyway. But half of + ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if + ;; unbound", which is used in the implementation of COPY-SYMBOL. -- + ;; CSR, 2003-04-22 + (:policy :fast) + (:translate symeval) + (:generator 8 + (inst cmpld object null-tn) + (inst beq NULL) + (load-tls-index value object) + (inst ldx value thread-base-tn value) + (inst cmpdi value no-tls-value-marker-widetag) + (inst bne DONE) + (loadw value object symbol-value-slot other-pointer-lowtag) + (inst b DONE) + NULL + (move value object) + DONE)) ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell ;;; is bound. -(define-vop (boundp-frob) +(define-vop (boundp) (:args (object :scs (descriptor-reg))) (:conditional) (:info target not-p) (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value)) - -#+sb-thread -(define-vop (boundp boundp-frob) + (:temporary (:scs (descriptor-reg)) value) (:translate boundp) (:generator 9 (inst cmpld object null-tn) @@ -250,14 +242,6 @@ (inst b? (if not-p :eq :ne) target) OUT)) -#-sb-thread -(define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmpwi value unbound-marker-widetag) - (inst b? (if not-p :eq :ne) target))) - (define-vop (symbol-hash) (:policy :fast-safe) (:translate symbol-hash) @@ -276,27 +260,6 @@ NULL (inst addi res null-tn (- (logand sb-vm:nil-value sb-vm:fixnum-tag-mask))) DONE)) -(define-vop (symbol-plist) - (:policy :fast-safe) - (:translate symbol-plist) - (:args (symbol :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (unsigned-reg)) temp) - (:generator 6 - (inst cmpld symbol null-tn) - (inst beq NULL) - (loadw res symbol symbol-info-slot other-pointer-lowtag) - (inst andi. temp res lowtag-mask) - (inst cmpwi temp list-pointer-lowtag) - (inst beq take-car) - (move res null-tn) ; if INFO is a non-list, then the PLIST is NIL - (inst b DONE) - NULL - (loadw res symbol (1- symbol-info-slot) list-pointer-lowtag) - ;; fallthru. NULL's info slot always holds a cons - TAKE-CAR - (loadw res res cons-car-slot list-pointer-lowtag) - DONE)) ;;;; Fdefinition (fdefn) objects. @@ -354,6 +317,7 @@ (:temporary (:scs (non-descriptor-reg)) type) (:results (result :scs (descriptor-reg))) (:generator 38 + (emit-gc-store-barrier fdefn nil (list type)) (let ((normal-fn (gen-label))) (load-type type function (- fun-pointer-lowtag)) (inst cmpdi type simple-fun-widetag) @@ -383,7 +347,6 @@ ;;; the symbol on the binding stack and stuff the new value into the ;;; symbol. ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual. -#+sb-thread (define-vop (dynbind) (:args (val :scs (any-reg descriptor-reg)) (symbol :scs (descriptor-reg))) @@ -398,19 +361,6 @@ (storew tls-index bsp-tn (- binding-symbol-slot binding-size)) (inst stdx val thread-base-tn tls-index)))) -#-sb-thread -(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 bsp-tn bsp-tn (* binding-size n-word-bytes)) - (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))) - -#+sb-thread (define-vop (unbind) (:temporary (:scs (descriptor-reg)) tls-index value) (:temporary (:scs (any-reg)) zero) @@ -423,20 +373,6 @@ (storew zero bsp-tn (- binding-value-slot binding-size)) (inst subi bsp-tn bsp-tn (* binding-size n-word-bytes)))) -#-sb-thread -(define-vop (unbind) - (:temporary (:scs (descriptor-reg)) symbol value) - (:temporary (:scs (any-reg)) zero) - (: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) - (inst li zero 0) - (storew zero bsp-tn (- binding-symbol-slot binding-size)) - (storew zero bsp-tn (- binding-value-slot binding-size)) - (inst subi bsp-tn bsp-tn (* binding-size n-word-bytes)))) - - (define-vop (unbind-to-here) (:args (arg :scs (descriptor-reg any-reg) :target where)) (:temporary (:scs (any-reg) :from (:argument 0)) where zero) @@ -452,10 +388,7 @@ (inst cmpdi symbol 0) (inst beq skip) (loadw value bsp-tn (- binding-value-slot binding-size)) - #+sb-thread (inst stdx value thread-base-tn symbol) - #-sb-thread - (storew value symbol symbol-value-slot other-pointer-lowtag) (storew zero bsp-tn (- binding-symbol-slot binding-size)) SKIP @@ -474,14 +407,14 @@ (:variant closure-info-offset fun-pointer-lowtag) (:translate %closure-index-ref)) +(define-vop (%closure-index-set descriptor-word-index-set) + (:variant closure-info-offset fun-pointer-lowtag) + (:translate %closure-index-set)) + (define-vop (funcallable-instance-info word-index-ref) (:variant funcallable-instance-info-offset fun-pointer-lowtag) (:translate %funcallable-instance-info)) -(define-vop (set-funcallable-instance-info word-index-set-nr) - (:variant funcallable-instance-info-offset fun-pointer-lowtag) - (:translate %set-funcallable-instance-info)) - (define-vop (closure-ref) (:args (object :scs (descriptor-reg))) (:results (value :scs (descriptor-reg any-reg))) @@ -530,7 +463,7 @@ (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types instance positive-fixnum)) -(define-vop (instance-index-set word-index-set) +(define-vop (instance-index-set descriptor-word-index-set) (:policy :fast-safe) (:translate %instance-set) (:variant instance-slots-offset instance-pointer-lowtag) @@ -554,31 +487,22 @@ ;;;; Code object frobbing. -(define-vop (code-header-ref-any) +(define-vop (code-header-ref+tag) (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:arg-types * tagged-num) + (:info implied-lowtag) + ;; conservative_root_p() in gencgc treats untagged pointers to fdefns + ;; as implicitly pinned. It has to be in a boxed register. (:results (value :scs (descriptor-reg))) (:policy :fast-safe) (:temporary (:scs (non-descriptor-reg)) temp) (:generator 2 ;; ASSUMPTION: N-FIXNUM-TAG-BITS = 3 (inst addi temp index (- other-pointer-lowtag)) - (inst ldx value object temp))) - -(define-vop (code-header-ref-fdefn) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types * tagged-num) - (:results (value :scs (descriptor-reg))) - (:policy :fast-safe) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 3 - ;; ASSUMPTION: N-FIXNUM-TAG-BITS = 3 - (inst addi temp index (- other-pointer-lowtag)) - ;; Loaded value is automatically pinned. (inst ldx value object temp) - (inst ori value value other-pointer-lowtag))) + (unless (zerop implied-lowtag) + (inst ori value value implied-lowtag)))) #-sb-xc-host (defun code-header-ref (code index) @@ -586,16 +510,36 @@ (let ((fdefns-start (sb-impl::code-fdefns-start-index code)) (count (code-n-named-calls code))) (declare ((unsigned-byte 16) fdefns-start count)) + (values (if (and (>= index fdefns-start) (< index (+ fdefns-start count))) - (%primitive code-header-ref-fdefn code index) - (%primitive code-header-ref-any code index)))) + (%primitive code-header-ref+tag code index other-pointer-lowtag) + (%primitive code-header-ref+tag code index 0))))) -(define-vop (code-header-set word-index-set-nr) +(define-vop (code-header-set) (:translate code-header-set) (:policy :fast-safe) - (:variant 0 other-pointer-lowtag)) - - + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp card) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:generator 10 + ;; Load mark table base + (inst ld temp thread-base-tn (ash thread-card-table-slot word-shift)) + (pseudo-atomic (pa-flag) + ;; Compute card mark index + (inst rldicl card object (- 64 gencgc-card-shift) (make-fixup nil :gc-barrier)) + ;; Touch the card mark byte. + (inst stbx thread-base-tn temp card) ; THREAD-TN's low byte is 0 + ;; set 'written' flag in the code header + ;; If two threads get here at the same time, they'll write the same byte. + (let ((byte (- #+big-endian 4 #+little-endian 3 other-pointer-lowtag))) + (inst lbz temp object byte) + (inst ori temp temp #x40) + (inst stb temp object byte)) + (inst addi temp index (- other-pointer-lowtag)) + (inst stdx value object temp)))) ;;;; raw instance slot accessors @@ -613,7 +557,7 @@ (:arg-types instance positive-fixnum) (:results (value :scs (,sc))) (:result-types ,primtype)) - (define-vop (,(symbolicate "%RAW-INSTANCE-SET/" suffix) word-index-set-nr) + (define-vop (,(symbolicate "%RAW-INSTANCE-SET/" suffix) word-index-set) (:policy :fast-safe) (:translate ,(symbolicate "%RAW-INSTANCE-SET/" suffix)) (:variant instance-slots-offset instance-pointer-lowtag) diff -Nru sbcl-2.1.10/src/compiler/ppc64/insts.lisp sbcl-2.1.11/src/compiler/ppc64/insts.lisp --- sbcl-2.1.10/src/compiler/ppc64/insts.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -457,13 +457,10 @@ (def-ppc-iformat (x-4 '(:name :tab rt)) rt (xo xo21-30)) -(def-ppc-iformat (x-5 '(:name :tab ra "," rs "," rb)) +(def-ppc-iformat (x-5 '(:name :tab rs "," ra "," rb)) rs ra rb (xo xo21-30) rc) -(def-ppc-iformat (x-7 '(:name :tab ra "," rs "," rb)) - rs ra rb (xo xo21-30)) - -(def-ppc-iformat (x-8 '(:name :tab ra "," rs "," nb)) +(def-ppc-iformat (x-8 '(:name :tab rs "," ra "," nb)) rs ra nb (xo xo21-30)) (def-ppc-iformat (x-9 '(:name :tab ra "," rs "," sh)) @@ -493,7 +490,7 @@ (def-ppc-iformat (x-22 '(:name :tab frt)) frt (xo xo21-30) rc) -(def-ppc-iformat (x-23 '(:name :tab ra "," frs "," rb)) +(def-ppc-iformat (x-23 '(:name :tab frs "," ra "," rb)) frs ra rb (xo xo21-30)) (def-ppc-iformat (x-24 '(:name :tab bt)) @@ -1473,9 +1470,12 @@ (macrolet ((def (mnemonic op Rc) `(define-instruction ,mnemonic (segment ra rs sh m) - (:declare (type (integer 0 63) sh m)) + (:declare (type (integer 0 63) sh) (type (or (integer 0 63) fixup) m)) (:printer md-form ((op 30) (subop ,op) (rc ,rc))) (:emitter + (when (and (fixup-p m) (eq (fixup-flavor m) :gc-barrier)) + (note-fixup segment :rldic-m m) + (setq m 0)) (emit-md-form-inst segment 30 (reg-tn-encoding rs) (reg-tn-encoding ra) (ldb (byte 5 0) sh) @@ -2407,6 +2407,10 @@ (:layout-id (aver (zerop (sap-ref-32 sap offset))) (setf (signed-sap-ref-32 sap offset) (the layout-id value))) + (:rldic-m ; This is the M (mask) immediate operand to RLDIC{L,R} which + ;; appears in (byte 6 5) of the instruction. See EMIT-MD-FORM-INST. + (setf (ldb (byte 6 5) (sap-ref-32 sap offset)) (encode-mask6 (- 64 value))) + (return-from fixup-code-object :immediate)) (:b (error "Can't deal with CALL fixups, yet.")) (:ba diff -Nru sbcl-2.1.10/src/compiler/ppc64/macros.lisp sbcl-2.1.11/src/compiler/ppc64/macros.lisp --- sbcl-2.1.10/src/compiler/ppc64/macros.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -35,12 +35,10 @@ (defmacro load-symbol (reg symbol) `(inst addi ,reg null-tn (static-symbol-offset ,symbol))) -#+sb-thread -(progn - (defun load-tls-index (reg symbol) - (inst lwz reg symbol (- #+little-endian 4 other-pointer-lowtag))) - (defun store-tls-index (reg symbol) - (inst stw reg symbol (- #+little-endian 4 other-pointer-lowtag)))) +(defun load-tls-index (reg symbol) + (inst lwz reg symbol (- #+little-endian 4 other-pointer-lowtag))) +(defun store-tls-index (reg symbol) + (inst stw reg symbol (- #+little-endian 4 other-pointer-lowtag))) (defmacro load-symbol-value (reg symbol) ;; Work around the usual lowtag subtraction problem. @@ -61,8 +59,6 @@ ;; cross-compile time so we can just use a fixed offset within the ;; TLS block instead of mucking about with the extra memory access ;; (and temp register, for stores)? -#+sb-thread -(progn (defmacro load-tl-symbol-value (reg symbol) `(progn (inst lwz ,reg null-tn (+ (static-symbol-offset ',symbol) @@ -72,14 +68,7 @@ `(progn (inst lwz ,temp null-tn (+ (static-symbol-offset ',symbol) (- #+little-endian 4 other-pointer-lowtag))) - (inst stdx ,reg thread-base-tn ,temp)))) -#-sb-thread -(progn -(defmacro load-tl-symbol-value (reg symbol) - `(load-symbol-value ,reg ,symbol)) -(defmacro store-tl-symbol-value (reg symbol temp) - (declare (ignore temp)) - `(store-symbol-value ,reg ,symbol))) + (inst stdx ,reg thread-base-tn ,temp))) (defmacro load-type (target source &optional (offset 0)) "Loads the type bits of a pointer into target independent of @@ -188,18 +177,7 @@ (declare (ignore stack-p node)) (binding* ((imm-size (typep size '(unsigned-byte 15))) ((region-base-tn field-offset) - #-sb-thread (values thread-base-tn ; will be STATIC-SPACE-START - ;; skip over the array header - (* 2 n-word-bytes)) - #+sb-thread (values thread-base-tn - (* thread-boxed-tlab-slot n-word-bytes)))) - - ;; use a spare register because of the usual problem that lw & sw only allow - ;; displacements that are a multiple of 4. Otherwise NULL-TN would do. - ;; STATIC-SPACE-START can be put into the register using exactly 1 instruction - ;; without referencing a code constant, whereas computing the actual base - ;; address of the struct would use an LIS + ORI. - #-sb-thread (inst lr thread-base-tn static-space-start) + (values thread-base-tn (* thread-boxed-tlab-slot n-word-bytes)))) (unless imm-size ; Make temp-tn be the size (if (numberp size) @@ -337,7 +315,6 @@ `(progn (inst ori alloc-tn alloc-tn pseudo-atomic-flag) ,@forms - #+sb-thread (when ,sync (inst sync)) (without-scheduling () diff -Nru sbcl-2.1.10/src/compiler/ppc64/memory.lisp sbcl-2.1.11/src/compiler/ppc64/memory.lisp --- sbcl-2.1.10/src/compiler/ppc64/memory.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/memory.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,6 +11,20 @@ ;;;; files for more information. (in-package "SB-VM") + +(defun emit-gc-store-barrier (object cell-address temps &optional value-tn-ref value-tn) + (aver (neq (car temps) cell-address)) ; LD would clobber the cell-address + (when (require-gc-store-barrier-p object value-tn-ref value-tn) + ;; (inst ld (car temps) thread-base-tn (ash thread-card-table-slot word-shift)) + ;; RLIDCL dest, source, (64-rightshift), (64-indexbits) + (inst rldicl (car temps) (or cell-address object) (- 64 gencgc-card-shift) + (make-fixup nil :gc-barrier)) + ;; THREAD-TN's low byte is 0. NL5 is the card table address. + (inst stbx thread-base-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'non-descriptor-reg) :offset nl5-offset) + (car temps)))) + ;;; 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. @@ -28,13 +42,39 @@ (value :scs (descriptor-reg any-reg))) (:variant-vars offset lowtag) (:policy :fast-safe) + (:vop-var vop) + (:temporary (:sc non-descriptor-reg) t1) (:generator 4 + (emit-gc-store-barrier object nil (list t1) (vop-nth-arg 1 vop) value) (storew value object offset lowtag))) ;;;; Indexed references: ;;; Define some VOPs for indexed memory reference. +(define-vop (descriptor-word-index-set) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (emit-gc-store-barrier object nil (list temp) (vop-nth-arg 2 vop) value) + (sc-case index + ((immediate) + (let ((offset (- (ash (+ (tn-value index) offset) word-shift) lowtag))) + (cond ((and (typep offset '(signed-byte 16)) (not (logtest offset #b11))) + (inst std value object offset)) + (t + (inst lr temp offset) + (inst stdx value object temp))))) + (t + (inst addi temp index (- (ash offset word-shift) lowtag)) + (inst stdx value object temp))))) + ;;; Due to the encoding restrictione that doubleword accesses can not displace ;;; from the base register by an arbitrarily aligned value, but only an even ;;; multiple of 4. By using a certain arrangement of lowtags we can get two of @@ -56,17 +96,15 @@ ;;; and there is no case in which left-shift is required. (defmacro define-indexer (name shift write-p ri-op rr-op &key sign-extend-byte multiple-of-four - (result t) &aux (net-shift (- shift n-fixnum-tag-bits))) `(define-vop (,name) (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)) - ,@(when write-p - `((value :scs (any-reg descriptor-reg) ,@(when result '(:target result)))))) + ,@(when write-p '((value :scs (any-reg descriptor-reg))))) (:arg-types * tagged-num ,@(when write-p '(*))) (:temporary (:scs (non-descriptor-reg)) temp) - ,@(when result - `((:results (,(if write-p 'result 'value) :scs (any-reg descriptor-reg))) + ,@(unless write-p + `((:results (value :scs (any-reg descriptor-reg))) (:result-types *))) (:variant-vars offset lowtag) (:policy :fast-safe) @@ -93,9 +131,7 @@ (- (ash offset word-shift) lowtag)) (inst ,rr-op value object temp))) ,@(when sign-extend-byte - `((inst extsb value value))) - ,@(when (and write-p result) - '((move result value)))))) + `((inst extsb value value)))))) (define-indexer word-index-ref 3 nil ld ldx) ;; Word means Lisp Word (define-indexer 32-bits-index-ref 2 nil lwz lwzx) @@ -109,11 +145,6 @@ (define-indexer 32-bits-index-set 2 t stw stwx) (define-indexer 16-bits-index-set 1 t sth sthx) (define-indexer byte-index-set 0 t stb stbx) -;; the -NR setters yield no result -(define-indexer word-index-set-nr 3 t std stdx :result nil) -(define-indexer 32-bits-index-set-nr 2 t stw stwx :result nil) -(define-indexer 16-bits-index-set-nr 1 t sth sthx :result nil) -(define-indexer byte-index-set-nr 0 t stb stbx :result nil) (define-vop (word-index-cas) (:args (object :scs (descriptor-reg)) @@ -126,12 +157,23 @@ (:result-types *) (:variant-vars offset lowtag) (:policy :fast-safe) + (:vop-var vop) (:generator 5 + (let ((ea + (ecase lowtag + (#.instance-pointer-lowtag nil) + (#.other-pointer-lowtag ; has to be (SETF SVREF) + (cond ((sc-is index immediate) + (let ((offset (- (ash (+ (tn-value index) offset) word-shift) lowtag))) + (inst lr temp offset))) + (t + (inst addi temp index (- (ash offset word-shift) lowtag)))) + (inst add temp object temp) + temp)))) + (emit-gc-store-barrier object ea (list result temp) (vop-nth-arg 3 vop) new-value)) (sc-case index ((immediate) - (let ((offset (- (+ (ash (tn-value index) word-shift) - (ash offset word-shift)) - lowtag))) + (let ((offset (- (ash (+ (tn-value index) offset) word-shift) lowtag))) (inst lr temp offset))) (t (inst sldi temp index (- word-shift n-fixnum-tag-bits)) diff -Nru sbcl-2.1.10/src/compiler/ppc64/nlx.lisp sbcl-2.1.11/src/compiler/ppc64/nlx.lisp --- sbcl-2.1.10/src/compiler/ppc64/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -42,7 +42,7 @@ (:args (catch :scs (descriptor-reg)) (nfp :scs (descriptor-reg)) (nsp :scs (descriptor-reg))) - #+sb-thread (:temporary (:scs (any-reg)) temp) + (:temporary (:scs (any-reg)) temp) (:vop-var vop) (:generator 10 (store-tl-symbol-value catch *current-catch-block* temp) @@ -126,7 +126,7 @@ ;;; (define-vop (set-unwind-protect) (:args (uwp :scs (any-reg))) - #+sb-thread (:temporary (:scs (any-reg)) temp) + (:temporary (:scs (any-reg)) temp) (:generator 7 (store-tl-symbol-value uwp *current-unwind-protect-block* temp))) @@ -135,7 +135,7 @@ (:args (current-block)) (:ignore current-block) (:temporary (:scs (any-reg)) block) - #+sb-thread (:temporary (:scs (any-reg)) temp) + (:temporary (:scs (any-reg)) temp) (:policy :fast-safe) (:generator 17 (load-tl-symbol-value block *current-catch-block*) @@ -146,7 +146,7 @@ (:args (current-block)) (:ignore current-block) (:temporary (:scs (any-reg)) block) - #+sb-thread (:temporary (:scs (any-reg)) temp) + (:temporary (:scs (any-reg)) temp) (:policy :fast-safe) (:generator 17 (load-tl-symbol-value block *current-unwind-protect-block*) @@ -214,6 +214,18 @@ (inst b defaulting-done)))))) (load-stack-tn csp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (move res value) + (load-stack-tn csp-tn sp))) (define-vop (nlx-entry-multiple) (:args (top :target result) (src) (count :target limit)) diff -Nru sbcl-2.1.10/src/compiler/ppc64/system.lisp sbcl-2.1.11/src/compiler/ppc64/system.lisp --- sbcl-2.1.10/src/compiler/ppc64/system.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/system.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -209,7 +209,6 @@ (:generator 1 (inst unimp pending-interrupt-trap))) -#+sb-thread (define-vop (current-thread-offset-sap) (:results (sap :scs (sap-reg))) (:result-types system-area-pointer) diff -Nru sbcl-2.1.10/src/compiler/ppc64/vm.lisp sbcl-2.1.11/src/compiler/ppc64/vm.lisp --- sbcl-2.1.10/src/compiler/ppc64/vm.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ppc64/vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,7 +11,8 @@ (in-package "SB-VM") -(defconstant-eqx +fixup-kinds+ #(:absolute :absolute64 :layout-id :b :ba :ha :l) #'equalp) +(defconstant-eqx +fixup-kinds+ #(:absolute :absolute64 :layout-id :b :ba :ha :l :rldic-m) + #'equalp) ;;; NUMBER-STACK-DISPLACEMENT ;;; @@ -76,8 +77,10 @@ (defreg thread 30) (defreg lip 31) + ;; nl5 is reserved for the GC card table base. It's restored after every + ;; foreign call, since it coincides with the sixth C arg-passing register. (defregset non-descriptor-regs - nl0 nl1 nl2 nl3 nl4 nl5 nl6 cfunc nargs nfp) + nl0 nl1 nl2 nl3 nl4 #|nl5|# nl6 cfunc nargs nfp) (defregset descriptor-regs fdefn a0 a1 a2 a3 ocfp lra lexenv l0 l1) diff -Nru sbcl-2.1.10/src/compiler/proclaim.lisp sbcl-2.1.11/src/compiler/proclaim.lisp --- sbcl-2.1.10/src/compiler/proclaim.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/proclaim.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -509,10 +509,11 @@ (ftype #'proclaim-ftype)) ctype type :declared))) (push raw-form *queued-proclaims*))) - #-sb-fluid (freeze-type + #-sb-fluid (map-args #'process-freeze-type-declaration)) ((start-block end-block) + #-(and sb-devel sb-xc-host) (when (and *compile-time-eval* (boundp '*compilation*)) (if (eq *block-compile-argument* :specified) (process-block-compile-declaration args kind) diff -Nru sbcl-2.1.10/src/compiler/represent.lisp sbcl-2.1.11/src/compiler/represent.lisp --- sbcl-2.1.10/src/compiler/represent.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/represent.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -217,7 +217,6 @@ (defconstant-eqx ignore-cost-vops '(set type-check-error) #'equal) (defconstant-eqx suppress-note-vops '(type-check-error) #'equal) -#-sb-devel (declaim (start-block select-tn-representation)) ;;; We special-case the move VOP, since using this costs for the @@ -324,9 +323,9 @@ (vop-block (tn-ref-vop ref))))) (tails (lambda-tail-set lambda))) (flet ((frob (fun) - (setf (ir2-physenv-number-stack-p - (physenv-info - (lambda-physenv fun))) + (setf (ir2-environment-number-stack-p + (environment-info + (lambda-environment fun))) t))) (frob lambda) (when tails @@ -620,7 +619,7 @@ (succ (ir2-block-block 2block)) (start (make-ctran)) (block (ctran-starts-block start)) - (no-op-node (make-no-op)) + (no-op-node (make-exit)) (new-2block (make-ir2-block block)) (vop-next (vop-next vop))) (link-node-to-previous-ctran no-op-node start) @@ -804,6 +803,53 @@ (cdr (the (not null) (assoc old-offset renumbering))))))) sorted)) +#+arm64 +(defun choose-zero-tn (tn) + (let (zero-tn) + (flet ((zero-tn () + (or zero-tn + (setf zero-tn + (component-live-tn + (make-wired-tn nil + sb-vm:any-reg-sc-number + sb-vm::zr-offset)))))) + (do ((tn tn (tn-next tn))) + ((null tn)) + (when (and (constant-tn-p tn) + (eql (tn-value tn) 0)) + (loop with next + for read = (tn-reads tn) then next + while read + do + (setf next (tn-ref-next read)) + (do* ((vop (tn-ref-vop read)) + (info (vop-info vop)) + (cost (vop-info-arg-costs info) (cdr cost)) + (op (vop-args vop) (tn-ref-across op))) + ((null cost)) + (when (eq op read) + (when (eql (svref (car cost) sb-vm:zero-sc-number) 0) + (change-tn-ref-tn read (zero-tn))) + (return))))))))) + +;;; The call VOPs allocate a temporary register wired to +;;; nfp-save-offset, but don't use it if there's no nfp-tn in the +;;; current frame, but the stack space is still allocated. +#-c-stack-is-control-stack +(defun unwire-nfp-save-tn (2comp) + (unless (ir2-component-nfp 2comp) + (do ((prev) + (tn (ir2-component-wired-tns 2comp) (tn-next tn))) + ((null tn)) + (cond ((and (sc-is tn sb-vm::control-stack) + (eql (tn-offset tn) sb-vm:nfp-save-offset)) + (setf (tn-kind tn) :unused) + (if prev + (setf (tn-next prev) (tn-next tn)) + (setf (ir2-component-wired-tns 2comp) (tn-next tn)))) + (t + (setf prev tn)))))) + ;;; This is the entry to representation selection. First we select the ;;; representation for all normal TNs, setting the TN-SC. After ;;; selecting the TN representations, we set the SC for all :ALIAS TNs @@ -863,6 +909,10 @@ (do-ir2-blocks (block component) (emit-moves-and-coercions block)) + + #+arm64 + (choose-zero-tn (ir2-component-constant-tns 2comp)) + ;; Give the optimizers a second opportunity to alter newly inserted vops ;; by looking for patterns that have a shorter expression as a single vop. (run-vop-optimizers component) @@ -873,5 +923,7 @@ (note-if-number-stack tn 2comp ,restricted)))) (frob ir2-component-normal-tns nil) (frob ir2-component-wired-tns t) - (frob ir2-component-restricted-tns t))) + (frob ir2-component-restricted-tns t) + #-c-stack-is-control-stack + (unwire-nfp-save-tn 2comp))) (values)) diff -Nru sbcl-2.1.10/src/compiler/riscv/arith.lisp sbcl-2.1.11/src/compiler/riscv/arith.lisp --- sbcl-2.1.10/src/compiler/riscv/arith.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/arith.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -375,9 +375,8 @@ ;; optimize this. (loop for masker in maskers for shift = 1 then (ash shift 1) do - (inst li mask masker) ; NL1 + (inst li mask masker) (let ((input (if (= shift 1) arg num))) - ; TEMP = NL2 ARG = NL3 NUM = NL0 (inst srli temp input shift) (inst and num input mask)) (inst and temp temp mask) diff -Nru sbcl-2.1.10/src/compiler/riscv/array.lisp sbcl-2.1.11/src/compiler/riscv/array.lisp --- sbcl-2.1.10/src/compiler/riscv/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -34,7 +34,7 @@ ;; 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 slli ndescr ndescr array-rank-position) (inst or ndescr ndescr type) (inst srli ndescr ndescr n-fixnum-tag-bits) ;; And store the header value. diff -Nru sbcl-2.1.10/src/compiler/riscv/call.lisp sbcl-2.1.11/src/compiler/riscv/call.lisp --- sbcl-2.1.10/src/compiler/riscv/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -38,12 +38,12 @@ ;;; 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) + (environment-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) (specify-save-tn - (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) + (environment-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) (make-wired-tn *backend-t-primitive-type* control-stack-arg-scn lra-save-offset))) ;;; Make a TN for the standard argument count passing location. We @@ -125,7 +125,7 @@ (:generator 2 (move res csp-tn) (inst addi csp-tn csp-tn (* n-word-bytes (sb-allocated-size 'control-stack))) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (inst addi nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame))) (move nfp nsp-tn)))) @@ -1002,7 +1002,7 @@ (:generator 3 (move value null-tn) (cond ((zerop index) - (inst bge zero-tn count done)) + (inst beq count zero-tn done)) (t (inst li index-temp (fixnumize index)) (inst bge index-temp count done))) diff -Nru sbcl-2.1.10/src/compiler/riscv/c-call.lisp sbcl-2.1.11/src/compiler/riscv/c-call.lisp --- sbcl-2.1.10/src/compiler/riscv/c-call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/c-call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -170,13 +170,12 @@ (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) - (:temporary (:scs (non-descriptor-reg)) addr) (:generator 2 ;; This probably has to be 3 instructions unless we can put some linkage entries ;; near enough to NULL-TN. Would only make a difference when compiling to memory ;; since compiling to file has to assume worst case. - (inst li addr (make-fixup foreign-symbol :foreign-dataref)) - (loadw res addr))) + (inst li res (make-fixup foreign-symbol :foreign-dataref)) + (loadw res res))) (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) diff -Nru sbcl-2.1.10/src/compiler/riscv/cell.lisp sbcl-2.1.11/src/compiler/riscv/cell.lisp --- sbcl-2.1.10/src/compiler/riscv/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -149,18 +149,16 @@ (inst beq temp zero-tn err-lab)))) ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) +(define-vop (boundp) (:args (object :scs (descriptor-reg))) (:conditional) (:info target not-p) (:policy :fast-safe) (:temporary (:scs (descriptor-reg)) value) - (:temporary (:scs (non-descriptor-reg)) temp)) - -#+sb-thread -(define-vop (boundp boundp-frob) - (:temporary (:scs (interior-reg)) lip) + #+sb-thread (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg)) temp) (:translate boundp) + #+sb-thread (:generator 9 (load-tls-index value object) (inst add lip thread-base-tn value) @@ -172,11 +170,8 @@ (inst xori temp value unbound-marker-widetag) (if not-p (inst beq temp zero-tn target) - (inst bne temp zero-tn target)))) - -#-sb-thread -(define-vop (boundp boundp-frob) - (:translate boundp) + (inst bne temp zero-tn target))) + #-sb-thread (:generator 9 (loadw value object symbol-value-slot other-pointer-lowtag) (inst xori temp value unbound-marker-widetag) @@ -378,9 +373,9 @@ closure-info-offset fun-pointer-lowtag (descriptor-reg any-reg) * %closure-index-ref) -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (descriptor-reg any-reg) * %set-funcallable-instance-info) +(define-full-setter %closure-index-set * + closure-info-offset fun-pointer-lowtag + (descriptor-reg any-reg) * %closure-index-set) (define-full-reffer funcallable-instance-info * funcallable-instance-info-offset fun-pointer-lowtag @@ -440,8 +435,40 @@ (define-full-reffer code-header-ref * 0 other-pointer-lowtag (descriptor-reg any-reg) * code-header-ref) -(define-full-setter code-header-set * 0 other-pointer-lowtag - (descriptor-reg any-reg) * code-header-set) +(define-vop (code-header-set) + (:translate code-header-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp card) + (:temporary (:sc non-descriptor-reg) pa-flag) + (:generator 10 + (inst li temp (make-fixup "gc_card_table_mask" :foreign-dataref)) + (loadw temp temp) ; address of gc_card_table_mask + (inst #+64-bit lwu #-64-bit lw temp temp 0) ; value of gc_card_table_mask (4-byte int) + (pseudo-atomic (pa-flag) + ;; Compute card mark index + (inst srli card object gencgc-card-shift) + (inst and card card temp) + ;; Load mark table base + (inst li temp (make-fixup "gc_card_mark" :foreign-dataref)) ; address of linkage entry + (loadw temp temp) ; address of gc_card_mark + (loadw temp temp) ; value of gc_card_mark (pointer) + ;; Touch the card mark byte. + (inst add temp temp card) + (inst sb zero-tn temp 0) + ;; set 'written' flag in the code header + ;; If two threads get here at the same time, they'll write the same byte. + (let ((byte (- 3 other-pointer-lowtag))) + (inst lbu temp object byte) + (inst ori temp temp #x40) + (inst sb temp object byte)) + ;; No need for LIP register because this is pseudo-atomic + (inst slli temp index (- word-shift n-fixnum-tag-bits)) + (inst add temp object temp) + (inst #+64-bit sd #-64-bit sw value temp (- other-pointer-lowtag))))) ;;;; raw instance slot accessors diff -Nru sbcl-2.1.10/src/compiler/riscv/float.lisp sbcl-2.1.11/src/compiler/riscv/float.lisp --- sbcl-2.1.10/src/compiler/riscv/float.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/float.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -787,14 +787,12 @@ (unless (location= value-tn r) (inst fmove :single r value-tn))) #+64-bit - (ecase slot - (:real - (unless (location= r x) - (inst fmove :single r x))) - (:imag - (inst fmvx<- :double temp x) - (inst srli temp temp 32) - (inst fmvx-> :single r temp)))) + (progn + (inst fmvx<- :double temp x) + (ecase slot + (:real) + (:imag (inst srli temp temp 32))) + (inst fmvx-> :single r temp))) (complex-single-stack (inst fload :single r (current-nfp-tn vop) (+ (ecase slot diff -Nru sbcl-2.1.10/src/compiler/riscv/nlx.lisp sbcl-2.1.11/src/compiler/riscv/nlx.lisp --- sbcl-2.1.10/src/compiler/riscv/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -186,6 +186,19 @@ (store-stack-tn tn move-temp)))))))) (load-stack-tn csp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (move res value) + (load-stack-tn csp-tn sp))) + (define-vop (nlx-entry-multiple) (:args (top :target result) (src) diff -Nru sbcl-2.1.10/src/compiler/riscv/system.lisp sbcl-2.1.11/src/compiler/riscv/system.lisp --- sbcl-2.1.10/src/compiler/riscv/system.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/system.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -232,38 +232,6 @@ (inst add ndescr ndescr offset) (inst subi ndescr ndescr (- other-pointer-lowtag fun-pointer-lowtag)) (inst add func code ndescr))) -;;; -(define-vop (symbol-info-vector) - (:policy :fast-safe) - (:translate symbol-info-vector) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:temporary (:sc unsigned-reg) temp) - (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is. - (inst andi temp res lowtag-mask) - (inst xori temp temp list-pointer-lowtag) - (inst bne temp zero-tn not-equal) - (loadw res res cons-cdr-slot list-pointer-lowtag) - NOT-EQUAL)) - -(define-vop (symbol-plist) - (:policy :fast-safe) - (:translate symbol-plist) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:temporary (:sc non-descriptor-reg) temp) - (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x) - ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist. - (loadw res res cons-car-slot list-pointer-lowtag) - (inst andi temp res fixnum-tag-mask) - (inst bne temp zero-tn not-equal) - (move res null-tn) - NOT-EQUAL)) - ;;;; Other random VOPs. diff -Nru sbcl-2.1.10/src/compiler/riscv/vm.lisp sbcl-2.1.11/src/compiler/riscv/vm.lisp --- sbcl-2.1.10/src/compiler/riscv/vm.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/riscv/vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -259,15 +259,17 @@ ;;; addresses. (defconstant single-value-return-byte-offset 0) +;;; 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 "x~D" offset))) + (format nil "R~D" offset))) + (float-registers (format nil "F~D" offset)) (control-stack (format nil "CS~D" offset)) - (float-registers (format nil "f~D" offset)) (non-descriptor-stack (format nil "NS~D" offset)) (constant (format nil "Const~D" offset)) (immediate-constant "Immed")))) diff -Nru sbcl-2.1.10/src/compiler/sparc/arith.lisp sbcl-2.1.11/src/compiler/sparc/arith.lisp --- sbcl-2.1.10/src/compiler/sparc/arith.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/sparc/arith.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -798,7 +798,7 @@ (:results (value :scs (unsigned-reg))) (:result-types unsigned-num)) -(define-vop (bignum-set word-index-set-nr) +(define-vop (bignum-set word-index-set) (:variant bignum-digits-offset other-pointer-lowtag) (:translate sb-bignum:%bignum-set) (:args (object :scs (descriptor-reg)) diff -Nru sbcl-2.1.10/src/compiler/sparc/array.lisp sbcl-2.1.11/src/compiler/sparc/array.lisp --- sbcl-2.1.10/src/compiler/sparc/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/sparc/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -31,7 +31,7 @@ ;; 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 sll ndescr ndescr array-rank-position) (inst or ndescr ndescr type) ;; Remove the extraneous fixnum tag bits because TYPE and RANK ;; were fixnums @@ -45,7 +45,7 @@ (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) -(define-vop (%set-array-dimension word-index-set-nr) +(define-vop (%set-array-dimension word-index-set) (:translate %set-array-dimension) (:policy :fast-safe) (:variant array-dimensions-offset other-pointer-lowtag)) @@ -94,7 +94,7 @@ (:results (value :scs ,scs)) (:result-types ,element-type)) (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type)) - ,(symbolicate (string variant) "-SET-NR")) + ,(symbolicate (string variant) "-SET")) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) @@ -385,7 +385,7 @@ (:results (value :scs (signed-reg))) (:result-types tagged-num)) -(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set-nr) +(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) @@ -404,7 +404,7 @@ (:results (value :scs (signed-reg))) (:result-types tagged-num)) -(define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set-nr) +(define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set) (:note "inline array store") (:variant vector-data-offset other-pointer-lowtag) (:translate data-vector-set) @@ -556,7 +556,7 @@ (:result-types unsigned-num) (:variant vector-data-offset other-pointer-lowtag)) -(define-vop (set-vector-raw-bits word-index-set-nr) +(define-vop (set-vector-raw-bits word-index-set) (:note "setf vector-raw-bits VOP") (:translate %set-vector-raw-bits) (:args (object :scs (descriptor-reg)) diff -Nru sbcl-2.1.10/src/compiler/sparc/call.lisp sbcl-2.1.11/src/compiler/sparc/call.lisp --- sbcl-2.1.10/src/compiler/sparc/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/sparc/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -41,14 +41,14 @@ ;;; 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) + (environment-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) (specify-save-tn - (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) + (environment-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env) (make-wired-tn *backend-t-primitive-type* control-stack-arg-scn lra-save-offset))) @@ -141,7 +141,7 @@ (move res csp-tn) (inst add csp-tn csp-tn (* n-word-bytes (sb-allocated-size 'control-stack))) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) (inst add nfp nsp-tn number-stack-displacement)))) @@ -1061,6 +1061,20 @@ (:variant 0 0) (:translate %more-arg)) +(define-vop (more-arg-or-nil) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1)) + (count :scs (any-reg))) + (:info index) + (:results (value :scs (descriptor-reg any-reg))) + (:result-types *) + (:generator 3 + (inst cmp count (fixnumize index)) + (inst b :le done) + (move value null-tn) + (loadw value object index) + done)) + ;;; Turn more arg (context, count) into a list. (define-vop () (:args (context-arg :target context :scs (descriptor-reg)) diff -Nru sbcl-2.1.10/src/compiler/sparc/c-call.lisp sbcl-2.1.11/src/compiler/sparc/c-call.lisp --- sbcl-2.1.10/src/compiler/sparc/c-call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/sparc/c-call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -197,10 +197,9 @@ (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) - (:temporary (:scs (non-descriptor-reg)) addr) (:generator 2 - (inst li addr (make-fixup foreign-symbol :foreign-dataref)) - (loadw res addr))) + (inst li res (make-fixup foreign-symbol :foreign-dataref)) + (loadw res res))) (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) diff -Nru sbcl-2.1.10/src/compiler/sparc/cell.lisp sbcl-2.1.11/src/compiler/sparc/cell.lisp --- sbcl-2.1.10/src/compiler/sparc/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/sparc/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -59,14 +59,12 @@ ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell ;;; is bound. -(define-vop (boundp-frob) +(define-vop (boundp) (:args (object :scs (descriptor-reg))) (:conditional) (:info target not-p) (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value)) - -(define-vop (boundp boundp-frob) + (:temporary (:scs (descriptor-reg)) value) (:translate boundp) (:generator 9 (loadw value object symbol-value-slot other-pointer-lowtag) @@ -218,14 +216,14 @@ (:variant closure-info-offset fun-pointer-lowtag) (:translate %closure-index-ref)) +(define-vop (%closure-index-set word-index-set) + (:variant closure-info-offset fun-pointer-lowtag) + (:translate %closure-index-set)) + (define-vop (funcallable-instance-info word-index-ref) (:variant funcallable-instance-info-offset fun-pointer-lowtag) (:translate %funcallable-instance-info)) -(define-vop (set-funcallable-instance-info word-index-set-nr) - (:variant funcallable-instance-info-offset fun-pointer-lowtag) - (:translate %set-funcallable-instance-info)) - (define-vop (closure-ref) (:args (object :scs (descriptor-reg))) (:results (value :scs (descriptor-reg any-reg))) @@ -272,7 +270,7 @@ (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types * positive-fixnum)) -(define-vop (instance-index-set word-index-set-nr) +(define-vop (instance-index-set word-index-set) (:policy :fast-safe) (:translate %instance-set) (:variant instance-slots-offset instance-pointer-lowtag) @@ -285,12 +283,37 @@ (:policy :fast-safe) (:variant 0 other-pointer-lowtag)) -(define-vop (code-header-set word-index-set) +(define-vop (code-header-set) (:translate code-header-set) (:policy :fast-safe) - (:variant 0 other-pointer-lowtag)) - - + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp card) + (:generator 10 + ;; Load the card mask + (inst li temp (make-fixup "gc_card_table_mask" :foreign-dataref)) ; linkage entry + (inst ld temp temp) ; address of gc_card_table_mask + (inst ld temp temp) ; value of gc_card_table_mask + (pseudo-atomic () + ;; Compute card mark index + (inst srl card object gencgc-card-shift) + (inst and card card temp) + ;; Load mark table base + (inst li temp (make-fixup "gc_card_mark" :foreign-dataref)) ; linkage entry + (inst ld temp temp) ; address of gc_card_mark + (inst ld temp temp) ; value of gc_card_mark + ;; Touch the card mark byte. + (inst stb zero-tn temp card) + ;; set 'written' flag in the code header + ;; If two threads get here at the same time, they'll write the same byte. + (let ((byte #+big-endian (- other-pointer-lowtag) #+little-endian (bug "Wat"))) + (inst ldub temp object byte) + (inst or temp temp #x40) + (inst stb temp object byte)) + (inst add temp index (- other-pointer-lowtag)) + (inst st value object temp)))) ;;;; raw instance slot accessors diff -Nru sbcl-2.1.10/src/compiler/sparc/memory.lisp sbcl-2.1.11/src/compiler/sparc/memory.lisp --- sbcl-2.1.10/src/compiler/sparc/memory.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/sparc/memory.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -34,16 +34,15 @@ ;;;; Indexed references: ;;; Define some VOPs for indexed memory reference. -(macrolet ((define-indexer (name write-p op shift &key (result t)) +(macrolet ((define-indexer (name write-p op shift) `(define-vop (,name) (:args (object :scs (descriptor-reg)) (index :scs (any-reg zero immediate)) - ,@(when write-p - `((value :scs (any-reg descriptor-reg) ,@(when result '(:target result)))))) + ,@(when write-p '((value :scs (any-reg descriptor-reg))))) (:arg-types * tagged-num ,@(when write-p '(*))) (:temporary (:scs (non-descriptor-reg)) temp) - ,@(when result - `((:results (,(if write-p 'result 'value) :scs (any-reg descriptor-reg))) + ,@(unless write-p + `((:results (value :scs (any-reg descriptor-reg))) (:result-types *))) (:variant-vars offset lowtag) (:policy :fast-safe) @@ -67,17 +66,12 @@ `((inst srl temp index ,shift))) (inst add temp ,(if (zerop shift) 'index 'temp) (- (ash offset word-shift) lowtag)) - (inst ,op value object temp))) - ,@(when (and write-p result) - '((move result value))))))) + (inst ,op value object temp))))))) (define-indexer word-index-ref nil ld 0) - (define-indexer word-index-set-nr t st 0 :result nil) (define-indexer word-index-set t st 0) (define-indexer halfword-index-ref nil lduh 1) (define-indexer signed-halfword-index-ref nil ldsh 1) - (define-indexer halfword-index-set-nr t sth 1 :result nil) (define-indexer halfword-index-set t sth 1) (define-indexer byte-index-ref nil ldub 2) (define-indexer signed-byte-index-ref nil ldsb 2) - (define-indexer byte-index-set-nr t stb 2 :result nil) (define-indexer byte-index-set t stb 2)) diff -Nru sbcl-2.1.10/src/compiler/sparc/nlx.lisp sbcl-2.1.11/src/compiler/sparc/nlx.lisp --- sbcl-2.1.10/src/compiler/sparc/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/sparc/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -207,6 +207,18 @@ (inst nop)))))) (load-stack-tn csp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (move res value) + (load-stack-tn csp-tn sp))) (define-vop (nlx-entry-multiple) (:args (top :target result) (src) (count)) diff -Nru sbcl-2.1.10/src/compiler/stack.lisp sbcl-2.1.11/src/compiler/stack.lisp --- sbcl-2.1.10/src/compiler/stack.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/stack.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -247,7 +247,7 @@ (setq start (merge-uvl-live-sets start (ir2-block-popped 2block))) ;; We cannot delete unused UVLs during NLX, so all UVLs live at - ;; ENTRY will be actually live at NLE. + ;; ENTRY which are not popped will be actually live at NLE. ;; ;; BUT, UNWIND-PROTECTor is called in the environment, which has ;; nothing in common with the environment of its entry. So we @@ -262,7 +262,9 @@ (cleanup (nlx-info-cleanup nlx-info))) (unless (eq (cleanup-kind cleanup) :unwind-protect) (let* ((entry-block (node-block (cleanup-mess-up cleanup))) - (entry-stack (ir2-block-start-stack (block-info entry-block)))) + (entry-stack (set-difference + (ir2-block-start-stack (block-info entry-block)) + (ir2-block-popped (block-info entry-block))))) (setq start (merge-uvl-live-sets start entry-stack)))))) (when *check-consistency* @@ -509,6 +511,8 @@ (when (and (block-start succ) (not (eq (ir2-block-start-stack (block-info succ)) top))) - (insert-stack-cleanups block succ))))) + ;; Return resets the stack, so no need to clean anything. + (unless (return-p (block-last succ)) + (insert-stack-cleanups block succ)))))) (values)) diff -Nru sbcl-2.1.10/src/compiler/target-disassem.lisp sbcl-2.1.11/src/compiler/target-disassem.lisp --- sbcl-2.1.10/src/compiler/target-disassem.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/target-disassem.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -45,13 +45,6 @@ (print-unreadable-object (inst stream :type t :identity t) (format stream "~A(~A)" (inst-name inst) (inst-format-name inst)))) -(declaim (ftype function read-suffix)) -(defun read-signed-suffix (length dstate) - (declare (type (member 8 16 32 64) length) - (type disassem-state dstate) - (optimize (speed 3) (safety 0))) - (sign-extend (read-suffix length dstate) length)) - ;;;; combining instructions where one specializes another ;;; Return non-NIL if the instruction SPECIAL is a more specific @@ -2206,7 +2199,7 @@ ;;;; code to disassemble assembler segments ;;; Disassemble the machine code instructions associated with -;;; BYTES (a vector of assembly-unit) betwen each of RANGES. +;;; BYTES (a vector of assembly-unit) between each of RANGES. (defun disassemble-assem-segment (bytes ranges stream) (declare (type stream stream)) (let* ((dstate (make-dstate)) @@ -2355,6 +2348,13 @@ length (dstate-byte-order dstate)) (incf (dstate-next-offs dstate) length)))) + +(defun read-signed-suffix (length dstate) + (declare (type (member 8 16 32 64) length) + (type disassem-state dstate) + (optimize (speed 3) (safety 0))) + (sign-extend (read-suffix length dstate) length)) + ;;;; optional routines to make notes about code diff -Nru sbcl-2.1.10/src/compiler/tn.lisp sbcl-2.1.11/src/compiler/tn.lisp --- sbcl-2.1.10/src/compiler/tn.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/tn.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -32,11 +32,11 @@ ,inner (progn ,@body) (if (setq ,tn (tn-next ,tn)) (go ,inner) (go ,outer))))) -(defun set-ir2-physenv-live-tns (value instance) - (setf (ir2-physenv-live-tns instance) value)) +(defun set-ir2-environment-live-tns (value instance) + (setf (ir2-environment-live-tns instance) value)) -(defun set-ir2-physenv-debug-live-tns (value instance) - (setf (ir2-physenv-debug-live-tns instance) value)) +(defun set-ir2-environment-debug-live-tns (value instance) + (setf (ir2-environment-debug-live-tns instance) value)) (defun set-ir2-component-alias-tns (value instance) (setf (ir2-component-alias-tns instance) value)) @@ -81,14 +81,14 @@ (case (tn-kind tn) (:environment (clear-live tn - #'ir2-physenv-live-tns - #'set-ir2-physenv-live-tns)) + #'ir2-environment-live-tns + #'set-ir2-environment-live-tns)) (:debug-environment (clear-live tn - #'ir2-physenv-debug-live-tns - #'set-ir2-physenv-debug-live-tns)))) + #'ir2-environment-debug-live-tns + #'set-ir2-environment-debug-live-tns)))) (clear-live (tn getter setter) - (let ((env (physenv-info (tn-physenv tn)))) + (let ((env (environment-info (tn-environment tn)))) (funcall setter (delete tn (funcall getter env)) env)))) (declare (inline used-p delete-some delete-1 clear-live)) (delete-some #'ir2-component-alias-tns @@ -170,24 +170,24 @@ (make-tn (incf (ir2-component-global-tn-counter (component-info *component-being-compiled*))) :unused nil nil)) -;;; Make TN be live throughout PHYSENV. Return TN. In the DEBUG case, -;;; the TN is treated normally in blocks in the environment which +;;; Make TN be live throughout ENV. Return TN. In the DEBUG case, the +;;; TN is treated normally in blocks in the environment which ;;; reference the TN, allowing targeting to/from the TN. This results ;;; in move efficient code, but may result in the TN sometimes not ;;; being live when you want it. -(defun physenv-live-tn (tn physenv) - (declare (type tn tn) (type physenv physenv)) +(defun environment-live-tn (tn env) + (declare (type tn tn) (type environment env)) (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :environment) - (setf (tn-physenv tn) physenv) - (push tn (ir2-physenv-live-tns (physenv-info physenv))) + (setf (tn-environment tn) env) + (push tn (ir2-environment-live-tns (environment-info env))) tn) -(defun physenv-debug-live-tn (tn physenv) - (declare (type tn tn) (type physenv physenv)) +(defun environment-debug-live-tn (tn env) + (declare (type tn tn) (type environment env)) (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :debug-environment) - (setf (tn-physenv tn) physenv) - (push tn (ir2-physenv-debug-live-tns (physenv-info physenv))) + (setf (tn-environment tn) env) + (push tn (ir2-environment-debug-live-tns (environment-info env))) tn) ;;; Make TN be live throughout the current component. Return TN. @@ -337,6 +337,18 @@ (push-in tn-ref-next res (tn-reads tn)))) res)) +(defun reference-tn-refs (refs write-p) + (when refs + (let* ((first (reference-tn (tn-ref-tn refs) write-p) ) + (prev first)) + (loop for tn-ref = (tn-ref-across refs) then (tn-ref-across tn-ref) + while tn-ref + do + (let ((ref (reference-tn (tn-ref-tn tn-ref) write-p))) + (setf (tn-ref-across prev) ref) + (setq prev ref))) + first))) + ;;; Make TN-REFS to reference each TN in TNs, linked together by ;;; TN-REF-ACROSS. WRITE-P is the WRITE-P value for the refs. MORE is ;;; stuck in the TN-REF-ACROSS of the ref for the last TN, or returned diff -Nru sbcl-2.1.10/src/compiler/typetran.lisp sbcl-2.1.11/src/compiler/typetran.lisp --- sbcl-2.1.10/src/compiler/typetran.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/typetran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -367,7 +367,7 @@ ;; as soon as any unknown is present. `(classoid-cell-typep ,(find-classoid-cell spec :create t) ,object)) ((unknown-type-p type) - #+sb-xc-host + #+(and sb-xc-host (not sb-devel)) (warn "can't open-code test of unknown type ~S" (type-specifier type)) ;; This is not a policy-based decision to notify here, @@ -686,11 +686,15 @@ (unless (or (eq dims '*) (equal dims (array-type-dimensions stype))) (cond ((cdr dims) - (values `(,header-test - ,@(when (eq (array-type-dimensions stype) '*) - (if (vop-existsp :translate %array-rank=) - `((%array-rank= ,obj ,(length dims))) - `((= (%array-rank ,obj) ,(length dims))))) + (values `(,@(if (and simple-array-header-p + (vop-existsp :translate simple-array-header-of-rank-p) + (eq (array-type-dimensions stype) '*)) + `((simple-array-header-of-rank-p ,obj ,(length dims))) + `(,header-test + ,@(when (eq (array-type-dimensions stype) '*) + (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) diff -Nru sbcl-2.1.10/src/compiler/vop.lisp sbcl-2.1.11/src/compiler/vop.lisp --- sbcl-2.1.10/src/compiler/vop.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/vop.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -134,8 +134,8 @@ ;;; environment pointer should be saved after the binding is ;;; instantiated. ;;; -;;; PHYSENV-INFO -;;; Holds the IR2-PHYSENV structure. +;;; ENVIRONMENT-INFO +;;; Holds the IR2-ENVIRONMENT structure. ;;; ;;; TAIL-SET-INFO ;;; Holds the RETURN-INFO structure. @@ -404,16 +404,16 @@ (xref (entry-info-xref entry))) (if (and type xref) (cons type xref) (or type xref)))) -;;; An IR2-PHYSENV is used to annotate non-LET LAMBDAs with their -;;; passing locations. It is stored in the PHYSENV-INFO. -(defstruct (ir2-physenv (:copier nil)) +;;; An IR2-ENVIRONMENT is used to annotate non-LET LAMBDAs with their +;;; passing locations. It is stored in the ENVIRONMENT-INFO. +(defstruct (ir2-environment (:copier nil)) ;; TN info for closed-over things within the function: an alist ;; mapping from NLX-INFOs and LAMBDA-VARs to TNs holding the ;; corresponding thing within this function ;; ;; Elements of this list have a one-to-one correspondence with - ;; elements of the PHYSENV-CLOSURE list of the PHYSENV object that - ;; links to us. + ;; elements of the ENVIRONMENT-CLOSURE list of the ENVIRONMENT + ;; object that links to us. (closure (missing-arg) :type list :read-only t) ;; the TNs that hold the OLD-FP and RETURN-PC within the function. ;; We always save these so that the debugger can do a backtrace, @@ -455,7 +455,7 @@ #+unwind-to-frame-and-call-vop (bsp-save-tn nil :type (or tn null))) -(defprinter (ir2-physenv) +(defprinter (ir2-environment) closure old-fp return-pc @@ -738,6 +738,12 @@ (declare (type vop vop)) (vop-info-name (vop-info vop))) +(defun set-vop-optimizer (info fun) + (when (vop-info-optimizer info) + ;; Warn about trying to make two optimizers, because it doesn't work + (warn "Redefining vop-info-optimizer for ~S" (vop-info-name info))) + (setf (vop-info-optimizer info) fun)) + ;; These printers follow the definition of VOP-INFO because they ;; want to inline VOP-INFO-NAME, and it's less code to move them here ;; than to move the defstructs of VOP-INFO and TEMPLATE. @@ -1086,8 +1092,8 @@ ;; some kind of info about how important this TN is (cost 0 :type fixnum) ;; If a :ENVIRONMENT or :DEBUG-ENVIRONMENT TN, this is the - ;; physical environment that the TN is live throughout. - (physenv nil :type (or physenv null)) + ;; environment that the TN is live throughout. + (environment nil :type (or environment null)) ;; Used by pack-iterative (vertex nil)) diff -Nru sbcl-2.1.10/src/compiler/x86/array.lisp sbcl-2.1.11/src/compiler/x86/array.lisp --- sbcl-2.1.10/src/compiler/x86/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -32,7 +32,7 @@ ;; 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 shl header array-rank-position) (inst or header type) (inst shr header n-fixnum-tag-bits) (pseudo-atomic () diff -Nru sbcl-2.1.10/src/compiler/x86/call.lisp sbcl-2.1.11/src/compiler/x86/call.lisp --- sbcl-2.1.10/src/compiler/x86/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,29 +14,9 @@ (defconstant arg-count-sc (make-sc+offset any-reg-sc-number ecx-offset)) (defconstant closure-sc (make-sc+offset descriptor-reg-sc-number eax-offset)) -;;; Make a passing location TN for a local call return PC. -;;; -;;; Always wire the return PC location to the stack in its standard -;;; location. -(defun make-return-pc-passing-location (standard) - (declare (ignore standard)) - (make-wired-tn (primitive-type-or-lose 'system-area-pointer) - sap-stack-sc-number return-pc-save-offset)) - (defconstant return-pc-passing-offset (make-sc+offset sap-stack-sc-number return-pc-save-offset)) -;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a -;;; location to pass OLD-FP in. -;;; -;;; This is wired in both the standard and the local-call conventions, -;;; because we want to be able to assume it's always there. Besides, -;;; the x86 doesn't have enough registers to really make it profitable -;;; to pass it in a register. -(defun make-old-fp-passing-location () - (make-wired-tn *fixnum-primitive-type* control-stack-sc-number - ocfp-save-offset)) - (defconstant old-fp-passing-offset (make-sc+offset control-stack-sc-number ocfp-save-offset)) @@ -46,16 +26,17 @@ ;;; ;;; Without using a save-tn - which does not make much sense if it is ;;; wired to the stack? -(defun make-old-fp-save-location (physenv) - (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type* - control-stack-sc-number - ocfp-save-offset) - physenv)) -(defun make-return-pc-save-location (physenv) - (physenv-debug-live-tn - (make-wired-tn (primitive-type-or-lose 'system-area-pointer) - sap-stack-sc-number return-pc-save-offset) - physenv)) +(defun make-old-fp-save-location () + (let ((tn (make-wired-tn *fixnum-primitive-type* + control-stack-sc-number + ocfp-save-offset))) + (setf (tn-kind tn) :environment) + tn)) +(defun make-return-pc-save-location () + (let ((tn (make-wired-tn (primitive-type-or-lose 'system-area-pointer) + sap-stack-sc-number return-pc-save-offset))) + (setf (tn-kind tn) :environment) + tn)) ;;; Make a TN for the standard argument count passing location. We only ;;; need to make the standard location, since a count is never passed when we diff -Nru sbcl-2.1.10/src/compiler/x86/cell.lisp sbcl-2.1.11/src/compiler/x86/cell.lisp --- sbcl-2.1.10/src/compiler/x86/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -391,9 +391,8 @@ closure-info-offset fun-pointer-lowtag (any-reg descriptor-reg) * %closure-index-ref) -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (any-reg descriptor-reg) * %set-funcallable-instance-info) +(define-full-setter %closure-index-set * closure-info-offset fun-pointer-lowtag + (any-reg descriptor-reg) * %closure-index-set) (define-full-reffer funcallable-instance-info * funcallable-instance-info-offset fun-pointer-lowtag @@ -466,18 +465,32 @@ (:translate code-header-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) + (index :scs (any-reg)) (value :scs (any-reg descriptor-reg))) - (:arg-types * unsigned-num *) - (:temporary (:sc unsigned-reg :offset eax-offset) eax) ; for the asm routine - (:temporary (:sc unsigned-reg :offset edx-offset) edx) - (:temporary (:sc unsigned-reg :offset edi-offset) edi) - (:ignore eax edx edi) + (:arg-types * tagged-num *) + (:temporary (:sc unsigned-reg) table card) (:generator 10 - (inst push value) - (inst push index) - (inst push object) - (inst call (make-fixup 'code-header-set :assembly-routine)))) + ;; Find card mark table base. If the linkage entry contained the + ;; *value* of gc_card_mark pointer, we could eliminate one deref. + ;; Putting it in a statc symbol would also work, but this vop is + ;; not performance-critical by any stretch of the imagination. + (inst mov table (make-ea :dword :disp (make-fixup "gc_card_mark" :foreign-dataref))) + (inst mov table (make-ea :dword :base table)) + (pseudo-atomic () + ;; Compute card mark index and touch the mark byte + (inst mov card object) + (inst shr card gencgc-card-shift) + (inst and card (make-fixup nil :gc-barrier)) + (inst mov (make-ea :byte :base table :index card) 0) + ;; set 'written' flag in the code header + ;; this doesn't need to use :LOCK because the only other writer + ;; would be a GCing thread, but we're pseudo-atomic here. + ;; If two threads actually did write the byte, then they would write + ;; the same value, and that works fine. + (inst or (make-ea :byte :base object :disp (- 3 other-pointer-lowtag)) #x40) + ;; store + (inst mov (make-ea :dword :base object :index index :disp (- other-pointer-lowtag)) + value)))) ;;;; raw instance slot accessors diff -Nru sbcl-2.1.10/src/compiler/x86/insts.lisp sbcl-2.1.11/src/compiler/x86/insts.lisp --- sbcl-2.1.10/src/compiler/x86/insts.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86/insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -831,11 +831,6 @@ (emit-byte segment #b11111111) (emit-ea segment src #b110)))))))) -(define-instruction pusha (segment) - (:printer byte ((op #b01100000))) - (:emitter - (emit-byte segment #b01100000))) - (define-instruction pop (segment dst) (:printer reg-no-width ((op #b01011))) (:printer reg/mem ((op '(#b1000111 #b000)) (width 1))) @@ -849,11 +844,6 @@ (emit-byte segment #b10001111) (emit-ea segment dst #b000)))))) -(define-instruction popa (segment) - (:printer byte ((op #b01100001))) - (:emitter - (emit-byte segment #b01100001))) - (define-instruction xchg (segment operand1 operand2) ;; Register with accumulator. (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg)) @@ -926,71 +916,35 @@ ;;;; flag control instructions -;;; CLC -- Clear Carry Flag. -(define-instruction clc (segment) - (:printer byte ((op #b11111000))) - (:emitter - (emit-byte segment #b11111000))) - -;;; CLD -- Clear Direction Flag. -(define-instruction cld (segment) - (:printer byte ((op #b11111100))) - (:emitter - (emit-byte segment #b11111100))) - -;;; CLI -- Clear Iterrupt Enable Flag. -(define-instruction cli (segment) - (:printer byte ((op #b11111010))) - (:emitter - (emit-byte segment #b11111010))) - -;;; CMC -- Complement Carry Flag. -(define-instruction cmc (segment) - (:printer byte ((op #b11110101))) - (:emitter - (emit-byte segment #b11110101))) - -;;; LAHF -- Load AH into flags. -(define-instruction lahf (segment) - (:printer byte ((op #b10011111))) - (:emitter - (emit-byte segment #b10011111))) - -;;; POPF -- Pop flags. -(define-instruction popf (segment) - (:printer byte ((op #b10011101))) - (:emitter - (emit-byte segment #b10011101))) - -;;; PUSHF -- push flags. -(define-instruction pushf (segment) - (:printer byte ((op #b10011100))) - (:emitter - (emit-byte segment #b10011100))) - -;;; SAHF -- Store AH into flags. -(define-instruction sahf (segment) - (:printer byte ((op #b10011110))) - (:emitter - (emit-byte segment #b10011110))) - -;;; STC -- Set Carry Flag. -(define-instruction stc (segment) - (:printer byte ((op #b11111001))) - (:emitter - (emit-byte segment #b11111001))) - -;;; STD -- Set Direction Flag. -(define-instruction std (segment) - (:printer byte ((op #b11111101))) - (:emitter - (emit-byte segment #b11111101))) - -;;; STI -- Set Interrupt Enable Flag. -(define-instruction sti (segment) - (:printer byte ((op #b11111011))) - (:emitter - (emit-byte segment #b11111011))) +(macrolet ((def (mnemonic opcode) + `(define-instruction ,mnemonic (segment) + (:printer byte ((op ,opcode))) + (:emitter (emit-byte segment ,opcode))))) + (def daa #x27) ; Decimal Adjust After Addition + (def das #x2F) ; Decimal Adjust after Subtraction + (def aaa #x37) ; ASCII Adjust After Addition + (def aas #x3F) ; ASCII Adjust After Subtraction + (def pusha #x60) ; push all regs + (def popa #x61) ; pop all regs + (def wait #x9B) ; Wait + (def pushf #x9C) ; Push flags + (def popf #x9D) ; Pop flags + (def sahf #x9E) ; Store AH into flags + (def lahf #x9F) ; Load AH from flags + (def leave #xC9) + (def into #xCE) ; Interrupt if Overflow + (def iret #xCF) ; Interrupt Return + (def xlat #xD7) ; Translate Byte + (def icebp #xF1) ; ICE breakpoint + (def hlt #xF4) ; Halt + (def cmc #xF5) ; Complement Carry Flag + (def clc #xF8) ; Clear Carry Flag + (def stc #xF9) ; Set Carry Flag + (def cli #xFA) ; Clear Iterrupt Enable Flag + (def sti #xFB) ; Set Interrupt Enable Flag + (def cld #xFC) ; Clear Direction Flag + (def std #xFD) ; Set Direction Flag +) ;;;; arithmetic @@ -999,7 +953,7 @@ (maybe-emit-operand-size-prefix segment size) (cond ((or (integerp src) - (and (fixup-p src) (memq (fixup-flavor src) '(:layout-id)))) + (and (fixup-p src) (memq (fixup-flavor src) '(:gc-barrier :layout-id)))) (cond ((and (neq size :byte) (typep src '(signed-byte 8))) (emit-byte segment #b10000011) (emit-ea segment dst opcode) @@ -1088,26 +1042,6 @@ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment dst #b011)))) -(define-instruction aaa (segment) - (:printer byte ((op #b00110111))) - (:emitter - (emit-byte segment #b00110111))) - -(define-instruction aas (segment) - (:printer byte ((op #b00111111))) - (:emitter - (emit-byte segment #b00111111))) - -(define-instruction daa (segment) - (:printer byte ((op #b00100111))) - (:emitter - (emit-byte segment #b00100111))) - -(define-instruction das (segment) - (:printer byte ((op #b00101111))) - (:emitter - (emit-byte segment #b00101111))) - (define-instruction mul (segment dst src) (:printer accum-reg/mem ((op '(#b1111011 #b100)))) (:emitter @@ -1388,12 +1322,6 @@ (aver (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10101010 #b10101011))))) - -(define-instruction xlat (segment) - (:printer byte ((op #b11010111))) - (:emitter - (emit-byte segment #b11010111))) - ;;;; bit manipulation @@ -1610,8 +1538,6 @@ (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000)) (emit-ea segment dst #b000))) -;;;; enter/leave - (define-instruction enter (segment disp &optional (level 0)) (:declare (type (unsigned-byte 16) disp) (type (unsigned-byte 8) level)) @@ -1620,11 +1546,6 @@ (emit-byte segment #b11001000) (emit-word segment disp) (emit-byte segment level))) - -(define-instruction leave (segment) - (:printer byte ((op #b11001001))) - (:emitter - (emit-byte segment #b11001001))) ;;;; prefetch (define-instruction prefetchnta (segment ea) @@ -1684,11 +1605,6 @@ (emit-byte segment #b11001101) (emit-byte segment number))))) -(define-instruction into (segment) - (:printer byte ((op #b11001110))) - (:emitter - (emit-byte segment #b11001110))) - (define-instruction bound (segment reg bounds) (:emitter (let ((size (matching-operand-size reg bounds))) @@ -1698,28 +1614,15 @@ (emit-byte segment #b01100010) (emit-ea segment bounds (reg-tn-encoding reg))))) -(define-instruction iret (segment) - (:printer byte ((op #b11001111))) - (:emitter - (emit-byte segment #b11001111))) ;;;; processor control -(define-instruction hlt (segment) - (:printer byte ((op #b11110100))) - (:emitter - (emit-byte segment #b11110100))) - (define-instruction nop (segment) (:printer byte ((op #b10010000))) (:printer ext-reg/mem-no-width ((op '(#x1F 0)))) (:emitter (emit-byte segment #b10010000))) -(define-instruction wait (segment) - (:printer byte ((op #b10011011))) - (:emitter - (emit-byte segment #b10011011))) ;;;; miscellaneous hackery @@ -2508,6 +2411,10 @@ (declare (type index offset)) #+sb-xc-host (declare (notinline code-object-size)) ; forward ref (sb-vm::with-code-instructions (sap code) + (when (eq flavor :gc-barrier) + ;; the VALUE is nbits, so convert it to an AND mask + (setf (sap-ref-32 sap offset) (1- (ash 1 value))) + (return-from fixup-code-object :immediate)) (ecase kind (:absolute (case flavor @@ -2523,7 +2430,8 @@ ;; 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))))))) + (>= offset (ash (code-jump-table-words code) word-shift)) + :absolute))))) (:relative ;; VALUE is the actual address wanted. ;; Replace word with displacement to get there. @@ -2539,7 +2447,7 @@ ;; 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))))) + :relative))))) ;;; Perform exhaustive analysis here because of the extreme degree ;;; of confusion I have about what is allowed to reach the instruction diff -Nru sbcl-2.1.10/src/compiler/x86/nlx.lisp sbcl-2.1.11/src/compiler/x86/nlx.lisp --- sbcl-2.1.10/src/compiler/x86/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -203,6 +203,19 @@ (inst jmp defaulting-done)))))) (inst mov esp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (start)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-label label) + (note-this-location vop :non-local-entry) + (inst mov res start) + (inst mov esp-tn sp))) + (define-vop (nlx-entry-multiple) (:args (top) (source) diff -Nru sbcl-2.1.10/src/compiler/x86/system.lisp sbcl-2.1.11/src/compiler/x86/system.lisp --- sbcl-2.1.10/src/compiler/x86/system.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86/system.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -233,39 +233,6 @@ :disp (- fun-pointer-lowtag (* simple-fun-insts-offset n-word-bytes)))))) -;;;; symbol frobbing - -(define-vop (symbol-info-vector) - (:policy :fast-safe) - (:translate symbol-info-vector) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:temporary (:sc unsigned-reg :offset eax-offset) eax) - (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is. - ;; This CMOV safely reads from memory when it does not move, because if - ;; there is an info-vector in the slot, it has at least one element. - ;; This would compile to almost the same code without a VOP, - ;; but using a jmp around a mov instead. - (inst lea eax (make-ea :dword :base res :disp (- list-pointer-lowtag))) - (emit-optimized-test-inst eax lowtag-mask) - (inst cmov :e res - (object-slot-ea res cons-cdr-slot list-pointer-lowtag)))) -(define-vop (symbol-plist) - (:policy :fast-safe) - (:translate symbol-plist) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:temporary (:sc unsigned-reg) temp) - (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x) - ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist. - (loadw res res cons-car-slot list-pointer-lowtag) - (inst mov temp nil-value) - (emit-optimized-test-inst res fixnum-tag-mask) - (inst cmov :e res temp))) ;;;; other miscellaneous VOPs diff -Nru sbcl-2.1.10/src/compiler/x86/values.lisp sbcl-2.1.11/src/compiler/x86/values.lisp --- sbcl-2.1.10/src/compiler/x86/values.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86/values.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,7 +12,7 @@ (in-package "SB-VM") (define-vop (reset-stack-pointer) - (:args (ptr :scs (any-reg))) + (:args (ptr :scs (any-reg control-stack))) (:generator 1 (move esp-tn ptr))) diff -Nru sbcl-2.1.10/src/compiler/x86-64/alloc.lisp sbcl-2.1.11/src/compiler/x86-64/alloc.lisp --- sbcl-2.1.10/src/compiler/x86-64/alloc.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -199,20 +199,13 @@ ;; Call an allocator trampoline and get the result in the proper register. ;; There are 2 choices of trampoline to invoke alloc() or alloc_list() ;; in C. This is chosen by the name of the asm routine. - (let ((consp (eq type 'list))) - (when (typep size 'integer) - (aver (= (align-up size (* 2 n-word-bytes)) size)) - (when (neq type 'list) - (incf size) ; the low bit means we're allocating a non-cons object - ;; Jump into the cons entry point which saves one instruction because why not. - (setq consp t))) - (cond ((typep size '(and integer (not (signed-byte 32)))) - ;; MOV accepts large immediate operands, PUSH does not - (inst mov alloc-tn size) - (inst push alloc-tn)) - (t - (inst push size))) - (invoke-asm-routine 'call (if consp 'cons->rnn 'alloc->rnn) node t)) + (cond ((typep size '(and integer (not (signed-byte 32)))) + ;; MOV accepts large immediate operands, PUSH does not + (inst mov alloc-tn size) + (inst push alloc-tn)) + (t + (inst push size))) + (invoke-asm-routine 'call (if (eq type 'list) 'list-alloc-tramp 'alloc-tramp) node t) (inst pop alloc-tn))) (let* ((NOT-INLINE (gen-label)) (DONE (gen-label)) @@ -305,7 +298,103 @@ (allocation nil bytes other-pointer-lowtag result-tn node nil thread-temp) (storew* header result-tn 0 other-pointer-lowtag t)))))))) -;;;; CONS, LIST and LIST* +;;;; CONS, ACONS, LIST and LIST* +(macrolet ((store-slot (tn list &optional (slot cons-car-slot) + (lowtag list-pointer-lowtag)) + ;; TODO: gencgc does not need EMIT-GC-STORE-BARRIER here, + ;; but other other GC strategies might. + `(let ((reg + ;; FIXME: single-float gets placed in the boxed header + ;; rather than just doing an immediate store. + (sc-case ,tn + ((control-stack constant) + (move temp ,tn) + temp) + (t + (encode-value-if-immediate ,tn))))) + (storew* reg ,list ,slot ,lowtag (not stack-allocate-p) temp)))) + +(define-vop (cons) + (:args (car :scs (any-reg descriptor-reg constant immediate)) + (cdr :scs (any-reg descriptor-reg constant immediate))) + (:temporary (:sc unsigned-reg :to (:result 0) :target result) alloc) + (:temporary (:sc unsigned-reg :to (:result 0)) temp) + (:results (result :scs (descriptor-reg))) + #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn) + (:node-var node) + (:generator 10 + (let ((stack-allocate-p (node-stack-allocate-p node)) + (nbytes (* cons-size n-word-bytes))) + (unless stack-allocate-p + (instrument-alloc 'list nbytes node (list temp alloc) thread-tn)) + (pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn) + (if stack-allocate-p + (stack-allocation nbytes 0 alloc) + (allocation 'list nbytes 0 alloc node temp thread-tn)) + (store-slot car alloc cons-car-slot 0) + (store-slot cdr alloc cons-cdr-slot 0) + (if (location= alloc result) + (inst or :byte alloc list-pointer-lowtag) + (inst lea result (ea list-pointer-lowtag alloc))))))) + +(define-vop (acons) + (:args (key :scs (any-reg descriptor-reg constant immediate)) + (val :scs (any-reg descriptor-reg constant immediate)) + (tail :scs (any-reg descriptor-reg constant immediate))) + (:temporary (:sc unsigned-reg :to (:result 0)) alloc) + (:temporary (:sc unsigned-reg :to (:result 0) :target result) temp) + (:results (result :scs (descriptor-reg))) + #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn) + (:node-var node) + (:translate acons) + (:policy :fast-safe) + (:generator 10 + (let ((stack-allocate-p nil) + (nbytes (* cons-size 2 n-word-bytes))) + (instrument-alloc 'list nbytes node (list temp alloc) thread-tn) + (pseudo-atomic (:thread-tn thread-tn) + (allocation 'list nbytes 0 alloc node temp thread-tn) + (store-slot tail alloc cons-cdr-slot 0) + (inst lea temp (ea (+ 16 list-pointer-lowtag) alloc)) + (store-slot temp alloc cons-car-slot 0) + (let ((pair temp) (temp alloc)) ; give STORE-SLOT the ALLOC as its TEMP + (store-slot key pair) + (store-slot val pair cons-cdr-slot)) + ;; ALLOC could have been clobbered by using it as a temp for + ;; loading a constant. + (if (location= temp result) + (inst sub result 16) ; TEMP is ALLOC+16+lowtag, so just subtract 16 + (inst lea result (ea (- 16) temp))))))) + +;;; CONS-2 is similar to ACONS, except that instead of producing +;;; ((X . Y) . Z) it produces (X Y . Z) +(define-vop (cons-2) + (:args (car :scs (any-reg descriptor-reg constant immediate)) + (cadr :scs (any-reg descriptor-reg constant immediate)) + (cddr :scs (any-reg descriptor-reg constant immediate))) + (:temporary (:sc unsigned-reg :to (:result 0) :target result) alloc) + (:temporary (:sc unsigned-reg :to (:result 0)) temp) + (:results (result :scs (descriptor-reg))) + #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn) + (:node-var node) + (:generator 10 + (let ((stack-allocate-p (node-stack-allocate-p node)) + (nbytes (* cons-size 2 n-word-bytes))) + (unless stack-allocate-p + (instrument-alloc 'list nbytes node (list temp alloc) thread-tn)) + (pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn) + (if stack-allocate-p + (stack-allocation nbytes 0 alloc) + (allocation 'list nbytes 0 alloc node temp thread-tn)) + (store-slot car alloc cons-car-slot 0) + (store-slot cadr alloc (+ 2 cons-car-slot) 0) + (store-slot cddr alloc (+ 2 cons-cdr-slot) 0) + (inst lea temp (ea (+ 16 list-pointer-lowtag) alloc)) + (store-slot temp alloc cons-cdr-slot 0) + (if (location= alloc result) + (inst or :byte alloc list-pointer-lowtag) + (inst lea result (ea list-pointer-lowtag alloc))))))) + (define-vop (list) (:args (things :more t :scs (descriptor-reg constant immediate))) (:temporary (:sc unsigned-reg) ptr temp) @@ -315,62 +404,31 @@ (:results (result :scs (descriptor-reg))) (:node-var node) (:generator 0 - (macrolet ((store-slot (tn list &optional (slot cons-car-slot) - (lowtag list-pointer-lowtag)) - `(let ((reg - ;; FIXME: single-float gets placed in the boxed header - ;; rather than just doing an immediate store. - (sc-case ,tn - ((control-stack constant) - (move temp ,tn) - temp) - (t - (encode-value-if-immediate ,tn))))) - (storew* reg ,list ,slot ,lowtag (not stack-allocate-p) temp)))) - (let ((stack-allocate-p (node-stack-allocate-p node)) - (size (* (pad-data-block cons-size) cons-cells)) - (lowtag (if (<= cons-cells 2) 0 list-pointer-lowtag))) - (unless stack-allocate-p - (instrument-alloc 'list size node (list ptr temp) thread-tn)) - (pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn) - (if stack-allocate-p - (stack-allocation size lowtag res) - (allocation 'list size lowtag res node temp thread-tn)) - (multiple-value-bind (last-base-reg lowtag car cdr) - (case cons-cells - (1 - (values res 0 cons-car-slot cons-cdr-slot)) - (2 - ;; Note that this does not use the 'ptr' register at all. - ;; It would require a different vop to free that register up. - (store-slot (tn-ref-tn things) res cons-car-slot 0) - (setf things (tn-ref-across things)) - (inst lea temp (ea (+ (* cons-size n-word-bytes) list-pointer-lowtag) res)) - (store-slot temp res cons-cdr-slot 0) - (values res 0 (+ cons-size cons-car-slot) (+ cons-size cons-cdr-slot))) - (t - (move ptr res) - (dotimes (i (1- cons-cells)) - (store-slot (tn-ref-tn things) ptr) - (setf things (tn-ref-across things)) - (inst add ptr (pad-data-block cons-size)) - (storew ptr ptr (- cons-cdr-slot cons-size) - list-pointer-lowtag)) - (values ptr list-pointer-lowtag cons-car-slot cons-cdr-slot))) - (store-slot (tn-ref-tn things) last-base-reg car lowtag) - (cond (star - (setf things (tn-ref-across things)) - (store-slot (tn-ref-tn things) last-base-reg cdr lowtag)) - (t - (storew* nil-value last-base-reg cdr lowtag - (not stack-allocate-p)))) - (cond ((<= cons-cells 2) - (if (location= result res) - (inst or :byte result list-pointer-lowtag) - (inst lea result (ea list-pointer-lowtag res)))) - (t - (move result res))))))) - (aver (null (tn-ref-across things))))) + (aver (>= cons-cells 3)) ; prevent regressions in ir2tran's vop selection + (let ((stack-allocate-p (node-stack-allocate-p node)) + (size (* (pad-data-block cons-size) cons-cells))) + (unless stack-allocate-p + (instrument-alloc 'list size node (list ptr temp) thread-tn)) + (pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn) + (if stack-allocate-p + (stack-allocation size list-pointer-lowtag res) + (allocation 'list size list-pointer-lowtag res node temp thread-tn)) + (move ptr res) + (dotimes (i (1- cons-cells)) + (store-slot (tn-ref-tn things) ptr) + (setf things (tn-ref-across things)) + (inst add ptr (pad-data-block cons-size)) + (storew ptr ptr (- cons-cdr-slot cons-size) list-pointer-lowtag)) + (store-slot (tn-ref-tn things) ptr cons-car-slot list-pointer-lowtag) + (cond (star + (setf things (tn-ref-across things)) + (store-slot (tn-ref-tn things) ptr cons-cdr-slot list-pointer-lowtag)) + (t + (storew* nil-value ptr cons-cdr-slot list-pointer-lowtag + (not stack-allocate-p)))))) + (aver (null (tn-ref-across things))) + (move result res))) +) ;;;; special-purpose inline allocators @@ -768,6 +826,7 @@ result 0 fun-pointer-lowtag (not stack-allocate-p))) ;; Finished with the pseudo-atomic instructions (when label + ;; TODO: gencgc does not need EMIT-GC-STORE-BARRIER here, but other other GC strategies might. (inst lea temp (rip-relative-ea label (ash simple-fun-insts-offset word-shift))) (storew temp result closure-fun-slot fun-pointer-lowtag) #+metaspace @@ -789,6 +848,7 @@ (storew header result 0 other-pointer-lowtag))) (t (alloc-other value-cell-widetag value-cell-size result node nil thread-tn))) + ;; TODO: gencgc does not need EMIT-GC-STORE-BARRIER here, but other other GC strategies might. (storew value result value-cell-value-slot other-pointer-lowtag))) ;;;; automatic allocators for primitive objects diff -Nru sbcl-2.1.10/src/compiler/x86-64/arith.lisp sbcl-2.1.11/src/compiler/x86-64/arith.lisp --- sbcl-2.1.10/src/compiler/x86-64/arith.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/arith.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1622,6 +1622,40 @@ (sb-c::delete-vop vop) new))))))) +;;; We can delete some MOVEs that seem often to get inserted with iteration constructs +;;; such as (setq i (1+ i)) where the result of 1+ creates a new TN which is moved +;;; to the same TN that is the input to 1+, but PACK chooses different physical registers +;;; for the arg and result of FAST-+-C/FIXNUM=>FIXNUM. So we "cleverly" can use the LEA +;;; instruction as a 3-operand ADD, only to move the destination of LEA back to the +;;; same register that was one of the input operands. Yet the TN which was the result +;;; had otherwise no use. Why does this happen? I don't know. +;;; +;;; So let's try to prevent it by removing the MOVE, which reduces to just the ADD +;;; instruction instead of LEA + MOV. If a vop can only take one physical representation +;;; (such as tagged fixnum) for input, and can only produce that same representation, +;;; and the TN flows back to that vop, then the move is not needed. But if a vop can take +;;; several physical representations, such as accepting either tagged or untagged, +;;; and the SC has not been chosen yet (which happens), then we can't remove. +;;; +;;; For some reason, it seems to come up a trememdous amount with FAST-+-C/FIXNUM=>FIXNUM. +;;; Maybe it comes up with others, I don't know. No harm in trying, I suppose. +;;; To do this for other vops, you have to be certain that the move isn't a coercion. +;;; +;;; [And it would be nice if every backend named their vops consistently +;;; so that this optimizer could be made architecture-independent] +;;; The SB-C::DELETE- function isn't defined yet in the build order, so wrap it in a lambda. +(flet ((optimizer (vop) (sb-c::delete-unnecessary-move vop))) + (dolist (name '(sb-vm::fast-+-c/fixnum=>fixnum + sb-vm::fast-+-c/signed=>signed + sb-vm::fast-+-c/unsigned=>unsigned + sb-vm::fast---c/fixnum=>fixnum + sb-vm::fast---c/signed=>signed + sb-vm::fast---c/unsigned=>unsigned + sb-vm::fast-*-c/fixnum=>fixnum + sb-vm::fast-*-c/signed=>signed + sb-vm::fast-*-c/unsigned=>unsigned)) + (sb-c::set-vop-optimizer (template-or-lose name) #'optimizer))) + (defun emit-optimized-cmp (x y temp &optional x-ctype) ;; Shorten the encoding by eliding a REX prefix where the upper bits ;; can not possibly matter. diff -Nru sbcl-2.1.10/src/compiler/x86-64/array.lisp sbcl-2.1.11/src/compiler/x86-64/array.lisp --- sbcl-2.1.10/src/compiler/x86-64/array.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -81,7 +81,7 @@ ;; 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 shl :dword header array-rank-position) (inst or :dword header type) (inst shr :dword header n-fixnum-tag-bits) (instrument-alloc nil bytes node temp thread-tn) @@ -304,7 +304,7 @@ `(progn (define-vop (,name dvset) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg signed-reg unsigned-reg)) (value :scs ,scs)) (:info addend) (:arg-types ,type tagged-num @@ -313,11 +313,15 @@ vector-data-offset)) ,el-type) (:temporary (:sc unsigned-reg) val-temp) + (:vop-var vop) (:generator 4 + ;; XXX: Is this good - we unpoison first, and then store? It seems wrong. ,@(unless (eq type 'simple-vector) '((unpoison-element object index addend))) - (gen-cell-set (ea (- (* (+ ,offset addend) n-word-bytes) ,lowtag) - object index (ash 1 (- word-shift n-fixnum-tag-bits))) - value val-temp))) + (let ((ea (ea (- (* (+ ,offset addend) n-word-bytes) ,lowtag) + object index (index-scale n-word-bytes index)))) + ,@(when (eq type 'simple-vector) + '((emit-gc-store-barrier object ea val-temp (vop-nth-arg 2 vop) value))) + (gen-cell-set ea value val-temp)))) (define-vop (,(symbolicate name "-C") dvset) (:args (object :scs (descriptor-reg)) (value :scs ,scs)) @@ -330,11 +334,14 @@ vector-data-offset)) ,el-type) (:temporary (:sc unsigned-reg) val-temp) + (:vop-var vop) (:generator 3 + ;; XXX: Is this good - we unpoison first, and then store? It seems wrong. ,@(unless (eq type 'simple-vector) '((unpoison-element object (+ index addend)))) - (gen-cell-set (ea (- (* (+ ,offset index addend) n-word-bytes) ,lowtag) - object) - value val-temp))))) + (let ((ea (ea (- (* (+ ,offset index addend) n-word-bytes) ,lowtag) object))) + ,@(when (eq type 'simple-vector) + '((emit-gc-store-barrier object ea val-temp (vop-nth-arg 1 vop) value))) + (gen-cell-set ea value val-temp)))))) (defmacro def-full-data-vector-frobs (type element-type &rest scs) `(progn (define-full-reffer+addend ,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" type) @@ -392,7 +399,7 @@ (define-vop (svref-with-addend+if-eq) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg signed-reg unsigned-reg)) (comparand :scs (any-reg descriptor-reg immediate))) (:info addend) (:arg-types simple-vector tagged-num * (:constant integer)) @@ -401,7 +408,7 @@ (inst cmp :qword (ea (- (* (+ vector-data-offset addend) n-word-bytes) other-pointer-lowtag) object index - (ash 1 (- word-shift n-fixnum-tag-bits))) + (index-scale n-word-bytes index)) (encode-value-if-immediate comparand)))) (define-vop (data-vector-ref-with-offset/constant-simple-vector) @@ -516,15 +523,15 @@ (:results (result :scs (any-reg))) (:result-types positive-fixnum) (:generator 3 - ;; using 32-bit operand size might elide the REX prefix on mov + shift - (multiple-value-bind (dword-index bit) (floor index 32) - (inst mov :dword result (ea (bit-base dword-index) object)) - (let ((right-shift (- bit n-fixnum-tag-bits))) - (cond ((plusp right-shift) - (inst shr :dword result right-shift)) - ((minusp right-shift) ; = left shift - (inst shl :dword result (- right-shift)))))) - (inst and :dword result (fixnumize 1)))) + ;; using 32-bit operand size might elide the REX prefix on mov + shift + (multiple-value-bind (dword-index bit) (floor index 32) + (inst mov :dword result (ea (bit-base dword-index) object)) + (let ((right-shift (- bit n-fixnum-tag-bits))) + (cond ((plusp right-shift) + (inst shr :dword result right-shift)) + ((minusp right-shift) ; = left shift + (inst shl :dword result (- right-shift)))))) + (inst and :dword result (fixnumize 1)))) (define-vop (data-vector-ref-with-offset/simple-bit-vector dvref) (:args (object :scs (descriptor-reg)) @@ -532,147 +539,179 @@ (:info addend) (:ignore addend) (:arg-types simple-bit-vector positive-fixnum (:constant (integer 0 0))) - (:temporary (:sc unsigned-reg) word temp) + (:temporary (:sc unsigned-reg) temp) (:results (result :scs (any-reg))) (:result-types positive-fixnum) (:vop-var vop) (:generator 4 ;; mem/reg BT is really slow. - (inst mov word index) - (inst shr word (integer-length (1- n-word-bits))) - (inst mov temp (ea (bit-base 0) object word n-word-bytes)) + (inst mov temp index) + (inst shr temp (integer-length (1- n-word-bits))) + (inst mov temp (ea (bit-base 0) object temp n-word-bytes)) (inst bt temp index) (inst sbb :dword result result) (inst and :dword result (fixnumize 1)))) +(define-vop (data-vector-ref-with-offset/simple-bit-vector-c-eq) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types simple-bit-vector + (:constant (integer 0 #x3ffffffff)) (:constant (integer 0 0))) + (:info index addend) + (:ignore addend) + (:conditional :eq) + (:generator 3 + (multiple-value-bind (byte-index bit) (floor index 8) + (inst test :byte (ea (+ byte-index + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) + object) + (ash 1 bit))))) + +(define-vop (data-vector-ref-with-offset/simple-bit-vector-eq) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:info addend) + (:ignore addend) + (:arg-types simple-bit-vector positive-fixnum (:constant (integer 0 0))) + (:temporary (:sc unsigned-reg) word) + (:conditional :nc) + (:vop-var vop) + (:generator 4 + ;; mem/reg BT is really slow. + (inst mov word index) + (inst shr word (integer-length (1- n-word-bits))) + (inst mov word (ea (bit-base 0) object word n-word-bytes)) + (inst bt word index))) + ;;;; vectors whose elements are 2 or 4 bits each (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-with-offset/ type) dvref) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:info addend) - (:ignore addend) - (: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 rcx-offset) ecx) - (:generator 20 - (move ecx index) - (inst shr ecx ,bit-shift) - (inst mov result - (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - object ecx n-word-bytes)) - (move ecx index) - ;; We used to mask ECX for all values of BITS, but since - ;; Intel's documentation says that the chip will mask shift - ;; and rotate counts by 63 automatically, we can safely move - ;; the masking operation under the protection of this UNLESS - ;; in the bit-vector case. --njf, 2006-07-14 - ,@(unless (= bits 1) - `((inst and ecx ,(1- elements-per-word)) - (inst shl ecx ,(1- (integer-length bits))))) - (inst shr result :cl) - (inst and result ,(1- (ash 1 bits))))) - (define-vop (,(symbolicate 'data-vector-ref-with-offset/ type "-C") dvref) - (:args (object :scs (descriptor-reg))) - (:arg-types ,type (:constant low-index) (:constant (integer 0 0))) - (:info index addend) - (:ignore addend) - (: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 shr result (* extra ,bits))) - (unless (= extra ,(1- elements-per-word)) - (inst and result ,(1- (ash 1 bits))))))) - (define-vop (,(symbolicate 'data-vector-set-with-offset/ type) dvset) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg) :target ecx) - (value :scs (unsigned-reg immediate))) - (:info addend) - (:ignore addend) - (:arg-types ,type positive-fixnum (:constant (integer 0 0)) - positive-fixnum) - (:temporary (:sc unsigned-reg) word-index) - (:temporary (:sc unsigned-reg) old) - (:temporary (:sc unsigned-reg :offset rcx-offset) ecx) - (:generator 25 - (unpoison-element object index) - (move word-index index) - (inst shr word-index ,bit-shift) - (inst mov old - (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - object word-index n-word-bytes)) - (move ecx index) - ;; We used to mask ECX for all values of BITS, but since - ;; Intel's documentation says that the chip will mask shift - ;; and rotate counts by 63 automatically, we can safely move - ;; the masking operation under the protection of this UNLESS - ;; in the bit-vector case. --njf, 2006-07-14 - ,@(unless (= bits 1) - `((inst and ecx ,(1- elements-per-word)) - (inst shl ecx ,(1- (integer-length bits))))) - (inst ror old :cl) - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (inst and old ,(lognot (1- (ash 1 bits))))) - (sc-case value - (immediate - (unless (zerop (tn-value value)) - (inst or old (logand (tn-value value) ,(1- (ash 1 bits)))))) - (unsigned-reg - (inst or old value))) - (inst rol old :cl) - (inst mov (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - object word-index n-word-bytes) - old))) - (define-vop (,(symbolicate 'data-vector-set-with-offset/ type "-C") dvset) - (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg immediate))) - (:arg-types ,type (:constant low-index) - (:constant (integer 0 0)) positive-fixnum) - (:temporary (:sc unsigned-reg) mask-tn) - (:info index addend) - (:ignore addend) - (:temporary (:sc unsigned-reg :to (:result 0)) old) - (:generator 20 - (unpoison-element object index) - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (inst mov old - (ea (- (* (+ word vector-data-offset) n-word-bytes) - other-pointer-lowtag) - object)) - (sc-case value - (immediate - (let* ((value (tn-value value)) - (mask ,(1- (ash 1 bits))) - (shift (* extra ,bits))) - (unless (= value mask) - (inst mov mask-tn (ldb (byte 64 0) - (lognot (ash mask shift)))) - (inst and old mask-tn)) - (unless (zerop value) - (inst mov mask-tn (ash value shift)) - (inst or old mask-tn)))) - (unsigned-reg - (let ((shift (* extra ,bits))) - (unless (zerop shift) - (inst ror old shift)) - (inst mov mask-tn (lognot ,(1- (ash 1 bits)))) - (inst and old mask-tn) - (inst or old value) - (unless (zerop shift) - (inst rol old shift))))) - (inst mov (ea (- (* (+ word vector-data-offset) n-word-bytes) - other-pointer-lowtag) - object) - old)))))))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref-with-offset/ type) dvref) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:info addend) + (:ignore addend) + (: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 rcx-offset) ecx) + (:generator 20 + (move ecx index) + (inst shr ecx ,bit-shift) + (inst mov result + (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + object ecx n-word-bytes)) + (move ecx index) + ;; We used to mask ECX for all values of BITS, but since + ;; Intel's documentation says that the chip will mask shift + ;; and rotate counts by 63 automatically, we can safely move + ;; the masking operation under the protection of this UNLESS + ;; in the bit-vector case. --njf, 2006-07-14 + ,@(unless (= bits 1) + `((inst and ecx ,(1- elements-per-word)) + (inst shl ecx ,(1- (integer-length bits))))) + (inst shr result :cl) + (inst and result ,(1- (ash 1 bits))))) + (define-vop (,(symbolicate 'data-vector-ref-with-offset/ type "-C") dvref) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant low-index) (:constant (integer 0 0))) + (:info index addend) + (:ignore addend) + (: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 shr result (* extra ,bits))) + (unless (= extra ,(1- elements-per-word)) + (inst and result ,(1- (ash 1 bits))))))) + (define-vop (,(symbolicate 'data-vector-set-with-offset/ type) dvset) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg) :target ecx) + (value :scs (unsigned-reg immediate))) + (:info addend) + (:ignore addend) + (:arg-types ,type positive-fixnum (:constant (integer 0 0)) + positive-fixnum) + (:temporary (:sc unsigned-reg) word-index) + (:temporary (:sc unsigned-reg) old) + (:temporary (:sc unsigned-reg :offset rcx-offset) ecx) + (:generator 25 + (unpoison-element object index) + (move word-index index) + (inst shr word-index ,bit-shift) + (inst mov old + (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + object word-index n-word-bytes)) + (move ecx index) + ;; We used to mask ECX for all values of BITS, but since + ;; Intel's documentation says that the chip will mask shift + ;; and rotate counts by 63 automatically, we can safely move + ;; the masking operation under the protection of this UNLESS + ;; in the bit-vector case. --njf, 2006-07-14 + ,@(unless (= bits 1) + `((inst and ecx ,(1- elements-per-word)) + (inst shl ecx ,(1- (integer-length bits))))) + (inst ror old :cl) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst and old ,(lognot (1- (ash 1 bits))))) + (sc-case value + (immediate + (unless (zerop (tn-value value)) + (inst or old (logand (tn-value value) ,(1- (ash 1 bits)))))) + (unsigned-reg + (inst or old value))) + (inst rol old :cl) + (inst mov (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + object word-index n-word-bytes) + old))) + (define-vop (,(symbolicate 'data-vector-set-with-offset/ type "-C") dvset) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg immediate))) + (:arg-types ,type (:constant low-index) + (:constant (integer 0 0)) positive-fixnum) + (:temporary (:sc unsigned-reg) mask-tn) + (:info index addend) + (:ignore addend) + (:temporary (:sc unsigned-reg :to (:result 0)) old) + (:generator 20 + (unpoison-element object index) + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (inst mov old + (ea (- (* (+ word vector-data-offset) n-word-bytes) + other-pointer-lowtag) + object)) + (sc-case value + (immediate + (let* ((value (tn-value value)) + (mask ,(1- (ash 1 bits))) + (shift (* extra ,bits))) + (unless (= value mask) + (inst mov mask-tn (ldb (byte 64 0) + (lognot (ash mask shift)))) + (inst and old mask-tn)) + (unless (zerop value) + (inst mov mask-tn (ash value shift)) + (inst or old mask-tn)))) + (unsigned-reg + (let ((shift (* extra ,bits))) + (unless (zerop shift) + (inst ror old shift)) + (inst mov mask-tn (lognot ,(1- (ash 1 bits)))) + (inst and old mask-tn) + (inst or old value) + (unless (zerop shift) + (inst rol old shift))))) + (inst mov (ea (- (* (+ word vector-data-offset) n-word-bytes) + other-pointer-lowtag) + object) + old)))))))) (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. @@ -761,7 +800,7 @@ (define-vop (data-vector-ref-with-offset/simple-array-double-float dvref) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg signed-reg unsigned-reg))) (:info addend) (:arg-types simple-array-double-float tagged-num (:constant (constant-displacement other-pointer-lowtag @@ -769,8 +808,7 @@ (:results (value :scs (double-reg))) (:result-types double-float) (:generator 7 - (inst movsd value (float-ref-ea object index addend 8 - :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + (inst movsd value (float-ref-ea object index addend 8 :scale (index-scale 8 index))))) (define-vop (data-vector-ref-c/simple-array-double-float dvref) (:args (object :scs (descriptor-reg))) @@ -785,7 +823,7 @@ (define-vop (data-vector-set-with-offset/simple-array-double-float dvset) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg signed-reg unsigned-reg)) (value :scs (double-reg))) (:info addend) (:arg-types simple-array-double-float tagged-num @@ -794,9 +832,7 @@ double-float) (:generator 20 (unpoison-element object index addend) - (inst movsd (float-ref-ea object index addend 8 - :scale (ash 1 (- word-shift n-fixnum-tag-bits))) - value))) + (inst movsd (float-ref-ea object index addend 8 :scale (index-scale 8 index)) value))) (define-vop (data-vector-set-with-offset/simple-array-double-float-c dvset) (:args (object :scs (descriptor-reg)) @@ -923,10 +959,10 @@ operand-size `(,operand-size ,(if (eq mov-inst 'movzx) :dword :qword)))) (n-bytes (the (member 1 2 4) (size-nbyte operand-size))) - ((index-sc scale) + ((index-scs scale) (if (>= n-bytes (ash 1 n-fixnum-tag-bits)) - (values 'any-reg (ash n-bytes (- n-fixnum-tag-bits))) - (values 'signed-reg n-bytes))) + (values '(any-reg signed-reg unsigned-reg) `(index-scale ,n-bytes index)) + (values '(signed-reg unsigned-reg) n-bytes))) (ea-expr `(ea (+ (* vector-data-offset n-word-bytes) (* addend ,n-bytes) (- other-pointer-lowtag)) @@ -938,7 +974,7 @@ `(progn (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype) dvref) (:args (object :scs (descriptor-reg)) - (index :scs (,index-sc))) + (index :scs ,index-scs)) (:info addend) (:arg-types ,ptype tagged-num (:constant (constant-displacement other-pointer-lowtag @@ -958,7 +994,7 @@ ;; FIXME: these all need to accept immediate SC for the value (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype) dvset) (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (,index-sc) :to (:eval 0)) + (index :scs ,index-scs :to (:eval 0)) (value :scs ,scs)) (:info addend) (:arg-types ,ptype tagged-num diff -Nru sbcl-2.1.10/src/compiler/x86-64/avx2-insts.lisp sbcl-2.1.11/src/compiler/x86-64/avx2-insts.lisp --- sbcl-2.1.10/src/compiler/x86-64/avx2-insts.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/avx2-insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -753,14 +753,12 @@ (:emitter (cond ((and (xmm-register-p dst) (ea-p src)) - (emit-avx2-inst segment dst src ,prefix #x10 :l 0)) + (emit-avx2-inst segment src dst ,prefix #x10 :l 0)) ((xmm-register-p dst) - (emit-avx2-inst segment dst src2 ,prefix #x10 :vvvv src - :l 0)) + (emit-avx2-inst segment dst src2 ,prefix #x10 :vvvv src :l 0)) (t (aver (xmm-register-p src)) - (emit-avx2-inst segment src dst ,prefix #x11 - :l 0))))))) + (emit-avx2-inst segment dst src ,prefix #x11 :l 0))))))) (def vmovsd #xf2) (def vmovss #xf3)) diff -Nru sbcl-2.1.10/src/compiler/x86-64/call.lisp sbcl-2.1.11/src/compiler/x86-64/call.lisp --- sbcl-2.1.10/src/compiler/x86-64/call.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,29 +14,9 @@ (defconstant arg-count-sc (make-sc+offset any-reg-sc-number rcx-offset)) (defconstant closure-sc (make-sc+offset any-reg-sc-number rax-offset)) -;;; Make a passing location TN for a local call return PC. -;;; -;;; Always wire the return PC location to the stack in its standard -;;; location. -(defun make-return-pc-passing-location (standard) - (declare (ignore standard)) - (make-wired-tn (primitive-type-or-lose 'system-area-pointer) - sap-stack-sc-number return-pc-save-offset)) - (defconstant return-pc-passing-offset (make-sc+offset sap-stack-sc-number return-pc-save-offset)) -;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a -;;; location to pass OLD-FP in. -;;; -;;; This is wired in both the standard and the local-call conventions, -;;; because we want to be able to assume it's always there. Besides, -;;; the x86 doesn't have enough registers to really make it profitable -;;; to pass it in a register. -(defun make-old-fp-passing-location () - (make-wired-tn *fixnum-primitive-type* control-stack-sc-number - ocfp-save-offset)) - (defconstant old-fp-passing-offset (make-sc+offset control-stack-sc-number ocfp-save-offset)) @@ -46,16 +26,17 @@ ;;; ;;; Without using a save-tn - which does not make much sense if it is ;;; wired to the stack? -(defun make-old-fp-save-location (physenv) - (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type* - control-stack-sc-number - ocfp-save-offset) - physenv)) -(defun make-return-pc-save-location (physenv) - (physenv-debug-live-tn - (make-wired-tn (primitive-type-or-lose 'system-area-pointer) - sap-stack-sc-number return-pc-save-offset) - physenv)) +(defun make-old-fp-save-location () + (let ((tn (make-wired-tn *fixnum-primitive-type* + control-stack-sc-number + ocfp-save-offset))) + (setf (tn-kind tn) :environment) + tn)) +(defun make-return-pc-save-location () + (let ((tn (make-wired-tn (primitive-type-or-lose 'system-area-pointer) + sap-stack-sc-number return-pc-save-offset))) + (setf (tn-kind tn) :environment) + tn)) ;;; Make a TN for the standard argument count passing location. We only ;;; need to make the standard location, since a count is never passed when we diff -Nru sbcl-2.1.10/src/compiler/x86-64/cell.lisp sbcl-2.1.11/src/compiler/x86-64/cell.lisp --- sbcl-2.1.10/src/compiler/x86-64/cell.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -39,7 +39,6 @@ (:results) (:vop-var vop) (:temporary (:sc unsigned-reg) val-temp) - #-ubsan (:ignore name) (:generator 1 (cond #+ubsan ((and (eql offset sb-vm:array-fill-pointer-slot) ; half-sized slot @@ -50,19 +49,27 @@ (inst mov :dword (vector-len-ea object) (or (encode-value-if-immediate value) value))) (t + ;; gencgc does not need to emit the barrier for constructors + (unless (member name '(%make-structure-instance make-weak-pointer + %make-ratio %make-complex)) + (emit-gc-store-barrier object nil val-temp (vop-nth-arg 1 vop) value)) (gen-cell-set (object-slot-ea object offset lowtag) value val-temp))))) (define-vop (compare-and-swap-slot) (:args (object :scs (descriptor-reg) :to :eval) - (old :scs (descriptor-reg any-reg) :target rax) + (old :scs (descriptor-reg any-reg) #|:target rax|#) (new :scs (descriptor-reg any-reg))) + ;; if OLD were LOCATION= to RAX then we'd clobber OLD + ;; while computing the EA for the barrier. (:temporary (:sc descriptor-reg :offset rax-offset - :from (:argument 1) :to :result :target result) + #|:from (:argument 1)|# :to :result :target result) rax) (:info name offset lowtag) (:ignore name) (:results (result :scs (descriptor-reg any-reg))) + (:vop-var vop) (:generator 5 + (emit-gc-store-barrier object nil rax (vop-nth-arg 2 vop) new) (move rax old) (inst cmpxchg :lock (ea (- (* offset n-word-bytes) lowtag) object) new) (move result rax))) @@ -80,7 +87,9 @@ (value :scs (descriptor-reg any-reg immediate))) (:policy :fast-safe) (:temporary (:sc unsigned-reg) val-temp) + (:vop-var vop) (:generator 4 + (emit-gc-store-barrier object nil val-temp (vop-nth-arg 1 vop) value) (gen-cell-set (if (sc-is object immediate) (symbol-slot-ea (tn-value object) symbol-value-slot) (object-slot-ea object symbol-value-slot other-pointer-lowtag)) @@ -153,7 +162,6 @@ (new :scs (descriptor-reg any-reg))) (:temporary (:sc descriptor-reg :offset rax-offset :from (:argument 1) :to (:result 0)) rax) - #+sb-thread (:temporary (:sc descriptor-reg :to (:result 0)) cell) #+gs-seg (:temporary (:sc unsigned-reg) thread-temp) (:results (result :scs (descriptor-reg any-reg))) @@ -166,6 +174,8 @@ ;; Even worse: don't supply old=NO-TLS-VALUE with a symbol whose ;; tls-index=0, because that would succeed, assigning NEW to each ;; symbol in existence having otherwise no thread-local value. + ;; Possible optimization: don't frob the card mark when storing into TLS + (emit-gc-store-barrier symbol nil cell (vop-nth-arg 2 vop) new) (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))) #+sb-thread (progn (compute-virtual-symbol) (move rax old) @@ -180,13 +190,17 @@ (define-vop (%cas-symbol-global-value) (:translate %cas-symbol-global-value) (:args (symbol :scs (descriptor-reg immediate) :to (:result 0)) - (old :scs (descriptor-reg any-reg) :target rax) + (old :scs (descriptor-reg any-reg) #|:target rax|#) (new :scs (descriptor-reg any-reg))) + ;; if OLD were LOCATION= to RAX then we'd clobber OLD + ;; while computing the EA for the barrier. (:temporary (:sc descriptor-reg :offset rax-offset - :from (:argument 1) :to (:result 0)) rax) + #|:from (:argument 1)|# :to (:result 0)) rax) (:results (result :scs (descriptor-reg any-reg))) (:policy :fast-safe) + (:vop-var vop) (:generator 10 + (emit-gc-store-barrier symbol nil rax (vop-nth-arg 2 vop) new) (move rax old) (inst cmpxchg :lock (if (sc-is symbol immediate) @@ -207,7 +221,10 @@ (:temporary (:sc descriptor-reg) cell) (:temporary (:sc unsigned-reg) val-temp) #+gs-seg (:temporary (:sc unsigned-reg) thread-temp) + (:vop-var vop) (:generator 4 + ;; Possible optimization: don't frob the card mark when storing into TLS + (emit-gc-store-barrier symbol nil val-temp (vop-nth-arg 1 vop) value) ;; Compute the address into which to store. CMOV can only move into ;; a register, so we can't conditionally move into the TLS and ;; conditionally move in the opposite flag sense to the symbol. @@ -456,6 +473,7 @@ (:temporary (:sc unsigned-reg) raw) (:results (result :scs (descriptor-reg))) (:generator 38 + (emit-gc-store-barrier fdefn nil raw) (inst mov raw (make-fixup 'closure-tramp :assembly-routine)) (inst cmp :byte (ea (- fun-pointer-lowtag) function) simple-fun-widetag) @@ -474,6 +492,8 @@ (:generator 38 ;; N.B. concerning the use of pseudo-atomic here, ;; refer to doc/internals-notes/fdefn-gc-safety + ;; No barrier here, because fdefns in immobile space rely on the SIGSEGV signal + ;; to manage the card marks. (pseudo-atomic () (storew function fdefn fdefn-fun-slot other-pointer-lowtag) (storew raw-word fdefn fdefn-raw-addr-slot other-pointer-lowtag) @@ -574,6 +594,7 @@ (store-binding-stack-pointer bsp) (storew temp bsp (- binding-value-slot binding-size)) (storew symbol bsp (- binding-symbol-slot binding-size)) + (emit-gc-store-barrier symbol nil temp) (storew val symbol symbol-value-slot other-pointer-lowtag))) #+sb-thread @@ -603,6 +624,7 @@ (:generator 0 (load-binding-stack-pointer bsp) (loadw symbol bsp (- binding-symbol-slot binding-size)) + (emit-gc-store-barrier symbol nil value) ; VALUE is the card-mark temp (loadw value bsp (- binding-value-slot binding-size)) (storew value symbol symbol-value-slot other-pointer-lowtag) (storew 0 bsp (- binding-symbol-slot binding-size)) @@ -630,12 +652,11 @@ (loadw symbol bsp binding-symbol-slot) (inst test symbol symbol)) (inst jmp :z SKIP) - (loadw value bsp binding-value-slot) - #-sb-thread - (storew value symbol symbol-value-slot other-pointer-lowtag) - #+sb-thread - (inst mov (thread-tls-ea symbol) value) - + #-sb-thread (progn (emit-gc-store-barrier symbol nil value) ; VALUE is the card-mark temp + (loadw value bsp binding-value-slot) + (storew value symbol symbol-value-slot other-pointer-lowtag)) + #+sb-thread (progn (loadw value bsp binding-value-slot) + (inst mov (thread-tls-ea symbol) value)) SKIP (inst movapd (ea bsp) zero) @@ -658,9 +679,8 @@ closure-info-offset fun-pointer-lowtag (any-reg descriptor-reg) * %closure-index-ref) -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (any-reg descriptor-reg) * %set-funcallable-instance-info) +(define-full-setter %closure-index-set * closure-info-offset fun-pointer-lowtag + (any-reg descriptor-reg) * %closure-index-set) (define-full-reffer funcallable-instance-info * funcallable-instance-info-offset fun-pointer-lowtag @@ -678,12 +698,14 @@ (value :scs (descriptor-reg any-reg))) (:info offset) (:generator 4 + ;; TODO: gencgc does not need EMIT-GC-STORE-BARRIER here, but other other GC strategies might. (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 + ;; TODO: gencgc does not need EMIT-GC-STORE-BARRIER here, but other other GC strategies might. (storew rbp-tn object (+ closure-info-offset offset) fun-pointer-lowtag))) ;;;; value cell hackery @@ -696,24 +718,104 @@ ;;;; structure hackery +(defun load-instance-length (result instance taggedp) + (inst mov :dword result (ea (- instance-pointer-lowtag) instance)) + ;; Returning fixnum/any-reg elides some REX prefixes due to the shifts + ;; being small. Maybe the asm optimizer could figure it out now? + (cond (taggedp + (inst shr :dword result (- instance-length-shift n-fixnum-tag-bits)) + (inst and :dword result (fixnumize instance-length-mask))) + (t + (inst shr :dword result instance-length-shift) + (inst and :dword result instance-length-mask)))) + (define-vop () (:policy :fast-safe) (:translate %instance-length) (:args (struct :scs (descriptor-reg))) (:results (res :scs (any-reg))) (:result-types positive-fixnum) - (:generator 4 - (inst mov :dword res (ea (- instance-pointer-lowtag) struct)) - ;; Returning fixnum/any-reg elides some REX prefixes due to the shifts - ;; being small. Maybe the asm optimizer could figure it out now? - (inst shr :dword res (- instance-length-shift n-fixnum-tag-bits)) - (inst and :dword res (fixnumize instance-length-mask)))) + (:generator 4 (load-instance-length res struct t))) (define-full-reffer instance-index-ref * instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref) (define-full-setter instance-index-set * instance-slots-offset - instance-pointer-lowtag (any-reg descriptor-reg immediate) * %instance-set) + instance-pointer-lowtag (any-reg descriptor-reg immediate constant) * %instance-set) + +;;; Try to group consecutive %INSTANCE-SET vops on the same instance +;;; so that: +;;; 1) we can potentially utilize multi-word stores, +;;; 2) a GC store barrier need occur once only (depending on the kind of barrier) +;;; +;;; in the absence of barriers, we would like to be allowed to rearrange +;;; stores; in particular, storing the constant 0 to clear out a structure +;;; should not require that you remember the slot order. +;;; all the more so if we are permitted to optimize the slot order of the defstruct +;;; by putting all tagged slots together, then all raw slots together. +;;; +(define-vop (instance-set-multiple) + (:args (instance :scs (descriptor-reg)) + (values :more t :scs (descriptor-reg constant immediate))) + (:temporary (:sc unsigned-reg) val-temp) + ;; Would like to try to store adjacent 0s (and/or NILs) using 16 byte stores. + (:temporary (:sc int-sse-reg) xmm-temp) + (:info indices) + (:generator 1 + (let* ((max-index (reduce #'max indices)) + ;;(min-index (reduce #'min indices)) + ;;(count (length indices)) + (zerop-mask 0) ; slots which become a zero + (constantp-mask 0) ; slots which become any constant + (const-vals (make-array (1+ max-index) :initial-element nil)) + (use-xmm-p)) + (do ((tn-ref values (tn-ref-across tn-ref)) + (indices indices (cdr indices))) + ((null tn-ref)) + (let ((tn (tn-ref-tn tn-ref))) + (when (constant-tn-p tn) + (let ((slot (car indices)) + (val (tn-value tn))) + (setf constantp-mask (logior constantp-mask (ash 1 slot)) + zerop-mask (logior zerop-mask (if (eql val 0) (ash 1 slot) 0)) + (aref const-vals slot) val))))) + ;; If there are at least 3 zeros stored or any pair of adjacent 0s + ;; then load the xmm-temp with 0. + (setq use-xmm-p (or (>= (logcount zerop-mask) 3) + (loop for slot below max-index + thereis (= (ldb (byte 2 slot) zerop-mask) #b11)))) + (emit-gc-store-barrier instance nil val-temp values) + (when use-xmm-p + (inst xorpd xmm-temp xmm-temp)) + (loop + (let* ((slot (pop indices)) + (val (tn-ref-tn values)) + (ea (ea (- (ash (+ instance-slots-offset slot) word-shift) + instance-pointer-lowtag) + instance))) + (aver (tn-p instance)) + (setq values (tn-ref-across values)) + ;; If the xmm temp was loaded with 0 and this value is 0, + ;; and possibly the next, then store through the temp + (cond + ((and use-xmm-p (constant-tn-p val) (eql (tn-value val) 0)) + (let* ((next-slot (car indices)) + (next-val (if next-slot (tn-ref-tn values)))) + (cond ((and (eql (1+ slot) next-slot) + (constant-tn-p next-val) + (eql (tn-value next-val) 0)) + (inst movupd ea xmm-temp) + (pop indices) + (setq values (tn-ref-across values))) + (t + (inst movsd ea xmm-temp))))) + ((stack-tn-p val) + (inst mov val-temp val) + (inst mov ea val-temp)) + (t + (gen-cell-set ea val val-temp))) + (unless indices (return))))) + (aver (not values)))) (define-full-compare-and-swap %instance-cas instance instance-slots-offset instance-pointer-lowtag @@ -863,19 +965,26 @@ (move result-lo rax) ; move low part first (move result-hi rdx)))) +;;; TODO: these GC-STORE-BARRIERs are inadequate if the GC strategy +;;; requires that 2 old pointees and 2 new pointees all be greyed. (macrolet - ((define-cmpxchg-vop (name memory-operand more-stuff &optional index-arg) - `(define-vop (,name) + ((define-dblcas (translate indexedp &rest rest) + `(define-vop () (:policy :fast-safe) - ,@more-stuff + (:translate ,translate) (:args (object :scs (descriptor-reg) :to :eval) - ,@index-arg + ,@(when indexedp '((index :scs (any-reg) :to :eval))) (expected-old-lo :scs (descriptor-reg any-reg) :target eax) (expected-old-hi :scs (descriptor-reg any-reg) :target edx) (new-lo :scs (descriptor-reg any-reg) :target ebx) (new-hi :scs (descriptor-reg any-reg) :target ecx)) + ,@(when indexedp '((:arg-types * positive-fixnum * * * *))) + ,@rest (:results (result-lo :scs (descriptor-reg any-reg)) (result-hi :scs (descriptor-reg any-reg))) + ;; this is sufficiently confusing that I don't want to try reusing + ;; one of the other declared temps as the EA for the store barrier. + (:temporary (:sc unsigned-reg) temp) (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 2) :to (:result 0)) eax) (:temporary (:sc unsigned-reg :offset rdx-offset @@ -883,28 +992,32 @@ (:temporary (:sc unsigned-reg :offset rbx-offset :from (:argument 4) :to (:result 0)) ebx) (:temporary (:sc unsigned-reg :offset rcx-offset - :from (:argument 5) :to (:result 0)) ecx) - (:generator 7 - (generate-dblcas ,memory-operand - expected-old-lo expected-old-hi new-lo new-hi - eax ebx ecx edx result-lo result-hi))))) - (define-cmpxchg-vop compare-and-exchange-pair - (ea (- list-pointer-lowtag) object) - ((:translate %cons-cas-pair))) - (define-cmpxchg-vop compare-and-exchange-pair-indexed - (ea offset object index (ash n-word-bytes (- n-fixnum-tag-bits))) - ((:variant-vars offset)) - ((index :scs (descriptor-reg any-reg) :to :eval)))) - -;; The CPU requires 16-byte alignment for the memory operand. -;; A vector's data portion starts on a 16-byte boundary, -;; so any even numbered index is OK. -(define-vop (%vector-cas-pair compare-and-exchange-pair-indexed) - (:translate %vector-cas-pair) - (:variant (- (* n-word-bytes vector-data-offset) other-pointer-lowtag))) - -;; Here you specify an odd numbered slot, otherwise get a bus error. -;; An instance's first user-visible slot at index 1 is 16-byte-aligned. -(define-vop (%instance-cas-pair compare-and-exchange-pair-indexed) - (:translate %instance-cas-pair) - (:variant (- (* n-word-bytes instance-slots-offset) instance-pointer-lowtag))) + :from (:argument 5) :to (:result 0)) ecx)))) + + (define-dblcas %cons-cas-pair nil + (:generator 2 + (emit-gc-store-barrier object nil temp) + (generate-dblcas (ea (- list-pointer-lowtag) object) + expected-old-lo expected-old-hi new-lo new-hi + eax ebx ecx edx result-lo result-hi))) + + ;; The CPU requires 16-byte alignment for the memory operand. + ;; A vector's data portion starts on a 16-byte boundary, so any even numbered index is OK. + (define-dblcas %vector-cas-pair t + (:generator 2 + (let ((ea (ea (- (* n-word-bytes vector-data-offset) other-pointer-lowtag) + object index (ash n-word-bytes (- n-fixnum-tag-bits))))) + (emit-gc-store-barrier object ea temp) + (generate-dblcas ea expected-old-lo expected-old-hi new-lo new-hi + eax ebx ecx edx result-lo result-hi)))) + + ;; Here you have to specify an odd numbered slot. + ;; An instance's first user-visible slot at index 1 is 16-byte-aligned. + ;; (Hmm, does the constraint differ by +/- compact-instance-header?) + (define-dblcas %instance-cas-pair t + (:generator 2 + (emit-gc-store-barrier object nil temp) + (let ((ea (ea (- (* n-word-bytes instance-slots-offset) instance-pointer-lowtag) + object index (ash n-word-bytes (- n-fixnum-tag-bits))))) + (generate-dblcas ea expected-old-lo expected-old-hi new-lo new-hi + eax ebx ecx edx result-lo result-hi))))) diff -Nru sbcl-2.1.10/src/compiler/x86-64/insts.lisp sbcl-2.1.11/src/compiler/x86-64/insts.lisp --- sbcl-2.1.10/src/compiler/x86-64/insts.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1729,7 +1729,8 @@ (emit-byte segment it)) ((or (integerp src) (and (fixup-p src) - (memq (fixup-flavor src) '(:layout-id :layout :immobile-symbol)))) + (memq (fixup-flavor src) '(:layout-id :layout :immobile-symbol + :gc-barrier)))) (emit-prefixes segment dst nil size :lock (lockp prefix)) (cond ((accumulator-p dst) (emit-byte segment @@ -3309,11 +3310,15 @@ ;;; 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. +;;; 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) +(defun fixup-code-object (code offset value kind flavor) (declare (type index offset)) (sb-vm::with-code-instructions (sap code) + (when (eq flavor :gc-barrier) + ;; the VALUE is nbits, so convert it to an AND mask + (setf (sap-ref-32 sap offset) (1- (ash 1 value))) + (return-from fixup-code-object :immediate)) ;; 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. diff -Nru sbcl-2.1.10/src/compiler/x86-64/macros.lisp sbcl-2.1.11/src/compiler/x86-64/macros.lisp --- sbcl-2.1.10/src/compiler/x86-64/macros.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -212,6 +212,13 @@ `(progn ,@forms (unless ,elide-if (emit-safepoint))) #-sb-safepoint (with-unique-names (label pa-bits-ea) + (let ((true + ;; TRUE is anything nonzero. Moving a register to memory is + ;; allegedly faster than reading an imm8 operand. I don't know, + ;; but I'm not going to debate it. However THREAD-TN is a better + ;; choice than RBP-TN since it's never written to. + #+(and sb-thread (not gs-seg)) 'thread-tn + #-(and sb-thread (not gs-seg)) 'rbp-tn)) `(let ((,label (gen-label)) (,pa-bits-ea #+sb-thread (thread-slot-ea @@ -219,18 +226,25 @@ #+gs-seg ,@(if thread (list thread))) #-sb-thread (static-symbol-value-ea '*pseudo-atomic-bits*))) (unless ,elide-if - (inst mov ,pa-bits-ea rbp-tn)) + (inst mov ,pa-bits-ea ,true)) ,@forms (unless ,elide-if - (inst xor ,pa-bits-ea rbp-tn) + (inst xor ,pa-bits-ea ,true) (inst jmp :z ,label) ;; if PAI was set, interrupts were disabled at the same time ;; using the process signal mask. - (inst break pending-interrupt-trap) - (emit-label ,label))))) + #+linux (inst icebp) + #-linux (inst break pending-interrupt-trap) + (emit-label ,label)))))) ;;;; indexed references +(defun index-scale (element-size index-tn) + (if (sc-is index-tn immediate) + 1 + (ash element-size + (if (sc-is index-tn any-reg) (- n-fixnum-tag-bits) 0)))) + (sb-xc:deftype load/store-index (scale lowtag min-offset &optional (max-offset min-offset)) `(integer ,(- (truncate (+ (ash 1 16) @@ -250,25 +264,36 @@ (:args (object :scs (descriptor-reg) :to :eval) (index :scs (,@(when (member translate '(%instance-cas %raw-instance-cas/word)) '(immediate)) - any-reg) :to :eval) - (old-value :scs ,scs :target rax) + any-reg signed-reg unsigned-reg) :to :eval) + (old-value :scs ,scs #|:target rax|#) (new-value :scs ,scs)) + (:vop-var vop) (:arg-types ,type tagged-num ,el-type ,el-type) + ;; if OLD-VALUE were LOCATION= to RAX then we'd clobber it + ;; while computing the EA for the barrier, or else we could use + ;; a separate temp. (:temporary (:sc descriptor-reg :offset rax-offset - :from (:argument 2) :to :result :target value) rax) + #|:from (:argument 2)|# :to :result :target value) rax) (:results (value :scs ,scs)) (:result-types ,el-type) (:generator 5 - (move rax old-value) - (inst cmpxchg :lock - (ea (- (* (+ (if (sc-is index immediate) (tn-value index) 0) ,offset) + (let ((ea (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) - (move value rax))))) + (index-scale n-word-bytes index)))) + ,@(ecase name + (%compare-and-swap-svref + ;; store barrier needs the EA of the affected element + '((emit-gc-store-barrier object ea rax (vop-nth-arg 3 vop) new-value))) + (%instance-cas + ;; store barrier affects only the object's base address + '((emit-gc-store-barrier object nil rax (vop-nth-arg 3 vop) new-value))) + (%raw-instance-cas/word)) + (move rax old-value) + (inst cmpxchg :lock ea new-value) + (move value rax)))))) (defun bignum-index-check (bignum index addend vop) (declare (ignore bignum index addend vop)) @@ -292,7 +317,7 @@ (:translate ,translate) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg signed-reg unsigned-reg))) (:arg-types ,type tagged-num) (:results (value :scs ,scs)) (:result-types ,el-type) @@ -301,7 +326,7 @@ ,@(when (eq translate 'sb-bignum:%bignum-ref) '((bignum-index-check object index 0 vop))) (inst mov value (ea (- (* ,offset n-word-bytes) ,lowtag) - object index (ash 1 (- word-shift n-fixnum-tag-bits)))))) + object index (index-scale n-word-bytes index))))) (define-vop (,(symbolicate name "-C")) (:translate ,translate) (:policy :fast-safe) @@ -341,7 +366,7 @@ (:translate ,translate) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg signed-reg unsigned-reg))) (:info addend) (:arg-types ,type tagged-num (:constant (constant-displacement other-pointer-lowtag @@ -353,7 +378,7 @@ ,@(when (eq translate 'sb-bignum:%bignum-ref-with-offset) '((bignum-index-check object index addend vop))) (let ((ea (ea (- (* (+ ,offset addend) n-word-bytes) ,lowtag) - object index (ash 1 (- word-shift n-fixnum-tag-bits))))) + object index (index-scale n-word-bytes index)))) ,@(trap 'index) (inst mov value ea)))) ;; This vop is really not ideal to have. Couldn't we recombine two constants @@ -378,14 +403,14 @@ ,@(trap '(emit-constant (+ index addend))) (inst mov value ea))))))) -;;; used for (SB-BIGNUM:%BIGNUM-SET %SET-FUNCALLABLE-INSTANCE-INFO -;;; %SET-ARRAY-DIMENSION %SET-VECTOR-RAW-BITS) +;;; used for: INSTANCE-INDEX-SET %CLOSURE-INDEX-SET +;;; SB-BIGNUM:%BIGNUM-SET %SET-ARRAY-DIMENSION %SET-VECTOR-RAW-BITS (defmacro define-full-setter (name type offset lowtag scs el-type translate) `(define-vop (,name) (:translate ,translate) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg immediate)) + (index :scs (any-reg immediate signed-reg unsigned-reg)) (value :scs ,scs)) (:arg-types ,type tagged-num ,el-type) (:vop-var vop) @@ -397,5 +422,7 @@ (ea (- (* (+ ,offset (tn-value index)) n-word-bytes) ,lowtag) object) (ea (- (* ,offset n-word-bytes) ,lowtag) - object index (ash 1 (- word-shift n-fixnum-tag-bits)))))) + object index (index-scale n-word-bytes index))))) + ,@(when (member name '(instance-index-set %closure-index-set)) + '((emit-gc-store-barrier object nil val-temp (vop-nth-arg 2 vop) value))) (gen-cell-set ea value val-temp))))) diff -Nru sbcl-2.1.10/src/compiler/x86-64/memory.lisp sbcl-2.1.11/src/compiler/x86-64/memory.lisp --- sbcl-2.1.10/src/compiler/x86-64/memory.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/memory.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,8 +18,45 @@ (+ nil-value (static-symbol-offset symbol) offset) (make-fixup symbol :immobile-symbol offset))))) +;;; TODOs: +;;; 1. Sometimes people write constructors like +;;; (defun make-foo (&key a b c) +;;; (let ((new-foo (really-make-foo))) +;;; (when should-set-a (setf (foo-a new-foo) a)) +;;; (when should-set-b (setf (foo-b new-foo) b)) +;;; ... +;;; In this case, the asssignments are constructor-like. Even though +;;; they look mutating, the store barrier can be omitted. +;;; I think the general idea is that if a slot of a newly +;;; constructed thing receives the value of an incoming +;;; argument, the object in that argument can't possibly +;;; be younger than the newly constructed thing. +;;; 2. hash-table k/v pair should mark once only. +;;; (the vector elements are certainly on the same card) +(defun emit-gc-store-barrier (object cell-address scratch-reg &optional value-tn-ref value-tn) + (when (sc-is object constant immediate) + (aver (symbolp (tn-value object)))) + (when (require-gc-store-barrier-p object value-tn-ref value-tn) + (if cell-address ; for SIMPLE-VECTOR, the page holding the specific element index gets marked + (inst lea scratch-reg cell-address) + ;; OBJECT could be a symbol in immobile space + (inst mov scratch-reg (encode-value-if-immediate object))) + (inst shr scratch-reg gencgc-card-shift) + ;; gc_allocate_ptes() asserts mask to be < 32 bits, which is hugely generous. + (inst and :dword scratch-reg card-index-mask) + ;; I wanted to use thread-tn as the source of the store, but it isn't 256-byte-aligned + ;; due to presence of negatively indexed thread header slots. + ;; Probably word-alignment is enough, because we can just check the lowest bit, + ;; borrowing upon the idea from PSEUDO-ATOMIC which uses RBP-TN as the source. + ;; I'd like to measure to see if using a register is actually better. + ;; If all threads store 0, it might be easier on the CPU's store buffer. + ;; Otherwise, it has to remember who "wins". 0 makes it indifferent. + (inst mov :byte (ea gc-card-table-reg-tn scratch-reg) + (or #| #+(or (not sb-thread) gs-seg) |# 0 thread-tn)))) + (defun gen-cell-set (ea value val-temp) - (if (sc-is value immediate) + (sc-case value + (immediate (let ((bits (encode-value-if-immediate value))) ;; Try to move imm-to-mem if BITS fits (acond ((or (and (fixup-p bits) @@ -30,8 +67,12 @@ (inst mov :qword ea it)) (t (inst mov val-temp bits) - (inst mov ea val-temp)))) - (inst mov :qword ea value))) + (inst mov ea val-temp))))) + (constant + (inst mov val-temp value) + (inst mov :qword ea val-temp)) + (t + (inst mov :qword ea value)))) ;;; 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. @@ -50,8 +91,11 @@ (:variant-vars offset lowtag) (:policy :fast-safe) (:temporary (:sc unsigned-reg) val-temp) + (:vop-var vop) (:generator 4 - (gen-cell-set (object-slot-ea object offset lowtag) value val-temp))) + (emit-gc-store-barrier object nil val-temp (vop-nth-arg 1 vop) value) + (let ((ea (object-slot-ea object offset lowtag))) + (gen-cell-set ea value val-temp)))) ;;; X86 special (define-vop (cell-xadd) diff -Nru sbcl-2.1.10/src/compiler/x86-64/nlx.lisp sbcl-2.1.11/src/compiler/x86-64/nlx.lisp --- sbcl-2.1.10/src/compiler/x86-64/nlx.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -186,6 +186,19 @@ (inst jmp defaulting-done)))))) (inst mov rsp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (start)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-label label) + (note-this-location vop :non-local-entry) + (inst mov res start) + (inst mov rsp-tn sp))) + (define-vop (nlx-entry-multiple) (:args (top :target result :scs (any-reg)) diff -Nru sbcl-2.1.10/src/compiler/x86-64/parms.lisp sbcl-2.1.11/src/compiler/x86-64/parms.lisp --- sbcl-2.1.10/src/compiler/x86-64/parms.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/parms.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -20,21 +20,27 @@ (defconstant-eqx +fixup-kinds+ #(:absolute :relative :absolute64) #'equalp) -;;; KLUDGE: It would seem natural to set this by asking our C runtime -;;; code for it, but mostly we need it for GENESIS, which doesn't in -;;; general have our C runtime code running to ask, so instead we set -;;; it by hand. -- WHN 2001-04-15 -;;; -;;; Actually any information that we can retrieve C-side would be -;;; useless in SBCL, since it's possible for otherwise binary -;;; compatible systems to return different values for getpagesize(). -;;; -- JES, 2007-01-06 +;;; This size is supposed to indicate something about the actual granularity +;;; at which you can map memory. We just hardwire it, but that may or may not +;;; be necessary any more. (defconstant +backend-page-bytes+ #+win32 65536 #-win32 32768) ;;; The size in bytes of GENCGC cards, i.e. the granularity at which -;;; writes to old generations are logged. With mprotect-based write -;;; barriers, this must be a multiple of the OS page size. -(defconstant gencgc-card-bytes +backend-page-bytes+) +;;; writes to old generations are logged. +;;; The size is a trade-off between efficiency of the allocator +;;; and efficiency of scanning. Generally a card-marking GC will use cards +;;; that are fairly small - The JVM used to use 512, I don't know if it still does. +;;; I've heard of as small as 64 bytes being used in academic papers. +;;; SBCL however has a problem with small sizes for two reasons: +;;; (1) the size in which we claim memory in the slow-path allocator is exactly +;;; the card size times a multiplier that does not work very well, and in fact +;;; will work worse once I checkin a change to improve concurrency within the +;;; slow path (2) heap scans can't begin at an arbitrary card because it might +;;; the middle of a partly-boxed object. So we need to distinguish between +;;; *strictly* boxed pages, and mixed-tagged/raw-word pages. +;;; Alternatively, GC could try to skip over the cards at the start of a contiguous +;;; block until it gets to the cards that are actully marked. +(defconstant gencgc-card-bytes 16384) ;;; The minimum size of new allocation regions. While it doesn't ;;; currently make a lot of sense to have a card size lower than ;;; the alloc granularity, it will, once we are smarter about finding diff -Nru sbcl-2.1.10/src/compiler/x86-64/system.lisp sbcl-2.1.11/src/compiler/x86-64/system.lisp --- sbcl-2.1.10/src/compiler/x86-64/system.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/system.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -219,15 +219,21 @@ (:args (x :scs (descriptor-reg))) (:info bits) (:arg-types t (:constant (unsigned-byte 8))) - (:generator 1 (inst mov :byte (ea (- 1 other-pointer-lowtag) x) bits))) + (:generator 1 + (inst mov :byte (ea (- (/ array-flags-position n-word-bytes) other-pointer-lowtag) x) + bits))) (define-vop () (:translate reset-header-bits) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:arg-types t (:constant (unsigned-byte 8))) + (:arg-types t (:constant (unsigned-byte 16))) (:info bits) (:generator 1 - (inst and :byte (ea (- 1 other-pointer-lowtag) x) (logandc1 bits #xff)))) + (let ((byte 1)) + (when (> bits #xff) + (setf bits (ash bits -8)) + (setf byte 2)) + (inst and :byte (ea (- byte other-pointer-lowtag) x) (logandc1 bits #xff))))) (define-vop (test-header-bit) (:translate test-header-bit) (:policy :fast-safe) @@ -236,10 +242,11 @@ (:arg-types t (:constant t)) (: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))) + (let ((byte 1)) + (when (> mask #xff) + (setf mask (ash mask -8)) + (setf byte 2)) + (inst test :byte (ea (- byte other-pointer-lowtag) array) mask)))) (define-vop (pointer-hash) (:translate pointer-hash) @@ -328,53 +335,27 @@ result)))) ;;;; symbol frobbing -(defun load-symbol-info-vector (result symbol) +(defun load-symbol-dbinfo (result symbol) (loadw result symbol symbol-info-slot other-pointer-lowtag) ;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is. ;; This CMOV safely reads from memory when it does not move, because if - ;; there is an info-vector in the slot, it has at least one element. - ;; Use bit index 3 of the lowtag to distinguish list from vector. - ;; A vector will have a 1 in that bit. + ;; there is a PACKED-INFO in the slot, it has at least 4 data words in total + ;; - the header, at least one info descriptor, and at least one datum. + ;; And since 3 is odd, that would be aligned up to 4. + ;; Use bit index 2 of the lowtag to distinguish list from instance. + ;; An instance will have a 0 in that bit. ;; This would compile to almost the same code without a VOP, ;; but using a jmp around a mov instead. - (aver (= (logior list-pointer-lowtag #b1000) other-pointer-lowtag)) - (inst test :byte result #b1000) - (inst cmov :e result - (object-slot-ea result cons-cdr-slot list-pointer-lowtag))) + (aver (= (logior instance-pointer-lowtag #b0100) list-pointer-lowtag)) + (inst test :byte result #b0100) + (inst cmov :nz result (object-slot-ea result cons-cdr-slot list-pointer-lowtag))) -(define-vop (symbol-info-vector) +(define-vop (symbol-dbinfo) (:policy :fast-safe) - (:translate symbol-info-vector) + (:translate symbol-dbinfo) (:args (x :scs (descriptor-reg))) (:results (res :scs (descriptor-reg))) - (:generator 1 (load-symbol-info-vector res x))) - -(define-vop (symbol-plist) - (:policy :fast-safe) - (:translate symbol-plist) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:temporary (:sc unsigned-reg) temp) - (:generator 1 - #-ubsan - (progn - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x) - ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist. - (loadw res res cons-car-slot list-pointer-lowtag) - (inst mov temp nil-value) - (inst test :byte res fixnum-tag-mask) - (inst cmov :e res temp)) - ;; This way doesn't assume that CAR and VECTOR-LENGTH are the same memory access. - ;; (And it's not even clear that using CMOV is preferable) - #+ubsan - (let ((out (gen-label))) - (loadw temp x symbol-info-slot other-pointer-lowtag) - (inst mov res nil-value) - (inst test :byte temp #b1000) ; if temp is a vector, return NIL - (inst jmp :ne out) - (loadw res temp cons-car-slot list-pointer-lowtag) - (emit-label out)))) + (:generator 1 (load-symbol-dbinfo res x))) ;;;; other miscellaneous VOPs diff -Nru sbcl-2.1.10/src/compiler/x86-64/type-vops.lisp sbcl-2.1.11/src/compiler/x86-64/type-vops.lisp --- sbcl-2.1.10/src/compiler/x86-64/type-vops.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/type-vops.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -518,7 +518,9 @@ (:args (object :scs (descriptor-reg)) (value :scs (any-reg descriptor-reg))) (:vop-var vop) + (:temporary (:sc unsigned-reg) temp) (:generator 1 + (emit-gc-store-barrier object nil temp (vop-nth-arg 1 vop) value) (inst mov :dword (ea (- 4 instance-pointer-lowtag) object) value))) (define-vop (%fun-layout %instance-layout) (:translate %fun-layout) @@ -526,6 +528,7 @@ (define-vop (%set-fun-layout %set-instance-layout) (:translate %set-fun-layout) (:generator 1 + (emit-gc-store-barrier object nil temp (vop-nth-arg 1 vop) value) (inst mov :dword (ea (- 4 fun-pointer-lowtag) object) value))) (define-vop () (:translate sb-c::layout-eq) diff -Nru sbcl-2.1.10/src/compiler/x86-64/values.lisp sbcl-2.1.11/src/compiler/x86-64/values.lisp --- sbcl-2.1.10/src/compiler/x86-64/values.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/values.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,7 +12,7 @@ (in-package "SB-VM") (define-vop (reset-stack-pointer) - (:args (ptr :scs (any-reg))) + (:args (ptr :scs (any-reg control-stack))) (:generator 1 (move rsp-tn ptr))) diff -Nru sbcl-2.1.10/src/compiler/x86-64/vm.lisp sbcl-2.1.11/src/compiler/x86-64/vm.lisp --- sbcl-2.1.10/src/compiler/x86-64/vm.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/compiler/x86-64/vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -81,6 +81,12 @@ ;;; shadow memory is pointed to by this register (RAX). (defconstant msan-temp-reg-number 0) +;;; The encoding anomaly for r12 makes it a perfect choice for the card table base. +;;; It will never be used with a constant displacement. +(define-symbol-macro card-table-reg 12) +(define-symbol-macro gc-card-table-reg-tn r12-tn) +(define-symbol-macro card-index-mask (make-fixup nil :gc-barrier)) + (macrolet ((defreg (name offset size) (declare (ignore size)) `(eval-when (:compile-toplevel :load-toplevel :execute) @@ -115,6 +121,7 @@ (remove-if (lambda (x) (member x `(,global-temp-reg ; if there is one ,thread-reg ; if using a GPR + ,card-table-reg ,rsp-offset ,rbp-offset))) (loop for i below 16 collect i)))))) diff -Nru sbcl-2.1.10/src/runtime/arm64-arch.c sbcl-2.1.11/src/runtime/arm64-arch.c --- sbcl-2.1.10/src/runtime/arm64-arch.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/arm64-arch.c 2021-11-30 16:16:46.000000000 +0000 @@ -106,7 +106,7 @@ void arch_handle_fun_end_breakpoint(os_context_t *context) { - *os_context_pc_addr(context) = (int) handle_fun_end_breakpoint(context); + *os_context_pc_addr(context) = (uword_t) handle_fun_end_breakpoint(context); } void @@ -122,8 +122,8 @@ 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)", - trap_instruction, *os_context_pc_addr(context)); + lose("Unrecognized trap instruction %08x in sigtrap_handler() (PC: %p)", + trap_instruction, (void*) *os_context_pc_addr(context)); } handle_trap(context, code); @@ -131,7 +131,7 @@ void sigill_handler(int signal, siginfo_t *siginfo, os_context_t *context) { fake_foreign_function_call(context); - lose("Unhandled SIGILL at %p.", *os_context_pc_addr(context)); + lose("Unhandled SIGILL at %p.", (void*) *os_context_pc_addr(context)); } void arch_install_interrupt_handlers() diff -Nru sbcl-2.1.10/src/runtime/arm64-darwin-os.c sbcl-2.1.11/src/runtime/arm64-darwin-os.c --- sbcl-2.1.10/src/runtime/arm64-darwin-os.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/arm64-darwin-os.c 2021-11-30 16:16:46.000000000 +0000 @@ -1,5 +1,6 @@ #include "thread.h" - +#include "gc-internal.h" +#include "gc-private.h" void set_thread_stack(void *address) { /* KLUDGE: There is no interface to change the stack location of the initial thread, and without that backtrace(3) returns zero @@ -47,6 +48,14 @@ memcpy(dst, src, n); THREAD_JIT(1); } +void jit_patch_code(lispobj code, lispobj value, unsigned long index) { + THREAD_JIT(0); + gc_card_mark[addr_to_card_index(code)] = 0; + SET_WRITTEN_FLAG(native_pointer(code)); + native_pointer(code)[index] = value; + THREAD_JIT(1); +} + void os_flush_icache(os_vm_address_t address, os_vm_size_t length) diff -Nru sbcl-2.1.10/src/runtime/bsd-os.c sbcl-2.1.11/src/runtime/bsd-os.c --- sbcl-2.1.10/src/runtime/bsd-os.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/bsd-os.c 2021-11-30 16:16:46.000000000 +0000 @@ -85,8 +85,7 @@ static void openbsd_init(); #endif -void -os_init(char *argv[], char *envp[]) +void os_init() { #ifdef __NetBSD__ netbsd_init(); diff -Nru sbcl-2.1.10/src/runtime/coalesce.c sbcl-2.1.11/src/runtime/coalesce.c --- sbcl-2.1.10/src/runtime/coalesce.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/coalesce.c 2021-11-30 16:16:46.000000000 +0000 @@ -96,8 +96,8 @@ // If 1, then we share vectors tagged as +VECTOR-SHAREABLE+, // but if >1, those and also +VECTOR-SHAREABLE-NONSTD+. int mask = gc_coalesce_string_literals > 1 - ? (VECTOR_SHAREABLE|VECTOR_SHAREABLE_NONSTD)<state_sem, 1); + os_sem_init(&extra_data->state_not_running_sem, 0); + os_sem_init(&extra_data->state_not_stopped_sem, 0); + os_sem_init(&extra_data->sprof_sem, 0); +#endif } void darwin_init(void) diff -Nru sbcl-2.1.10/src/runtime/fullcgc.c sbcl-2.1.11/src/runtime/fullcgc.c --- sbcl-2.1.10/src/runtime/fullcgc.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/fullcgc.c 2021-11-30 16:16:46.000000000 +0000 @@ -75,7 +75,7 @@ /* The whole-page allocator works backwards from the end of dynamic space. * If it collides with 'next_free_page', then you lose. - * TOOD: It would be reasonably simple to have this request more memory from + * TODO: It would be reasonably simple to have this request more memory from * the OS instead of failing on overflow */ static void* get_free_page() { --free_page; @@ -634,12 +634,15 @@ if (sweeplog) fflush(sweeplog); +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + free_page = next_free_page; +#else page_index_t first_page, last_page; for (first_page = 0; first_page < next_free_page; ++first_page) - if (page_table[first_page].write_protected + if (PAGE_WRITEPROTECTED_P(first_page) && protection_mode(first_page) == PHYSICAL) { last_page = first_page; - while (page_table[last_page+1].write_protected + while (PAGE_WRITEPROTECTED_P(last_page+1) && protection_mode(last_page+1) == PHYSICAL) ++last_page; os_protect(page_address(first_page), @@ -647,6 +650,7 @@ OS_VM_PROT_READ | OS_VM_PROT_EXECUTE); first_page = last_page; } +#endif while (free_page < page_table_pages) { page_table[free_page++].type = FREE_PAGE_FLAG; } diff -Nru sbcl-2.1.10/src/runtime/gc-assert.h sbcl-2.1.11/src/runtime/gc-assert.h --- sbcl-2.1.10/src/runtime/gc-assert.h 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/gc-assert.h 2021-11-30 16:16:46.000000000 +0000 @@ -27,19 +27,11 @@ /// Disable all assertions if NDEBUG #ifdef NDEBUG # define gc_assert(ex) ((void)0) -# define gc_assert_verbose(ex, fmt, ...) ((void)0) #else # define gc_assert(ex) \ do { \ if (!(ex)) gc_abort(); \ } while (0) -# define gc_assert_verbose(ex, fmt, ...) \ -do { \ - if (!(ex)) { \ - fprintf(stderr, fmt, ## __VA_ARGS__); \ - gc_abort(); \ - } \ -} while (0) #endif #endif diff -Nru sbcl-2.1.10/src/runtime/gc-common.c sbcl-2.1.11/src/runtime/gc-common.c --- sbcl-2.1.10/src/runtime/gc-common.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/gc-common.c 2021-11-30 16:16:46.000000000 +0000 @@ -196,8 +196,9 @@ } // This assertion is usually the one that fails when something // is subtly wrong with the heap, so definitely always do it. - gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n", - object_ptr, start, end); + if (object_ptr != end) + lose("heap_scavenge failure: Final object pointer %p, start %p, end %p", + object_ptr, start, end); } // Scavenge a block of memory from 'start' extending for 'n_words' @@ -441,11 +442,38 @@ * instances */ +int n_unboxed_instances; static inline lispobj copy_instance(lispobj object) { // Object is an un-forwarded object in from_space lispobj header = *(lispobj*)(object - INSTANCE_POINTER_LOWTAG); int original_length = instance_length(header); + + int page_type = BOXED_PAGE_FLAG; +#ifdef LISP_FEATURE_GENCGC + lispobj layout = instance_layout(INSTANCE(object)); + if (layout) { + generation_index_t gen = 0; + // If the layout is pseudo-static and the bitmap is 0 then this instance can go + // on an unboxed page to avoid further pointer tracing. + // And it could never be a valid argument to CHANGE-CLASS. + #ifdef LISP_FEATURE_IMMOBILE_SPACE + if (find_fixedobj_page_index((void*)layout)) + gen = immobile_obj_generation((lispobj*)LAYOUT(layout)); + #else + page_index_t p = find_page_index((void*)layout); + if (p >= 0) gen = page_table[p].gen; + #endif + if (gen == PSEUDO_STATIC_GENERATION) { + struct bitmap bitmap = get_layout_bitmap(LAYOUT(layout)); + if (bitmap.nwords == 1 && !bitmap.bits[0]) { + page_type = UNBOXED_PAGE_FLAG; + // ++n_unboxed_instances; // for metrics gathering + } + } + } +#endif + lispobj copy; // KLUDGE: reading both flags at once doesn't really work // unless either we know what the opaque values are: @@ -458,7 +486,8 @@ * adding 1 for the header will effectively add 2 words. * Otherwise, don't add anything because a padding slot exists */ int new_length = original_length + (original_length & 1); - copy = gc_copy_object_resizing(object, 1 + (new_length|1), BOXED_PAGE_FLAG, + copy = gc_copy_object_resizing(object, 1 + (new_length|1), + page_type, 1 + (original_length|1)); lispobj *base = native_pointer(copy); /* store the old address as the hash value */ @@ -480,7 +509,7 @@ instance_length(*base)); #endif } else { - copy = copy_object(object, 1 + (original_length|1)); + copy = gc_general_copy_object(object, 1 + (original_length|1), page_type); } set_forwarding_pointer(native_pointer(object), copy); return copy; @@ -493,7 +522,7 @@ lispobj copy = copy_instance(object); *where = copy; - struct instance* node = (struct instance*)(copy - INSTANCE_POINTER_LOWTAG); + struct instance* node = INSTANCE(copy); lispobj layout = instance_layout((lispobj*)node); if (layout) { if (forwarding_pointer_p((lispobj*)LAYOUT(layout))) @@ -507,7 +536,7 @@ && !forwarding_pointer_p(native_pointer(object))) { copy = copy_instance(object); node->slots[INSTANCE_DATA_START] = copy; - node = (struct instance*)(copy - INSTANCE_POINTER_LOWTAG); + node = INSTANCE(copy); // We don't have to stop upon seeing an instance with a different layout. // The only other object in the 'next' chain could be *TAIL-ATOM* if we reach // the end. It's possible that all of the tests in the 'while' loop are met @@ -667,7 +696,7 @@ DEF_SCAV_BOXED(tiny_boxed, TINY_BOXED_NWORDS) static inline int array_header_nwords(lispobj header) { - unsigned char rank = (header >> 16); + unsigned char rank = (header >> ARRAY_RANK_POSITION); ++rank; // wraparound from 255 to 0 int nwords = sizeof (struct array)/N_WORD_BYTES + (rank-1); return ALIGN_UP(nwords, 2); @@ -1050,6 +1079,7 @@ while (vectors) { struct vector* vector = (struct vector*)vectors->car; vectors = (struct cons*)vectors->cdr; + ensure_non_ptr_word_writable(&vector->header); UNSET_WEAK_VECTOR_VISITED(vector); sword_t len = vector_len(vector); sword_t i; @@ -1134,7 +1164,7 @@ if (!vector_flagp(header, VectorWeakVisited)) { weak_vectors = (struct cons*)gc_private_cons((uword_t)vector, (uword_t)weak_vectors); - *vector |= flag_VectorWeakVisited << N_WIDETAG_BITS; + *vector |= flag_VectorWeakVisited << ARRAY_FLAGS_POSITION; } } @@ -1506,7 +1536,24 @@ /* Walk through the chain whose first element is *FIRST and remove * dead weak entries. - * Return the new value for 'should rehash' */ + * Return the new value for 'should rehash'. + * + * This operation might have to touch a hash-table that is currently + * on a write-protected page, as follows: + * hash-table in gen5 (WRITE-PROTECTED) -> pair vector in gen5 (NOT WRITE-PROTECTED) + * -> younger k/v in gen1 that are deemed not-alive. + * That's all fine, but now we have to store into the table for two reasons: + * 1. to adjust the count + * 2. to store the list of reusable cells + * The former store is a non-pointer, but the latter may create an old->young pointer, + * because the list of cells for reuse is freshly consed (and therefore young). + * Moreover, when updating 'smashed_cells', that slot might not even be on the same + * hardware page as the table header (if a page-spanning object) so it might be + * unwritable even if words 0 through are writable. + * Employing the NON_FAULTING_STORE macro might make sense for the non-pointer slot, + * except that it's potentially a lot more unprotects and reprotects. + * Better to just get it done once. + */ static inline boolean cull_weak_hash_table_bucket(struct hash_table *hash_table, uint32_t bucket, uint32_t index, @@ -1544,12 +1591,14 @@ cons->cdr = hash_table->culled_values; cons->car = val; lispobj list = make_lispobj(cons, LIST_POINTER_LOWTAG); + ensure_ptr_word_writable(&hash_table->culled_values); hash_table->culled_values = list; // ensure this cons doesn't get smashed into (0 . 0) by full gc if (!compacting_p()) gc_mark_obj(list); } kv_vector[2 * index] = empty_symbol; kv_vector[2 * index + 1] = empty_symbol; + ensure_non_ptr_word_writable(&hash_table->_count); hash_table->_count -= make_fixnum(1); // Push (index . bucket) onto the table's GC culled cell list. @@ -1573,6 +1622,7 @@ cons->cdr = hash_table->smashed_cells; // Lisp code must atomically pop the list whereas this C code // always wins and does not need compare-and-swap. + ensure_ptr_word_writable(&hash_table->smashed_cells); hash_table->smashed_cells = make_lispobj(cons, LIST_POINTER_LOWTAG); // ensure this cons doesn't get smashed into (0 . 0) by full gc if (!compacting_p()) gc_mark_obj(hash_table->smashed_cells); @@ -2428,54 +2478,6 @@ } #endif /* x86oid targets */ -void varint_unpacker_init(struct varint_unpacker* unpacker, lispobj integer) -{ - if (fixnump(integer)) { - unpacker->word = fixnum_value(integer); - unpacker->limit = N_WORD_BYTES; - unpacker->data = (char*)&unpacker->word; - } else { - struct bignum* bignum = (struct bignum*)(integer - OTHER_POINTER_LOWTAG); - unpacker->word = 0; - unpacker->limit = HeaderValue(bignum->header) * N_WORD_BYTES; - unpacker->data = (char*)bignum->digits; - } - unpacker->index = 0; -} - -// Fetch the next varint from 'unpacker' into 'result'. -// Because there is no length prefix on the number of varints encoded, -// spurious trailing zeros might be observed. The data consumer can -// circumvent that by storing a count as the first value in the series. -// Return 1 for success, 0 for EOF. -int varint_unpack(struct varint_unpacker* unpacker, int* result) -{ - if (unpacker->index >= unpacker->limit) return 0; - int accumulator = 0; - int shift = 0; - while (1) { -#ifdef LISP_FEATURE_LITTLE_ENDIAN - int byte = unpacker->data[unpacker->index]; -#else - // bignums are little-endian in word order, - // but machine-native within each word. - // We could pack bytes MSB-to-LSB in the bigdigits, - // but that seems less intuitive on the Lisp side. - int word_index = unpacker->index / N_WORD_BYTES; - int byte_index = unpacker->index % N_WORD_BYTES; - int byte = (((unsigned int*)unpacker->data)[word_index] - >> (byte_index * 8)) & 0xFF; -#endif - ++unpacker->index; - accumulator |= (byte & 0x7F) << shift; - if (!(byte & 0x80)) break; - gc_assert(unpacker->index < unpacker->limit); - shift += 7; - } - *result = accumulator; - return 1; -} - /* Our own implementation of heapsort, because some C libraries have a qsort() * that calls malloc() apparently, which we MUST NOT do. */ @@ -2519,6 +2521,7 @@ } /// External function for calling from Lisp. -page_index_t ext_lispobj_size(lispobj *addr) { +uword_t primitive_object_size(lispobj ptr) { + lispobj* addr = native_pointer(ptr); return OBJECT_SIZE(*addr,addr) * N_WORD_BYTES; } diff -Nru sbcl-2.1.10/src/runtime/gc-internal.h sbcl-2.1.11/src/runtime/gc-internal.h --- sbcl-2.1.10/src/runtime/gc-internal.h 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/gc-internal.h 2021-11-30 16:16:46.000000000 +0000 @@ -84,21 +84,23 @@ * - 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 +#define vector_flagp(header, val) ((int)header & (flag_##val << ARRAY_FLAGS_POSITION)) +#define vector_flags_zerop(header) ((int)(header) & 0x07 << ARRAY_FLAGS_POSITION) == 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 +#define ordinary_simple_vector_p(header) \ + ((int)(header) & (0x07 << ARRAY_FLAGS_POSITION | 0xffff >> (16-ARRAY_FLAGS_POSITION))) \ + == 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) + ((int)(header) & ((flag_VectorWeak|flag_VectorHashing) << ARRAY_FLAGS_POSITION)) == \ + (flag_VectorWeak << ARRAY_FLAGS_POSITION) // Mask out the fullcgc mark bit when asserting header validity #define UNSET_WEAK_VECTOR_VISITED(v) \ - gc_assert((v->header & 0xffff) == \ - (((flag_VectorWeakVisited|flag_VectorWeak) << N_WIDETAG_BITS) \ + gc_assert((v->header & (0xff << ARRAY_FLAGS_POSITION | 0xff)) == \ + (((flag_VectorWeakVisited|flag_VectorWeak) << ARRAY_FLAGS_POSITION) \ | SIMPLE_VECTOR_WIDETAG)); \ - v->header ^= flag_VectorWeakVisited << N_WIDETAG_BITS + v->header ^= flag_VectorWeakVisited << ARRAY_FLAGS_POSITION /* values for the *_alloc_* parameters, also see the commentary for * struct page in gencgc-internal.h. These constants are used in gc-common, diff -Nru sbcl-2.1.10/src/runtime/gc-private.h sbcl-2.1.11/src/runtime/gc-private.h --- sbcl-2.1.10/src/runtime/gc-private.h 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/gc-private.h 2021-11-30 16:16:46.000000000 +0000 @@ -134,11 +134,11 @@ return (header & (OBJ_WRITTEN_FLAG << 24)) != 0; } -#ifndef LISP_FEATURE_IMMOBILE_SPACE - -static inline boolean filler_obj_p(lispobj __attribute__((unused)) *obj) { return 0; } +static inline boolean filler_obj_p(lispobj* obj) { + return widetag_of(obj) == CODE_HEADER_WIDETAG && obj[1] == 0; +} -#else +#ifdef LISP_FEATURE_IMMOBILE_SPACE extern void enliven_immobile_obj(lispobj*,int); @@ -203,10 +203,6 @@ #error "Need to define immobile_obj_gen_bits() for big-endian" #endif /* little-endian */ -static inline boolean filler_obj_p(lispobj* obj) { - return widetag_of(obj) == CODE_HEADER_WIDETAG && obj[1] == 0; -} - #endif /* immobile space */ #define WEAK_POINTER_CHAIN_END (void*)(intptr_t)-1 @@ -312,12 +308,17 @@ * but seems only to be a problem in fullcgc) */ +extern char* gc_card_mark; +#ifdef LISP_FEATURE_SOFT_CARD_MARKS +#define NON_FAULTING_STORE(operation, addr) { operation; } +#else #define NON_FAULTING_STORE(operation, addr) { \ page_index_t page_index = find_page_index(addr); \ - if (page_index < 0 || !page_table[page_index].write_protected) { operation; } \ + if (page_index < 0 || !PAGE_WRITEPROTECTED_P(page_index)) { operation; } \ else { unprotect_page_index(page_index); \ operation; \ protect_page(page_address(page_index), page_index); }} +#endif #ifdef LISP_FEATURE_DARWIN_JIT #define OS_VM_PROT_JIT_READ OS_VM_PROT_READ @@ -327,22 +328,24 @@ #define OS_VM_PROT_JIT_ALL OS_VM_PROT_ALL #endif -/* This is used bu the fault handler, and potentially during GC */ +/* This is used by the fault handler, and potentially during GC */ static inline void unprotect_page_index(page_index_t page_index) { +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + int card = page_to_card_index(page_index); + if (gc_card_mark[card] == 1) gc_card_mark[card] = 0; // NEVER CHANGE '2' to '0' +#else os_protect(page_address(page_index), GENCGC_CARD_BYTES, OS_VM_PROT_JIT_ALL); unsigned char *pflagbits = (unsigned char*)&page_table[page_index].gen - 1; __sync_fetch_and_or(pflagbits, WP_CLEARED_FLAG); - __sync_fetch_and_and(pflagbits, ~WRITE_PROTECTED_FLAG); + SET_PAGE_PROTECTED(page_index, 0); +#endif } -static inline void protect_page(void* page_addr, page_index_t page_index) +static inline void protect_page(void* page_addr, + __attribute__((unused)) page_index_t page_index) { -#ifdef LISP_FEATURE_DARWIN_JIT - if ((page_table[page_index].type & PAGE_TYPE_MASK) == CODE_PAGE_TYPE) { - return; - } -#endif +#ifndef LISP_FEATURE_SOFT_CARD_MARKS os_protect((void *)page_addr, GENCGC_CARD_BYTES, OS_VM_PROT_JIT_READ); /* Note: we never touch the write_protected_cleared bit when protecting @@ -358,21 +361,38 @@ * But nothing is really gained by resetting the cleared flag. * It is explicitly zeroed on pages marked as free though. */ - page_table[page_index].write_protected = 1; +#endif + gc_card_mark[addr_to_card_index(page_addr)] = 1; +} + +// Two helpers to avoid invoking the memory fault signal handler. +// For clarity, distinguish between words which *actually* need to frob +// physical (MMU-based) protection versus those which don't, +// but are forced to call mprotect() because it's the only choice. +// Unlike with NON_FAULTING_STORE, in this case we actually do want to record that +// the ensuing store toggles the WP bit without invoking the fault handler. +static inline void ensure_ptr_word_writable(void* addr) { + page_index_t index = find_page_index(addr); + gc_assert(index >= 0); + if (PAGE_WRITEPROTECTED_P(index)) unprotect_page_index(index); +} +static inline void ensure_non_ptr_word_writable(__attribute__((unused)) void* addr) +{ + // don't need to do anything if not using hardware page protection +#ifndef LISP_FEATURE_SOFT_CARD_MARKS + ensure_ptr_word_writable(addr); +#endif } #else +/* cheneygc */ +#define ensure_ptr_word_writable(dummy) +#define ensure_non_ptr_word_writable(dummy) #define NON_FAULTING_STORE(operation, addr) operation #endif -#if defined(LISP_FEATURE_X86_64) || defined(LISP_FEATURE_X86) -# define CODE_PAGES_USE_SOFT_PROTECTION 1 -#else -# define CODE_PAGES_USE_SOFT_PROTECTION 0 -#endif - #define KV_PAIRS_HIGH_WATER_MARK(kvv) fixnum_value(kvv[0]) #define KV_PAIRS_REHASH(kvv) kvv[1] diff -Nru sbcl-2.1.10/src/runtime/gencgc.c sbcl-2.1.11/src/runtime/gencgc.c --- sbcl-2.1.10/src/runtime/gencgc.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/gencgc.c 2021-11-30 16:16:46.000000000 +0000 @@ -60,6 +60,7 @@ #include "genesis/cons.h" #include "forwarding-ptr.h" #include "lispregs.h" +#include "var-io.h" /* forward declarations */ page_index_t gc_find_freeish_pages(page_index_t *restart_page_ptr, sword_t nbytes, @@ -132,12 +133,6 @@ /* Should we do a pre-scan of the heap before it's GCed? */ boolean pre_verify_gen_0 = 0; // FIXME: should be named 'pre_verify_gc' -/* If defined, free pages are read-protected to ensure that nothing - * accesses them. - */ - -/* #define READ_PROTECT_FREE_PAGES */ - /* * GC structures and variables @@ -164,6 +159,7 @@ * page_table_pages is set from the size of the dynamic space. */ page_index_t page_table_pages; struct page *page_table; +char *gc_card_mark; lispobj gc_object_watcher; int gc_traceroot_criterion; int gc_n_stack_pins; @@ -185,6 +181,7 @@ return (page_table[page].type & BOXED_PAGE_FLAG); } +#ifndef LISP_FEATURE_SOFT_CARD_MARKS /// Return true if low 4 'type' bits are 0zz1, false otherwise (z = don't-care) /// i.e. true of pages which could hold boxed or partially boxed objects. static inline boolean page_boxed_no_region_p(page_index_t page) { @@ -197,6 +194,7 @@ && !page_table[page].pinned && (page_table[page].gen == generation)); } +#endif /* Calculate the start address for the given page number. */ inline char * @@ -267,9 +265,9 @@ * and a store is simpler than a bitwise operation */ static inline void reset_page_flags(page_index_t page) { page_table[page].scan_start_offset_ = 0; - // Any C compiler worth its salt should merge these into one store - page_table[page].type = page_table[page].write_protected + page_table[page].type = page_table[page].padding = page_table[page].write_protected_cleared = page_table[page].pinned = 0; + SET_PAGE_PROTECTED(page,0); } /// External function for calling from Lisp. @@ -391,7 +389,7 @@ for (i = 0; i < next_free_page; i++) if (!page_free_p(i) && (page_table[i].gen == generation)) { total++; - if (page_table[i].write_protected) + if (PAGE_WRITEPROTECTED_P(i)) wp++; } if (n_write_protected) @@ -475,25 +473,23 @@ for (i = begin; i <= end; i++) { page_index_t page; // page kinds: small {boxed,code,unboxed}, large {boxed,code,unboxed} - page_index_t pagect[6], pinned_cnt = 0, tot_pages = 0; + page_index_t pagect[6], pinned_cnt = 0; memset(pagect, 0, sizeof pagect); for (page = 0; page < next_free_page; page++) if (!page_free_p(page) && page_table[page].gen == i) { - int k; - switch (page_table[page].type & PAGE_TYPE_MASK) { - case CODE_PAGE_TYPE: k = 1; break; - case UNBOXED_PAGE_FLAG: k = 2; break; - default: k = 0; break; - } + // translate BOXED -> 0, UNBOXED -> 1, CODE -> 2 + int k = (page_table[page].type & PAGE_TYPE_MASK) - 1; if (page_single_obj_p(page)) k += 3; pagect[k]++; if (page_table[page].pinned) pinned_cnt++; } - tot_pages = pagect[0] + pagect[1] + pagect[2] - + pagect[3] + pagect[4] + pagect[5]; struct generation* gen = &generations[i]; gc_assert(gen->bytes_allocated == count_generation_bytes_allocated(i)); + page_index_t tot_pages, n_protected; + tot_pages = count_generation_pages(i, &n_protected); + gc_assert(tot_pages == + pagect[0] + pagect[1] + pagect[2] + pagect[3] + pagect[4] + pagect[5]); fprintf(file, " %d %7"PAGE_INDEX_FMT"%7"PAGE_INDEX_FMT"%7"PAGE_INDEX_FMT "%7"PAGE_INDEX_FMT"%7"PAGE_INDEX_FMT"%7"PAGE_INDEX_FMT @@ -503,12 +499,12 @@ " %11"OS_VM_SIZE_FMT " %7"PAGE_INDEX_FMT" %3d %7.4f\n", i, - pagect[0], pagect[1], pagect[2], pagect[3], pagect[4], pagect[5], + pagect[0], pagect[2], pagect[1], pagect[3], pagect[5], pagect[4], pinned_cnt, (uintptr_t)gen->bytes_allocated, (uintptr_t)npage_bytes(tot_pages) - generations[i].bytes_allocated, (uintptr_t)gen->gc_trigger, - count_generation_pages(i, 0), + n_protected, gen->num_gc, generation_average_age(i)); } @@ -732,9 +728,6 @@ void zero_dirty_pages(page_index_t start, page_index_t end, int page_type) { page_index_t i, j; -#ifdef READ_PROTECT_FREE_PAGES - os_protect(page_address(start), npage_bytes(1+end-start), OS_VM_PROT_ALL); -#endif // If allocating boxed pages to gen0 (or scratch which becomes gen0) then // this allocation is potentially going to be extended by lisp (if it happens to // pick up the tail of the page as its next available region) @@ -1316,7 +1309,7 @@ boolean result = page_table[index].type == allocated && page_table[index].gen == gen - && !page_table[index].write_protected + && !PAGE_WRITEPROTECTED_P(index) && !page_table[index].pinned; return result; #else @@ -1330,15 +1323,16 @@ * write_protected_cleared flag = 1 because it was at some point WP'ed. * Those pages are usable, so we do have to mask out the 'cleared' bit. * - * pin -\ /--- WP - * v v - * #b11111111_10111111 + * pin -\ + * v + * #b11111111_10_11111 * ^ ^^^^^ -- type * WP-clr / * * The flags reside at 1 byte prior to 'gen' in the page structure. */ - return (*(int16_t*)(&page_table[index].gen-1) & 0xFFBF) == ((gen<<8)|allocated); + return ((*(int16_t*)(&page_table[index].gen-1) & 0xFFBF) == ((gen<<8)|allocated)) + && !PAGE_WRITEPROTECTED_P(index); #endif } @@ -1398,7 +1392,7 @@ continue; } - gc_dcheck(!page_table[first_page].write_protected); + gc_dcheck(!PAGE_WRITEPROTECTED_P(first_page)); /* page_free_p() can legally be used at index 'page_table_pages' * because the array dimension is 1+page_table_pages */ for (last_page = first_page+1; @@ -1410,7 +1404,7 @@ * otherwise, lossage would routinely occur in the fault handler) */ bytes_found += GENCGC_CARD_BYTES; gc_dcheck(0 == page_bytes_used(last_page)); - gc_dcheck(!page_table[last_page].write_protected); + gc_dcheck(!PAGE_WRITEPROTECTED_P(last_page)); } if (bytes_found > most_bytes_found) { @@ -1539,7 +1533,7 @@ gc_assert(page_table[page].type == old_allocated); \ gc_assert(page_table[page].gen == from_space); \ gc_assert(page_scan_start_offset(page) == npage_bytes(page-first_page)); \ - gc_assert(!page_table[page].write_protected); \ + gc_assert(!PAGE_WRITEPROTECTED_P(page)); \ page_table[page].gen = new_gen; \ page_table[page].type = new_allocated @@ -1572,7 +1566,7 @@ page_table[page].type == old_allocated && page_scan_start_offset(page) == npage_bytes(page - first_page)) { // These pages are part of oldspace, which was un-write-protected. - gc_assert(!page_table[page].write_protected); + gc_assert(!PAGE_WRITEPROTECTED_P(page)); /* Zeroing must have been done before shrinking the object. * (It is strictly necessary for correctness with objects other @@ -1690,7 +1684,7 @@ * (This assertion is compiled out in a normal build, * so even if incorrect, it should be relatively harmless) */ - gc_dcheck(!page_table[find_page_index(wp)].write_protected); + gc_dcheck(!PAGE_WRITEPROTECTED_P(find_page_index(wp))); add_to_weak_pointer_chain(wp); } @@ -2167,7 +2161,7 @@ /* Oldspace pages were unprotected at start of GC. * Assert this here, because the previous logic used to, * and page protection bugs are scary */ - gc_assert(!page_table[page].write_protected); + gc_assert(!PAGE_WRITEPROTECTED_P(page)); /* Mark the page as containing pinned objects. */ page_table[page].pinned = 1; } @@ -2192,7 +2186,7 @@ } if (lowtag_of(object) == INSTANCE_POINTER_LOWTAG) { - struct instance* instance = (struct instance*)(object - INSTANCE_POINTER_LOWTAG); + struct instance* instance = INSTANCE(object); lispobj layout = instance_layout((lispobj*)instance); if (layout && lockfree_list_node_layout_p(LAYOUT(layout))) { // When pinning a logically deleted lockfree list node, always pin the @@ -2296,93 +2290,16 @@ #define IN_REGION_P(a,kind) (kind##_region.start_addr<=a && a<=kind##_region.free_pointer) #define IN_BOXED_REGION_P(a) IN_REGION_P(a,boxed)||IN_REGION_P(a,code) -/* If the given page is not write-protected, then scan it for pointers - * to younger generations or the top temp. generation, if no - * suspicious pointers are found then the page is write-protected. - * - * Care is taken to check for pointers to any open allocation regions, - * which by design contain younger objects. - * - * We return 1 if the page was write-protected, else 0. - * - * Note that because of the existence of some words which have fixnum lowtag - * but are actually pointers, you might think it would be possible for this - * function to go wrong, protecting a page that contains old->young pointers. - * Indeed the edge cases are rare enough not to have manifested ever, - * as far anyone knows. - * - * Suspect A is CLOSURE-FUN, which is a fixnum (on x86) which when treated - * as a pointer indicates the entry point to call. Its function can never - * be an object younger than itself. (An invariant of any immutable object) - * - * Suspect B is FDEFN-RAW-ADDRESS. This is a problem, but only under worst-case - * assumptions. Previous remarks here mentioned pinning and/or absence of calls - * to update_page_write_prot(). That explanation was flawed, as is almost - * anything in GC comments mentioning the obsolete pinning code. - * See 'doc/internals-notes/fdefn-gc-safety' for execution schedules - * that lead to invariant loss. - */ -static int -update_page_write_prot(page_index_t page) -{ - generation_index_t gen = page_table[page].gen; - sword_t j; - int wp_it = 1; - lispobj *page_addr = (lispobj*)page_address(page); - sword_t num_words = page_bytes_used(page) / N_WORD_BYTES; - - /* Shouldn't be a free page. */ - gc_dcheck(!page_free_p(page)); // Implied by the next assertion - gc_assert(page_bytes_used(page) != 0); - - if (!ENABLE_PAGE_PROTECTION) return 0; - - /* Skip if it's unboxed, already write-protected, or pinned */ - /* The 'pinned' check is sort of bogus but sort of necessary, - * but doesn't completely fix the problem that it tries to, which is - * passing a memory address to the OS for it to write into. - * An object on a never-written protected page would still fail. - * It's probably rare to pass boxed pages to the OS, but it could be - * to read fixnums into a simple-vector. - * If we had soft write protection (mark bits) instead of physical - * protection, then we could/would protect pinned pages. - * (See git rev 216e37a316) */ - if (page_table[page].write_protected || !page_boxed_p(page) || - page_table[page].pinned) - return (0); - - /* Scan the page for pointers to younger generations or the - * temp generation, which is numerically 7 but logically younger */ - - /* This is conservative: any word satisfying is_lisp_pointer() is - * assumed to be a pointer. To do otherwise would require a family - * of scavenge-like functions. */ - for (j = 0; j < num_words; j++) { - void *ptr; - page_index_t index; - lispobj __attribute__((unused)) header; - - lispobj word = page_addr[j]; - if (is_lisp_pointer(word)) - ptr = (void*)word; -#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER - else if (lowtag_of(word>>32)==INSTANCE_POINTER_LOWTAG && - (header_widetag(word)==INSTANCE_WIDETAG|| - header_widetag(word)==FUNCALLABLE_INSTANCE_WIDETAG)) { - ptr = (void*)(word >> 32); - } -#endif -#ifdef LISP_FEATURE_UNTAGGED_FDEFNS - else if (!(word & LOWTAG_MASK) && (find_page_index((void*)word) >= 0) - && widetag_of((lispobj*)word) == FDEFN_WIDETAG) { - ptr = (void*)word; - } -#endif - else - continue; +/* Return true if 'ptr' is OK to be on a write-protected page + * of an object in 'gen'. That is, if the pointer does not point to a younger object */ +static boolean ptr_ok_to_writeprotect(lispobj obj, generation_index_t gen) +{ + page_index_t index; + void* ptr = (void*)obj; + lispobj __attribute__((unused)) header; - /* Check that it's in the dynamic space */ - if ((index = find_page_index(ptr)) != -1) { + /* Check that it's in the dynamic space */ + if ((index = find_page_index(ptr)) != -1) { int pointee_gen = page_table[index].gen; if (/* Does it point to a younger or the temp. generation? */ (pointee_gen < gen || pointee_gen == SCRATCH_GENERATION) && @@ -2391,8 +2308,7 @@ (((lispobj)ptr & (GENCGC_CARD_BYTES-1)) < page_bytes_used(index) || ((page_table[index].type & OPEN_REGION_PAGE_FLAG) && (IN_BOXED_REGION_P(ptr) || IN_REGION_P(ptr,unboxed))))) { - wp_it = 0; - break; + return 0; } } #ifdef LISP_FEATURE_IMMOBILE_SPACE @@ -2424,17 +2340,148 @@ // A bogus generation number implies a not-really-pointer, // but it won't cause misbehavior. if (pointee_gen < gen || pointee_gen == SCRATCH_GENERATION) { - wp_it = 0; - break; + return 0; } } #endif - } + return 1; +} + +/* Given a range of pages at least one of which is not WPed (logically or physically, + * depending on SOFT_CARD_MARKS), scan all those pages for pointers to younger generations. + * If no such pointers are found, then write-protect the range. + * + * Care is taken to check for pointers to any open allocation regions, + * which by design contain younger objects. + * + * If we find a word which is a witness for the inability to apply write-protection, + * then return the address of that word or a neighboring word. + * Otherwise return 0. The word address is just for debugging; there are cases + * where we don't apply write protectection, but nonetheless return 0. + * + * This function is still buggy, but not in a fatal way. + * The issue is that for any kind of weak object - hash-table vector, + * weak pointer, or weak simple-vector, we skip scavenging the object + * which might leave some pointers to younger generation objects + * which will later be smashed when processing weak objects. + * That is, the referent is non-live. But when we scanned this page range, + * it looks like it still had the pointer to the younger object. + * To get this really right, we would have to wait until after weak objects + * have been processed. + * It may or may not be possible to get verify_range to croak + * about suboptimal application of WP. Possibly not, because of the hack + * for pinned pages without soft card marking (which won't WP). + * + * See also 'doc/internals-notes/fdefn-gc-safety' for execution schedules + * that lead to invariant loss with FDEFNs. This might not be a problem + * in practice. At least it seems like it never has been. + */ +#define STICKY_MARK 2 + +static lispobj* +update_writeprotection(page_index_t first_page, page_index_t last_page, + lispobj* start, lispobj* limit) +{ + /* Shouldn't be a free page. */ + gc_dcheck(!page_free_p(first_page)); // Implied by the next assertion + gc_assert(page_bytes_used(first_page) != 0); - if (wp_it == 1) - protect_page(page_addr, page); + if (!ENABLE_PAGE_PROTECTION) return 0; + if (!page_boxed_p(first_page)) return 0; - return (wp_it); + { + page_index_t page; +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + /* If any page is referenced from the stack (mark byte = 2), then we're + * can not apply protection even if we see no witness, because the + * absence of synchronization between mutator and GC means that the next + * instruction issued when the mutator resumes might create the witness, + * and it thinks it already marked a card */ + for (page = first_page; page <= last_page; ++page) + if (gc_card_mark[page_to_card_index(page)] == STICKY_MARK) return 0; +#else + /* Skip if any page is pinned. + * The 'pinned' check is sort of bogus but sort of necessary, + * but doesn't completely fix the problem that it tries to, which is + * passing a memory address to the OS for it to write into. + * An object on a never-written protected page would still fail. + * It's probably rare to pass boxed pages to the OS, but it could be + * to read fixnums into a simple-vector. */ + for (page = first_page; page <= last_page; ++page) + if (page_table[page].pinned) return 0; +#endif + } + + /* Now we attempt to find any 1 "witness" that the pages should NOT be protected. + * If such witness is found, then return without doing anything, otherwise + * apply protection to the range. */ + generation_index_t gen = page_table[first_page].gen; + lispobj* where = start; + sword_t nwords; + for ( where = start ; where < limit ; where += nwords ) { + lispobj word = *where; + if (is_cons_half(word)) { + if (!ptr_ok_to_writeprotect(word, gen)) return where; + word = where[1]; + if (is_lisp_pointer(word) && !ptr_ok_to_writeprotect(word, gen)) return where+1; + nwords = 2; + } else { + int widetag = widetag_of(where); + nwords = sizetab[widetag](where); + sword_t index; + lispobj layout; + if (leaf_obj_widetag_p(widetag)) { + } + /* This function will never be called on a page of code, hence if we + * see genuine (non-filler) code, that's wrong. Otherwise, just do the + * the switch { } below and we'll scan too many words of the object, + * but that's merely inefficient, not a fatal flaw */ + else if (widetag == CODE_HEADER_WIDETAG) { + if (!filler_obj_p(where)) lose("code @ %p on non-code page", where); + } + else switch (widetag) { +#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER + case INSTANCE_WIDETAG: case FUNCALLABLE_INSTANCE_WIDETAG: + // instance_layout works on funcallable or regular instances + // and we have to specially check it because it's in the upper + // bytes of the 0th word. + layout = instance_layout(where); + if (layout) { + if (!ptr_ok_to_writeprotect(layout, gen)) return where; + if (lockfree_list_node_layout_p(LAYOUT(layout)) && + !ptr_ok_to_writeprotect(((struct instance*)where) + ->slots[INSTANCE_DATA_START], gen)) + return where; + } +#else + case INSTANCE_WIDETAG: + // instance_layout works only on regular instances, + // we don't have to treat it specially but we do have to + // check for lockfree list nodes. + layout = instance_layout(where); + if (layout && lockfree_list_node_layout_p(LAYOUT(layout)) && + !ptr_ok_to_writeprotect(((struct instance*)where) + ->slots[INSTANCE_DATA_START], gen)) + return where; +#endif + // FALLTHROUGH_INTENDED + default: + for (index=1; index= 0) return page_table[page].write_protected; + if (page >= 0) return PAGE_WRITEPROTECTED_P(page); #ifdef LISP_FEATURE_IMMOBILE_SPACE if (immobile_space_p((lispobj)addr)) return immobile_card_protected_p(addr); #endif - lose("card_protected_p(%p)", addr); + lose("addr_protected_p(%p)", addr); } // NOTE: This function can produces false failure indications, @@ -3000,30 +3075,31 @@ FAIL_IF((READ_ONLY_SPACE_START <= (uword_t)where && where < read_only_space_free_pointer), "dynamic space from RO space"); - if (CODE_PAGES_USE_SOFT_PROTECTION - && state->widetag == CODE_HEADER_WIDETAG + if (state->widetag == CODE_HEADER_WIDETAG && ! is_in_static_space(state->object_start) && to_gen < state->object_gen) { // two things must be true: // 1. the page containing object_start must not be write-protected - FAIL_IF(card_protected_p(state->object_start), + FAIL_IF(addr_protected_p(state->object_start), "younger obj from WP'd code header page"); // 2. the object header must be marked as written if (!header_rememberedp(*state->object_start)) lose("code @ %p (g%d). word @ %p -> %"OBJ_FMTX" (g%d)", state->object_start, state->object_gen, where, thing, to_gen); - } else if (state->flags & VERIFYING_GENERATIONAL) { - // When testing for old->young ptrs, if from dynamic space then use - // the address of the word that holds the pointer in question, - // geting the per-page generation. Immobile space has only a generation - // per object, and you *must* use the correct object header address. - lispobj vaddr = (lispobj)(state->vaddr ? state->vaddr : where); - generation_index_t from_gen - = gen_of(find_page_index((lispobj*)vaddr) >= 0 ? - vaddr : (lispobj)state->object_start); - FAIL_IF(to_gen < from_gen && card_protected_p((lispobj*)vaddr), - "younger obj from WP page"); + } else if ((state->flags & VERIFYING_GENERATIONAL) && to_gen < state->object_gen) { +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + /* The WP criteria are: + * - SIMPLE-VECTOR marks the page containing the cell in question + * - Everything else marks the object header */ + int fail_wp_check = addr_protected_p( + (state->widetag == SIMPLE_VECTOR_WIDETAG) ? where : state->object_start); +#else + /* Check the page containing the pointer, but use 'vaddr' in case the pointer + * had to be decoded, and so 'where' isn't the address holding that pointer */ + int fail_wp_check = addr_protected_p(state->vaddr ? state->vaddr : where); +#endif + FAIL_IF(fail_wp_check, "younger obj from WP page"); } int valid; if (state->flags & VERIFY_AGGRESSIVE) // Extreme paranoia mode @@ -3045,7 +3121,7 @@ if (is_lisp_immediate(thing) || widetag == NO_TLS_VALUE_MARKER_WIDETAG) { /* skip immediates */ } else if (!(other_immediate_lowtag_p(widetag) && LOWTAG_FOR_WIDETAG(widetag))) { - lose("Unhandled widetag %d at %p", widetag, where); + lose("Unhandled widetag #x%02x at %p", widetag, where); } else if (leaf_obj_widetag_p(widetag)) { #ifdef LISP_FEATURE_UBSAN if (specialized_vector_widetag_p(widetag)) { @@ -3132,7 +3208,6 @@ gc_assert(!layout || layout == LAYOUT_OF_FUNCTION); #endif }); -#if CODE_PAGES_USE_SOFT_PROTECTION generation_index_t my_gen = gen_of((lispobj)where); boolean rememberedp = header_rememberedp(*where); /* The remembered set invariant is that an object is marked "written" @@ -3147,9 +3222,8 @@ (state->min_pointee_gen < my_gen) != rememberedp : (state->min_pointee_gen < my_gen) && !rememberedp) lose("object @ %p is gen%d min_pointee=gen%d %s", - where, my_gen, state->min_pointee_gen, + (void*)compute_lispobj(where), my_gen, state->min_pointee_gen, rememberedp ? "written" : "not written"); -#endif count = code_total_nwords(code); break; } @@ -3290,42 +3364,46 @@ static void write_protect_generation_pages(generation_index_t generation) { - page_index_t start = 0, end; - int n_hw_prot = 0, n_sw_prot = 0; - // Neither 0 nor scratch can be protected. Additionally, protection of // pseudo-static space is applied only in gc_load_corefile_ptes(). gc_assert(generation != 0 && generation != SCRATCH_GENERATION && generation != PSEUDO_STATIC_GENERATION); +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + page_index_t page; + for (page = 0; page < next_free_page; ++page) { + if (page_table[page].gen == generation && page_boxed_p(page) + && page_bytes_used(page) + // must not touch a card referenced from the control stack + // because the next instruction executed by user code + // might store an old->young pointer. + && gc_card_mark[page_to_card_index(page)] != STICKY_MARK) + SET_PAGE_PROTECTED(page, 1); + } +#else + page_index_t start = 0, end; + int n_hw_prot = 0, n_sw_prot = 0; + while (start < next_free_page) { - if (!protect_page_p(start, generation) -#ifdef LISP_FEATURE_DARWIN_JIT - || is_code(page_table[start].type) -#endif - ) { + if (!protect_page_p(start, generation)) { ++start; continue; } if (protection_mode(start) == LOGICAL) { - page_table[start].write_protected = 1; + SET_PAGE_PROTECTED(start, 1); ++n_sw_prot; ++start; continue; } /* Note the page as protected in the page tables. */ - page_table[start].write_protected = 1; + SET_PAGE_PROTECTED(start, 1); /* Find the extent of pages desiring physical protection */ for (end = start + 1; end < next_free_page; end++) { - if (!protect_page_p(end, generation) || protection_mode(end) == LOGICAL -#ifdef LISP_FEATURE_DARWIN_JIT - || is_code(page_table[end].type) -#endif - ) + if (!protect_page_p(end, generation) || protection_mode(end) == LOGICAL) break; - page_table[end].write_protected = 1; + SET_PAGE_PROTECTED(end, 1); } n_hw_prot += end - start; @@ -3342,10 +3420,16 @@ "/write protected %d of %d pages in generation %d\n", n_protected, n_total, generation)); } +#endif } static void unprotect_all_pages() { +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + // This function remove physical protection only, and does not alter + // the WP bit, so therefore do nothing for soft card marks. + return; +#endif #ifndef LISP_FEATURE_DARWIN_JIT os_protect(page_address(0), npage_bytes(next_free_page), OS_VM_PROT_ALL); #else @@ -3438,12 +3522,66 @@ } } -#if GENCGC_IS_PRECISE && !defined(reg_CODE) +static void __attribute__((unused)) +sticky_mark_large_vector(page_index_t page, lispobj word) +{ + /* Given that 'page' holds a large object, if 'word' is the correctly-tagged + * pointer to the base of a simple-vector, then set the sticky mark on any + * already-marked page of the object */ + lispobj* scan_start = page_scan_start(page); + switch (widetag_of(scan_start)) { + case CODE_HEADER_WIDETAG: + /* Stores to code are done pseudo-atomically with affecting the card mark. + * Therefore we don't need to do anything else. The "next" store + * won't create an old->young pointer, since it already happened */ + return; + case SIMPLE_VECTOR_WIDETAG: + if (word != make_lispobj(scan_start, OTHER_POINTER_LOWTAG)) return; + generation_index_t gen = page_table[page].gen; + while (1) { + if (!PAGE_WRITEPROTECTED_P(page)) SET_PAGE_PROTECTED(page, STICKY_MARK); + if (page_ends_contiguous_block_p(page, gen)) return; + ++page; + } + } +} + +static void __attribute__((unused)) sticky_mark_card_if_marked(lispobj word) +{ +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + /* Additional logic for soft marks: any word that is potentially a + * tagged pointer to a page being written must preserve the mark regardless + * of what update_write_protection() thinks. That's because the mark is set + * prior to storing. If GC occurs in between setting the mark and storing, + * then resetting the mark would be wrong if the subsequent store + * creates an old->young pointer. + * Mark stickiness is checked only once per invocation of collect_garbge(), + * so it when scanning stacks for generation 0 but not higher gens. + * Also note the two scenarios: + * (1) tagged pointer to a large simple-vector, but we scan card-by-card + * for specifically the marked cards. This has to be checked first + * so as not to fail to see subsequent pages if the first is marked. + * (2) tagged pointer to an object that marks only the page containing + * the object base */ + page_index_t page = find_page_index((void*)word); + if (page >= 0 && page_boxed_p(page) // stores to raw bytes are uninteresting + && (word & (GENCGC_CARD_BYTES - 1)) < page_bytes_used(page) + && plausible_tag_p(word)) { // "plausible" is good enough + if (page_single_obj_p(page)) + sticky_mark_large_vector(page, word); + else if (gc_card_mark[addr_to_card_index((void*)word)] == 0) { + SET_PAGE_PROTECTED(page, STICKY_MARK); + } + } +#endif +} lispobj * dynamic_space_code_from_pc(char *pc) { - /* Only look at untagged pointers, otherwise they won't be in the PC. */ + /* Only look at untagged pointers, otherwise they won't be in the PC. + * (which is a valid precondition for fixed-length 4-byte instructions, + * not variable-length) */ if((long)pc % 4 == 0 && is_code(page_table[find_page_index(pc)].type)) { lispobj *object = search_dynamic_space(pc); if (object != NULL && widetag_of(object) == CODE_HEADER_WIDETAG) @@ -3453,7 +3591,7 @@ return NULL; } -void maybe_pin_code(lispobj addr) { +static void __attribute__((unused)) maybe_pin_code(lispobj addr) { page_index_t page = find_page_index((char*)addr); if (page < 0) return; @@ -3465,11 +3603,41 @@ } } -void pin_stack(struct thread* th) { +#ifdef LISP_FEATURE_PPC64 +static void semiconservative_pin_stack(struct thread* th, + generation_index_t gen) { + /* Stack can only pin code, since it contains return addresses. + * Non-code pointers on stack do *not* pin anything, and may be updated + * when scavenging. + * Interrupt contexts' boxed registers do pin their referents */ + lispobj *object_ptr; + for (object_ptr = th->control_stack_start; + object_ptr < access_control_stack_pointer(th); + object_ptr++) + maybe_pin_code(*object_ptr); + int i = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)); + for (i = i - 1; i >= 0; --i) { + os_context_t* context = nth_interrupt_context(i, th); + int j; + // FIXME: if we pick a register to consistently use with m[ft]lr + // then we would only need to examine that, and LR and CTR here. + // We may already be consistent, I just don't what the consistency is. + static int boxed_registers[] = BOXED_REGISTERS; + for (j = (int)(sizeof boxed_registers / sizeof boxed_registers[0])-1; j >= 0; --j) { + lispobj word = *os_context_register_addr(context, boxed_registers[j]); + preserve_pointer((void*)word); // maybe pin something, tagged pointer or not + // If pointer lowtagged, then possibly set stickiness + if (gen == 0 && is_lisp_pointer(word)) sticky_mark_card_if_marked(word); + } + preserve_pointer((void*)*os_context_lr_addr(context)); + preserve_pointer((void*)*os_context_ctr_addr(context)); + } +} +#endif - if(!conservative_stack) - return; +#if GENCGC_IS_PRECISE && !defined(reg_CODE) +static void pin_stack(struct thread* th) { lispobj *cfp = access_control_frame_pointer(th); if (cfp) { @@ -3491,6 +3659,105 @@ } #endif +#if !GENCGC_IS_PRECISE +static void NO_SANITIZE_ADDRESS NO_SANITIZE_MEMORY +conservative_stack_scan(struct thread* th, + __attribute__((unused)) generation_index_t gen, + void* stack_hot_end) +{ + /* there are potentially two stacks for each thread: the main + * stack, which may contain Lisp pointers, and the alternate stack. + * We don't ever run Lisp code on the altstack, but it may + * host a sigcontext with lisp objects in it */ + + /* what we need to do: (1) find the stack pointer for the main + * stack; scavenge it (2) find the interrupt context on the + * alternate stack that might contain lisp values, and scavenge + * that */ + + /* we assume that none of the preceding applies to the thread that + * initiates GC. If you ever call GC from inside an altstack + * handler, you will lose. */ + + void* esp = (void*)-1; +# if defined(LISP_FEATURE_SB_SAFEPOINT) + /* Conservative collect_garbage is always invoked with a + * foreign C call or an interrupt handler on top of every + * existing thread, so the stored SP in each thread + * structure is valid, no matter which thread we are looking + * at. For threads that were running Lisp code, the pitstop + * and edge functions maintain this value within the + * interrupt or exception handler. */ + esp = os_get_csp(th); + assert_on_stack(th, esp); + + /* And on platforms with interrupts: scavenge ctx registers. */ + + /* Disabled on Windows, because it does not have an explicit + * stack of `interrupt_contexts'. The reported CSP has been + * chosen so that the current context on the stack is + * covered by the stack scan. See also set_csp_from_context(). */ +# ifndef LISP_FEATURE_WIN32 + if (th != get_sb_vm_thread()) { + int k = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)); + while (k > 0) { + os_context_t* context = nth_interrupt_context(--k, th); + if (context) + preserve_context_registers((void(*)(os_context_register_t))preserve_pointer, + context); + } + } +# endif +# elif defined(LISP_FEATURE_SB_THREAD) + if(th==get_sb_vm_thread()) { + esp = stack_hot_end; + } else { + sword_t i,free; + lispobj* esp1; + free=fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)); + for(i=free-1;i>=0;i--) { + os_context_t *c = nth_interrupt_context(i, th); + esp1 = (lispobj*) *os_context_register_addr(c,reg_SP); + if (esp1 >= th->control_stack_start && esp1 < th->control_stack_end) { + if ((void*)esp1control_stack_start; + lispobj exclude_to = (lispobj)th + dynamic_values_bytes; + + // This loop would be more naturally expressed as + // for (ptr = esp; ptr < th->control_stack_end; ++ptr) + // However there is a very subtle problem with that: 'esp = &raise' + // is not necessarily properly aligned to be a stack pointer! + void **ptr; + for (ptr = ((void **)th->control_stack_end)-1; ptr >= (void**)esp; ptr--) { + lispobj word = (lispobj)*ptr; + // Also note that we can eliminate small fixnums from consideration + // since there is no memory on the 0th page. + // (most OSes don't let users map memory there, though they used to). + if (word >= BACKEND_PAGE_BYTES && + !(exclude_from <= word && word < exclude_to)) { + preserve_pointer((void*)word); + if (gen == 0 && is_lisp_pointer(word)) sticky_mark_card_if_marked(word); + } + } +} +#endif + /* 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 @@ -3555,6 +3822,7 @@ 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. + * FIXME: why would it not? More explanation needed! * 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) @@ -3594,151 +3862,30 @@ } - /* Scavenge the stacks' conservative roots. */ + /* Possibly pin stack roots and/or *PINNED-OBJECTS*, unless saving a core. + * Scavenging (fixing up pointers) will occur later on */ - /* there are potentially two stacks for each thread: the main - * stack, which may contain Lisp pointers, and the alternate stack. - * We don't ever run Lisp code on the altstack, but it may - * host a sigcontext with lisp objects in it */ - - /* what we need to do: (1) find the stack pointer for the main - * stack; scavenge it (2) find the interrupt context on the - * alternate stack that might contain lisp values, and scavenge - * that */ - - /* we assume that none of the preceding applies to the thread that - * initiates GC. If you ever call GC from inside an altstack - * handler, you will lose. */ - -#if !GENCGC_IS_PRECISE - /* And if we're saving a core, there's no point in being conservative. */ if (conservative_stack) { for_each_thread(th) { - void* esp = (void*)-1; - if (th->state_word.state == STATE_DEAD) - continue; -# if defined(LISP_FEATURE_SB_SAFEPOINT) - /* Conservative collect_garbage is always invoked with a - * foreign C call or an interrupt handler on top of every - * existing thread, so the stored SP in each thread - * structure is valid, no matter which thread we are looking - * at. For threads that were running Lisp code, the pitstop - * and edge functions maintain this value within the - * interrupt or exception handler. */ - esp = os_get_csp(th); - assert_on_stack(th, esp); - - /* And on platforms with interrupts: scavenge ctx registers. */ - - /* Disabled on Windows, because it does not have an explicit - * stack of `interrupt_contexts'. The reported CSP has been - * chosen so that the current context on the stack is - * covered by the stack scan. See also set_csp_from_context(). */ -# ifndef LISP_FEATURE_WIN32 - if (th != get_sb_vm_thread()) { - int k = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)); - while (k > 0) { - os_context_t* context = nth_interrupt_context(--k, th); - if (context) - preserve_context_registers((void(*)(os_context_register_t))preserve_pointer, - context); - } - } -# endif -# elif defined(LISP_FEATURE_SB_THREAD) - if(th==get_sb_vm_thread()) { - esp = (void*)&raise; - } else { - sword_t i,free; - lispobj* esp1; - free=fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)); - for(i=free-1;i>=0;i--) { - os_context_t *c = nth_interrupt_context(i, th); - esp1 = (lispobj*) *os_context_register_addr(c,reg_SP); - if (esp1 >= th->control_stack_start && esp1 < th->control_stack_end) { - if ((void*)esp1control_stack_start; - lispobj exclude_to = (lispobj)th + dynamic_values_bytes; - - // This loop would be more naturally expressed as - // for (ptr = esp; ptr < th->control_stack_end; ++ptr) - // However there is a very subtle problem with that: 'esp = &raise' - // is not necessarily properly aligned to be a stack pointer! - void **ptr; - for (ptr = ((void **)th->control_stack_end)-1; ptr >= (void**)esp; ptr--) { - lispobj word = (lispobj)*ptr; - // Also note that we can eliminate small fixnums from consideration - // since there is no memory on the 0th page. - // (most OSes don't let users map memory there, though they used to). - if (word >= BACKEND_PAGE_BYTES && - !(exclude_from <= word && word < exclude_to)) - preserve_pointer((void*)word); - } - } - } + if (th->state_word.state == STATE_DEAD) continue; +#if !GENCGC_IS_PRECISE + /* Pin everything in fromspace with a stack root, and also set the + * sticky card mark on any page (in any generation) + * referenced from the stack. */ + conservative_stack_scan(th, generation, &raise); #else - /* Non-x86oid systems don't have "conservative roots" as such, but - * the same mechanism is used for objects pinned for use by alien - * code. */ - for_each_thread(th) { -#if GENCGC_IS_PRECISE && !defined(reg_CODE) - pin_stack(th); + // Pin code if needed, and then *PINNED-OBJECTS* +# ifdef LISP_FEATURE_PPC64 + semiconservative_pin_stack(th, generation); +# elif !defined(reg_CODE) + pin_stack(th); +# endif + lispobj pin_list = read_TLS(PINNED_OBJECTS,th); + for ( ; pin_list != NIL ; pin_list = CONS(pin_list)->cdr ) + pin_exact_root(CONS(pin_list)->car); #endif - lispobj pin_list = read_TLS(PINNED_OBJECTS,th); - while (pin_list != NIL) { - pin_exact_root(CONS(pin_list)->car); - pin_list = CONS(pin_list)->cdr; - } -#ifdef LISP_FEATURE_PPC64 - // Scan the control stack and interrupt contexts for ambiguous code roots. - // Doing it in gc-common would be too late, since all pinned objects have - // to be discovered before transporting anything. - // I think we never store reg_CODE on the control stack (yet) - it will only - // appear in an interrupt context - so this is probably unnecessary for now. - // However, I'd like to eliminate LRAs (at least on the PPC64 backend), - // in which case all the looks-like-fixnum return PCs on the control stack, - // will need to enliven what they point to. - // So we will end up doubly traversing the control stack(s), but it should - // be a performance gain to avoid all the PC adjustments for call/return. - lispobj *object_ptr; - for (object_ptr = th->control_stack_start; - object_ptr < access_control_stack_pointer(th); - object_ptr++) - preserve_pointer((void*)*object_ptr); - int i = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)); - for (i = i - 1; i >= 0; --i) { - os_context_t* context = nth_interrupt_context(i, th); - int j; - // FIXME: if we pick a register to consistently use with m[ft]lr - // then we would only need to examine that, and LR and CTR here. - // We may already be consistent, I just don't what the consistency is. - static int boxed_registers[] = BOXED_REGISTERS; - int __attribute__((unused)) ct = 0; - for (j = (int)(sizeof boxed_registers / sizeof boxed_registers[0])-1; j >= 0; --j) - preserve_pointer((void*)*os_context_register_addr(context, - boxed_registers[j])); - preserve_pointer((void*)*os_context_lr_addr(context)); - preserve_pointer((void*)*os_context_ctr_addr(context)); } -#endif // PPC64 } -#endif // Thread creation optionally no longer synchronizes the creating and // created thread. When synchronized, the parent thread is responsible @@ -3990,6 +4137,8 @@ maybe_verify: if (generation >= verify_gens) verify_heap(VERIFY_POST_GC | (generation<<16)); + extern int n_unboxed_instances; + n_unboxed_instances = 0; } static page_index_t @@ -4197,6 +4346,7 @@ memset(n_scav_calls, 0, sizeof n_scav_calls); memset(n_scav_skipped, 0, sizeof n_scav_skipped); garbage_collect_generation(gen, raise); + if (gencgc_verbose) fprintf(stderr, "code scavenged: %d total, %d skipped\n", @@ -4245,6 +4395,14 @@ } write_protect_generation_pages(gen_to_wp); } +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + { + page_index_t page; + for (page=0; pagefixups) { + code = (struct code*)where; + varint_unpacker_init(&unpacker, code->fixups); + // There are two other data streams preceding the one we want + skip_data_stream(&unpacker); + skip_data_stream(&unpacker); + char* instructions = code_text_start(code); + int prev_loc = 0, loc; + while (varint_unpack(&unpacker, &loc) && loc != 0) { + loc += prev_loc; + prev_loc = loc; + void* patch_where = instructions + loc; + gcbarrier_patch_code(patch_where, gc_card_table_nbits); + } + } + where += OBJECT_SIZE(*where, where); + } +} static void gc_allocate_ptes() { page_index_t i; @@ -4376,6 +4560,40 @@ page_table = calloc(1+page_table_pages, sizeof(struct page)); gc_assert(page_table); + // The card table size is a power of 2 at *least* as large + // as the number of cards. These are the default values. + int nbits = 14, num_gc_cards = 1 << nbits; + + // Sure there's a fancier way to round up to a power-of-2 + // but this is executed exactly once, so KISS. + while (num_gc_cards < page_table_pages) { ++nbits; num_gc_cards <<= 1; } + // 2 Gigacards should suffice for now. That would span 2TiB of memory + // using 1Kb card size, or more if larger card size. + gc_assert(nbits < 32); + // If the space size is less than or equal to the number of cards + // that 'gc_card_table_nbits' cover, we're fine. Otherwise, problem. + // 'nbits' is what we need, 'gc_card_table_nbits' is what the core was compiled for. + if (nbits > gc_card_table_nbits) { + gc_card_table_nbits = nbits; +#if defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_X86 || defined LISP_FEATURE_X86_64 + // The value needed based on dynamic space size exceeds the value that the + // core was compiled for, so we need to patch all code blobs. + gcbarrier_patch_code_range(READ_ONLY_SPACE_START, read_only_space_free_pointer); + gcbarrier_patch_code_range(STATIC_SPACE_START, static_space_free_pointer); + gcbarrier_patch_code_range(DYNAMIC_SPACE_START, dynamic_space_free_pointer); +#ifdef LISP_FEATURE_IMMOBILE_SPACE + gcbarrier_patch_code_range(VARYOBJ_SPACE_START, varyobj_free_pointer); +#endif +#endif + } + // Regardless of the mask implied by space size, it has to be gc_card_table_nbits wide + // even if that is excessive - when the core is restarted using a _smaller_ dynamic space + // size than saved at - otherwise lisp could overrun the mark table. + num_gc_cards = 1 << gc_card_table_nbits; + gc_card_table_mask = num_gc_cards - 1; + gc_card_mark = calloc(num_gc_cards, 1); + // fprintf(stderr, "card mark table @ %p\n", gc_card_mark); + gc_common_init(); hopscotch_create(&pinned_objects, HOPSCOTCH_HASH_FUN_DEFAULT, 0 /* hashset */, 32 /* logical bin count */, 0 /* default range */); @@ -4577,8 +4795,7 @@ extern boolean continue_after_memoryfault_on_unprotected_pages; boolean continue_after_memoryfault_on_unprotected_pages = 0; -int -gencgc_handle_wp_violation(void* fault_addr) +int gencgc_handle_wp_violation(void* fault_addr) { page_index_t page_index = find_page_index(fault_addr); @@ -4603,21 +4820,21 @@ /* not within the dynamic space -- not our responsibility */ return 0; - } else { -#if CODE_PAGES_USE_SOFT_PROTECTION || defined (LISP_FEATURE_DARWIN_JIT) - 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 - // concurrently for the same page are fine because they're all doing - // the same bit operations. - gc_assert(!(page_table[page_index].type & OPEN_REGION_PAGE_FLAG)); - unsigned char *pflagbits = (unsigned char*)&page_table[page_index].gen - 1; - unsigned char flagbits = __sync_fetch_and_add(pflagbits, 0); - if (flagbits & WRITE_PROTECTED_FLAG) { + } +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + lose("misuse of mprotect() on dynamic space @ %p", fault_addr); +#else + gc_assert(!is_code(page_table[page_index].type)); + // 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 + // concurrently for the same page are fine because they're all doing + // the same bit operations. + gc_assert(!(page_table[page_index].type & OPEN_REGION_PAGE_FLAG)); + if (PAGE_WRITEPROTECTED_P(page_index)) { unprotect_page_index(page_index); - } else if (!ignore_memoryfaults_on_unprotected_pages) { + } else if (!ignore_memoryfaults_on_unprotected_pages) { + unsigned char *pflagbits = (unsigned char*)&page_table[page_index].gen - 1; + unsigned char flagbits = __sync_fetch_and_add(pflagbits, 0); /* The only acceptable reason for this signal on a heap * access is that GENCGC write-protected the page. * However, if two CPUs hit a wp page near-simultaneously, @@ -4644,16 +4861,16 @@ (uintptr_t)page_scan_start_offset(page_index), page_bytes_used(page_index), page_table[page_index].type, - page_table[page_index].write_protected, + PAGE_WRITEPROTECTED_P(page_index), page_table[page_index].write_protected_cleared, page_table[page_index].gen); if (!continue_after_memoryfault_on_unprotected_pages) lose("Feh."); } - } - /* Don't worry, we can handle it. */ - return 1; } +#endif + /* Don't worry, we can handle it. */ + return 1; } /* This is to be called when we catch a SIGSEGV/SIGBUS, determine that * it's not just a case of the program hitting the write barrier, and @@ -4683,6 +4900,8 @@ * + The pseudo-static generation isn't normally collected, but it seems * reasonable to collect it at least when saving a core. So move the * pages to a normal generation. + * + Instances on unboxed pages need to have their layout pointer visited, + * so all pages have to be turned to boxed. */ static void prepare_for_final_gc () @@ -4694,6 +4913,11 @@ // Compaction requires that we permit large objects to be copied henceforth. // Object of size >= LARGE_OBJECT_SIZE get re-allocated to single-object pages. page_table[i].type &= ~SINGLE_OBJECT_FLAG; + // Turn every page to boxed so that the layouts of instances + // which were relocated to unboxed pages get scanned and fixed. + if ((page_table[i].type & PAGE_TYPE_MASK) == UNBOXED_PAGE_FLAG) + page_table[i].type = + (page_table[i].type | BOXED_PAGE_FLAG) & ~UNBOXED_PAGE_FLAG; if (page_table[i].gen == PSEUDO_STATIC_GENERATION) { int used = page_bytes_used(i); page_table[i].gen = HIGHEST_NORMAL_GENERATION; @@ -4868,9 +5092,30 @@ lose("Attempt to save core after non-conservative GC failed."); } +#ifdef LISP_FEATURE_DARWIN_JIT +/* Inexplicably, an executable page can generate spurious faults if + * it's not written to after changing its protection flags. + * Touch every page... */ +void darwin_jit_code_pages_kludge () { + THREAD_JIT(0); + page_index_t page; + for (page = 0; page < next_free_page; page++) { + if(is_code(page_table[page].type)) { + char* addr = page_address(page); + for (unsigned i = 0; i < GENCGC_CARD_BYTES; i+=4096) { + volatile char* page_start = addr + i; + page_start[0] = page_start[0]; + } + } + } + THREAD_JIT(1); +} +#endif + /* Read corefile ptes from 'fd' which has already been positioned * and store into the page table */ -void gc_load_corefile_ptes(core_entry_elt_t n_ptes, core_entry_elt_t total_bytes, +void gc_load_corefile_ptes(int card_table_nbits, + core_entry_elt_t n_ptes, core_entry_elt_t total_bytes, os_vm_offset_t offset, int fd) { gc_assert(ALIGN_UP(n_ptes * sizeof (struct corefile_pte), N_WORD_BYTES) @@ -4878,6 +5123,7 @@ // Allocation of PTEs is delayed 'til now so that calloc() doesn't // consume addresses that would have been taken by a mapped space. + gc_card_table_nbits = card_table_nbits; gc_allocate_ptes(); if ( @@ -4930,21 +5176,26 @@ // write-protecting needs the current value of next_free_page next_free_page = n_ptes; if (gen != 0 && ENABLE_PAGE_PROTECTION) { +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + page_index_t p; + for (p = 0; p < next_free_page; ++p) if (page_bytes_used(p)) SET_PAGE_PROTECTED(p, 1); +#else // coreparse can avoid hundreds to thousands of mprotect() calls by // treating the whole range from the corefile as protectable, except // that soft-marked code pages must NOT be subject to mprotect. // So just watch out for empty pages and code. Unboxed object pages // will get unprotected on demand. -#define non_protectable_page_p(x) !page_bytes_used(x) || \ - (CODE_PAGES_USE_SOFT_PROTECTION && is_code(page_table[x].type)) +#define non_protectable_page_p(x) !page_bytes_used(x) || is_code(page_table[x].type) page_index_t start = 0, end; // cf. write_protect_generation_pages() while (start < next_free_page) { #ifdef LISP_FEATURE_DARWIN_JIT if(is_code(page_table[start].type)) { + SET_PAGE_PROTECTED(start,1); for (end = start + 1; end < next_free_page; end++) { - if (non_protectable_page_p(end) || !is_code(page_table[end].type)) + if (!page_bytes_used(end) || !is_code(page_table[end].type)) break; + SET_PAGE_PROTECTED(end,1); } os_protect(page_address(start), npage_bytes(end - start), OS_VM_PROT_ALL); start = end+1; @@ -4952,26 +5203,23 @@ } #endif if (non_protectable_page_p(start)) { - ++start; continue; } - page_table[start].write_protected = 1; + SET_PAGE_PROTECTED(start,1); for (end = start + 1; end < next_free_page; end++) { - if (non_protectable_page_p(end) -#ifdef LISP_FEATURE_DARWIN_JIT - || is_code(page_table[end].type) -#endif - ) + if (non_protectable_page_p(end)) break; - page_table[end].write_protected = 1; + SET_PAGE_PROTECTED(end,1); } os_protect(page_address(start), npage_bytes(end - start), OS_VM_PROT_JIT_READ); start = end; } +#endif } #ifdef LISP_FEATURE_DARWIN_JIT + darwin_jit_code_pages_kludge(); /* For some reason doing an early pthread_jit_write_protect_np sometimes fails. Which is weird, because it's done many times in arch_write_linkage_table_entry later. Adding the executable bit here avoids calling pthread_jit_write_protect_np */ @@ -5005,7 +5253,7 @@ printf("page %"PAGE_INDEX_FMT" gen %d type %x ss %p used %x%s\n", page, page_table[page].gen, page_table[page].type, page_scan_start(page), page_bytes_used(page), - page_table[page].write_protected? " WP":""); + PAGE_WRITEPROTECTED_P(page)? " WP":""); return; } #ifdef LISP_FEATURE_IMMOBILE_SPACE @@ -5014,7 +5262,7 @@ printf("page %ld (v) ss=%p gens %x%s\n", page, varyobj_scan_start(page), varyobj_pages[page].generations, - card_protected_p((void*)obj)? " WP":""); + addr_protected_p((void*)obj)? " WP":""); return; } page = find_fixedobj_page_index((void*)obj); @@ -5022,7 +5270,7 @@ printf("page %ld (f) align %d gens %x%s\n", page, fixedobj_pages[page].attr.parts.obj_align, fixedobj_pages[page].attr.parts.gens_, - card_protected_p((void*)obj)? " WP":""); + addr_protected_p((void*)obj)? " WP":""); return; } #endif @@ -5068,8 +5316,7 @@ // that got copied as written, which would allow dropping the second half // of the OR condition. As is, we scavenge "too much" of newspace which // is not an issue of correctness but rather efficiency. - if (!CODE_PAGES_USE_SOFT_PROTECTION || - header_rememberedp(header) || (my_gen == new_space) || + if (header_rememberedp(header) || (my_gen == new_space) || ((uword_t)object >= STATIC_SPACE_START && object < static_space_free_pointer)) { // FIXME: We sometimes scavenge protected pages. // This assertion fails, but things work nonetheless. @@ -5081,9 +5328,7 @@ #ifdef LISP_FEATURE_UNTAGGED_FDEFNS // Process each untagged fdefn pointer. - // If CODE_PAGES_USE_SOFT_PROTECTION were enabled along with untagged fdefns, - // then the generation check at the bottom of this function would have to be - // modified to take into account untagged pointers. + // TODO: assert that the generation of any fdefn is older than that of 'code'. lispobj* fdefns_start = code->constants + code_n_funs(code) * CODE_SLOTS_PER_SIMPLE_FUN; int n_fdefns = code_n_named_calls(code); @@ -5124,7 +5369,7 @@ * pointers. If my_gen is newspace, there can be no such pointers * because newspace is the lowest numbered generation post-GC * (regardless of whether this is a promotion cycle) */ - if (CODE_PAGES_USE_SOFT_PROTECTION && my_gen != new_space) { + if (my_gen != new_space) { lispobj *where, *end = object + n_header_words, ptr; for (where= object + 2; where < end; ++where) if (is_lisp_pointer(ptr = *where) && obj_gen_lessp(ptr, my_gen)) diff -Nru sbcl-2.1.10/src/runtime/gencgc-internal.h sbcl-2.1.11/src/runtime/gencgc-internal.h --- sbcl-2.1.10/src/runtime/gencgc-internal.h 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/gencgc-internal.h 2021-11-30 16:16:46.000000000 +0000 @@ -108,11 +108,7 @@ * * If the page is free, all the following fields are zero. */ type :5, - /* This is set when the page is write-protected. This should - * always reflect the actual write_protect status of a page. - * (If the page is written into, we catch the exception, make - * the page writable, and clear this flag.) */ - write_protected :1, + padding :1, /* This flag is set when the above write_protected flag is * cleared by the SIGBUS handler (or SIGSEGV handler, for some * OSes). This is useful for re-scavenging pages that are @@ -131,12 +127,35 @@ extern struct page *page_table; #ifdef LISP_FEATURE_BIG_ENDIAN # define WP_CLEARED_FLAG (1<<1) -# define WRITE_PROTECTED_FLAG (1<<2) #else -# define WRITE_PROTECTED_FLAG (1<<5) # define WP_CLEARED_FLAG (1<<6) #endif +/* When computing a card index we never subtract the heap base, which simplifies + * code generation. Because there is no alignment constraint beyond being card-aligned, + * the low bits can wraparound from all 1s to all 0s such that lowest numbered + * page index in linear order may have a higher card index. + * As a small example of the distinction between page index and card index: + * heap base = 0xEB00, card size = 256 bytes, total cards = 8, mask = #b111 + * + * page page card + * index addr index + * 0 EB00 3 + * 1 EC00 4 + * 2 ED00 5 + * 3 EE00 6 + * 4 EF00 7 + * 5 F000 0 + * 6 F100 1 + * 7 F200 2 + */ +extern char * gc_card_mark; +extern int gc_card_table_mask; +#define addr_to_card_index(addr) ((((uword_t)addr)>>GENCGC_CARD_SHIFT) & gc_card_table_mask) +#define page_to_card_index(n) addr_to_card_index(page_address(n)) +#define PAGE_WRITEPROTECTED_P(n) (gc_card_mark[page_to_card_index(n)] & 1) +#define SET_PAGE_PROTECTED(n,val) gc_card_mark[page_to_card_index(n)] = val + struct __attribute__((packed)) corefile_pte { uword_t sso; // scan start offset page_bytes_t bytes_used; diff -Nru sbcl-2.1.10/src/runtime/gencgc-private.h sbcl-2.1.11/src/runtime/gencgc-private.h --- sbcl-2.1.10/src/runtime/gencgc-private.h 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/gencgc-private.h 2021-11-30 16:16:46.000000000 +0000 @@ -89,17 +89,18 @@ #endif +// If *all* pages use soft card marks, then protection_mode() is not a thing. +// Otherwise, only pages of code use soft card marks; return an enum indicating +// whether the page protection for the specified page is applied in harware. +#ifndef LISP_FEATURE_SOFT_CARD_MARKS enum prot_mode { PHYSICAL, LOGICAL }; static inline enum prot_mode protection_mode(page_index_t page) { -#if CODE_PAGES_USE_SOFT_PROTECTION // code pages can be marked as logically read-only without OS protection, // and everything else uses hardware-based protection where applicable. return ((page_table[page].type & PAGE_TYPE_MASK) == CODE_PAGE_TYPE) ? LOGICAL : PHYSICAL; -#else - return PHYSICAL; // all pages, if protected, use hardware-based protection -#endif } +#endif #ifndef LISP_FEATURE_SB_THREAD #define SINGLE_THREAD_BOXED_REGION (struct alloc_region*)(STATIC_SPACE_START + 2*N_WORD_BYTES) diff -Nru sbcl-2.1.10/src/runtime/globals.h sbcl-2.1.11/src/runtime/globals.h --- sbcl-2.1.10/src/runtime/globals.h 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/globals.h 2021-11-30 16:16:46.000000000 +0000 @@ -54,6 +54,7 @@ extern unsigned int varyobj_space_size; #endif extern uword_t asm_routines_start, asm_routines_end; +extern int gc_card_table_nbits; static inline lispobj points_to_asm_code_p(uword_t ptr) { return asm_routines_start <= ptr && ptr < asm_routines_end; diff -Nru sbcl-2.1.10/src/runtime/GNUmakefile sbcl-2.1.11/src/runtime/GNUmakefile --- sbcl-2.1.10/src/runtime/GNUmakefile 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/GNUmakefile 2021-11-30 16:16:46.000000000 +0000 @@ -122,9 +122,9 @@ # for this to work, you must have with-gcc-tls in your build features already. # can't define it here because then it conflicts if you have it in both places. %.pic.o: %.c - $(CC) -fPIC -c $(CPPFLAGS) -DSHARED_LIBRARY=1 $(filter-out -fno-pie,$(CFLAGS)) $< -o $@ + $(CC) -fPIC -c $(CPPFLAGS) $(filter-out -fno-pie,$(CFLAGS)) $< -o $@ %.pic.o: %.S # (-fPIC doesn't affect hand-written assembly source) - $(CC) -c $(CPPFLAGS) -DSHARED_LIBRARY=1 $(CFLAGS) $< -o $@ + $(CC) -c $(CPPFLAGS) $(CFLAGS) $< -o $@ SHRINKWRAP_DEPS = ../../output/sbcl.core ../../tools-for-build/editcore.lisp shrinkwrap-sbcl.s shrinkwrap-sbcl-core.o: $(SHRINKWRAP_DEPS) diff -Nru sbcl-2.1.10/src/runtime/haiku-os.c sbcl-2.1.11/src/runtime/haiku-os.c --- sbcl-2.1.10/src/runtime/haiku-os.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/haiku-os.c 2021-11-30 16:16:46.000000000 +0000 @@ -61,10 +61,7 @@ return (status == 0) ? copied_string(info.name) : 0; } -void -os_init(char __attribute__((unused)) *argv[], char __attribute__((unused)) *envp[]) -{ -} +void os_init() {} static void sigsegv_handler(int signal, siginfo_t *info, os_context_t *context) diff -Nru sbcl-2.1.10/src/runtime/immobile-space.c sbcl-2.1.11/src/runtime/immobile-space.c --- sbcl-2.1.10/src/runtime/immobile-space.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/immobile-space.c 2021-11-30 16:16:46.000000000 +0000 @@ -277,7 +277,25 @@ 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); + /* BUG: This assertion is itself buggy and has to be commented out + * if running with extra debug assertions. + * It's only OK in single-threaded code, but consider two threads: + * Thread A Thread B + * -------- -------- + * 1. change attributes of + * page 483 (e.g.) from 0 + * to something + * 2. observe that page 483 has + * desired page_attributes, + * and return it from get_freeish_page + * 3. read the now-obsolete value of + * fixedobj_free_pointer at the dcheck. + * 4. bump the free pointer to + * the end of page 483 + * and return that page + * 5. FAIL the dcheck + * 5. pass the dcheck */ + // gc_dcheck(fixedobj_page_address(page) < (void*)fixedobj_free_pointer); do { page_data = fixedobj_page_address(page); obj_ptr = page_data + fixedobj_pages[page].free_index; diff -Nru sbcl-2.1.10/src/runtime/interrupt.c sbcl-2.1.11/src/runtime/interrupt.c --- sbcl-2.1.10/src/runtime/interrupt.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/interrupt.c 2021-11-30 16:16:46.000000000 +0000 @@ -324,7 +324,7 @@ #define RECORD_SIGNAL(sig,ctxt) #endif -#if defined(SHARED_LIBRARY) || defined(LISP_FEATURE_WIN32) +#ifdef LISP_FEATURE_WIN32 # define should_handle_in_this_thread(c) (1) #else # define should_handle_in_this_thread(c) lisp_thread_p(c) diff -Nru sbcl-2.1.10/src/runtime/linux-os.c sbcl-2.1.11/src/runtime/linux-os.c --- sbcl-2.1.10/src/runtime/linux-os.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/linux-os.c 2021-11-30 16:16:46.000000000 +0000 @@ -259,8 +259,7 @@ #endif -void os_init(char __attribute__((unused)) *argv[], - char __attribute__((unused)) *envp[]) +void os_init() { #ifdef LISP_FEATURE_SB_FUTEX futex_init(); @@ -339,6 +338,11 @@ void os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot) { +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + // dynamic space should not have protections manipulated + if (find_page_index(address) >= 0) + lose("unexpected call to os_protect with software card marks"); +#endif if (mprotect(address, length, prot)) { if (errno == ENOMEM) { lose("An mprotect call failed with ENOMEM. This probably means that the maximum amount\n" diff -Nru sbcl-2.1.10/src/runtime/os.h sbcl-2.1.11/src/runtime/os.h --- sbcl-2.1.10/src/runtime/os.h 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/os.h 2021-11-30 16:16:46.000000000 +0000 @@ -76,7 +76,7 @@ /* Do anything we need to do when starting up the runtime environment * in this OS. */ -extern void os_init(char *argv[], char *envp[]); +extern void os_init(); /* Install any OS-dependent low-level signal handlers which are needed * by the runtime environment. E.g. the signals raised by a violation diff -Nru sbcl-2.1.10/src/runtime/ppc64-assem.S sbcl-2.1.11/src/runtime/ppc64-assem.S --- sbcl-2.1.10/src/runtime/ppc64-assem.S 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/ppc64-assem.S 2021-11-30 16:16:46.000000000 +0000 @@ -211,6 +211,9 @@ ld reg_A2,16(reg_CFP) ld reg_A3,24(reg_CFP) + /* load card table base */ + ld reg_NL5, THREAD_CARD_TABLE_OFFSET(reg_THREAD) + /* Calculate LRA */ lis reg_LRA,lra@h ori reg_LRA,reg_LRA,lra@l @@ -445,6 +448,9 @@ mr reg_CSP,reg_CFP mr reg_CFP,reg_OCFP + /* load card table base */ + ld reg_NL5, THREAD_CARD_TABLE_OFFSET(reg_THREAD) + /* And back into Lisp. */ blr @@ -471,11 +477,10 @@ obtain a tagged pointer to the enclosing code component. Code pointers have no tag, so we have have to subtract OTHER_POINTER_LOWTAG as well as account for the number of - boxed words (see calculation for RETURN_PC_WIDETAG, above). - Restoring reg_CODE doesn't appear to be strictly necessary - here, but let's observe the niceties.*/ - /* KLUDGE: the extra 2 words are for the jump table prefix and padding. */ - addi reg_CODE, reg_LRA, (2+((CODE_SIZE+1)&~1))*-N_WORD_BYTES-OTHER_POINTER_LOWTAG + boxed words (see calculation for RETURN_PC_WIDETAG, above). */ + /* KLUDGE: I have no idea why CODE_SIZE+4 is correct here, + let alone the general formula for keeping this maintenance-free */ + addi reg_CODE, reg_LRA, (CODE_SIZE+4)*-N_WORD_BYTES-OTHER_POINTER_LOWTAG /* Multiple values are stored relative to reg_OCFP, which we set to be the current top-of-stack. */ diff -Nru sbcl-2.1.10/src/runtime/ppc-arch.c sbcl-2.1.11/src/runtime/ppc-arch.c --- sbcl-2.1.10/src/runtime/ppc-arch.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/ppc-arch.c 2021-11-30 16:16:46.000000000 +0000 @@ -835,3 +835,19 @@ os_flush_icache((os_vm_address_t) reloc_addr, (char*) inst_ptr - reloc_addr); } + +void gcbarrier_patch_code(void* where, int nbits) +{ +#ifdef LISP_FEATURE_64_BIT + int m_operand = 64 - nbits; + // the M field has a kooky encoding + int m_encoded = ((m_operand & 0x1F) << 1) | (m_operand >> 5); + unsigned int* pc = where; + unsigned int inst = *pc; + // .... ____ _xxx xxx_ ____ = 0x7E0; + // ^ deposit it here, in (BYTE 6 5) of the instruction. + *pc = (inst & ~0x7E0) | (m_encoded << 5); +#else + lose("can't patch rldicl in 32-bit"); // illegal instruction +#endif +} diff -Nru sbcl-2.1.10/src/runtime/ppc-assem.S sbcl-2.1.11/src/runtime/ppc-assem.S --- sbcl-2.1.10/src/runtime/ppc-assem.S 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/ppc-assem.S 2021-11-30 16:16:46.000000000 +0000 @@ -647,11 +647,10 @@ obtain a tagged pointer to the enclosing code component. Both values are tagged OTHER_POINTER_LOWTAG, so we just have to account for N words (see calculation for RETURN_PC_WIDETAG, above) - between the two addresses. - Restoring reg_CODE doesn't appear to be strictly necessary - here, but let's observe the niceties.*/ - /* KLUDGE: the extra 2 words are for the jump table prefix and padding. */ - addi reg_CODE, reg_LRA, (2+((CODE_SIZE+1)&~1))*-N_WORD_BYTES + between the two addresses. */ + /* KLUDGE: I have no idea why CODE_SIZE+4 is correct here, + let alone the general formula for keeping this maintenance-free */ + addi reg_CODE, reg_LRA, (CODE_SIZE+4)*-N_WORD_BYTES /* Multiple values are stored relative to reg_OCFP, which we set to be the current top-of-stack. */ diff -Nru sbcl-2.1.10/src/runtime/print.c sbcl-2.1.11/src/runtime/print.c --- sbcl-2.1.10/src/runtime/print.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/print.c 2021-11-30 16:16:46.000000000 +0000 @@ -26,6 +26,7 @@ #include "code.h" #include "gc-internal.h" #include "gc-private.h" +#include "genesis/gc-tables.h" #include #include "thread.h" /* genesis/primitive-objects.h needs this */ #include @@ -421,7 +422,7 @@ static void brief_struct(lispobj obj) { - struct instance *instance = (struct instance *)native_pointer(obj); + struct instance *instance = INSTANCE(obj); extern struct vector * instance_classoid_name(lispobj*); struct vector * classoid_name; classoid_name = instance_classoid_name((lispobj*)instance); @@ -464,7 +465,7 @@ static void print_struct(lispobj obj) { - struct instance *instance = (struct instance *)native_pointer(obj); + struct instance *instance = INSTANCE(obj); short int i; char buffer[16]; lispobj layout = instance_layout(native_pointer(obj)); @@ -573,19 +574,18 @@ lispobj symbol_function(lispobj* symbol) { - lispobj info = ((struct symbol*)symbol)->info; - if (listp(info)) - info = CONS(info)->cdr; - if (lowtag_of(info) == OTHER_POINTER_LOWTAG) { - struct vector* v = VECTOR(info); - int len = vector_len(v); - if (len != 0) { - lispobj elt = v->data[0]; // Just like INFO-VECTOR-FDEFN - if (fixnump(elt) && (fixnum_value(elt) & 07777) >= 07701) { - lispobj fdefn = v->data[len-1]; - if (lowtag_of(fdefn) == OTHER_POINTER_LOWTAG) - return FDEFN(fdefn)->fun; - } + lispobj info_holder = ((struct symbol*)symbol)->info; + if (listp(info_holder)) + info_holder = CONS(info_holder)->cdr; + if (lowtag_of(info_holder) == INSTANCE_POINTER_LOWTAG) { + struct instance* info = INSTANCE(info_holder); + // Do the same thing as PACKED-INFO-FDEFN + lispobj elt = info->slots[INSTANCE_DATA_START]; + if (fixnump(elt) && (fixnum_value(elt) & 07777) >= 07701) { + int len = (info->header >> INSTANCE_LENGTH_SHIFT) & INSTANCE_LENGTH_MASK; + lispobj fdefn = info->slots[len-1]; + if (lowtag_of(fdefn) == OTHER_POINTER_LOWTAG) + return FDEFN(fdefn)->fun; } } return NIL; @@ -821,9 +821,8 @@ break; default: NEWLINE_OR_RETURN; - if (type >= SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG && - type <= SIMPLE_BIT_VECTOR_WIDETAG) // ASSUMPTION: widetag ordering - printf("length = %ld", vector_len(VECTOR(obj))); + if (specialized_vector_widetag_p(type)) + printf("length = %"OBJ_FMTd, vector_len(VECTOR(obj))); else printf("Unknown header object?"); break; diff -Nru sbcl-2.1.10/src/runtime/private-cons.inc sbcl-2.1.11/src/runtime/private-cons.inc --- sbcl-2.1.10/src/runtime/private-cons.inc 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/private-cons.inc 2021-11-30 16:16:46.000000000 +0000 @@ -81,7 +81,7 @@ if (PRIVATE_CONS_DEBUG) fprintf(stderr, "GC-private page @ %p\n", page_header); gc_assert(last_page == page); - gc_assert(!page_table[page].write_protected); + gc_assert(!PAGE_WRITEPROTECTED_P(page)); page_table[page].gen = 0; page_table[page].type = UNBOXED_PAGE_FLAG; zero_dirty_pages(page, page, 0); diff -Nru sbcl-2.1.10/src/runtime/runtime.c sbcl-2.1.11/src/runtime/runtime.c --- sbcl-2.1.10/src/runtime/runtime.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/runtime.c 2021-11-30 16:16:46.000000000 +0000 @@ -304,37 +304,23 @@ static size_t parse_size_arg(char *arg, char *arg_name) { - char *tail, *power_name; - size_t power, res; + char *tail; + size_t power = 20, res; res = strtoul(arg, &tail, 0); if (arg == tail) { lose("%s argument is not a number: %s", arg_name, arg); } else if (tail[0]) { - int i, size; - power_name = copied_string(tail); - size = strlen(power_name); - for (i=0; i= (SIZE_MAX >> power))) { @@ -398,94 +384,123 @@ extern void write_protect_immobile_space(); struct lisp_startup_options lisp_startup_options; -int -initialize_lisp(int argc, char *argv[], char *envp[]) + +struct cmdline_options { + char *core; + char **argv; + boolean disable_lossage_handler_p; + int merge_core_pages; +}; + +static int is_memsize_arg(char *argv[], int argi, int argc, int *merge_core_pages) { -#ifdef LISP_FEATURE_WIN32 - /* 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); + char *arg = argv[argi]; + if (!strcmp(arg, "--dynamic-space-size")) { + if ((argi+1) >= argc) lose("missing argument for --dynamic-space-size"); + dynamic_space_size = parse_size_arg(argv[argi+1], + "--dynamic-space-size"); +#ifdef MAX_DYNAMIC_SPACE_END + if (!((DYNAMIC_SPACE_START < + DYNAMIC_SPACE_START+dynamic_space_size) && + (DYNAMIC_SPACE_START+dynamic_space_size <= + MAX_DYNAMIC_SPACE_END))) { + char* suffix = ""; + char* size = argv[argi-1]; + if (!strchr(size, 'B') && !strchr(size, 'b')) suffix = " [MB]"; + lose("--dynamic-space-size argument %s%s is too large, max %lu KB", + size, suffix, (MAX_DYNAMIC_SPACE_END-DYNAMIC_SPACE_START) / 1024); + } #endif + return 2; + } + if (!strcmp(arg, "--control-stack-size")) { + if ((argi+1) >= argc) lose("missing argument for --control-stack-size"); + thread_control_stack_size = parse_size_arg(argv[argi+1], "--control-stack-size"); + return 2; + } + if (!strcmp(arg, "--tls-limit")) { + // this is not named "tls-size" because "size" is not the + // best measurement for how many symbols to allow + if ((argi+1) >= argc) lose("missing argument for --tls-limit"); + dynamic_values_bytes = N_WORD_BYTES * atoi(argv[argi+1]); + return 2; + } + if (!strcmp(arg, "--merge-core-pages")) { + *merge_core_pages = 1; + return 1; + } + if (!strcmp(arg, "--no-merge-core-pages")) { + *merge_core_pages = 0; + return 1; + } + return 0; +} - /* 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; - +static struct cmdline_options +parse_argv(struct memsize_options memsize_options, + int argc, char *argv[], char *core) +{ #ifdef LISP_FEATURE_WIN32 wchar_t #else char #endif **sbcl_argv = 0; - os_vm_offset_t embedded_core_offset = 0; - /* other command line options */ - boolean end_runtime_options = 0; boolean disable_lossage_handler_p #if defined(LISP_FEATURE_SB_LDB) = 0; #else = 1; #endif - boolean debug_environment_p = 0; - - lispobj initial_function; int merge_core_pages = -1; - struct memsize_options memsize_options; - memsize_options.present_in_core = 0; - - boolean have_hardwired_spaces = os_preinit(argv, envp); - - 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 - * options */ - if (!(sbcl_runtime = os_get_runtime_executable_path())) - sbcl_runtime = search_for_executable(argv[0]); - - if (!(sbcl_runtime_home = dir_name(argv[0]))) - if (!(sbcl_runtime_home = dir_name(sbcl_runtime))) - sbcl_runtime_home = libpath; - - if (sbcl_runtime) { - os_vm_offset_t offset = search_for_embedded_core(sbcl_runtime, &memsize_options); - if (offset != -1) { - embedded_core_offset = offset; - core = sbcl_runtime; - } - } - - /* Parse our part of the command line (aka "runtime options"), - * stripping out those options that we handle. */ + int argi = 1; + int n_consumed; if (memsize_options.present_in_core) { + /* Our arg parsing isn't (and can't be) integrated with the application's, + * but we really want users to be able to override the heap size. + * So don't parse most options, but _do_ parse memory size options and/or + * core page merging options, wherever they occur, and strip them out. + * Any args that remain are passed through to Lisp. + * + * This does have a small semantic glitch: If your executable accepts + * flags such as "--my-opt" "--merge-core-pages" where "--merge-core-pages" + * is literally (and perversely) the value the user gives to "--my-opt", + * that's just too bad! The somewhat conventional "--" option will stop + * parsing SBCL options and pass everything else through including the "--". + * The rationale for passing "--" through is that we're trying to be + * as uninvasive as possible. Let's hope that nobody needs to put a "--" + * to the left of any of the memory size options */ 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; + sbcl_argv = successful_malloc((argc + 1) * sizeof(char *)); + sbcl_argv[0] = argv[0]; + int stop_parsing = 0; // have we seen '--' + int output_index = 1; + while (argi < argc) { + if (stop_parsing) // just copy it over + sbcl_argv[output_index++] = argv[argi++]; + else if (!strcmp(argv[argi], "--")) // keep it, but parse nothing else + sbcl_argv[output_index++] = argv[argi++], stop_parsing = 1; + else if ((n_consumed = is_memsize_arg(argv, argi, argc, &merge_core_pages))) + argi += n_consumed; // eat it + else // default action - copy it + sbcl_argv[output_index++] = argv[argi++]; + } + sbcl_argv[output_index] = 0; #else int wargc; sbcl_argv = CommandLineToArgvW(GetCommandLineW(), &wargc); + // Somebody who wishes this to work for #+win32 should feel free to do the same... #endif } else { - int argi = 1; - + boolean end_runtime_options = 0; + /* Parse our any of the command-line options that we handle from C, + * stopping at the first one that we don't, and leave the rest */ while (argi < argc) { char *arg = argv[argi]; if (0 == strcmp(arg, "--script")) { @@ -522,40 +537,8 @@ /* As in "--help" case, I think this is expected. */ print_version(); exit(0); - } else if (0 == strcmp(arg, "--dynamic-space-size")) { - ++argi; - if (argi >= argc) - lose("missing argument for --dynamic-space-size"); - dynamic_space_size = parse_size_arg(argv[argi++], - "--dynamic-space-size"); -# ifdef MAX_DYNAMIC_SPACE_END - if (!((DYNAMIC_SPACE_START < - DYNAMIC_SPACE_START+dynamic_space_size) && - (DYNAMIC_SPACE_START+dynamic_space_size <= - MAX_DYNAMIC_SPACE_END))) { - char* suffix = ""; - char* size = argv[argi-1]; - if (!strchr(size, 'B') && !strchr(size, 'b')) { - suffix = " [MB]"; - } - lose("--dynamic-space-size argument %s%s is too large, max %lu KB", - size, suffix, - (MAX_DYNAMIC_SPACE_END-DYNAMIC_SPACE_START) / 1024); - } -# endif - } else if (0 == strcmp(arg, "--control-stack-size")) { - ++argi; - if (argi >= argc) - lose("missing argument for --control-stack-size"); - errno = 0; - thread_control_stack_size = parse_size_arg(argv[argi++], "--control-stack-size"); - } else if (0 == strcmp(arg, "--tls-limit")) { - // this is not named "tls-size" because "size" is not the - // best measurement for how many symbols to allow - ++argi; - if (argi >= argc) - lose("missing argument for --tls-limit"); - dynamic_values_bytes = N_WORD_BYTES * atoi(argv[argi++]); + } else if ((n_consumed = is_memsize_arg(argv, argi, argc, &merge_core_pages))) { + argi += 2; } else if (0 == strcmp(arg, "--debug-environment")) { debug_environment_p = 1; ++argi; @@ -569,12 +552,6 @@ end_runtime_options = 1; ++argi; break; - } else if (0 == strcmp(arg, "--merge-core-pages")) { - ++argi; - merge_core_pages = 1; - } else if (0 == strcmp(arg, "--no-merge-core-pages")) { - ++argi; - merge_core_pages = 0; } else { /* This option was unrecognized as a runtime option, * so it must be a toplevel option or a user option, @@ -628,6 +605,74 @@ sbcl_argv[argj] = 0; } } + if (debug_environment_p) { + print_environment(argc, argv); + } + + struct cmdline_options o; + o.core = core; + o.argv = sbcl_argv; + o.disable_lossage_handler_p = disable_lossage_handler_p; + o.merge_core_pages = merge_core_pages; + return o; +} + +int +initialize_lisp(int argc, char *argv[], char *envp[]) +{ +#ifdef LISP_FEATURE_WIN32 + /* 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; + + os_vm_offset_t embedded_core_offset = 0; + + lispobj initial_function; + struct memsize_options memsize_options; + memsize_options.present_in_core = 0; + + boolean have_hardwired_spaces = os_preinit(argv, envp); + + 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 + * options */ + if (!(sbcl_runtime = os_get_runtime_executable_path())) + sbcl_runtime = search_for_executable(argv[0]); + + if (!(sbcl_runtime_home = dir_name(argv[0]))) + if (!(sbcl_runtime_home = dir_name(sbcl_runtime))) + sbcl_runtime_home = libpath; + + if (sbcl_runtime) { + os_vm_offset_t offset = search_for_embedded_core(sbcl_runtime, &memsize_options); + if (offset != -1) { + embedded_core_offset = offset; + core = sbcl_runtime; + } + } + + struct cmdline_options options = parse_argv(memsize_options, argc, argv, core); /* Align down to multiple of page_table page size, and to the appropriate * stack alignment. */ @@ -637,10 +682,7 @@ #endif thread_control_stack_size &= ~(sword_t)(CONTROL_STACK_ALIGNMENT_BYTES-1); - os_init(argv, envp); - if (debug_environment_p) { - print_environment(argc, argv); - } + os_init(); dyndebug_init(); // 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 @@ -649,6 +691,7 @@ gc_init(); /* If no core file was specified, look for one. */ + core = options.core; if (!core && !(core = search_for_core())) { /* Try resolving symlinks */ if (sbcl_runtime) { @@ -696,7 +739,7 @@ * of mapping dynamic space at our preferred address (if movable). * If not movable, it was already mapped in allocate_spaces(). */ initial_function = load_core_file(core, embedded_core_offset, - merge_core_pages); + options.merge_core_pages); if (initial_function == NIL) { lose("couldn't find initial function"); } @@ -708,7 +751,7 @@ define_var("nil", NIL, 1); define_var("t", T, 1); - if (!disable_lossage_handler_p) + if (!options.disable_lossage_handler_p) enable_lossage_handler(); os_link_runtime(); @@ -736,7 +779,7 @@ * need to be processed further there, to do locale conversion. */ core_string = core; - posix_argv = sbcl_argv; + posix_argv = options.argv; FSHOW((stderr, "/funcalling initial_function=0x%lx\n", (unsigned long)initial_function)); diff -Nru sbcl-2.1.10/src/runtime/save.c sbcl-2.1.11/src/runtime/save.c --- sbcl-2.1.10/src/runtime/save.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/save.c 2021-11-30 16:16:46.000000000 +0000 @@ -368,7 +368,8 @@ memset(data + aligned_size - N_WORD_BYTES, 0, N_WORD_BYTES); gc_store_corefile_ptes((struct corefile_pte*)data); write_lispobj(PAGE_TABLE_CORE_ENTRY_TYPE_CODE, file); - write_lispobj(5, file); // 5 = # of words in this core header entry + write_lispobj(6, file); // number of words in this core header entry + write_lispobj(gc_card_table_nbits, file); write_lispobj(next_free_page, file); write_lispobj(aligned_size, file); sword_t offset = write_bytes(file, data, aligned_size, core_start_pos, diff -Nru sbcl-2.1.10/src/runtime/sunos-os.c sbcl-2.1.11/src/runtime/sunos-os.c --- sbcl-2.1.10/src/runtime/sunos-os.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/sunos-os.c 2021-11-30 16:16:46.000000000 +0000 @@ -26,10 +26,7 @@ #include "gc-internal.h" #endif -void -os_init(char *argv[], char *envp[]) -{ -} +void os_init() {} os_vm_address_t os_validate(int attributes, os_vm_address_t addr, os_vm_size_t len, int __attribute__((unused)) execute, int __attribute__((unused)) jit) diff -Nru sbcl-2.1.10/src/runtime/thread.c sbcl-2.1.11/src/runtime/thread.c --- sbcl-2.1.10/src/runtime/thread.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/thread.c 2021-11-30 16:16:46.000000000 +0000 @@ -347,6 +347,14 @@ #else funcall0(function); #endif + // If we end up returning, clean up the initial thread. +#ifdef LISP_FEATURE_SB_THREAD + unlink_thread(th); +#else + all_threads = NULL; +#endif + arch_os_thread_cleanup(th); + ASSIGN_CURRENT_THREAD(NULL); } #ifdef LISP_FEATURE_SB_THREAD @@ -911,17 +919,12 @@ #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; 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; - th->dynspace_pte_base = (lispobj)page_table; -#endif th->os_address = spaces; th->control_stack_start = (lispobj*)aligned_spaces; @@ -1041,6 +1044,14 @@ #if GENCGC_IS_PRECISE thread_interrupt_data(th).allocation_trap_context = 0; #endif +#if defined LISP_FEATURE_PPC64 + /* Storing a 0 into code coverage mark bytes or GC card mark bytes + * can be done from the low byte of the thread base register. + * The thread alignment is BACKEND_PAGE_BYTES (from thread.h), but seeing as this is + * a similar-but-different requirement, it pays to double-check */ + if ((lispobj)th & 0xFF) lose("Thread struct not at least 256-byte-aligned"); + th->card_table = (lispobj)gc_card_mark; +#endif #ifdef LISP_FEATURE_SB_THREAD // This macro is the same as "write_TLS(sym,val,th)" but can't be spelled thus. diff -Nru sbcl-2.1.10/src/runtime/traceroot.c sbcl-2.1.11/src/runtime/traceroot.c --- sbcl-2.1.10/src/runtime/traceroot.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/traceroot.c 2021-11-30 16:16:46.000000000 +0000 @@ -980,7 +980,9 @@ &targets, &visited, inverted_heap, &scratchpad, n_pins, pins, context_scanner, criterion); - if ((VECTOR(paths)->data[i] = path) != 0) ++n_found; + lispobj* elt = VECTOR(paths)->data + i; + ensure_ptr_word_writable(elt); + if ((*elt = path) != 0) ++n_found; } ++i; } while (weak_pointers != NIL); diff -Nru sbcl-2.1.10/src/runtime/var-io.c sbcl-2.1.11/src/runtime/var-io.c --- sbcl-2.1.10/src/runtime/var-io.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/var-io.c 2021-11-30 16:16:46.000000000 +0000 @@ -9,6 +9,11 @@ * files for more information. */ +#include "genesis/config.h" +#include "genesis/bignum.h" +#include "gc-assert.h" +#include "var-io.h" + // Read a variable-length encoded 32-bit integer from SOURCE and // return its value. // @@ -35,3 +40,57 @@ } return result; } + +void varint_unpacker_init(struct varint_unpacker* unpacker, lispobj integer) +{ + if (fixnump(integer)) { + unpacker->word = fixnum_value(integer); + unpacker->limit = N_WORD_BYTES; + unpacker->data = (char*)&unpacker->word; + } else { + struct bignum* bignum = (struct bignum*)(integer - OTHER_POINTER_LOWTAG); + unpacker->word = 0; + unpacker->limit = HeaderValue(bignum->header) * N_WORD_BYTES; + unpacker->data = (char*)bignum->digits; + } + unpacker->index = 0; +} + +// Fetch the next varint from 'unpacker' into 'result'. +// Because there is no length prefix on the number of varints encoded, +// spurious trailing zeros might be observed. The data consumer can +// circumvent that by storing a count as the first value in the series. +// Return 1 for success, 0 for EOF. +int varint_unpack(struct varint_unpacker* unpacker, int* result) +{ + if (unpacker->index >= unpacker->limit) return 0; + int accumulator = 0; + int shift = 0; + while (1) { +#ifdef LISP_FEATURE_LITTLE_ENDIAN + int byte = unpacker->data[unpacker->index]; +#else + // bignums are little-endian in word order, + // but machine-native within each word. + // We could pack bytes MSB-to-LSB in the bigdigits, + // but that seems less intuitive on the Lisp side. + int word_index = unpacker->index / N_WORD_BYTES; + int byte_index = unpacker->index % N_WORD_BYTES; + int byte = (((uword_t*)unpacker->data)[word_index] >> (byte_index * 8)) & 0xFF; +#endif + ++unpacker->index; + accumulator |= (byte & 0x7F) << shift; + if (!(byte & 0x80)) break; + gc_assert(unpacker->index < unpacker->limit); + shift += 7; + } + *result = accumulator; + return 1; +} + +void skip_data_stream(struct varint_unpacker* unpacker) +{ + // Read elements until seeing a 0 + int val; + while (varint_unpack(unpacker, &val) && val != 0) { } +} diff -Nru sbcl-2.1.10/src/runtime/var-io.h sbcl-2.1.11/src/runtime/var-io.h --- sbcl-2.1.10/src/runtime/var-io.h 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/var-io.h 2021-11-30 16:16:46.000000000 +0000 @@ -25,5 +25,6 @@ void varint_unpacker_init(struct varint_unpacker*, lispobj); int varint_unpack(struct varint_unpacker*, int*); +void skip_data_stream(struct varint_unpacker* unpacker); #endif /* _VAR_IO_H_ */ diff -Nru sbcl-2.1.10/src/runtime/win32-os.c sbcl-2.1.11/src/runtime/win32-os.c --- sbcl-2.1.10/src/runtime/win32-os.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/win32-os.c 2021-11-30 16:16:46.000000000 +0000 @@ -841,8 +841,7 @@ static LARGE_INTEGER lisp_init_time; static double qpcMultiplier; -void os_init(char __attribute__((__unused__)) *argv[], - char __attribute__((__unused__)) *envp[]) +void os_init() { #ifdef LISP_FEATURE_64_BIT LARGE_INTEGER qpcFrequency; @@ -1133,7 +1132,7 @@ /* dynamic space */ page_index_t page = find_page_index(fault_address); - if (page != -1 && !page_table[page].write_protected) { + if (page != -1 && !PAGE_WRITEPROTECTED_P(page)) { os_commit_memory(PTR_ALIGN_DOWN(fault_address, os_vm_page_size), os_vm_page_size); return 0; diff -Nru sbcl-2.1.10/src/runtime/x86-64-arch.c sbcl-2.1.11/src/runtime/x86-64-arch.c --- sbcl-2.1.10/src/runtime/x86-64-arch.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/x86-64-arch.c 2021-11-30 16:16:46.000000000 +0000 @@ -27,11 +27,13 @@ #include "getallocptr.h" #include "unaligned.h" #include "search.h" +#include "var-io.h" #include "genesis/static-symbols.h" #include "genesis/symbol.h" #include "forwarding-ptr.h" #include "core.h" +#include "gc-private.h" #define INT3_INST 0xCC #define INTO_INST 0xCE @@ -374,6 +376,12 @@ siginfo_t __attribute__((unused)) *info, os_context_t *context) { +#ifdef LISP_FEATURE_LINUX + // ICEBP instruction = handle-pending-interrupt following pseudo-atomic + if (((unsigned char*)*os_context_pc_addr(context))[-1] == 0xF1) + return interrupt_handle_pending(context); +#endif + unsigned int trap; if (single_stepping) { @@ -707,7 +715,15 @@ v->data[index] = v->data[index+1] = NIL; index += 2; } + // Wasn't the point of code serial# that you don't store + // code blob pointers into the various profiling buffers? (FIXME?) if (code) { +#ifdef LISP_FEATURE_SOFT_CARD_MARKS + page_index_t page = find_page_index(&v->data[index]); + // technically this only needs to be unprotected if the generation + // of the code is younger, but the KISS principle pertains. + if (page >= 0) unprotect_page_index(page); +#endif v->data[index] = make_lispobj(code, OTHER_POINTER_LOWTAG); v->data[index+1] = make_fixnum((lispobj)pc - (lispobj)code); } else { @@ -774,3 +790,5 @@ int __attribute__((unused)) ret = thread_mutex_unlock(&alloc_profiler_lock); gc_assert(ret == 0); } + +#include "x86-arch-shared.inc" diff -Nru sbcl-2.1.10/src/runtime/x86-64-assem.S sbcl-2.1.11/src/runtime/x86-64-assem.S --- sbcl-2.1.10/src/runtime/x86-64-assem.S 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/x86-64-assem.S 2021-11-30 16:16:46.000000000 +0000 @@ -25,8 +25,6 @@ #include "genesis/fdefn.h" #include "genesis/static-symbols.h" #include "genesis/thread.h" -#include "genesis/ratio.h" -#include "genesis/complex.h" /* Minimize conditionalization for different OS naming schemes. */ #if defined __linux__ || defined LISP_FEATURE_HAIKU || defined LISP_FEATURE_FREEBSD || \ @@ -49,16 +47,9 @@ /* Get the right type of alignment. Linux, FreeBSD and OpenBSD * want alignment in bytes. */ #if defined(__linux__) || defined(LISP_FEATURE_FREEBSD) || defined(__OpenBSD__) || defined __NetBSD__ || defined(__sun) || defined _WIN64 || defined(__DragonFly__) -#define align_4byte 4 -#define align_8byte 8 #define align_16byte 16 -#define align_32byte 32 -#define align_page 32768 #else -#define align_4byte 2 -#define align_8byte 3 #define align_16byte 4 -#define align_page 15 #endif /* @@ -82,6 +73,7 @@ #define TRAP int3 #endif +#define CARD_TABLE_REG %r12 #define THREAD_BASE_REG %r13 #ifdef LISP_FEATURE_WIN32 @@ -224,6 +216,7 @@ # DW_OP_breg6 (rbp): 0 / DW_OP_deref / DW_OP_lit16 / DW_OP_plus .cfi_escape 0x0f, 5, 0x76, 0, 6, 0x40, 0x22 Lcall: + LOAD_PIC_VAR(gc_card_mark, CARD_TABLE_REG) call *CLOSURE_FUN_OFFSET(%rax) /* If the function returned multiple values, the carry flag will be set. @@ -290,6 +283,7 @@ #else mov (ENTER_ALIEN_CALLBACK_FDEFN+FDEFN_FUN_OFFSET),%rax #endif + LOAD_PIC_VAR(gc_card_mark, CARD_TABLE_REG) call *CLOSURE_FUN_OFFSET(%rax) /* Restore C regs */ diff -Nru sbcl-2.1.10/src/runtime/x86-64-haiku-os.c sbcl-2.1.11/src/runtime/x86-64-haiku-os.c --- sbcl-2.1.10/src/runtime/x86-64-haiku-os.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/x86-64-haiku-os.c 2021-11-30 16:16:46.000000000 +0000 @@ -47,10 +47,10 @@ // just guessing here /* reset exception flags and restore control flags on SSE2 FPU */ - unsigned int temp = (context->uc_mcontext.fpu.mxcsr) & ~0x3F; + unsigned int temp = (context->uc_mcontext.fpu.fp_fxsave.mxcsr) & ~0x3F; asm ("ldmxcsr %0" : : "m" (temp)); /* same for x87 FPU. */ - asm ("fldcw %0" : : "m" (context->uc_mcontext.fpu.control)); + asm ("fldcw %0" : : "m" (context->uc_mcontext.fpu.fp_fxsave.control)); } void diff -Nru sbcl-2.1.10/src/runtime/x86-arch.c sbcl-2.1.11/src/runtime/x86-arch.c --- sbcl-2.1.10/src/runtime/x86-arch.c 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/src/runtime/x86-arch.c 2021-11-30 16:16:46.000000000 +0000 @@ -27,6 +27,7 @@ #include "forwarding-ptr.h" #include "var-io.h" #include "code.h" +#include "unaligned.h" #include "genesis/static-symbols.h" #include "genesis/symbol.h" @@ -405,3 +406,5 @@ /* write a nop for good measure. */ *reloc_addr = 0x90; } + +#include "x86-arch-shared.inc" diff -Nru sbcl-2.1.10/src/runtime/x86-arch-shared.inc sbcl-2.1.11/src/runtime/x86-arch-shared.inc --- sbcl-2.1.10/src/runtime/x86-arch-shared.inc 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/runtime/x86-arch-shared.inc 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,4 @@ +void gcbarrier_patch_code(void* where, int nbits) +{ + UNALIGNED_STORE32(where, ((1<= where limit) gens) + (let* ((word (sb-sys:sap-ref-word where 0)) + (targ-page) + (gen (when (and (sb-vm:is-lisp-pointer word) + (>= (setq targ-page (sb-vm:find-page-index word)) 0)) + (sb-alien:slot (sb-alien:deref sb-vm::page-table targ-page) + 'sb-vm::gen)))) + (when gen (setq gens (logior gens (ash 1 gen)))) + (when print + (sb-alien:alien-funcall + (sb-alien:extern-alien "printf" + (function sb-alien:void system-area-pointer + system-area-pointer + sb-alien:unsigned + sb-alien:unsigned)) + (sb-sys:vector-sap (if gen #.(format nil "%p: %p -> %d~%") #.(format nil "%p: %p~%"))) + where word (or gen 0)))))))) + +;;; Make sure promotions do occur. +(setf (generation-number-of-gcs-before-promotion 0) 1) + +(defstruct foo a b c) +(defparameter *l* nil) +(defun construct (n) + (setq *l* (make-ordered-list :key-type 'fixnum)) + (loop repeat n for key from 10 by 10 do (lfl-insert *l* key (make-foo :a key)))) + +(defun scan-lfl-gens (deletep &aux page-indices) + (do ((node (get-next (list-head *l*)) ; can't delete the dummy node (list head) + (get-next node))) + ((eq node *tail-atom*)) + (when (eql (generation-of node) 1) + (let ((page (sb-vm:find-page-index + (sb-kernel:get-lisp-obj-address node)))) + (pushnew page page-indices))) + (let ((succ (get-next node))) + (when (and (eql (generation-of node) 1) + (eql (generation-of succ) 0) + deletep) + ;; Logically delete NODE, turning its successor pointer untagged. + (format t "~A (deleting) -> ~A~%" node succ) + (with-pinned-objects (succ) + (cas (%node-next node) succ (make-marked-ref succ)))))) + (dolist (page page-indices) + (format t "Page ~d -> ~b~%" page (scan-pointee-gens page)))) + +(defun test-fixnum-as-pointer () + (construct 250) + (gc :gen 1) + (loop for key from 15 by 400 repeat 10 do (lfl-insert *l* key (- key))) + ;; For informational purposes, print the page number on which any node + ;; of *L* is present, and the bitmask of generations to which that page points. + (scan-lfl-gens nil) + ;; Now logically delete any node on a generation 1 page that points + ;; to a generation 0 page. The deletion algorithm first marks the NEXT + ;; pointer on the node being deleted, where "mark" equates to turning + ;; the successor pointer to an untagged pointer. + (scan-lfl-gens t) + (gc)) + +(test-util:with-test (:name :lfl-hidden-pointers) (test-fixnum-as-pointer)) diff -Nru sbcl-2.1.10/tests/save1.test.sh sbcl-2.1.11/tests/save1.test.sh --- sbcl-2.1.10/tests/save1.test.sh 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/tests/save1.test.sh 2021-11-30 16:16:46.000000000 +0000 @@ -15,6 +15,7 @@ # diagnosed and fixed by Dan Barlow in sbcl-0.7.7.29 run_sbcl < right. - ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17) - (eql 1 (find 2 seq :test #'>)) - (find 2 seq :key #'1+) - (find 1 seq :from-end t) - (null (find 1 seq :from-end t :start 1)) - (null (find 0 seq :from-end t)) - (eql 0 (position 1 seq :key #'abs)) - (null (position nil seq :test 'equal)) - (eql 1 (find-if #'1- seq :key #'log)) - (eql 0 (position-if #'identity seq :from-end t)) - (null (find-if-not #'sin seq)) - (eql 0 (position-if-not #'packagep seq :key 'identity)))) -(for-every-seq #(1 2 3 2 1) - '((find 3 seq) - (find 3 seq :from-end 'yes) - (eql 1 (position 1.5 seq :test #'<)) - (eql 0 (position 0 seq :key '1-)) - (eql 4 (position 0 seq :key '1- :from-end t)) - (eql 2 (position 4 seq :key '1+)) - (eql 2 (position 4 seq :key '1+ :from-end t)) - (eql 1 (position 2 seq)) - (eql 1 (position 2 seq :start 1)) - (null (find 2 seq :start 1 :end 1)) - (eql 3 (position 2 seq :start 2)) - (eql 3 (position 2 seq :key nil :from-end t)) - (eql 2 (position 3 seq :test '=)) - (eql 0 (position 3 seq :test-not 'equalp)) - (eql 2 (position 3 seq :test 'equal :from-end t)) - (null (position 4 seq :test #'eql)) - (null (find-if #'packagep seq)) - (eql 1 (find-if #'plusp seq)) - (eql 3 (position-if #'plusp seq :key #'1- :from-end t)) - (eql 1 (position-if #'evenp seq)) - (eql 3 (position-if #'evenp seq :from-end t)) - (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2)) - (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2)) - (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2)) - (null (find-if-not #'plusp seq)) - (eql 0 (position-if-not #'evenp seq)) - (eql 0 (search #(1) seq)) - (eql 1 (search #(4 5) seq :key 'oddp)) - (eql 1 (search #(-2) seq :test (lambda (a b) (= (- a) b)))) - (eql 4 (search #(1) seq :start2 1)) - (null (search #(3) seq :start2 3)) - (eql 2 (search #(3) seq :start2 2)) - (eql 0 (search #(1 2) seq)) - (null (search #(2 1 3) seq)) - (eql 0 (search #(0 1 2 4) seq :start1 1 :end1 3)) - (eql 3 (search #(0 2 1 4) seq :start1 1 :end1 3)) - (eql 4 (search #(1) seq :from-end t)) - (eql 0 (search #(1 2) seq :from-end t)) - (null (search #(1 2) seq :from-end t :start2 1)) - (eql 0 (search #(0 1 2 4) seq :from-end t :start1 1 :end1 3)) - (eql 3 (search #(0 2 1 4) seq :from-end t :start1 1 :end1 3)) - (null (search #(2 1 3) seq :from-end t)))) -(for-every-seq "string test" - '((null (find 0 seq)) - (null (find #\D seq :key #'char-upcase)) - (find #\E seq :key #'char-upcase) - (null (find #\e seq :key #'char-upcase)) - (eql 3 (position #\i seq)) - (eql 0 (position #\s seq :key #'char-downcase)) - (eql 1 (position #\s seq :key #'char-downcase :test #'char/=)) - (eql 9 (position #\s seq :from-end t :test #'char=)) - (eql 10 (position #\s seq :from-end t :test #'char/=)) - (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal)) - (eql 5 (position-if (lambda (c) (equal #\g c)) seq)) - (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t)) - (find-if #'characterp seq) - (find-if (lambda (c) (typep c 'base-char)) seq :from-end t) - (null (find-if 'upper-case-p seq)))) -;;; SUBSEQ +(with-test (:name :seq.1) + (for-every-seq #() + '((null (find 1 seq)) + (null (find 1 seq :from-end t)) + (null (position 1 seq :key (indiscriminate #'abs))) + (null (position nil seq :test (constantly t))) + (null (position nil seq :test nil)) + (null (position nil seq :test-not nil)) + (null (find-if #'1+ seq :key (indiscriminate #'log))) + (null (position-if #'identity seq :from-end t)) + (null (find-if-not #'packagep seq)) + (null (position-if-not #'packagep seq :key nil))))) + +(with-test (:name :seq.2) + (for-every-seq #(1) + '((null (find 2 seq)) + ;; Get the argument ordering for asymmetric tests like #'> right. + ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17) + (eql 1 (find 2 seq :test #'>)) + (find 2 seq :key #'1+) + (find 1 seq :from-end t) + (null (find 1 seq :from-end t :start 1)) + (null (find 0 seq :from-end t)) + (eql 0 (position 1 seq :key #'abs)) + (null (position nil seq :test 'equal)) + (eql 1 (find-if #'1- seq :key #'log)) + (eql 0 (position-if #'identity seq :from-end t)) + (null (find-if-not #'sin seq)) + (eql 0 (position-if-not #'packagep seq :key 'identity))))) + +(with-test (:name :seq.3) + (for-every-seq #(1 2 3 2 1) + '((find 3 seq) + (find 3 seq :from-end 'yes) + (eql 1 (position 1.5 seq :test #'<)) + (eql 0 (position 0 seq :key '1-)) + (eql 4 (position 0 seq :key '1- :from-end t)) + (eql 2 (position 4 seq :key '1+)) + (eql 2 (position 4 seq :key '1+ :from-end t)) + (eql 1 (position 2 seq)) + (eql 1 (position 2 seq :start 1)) + (null (find 2 seq :start 1 :end 1)) + (eql 3 (position 2 seq :start 2)) + (eql 3 (position 2 seq :key nil :from-end t)) + (eql 2 (position 3 seq :test '=)) + (eql 0 (position 3 seq :test-not 'equalp)) + (eql 2 (position 3 seq :test 'equal :from-end t)) + (null (position 4 seq :test #'eql)) + (null (find-if #'packagep seq)) + (eql 1 (find-if #'plusp seq)) + (eql 3 (position-if #'plusp seq :key #'1- :from-end t)) + (eql 1 (position-if #'evenp seq)) + (eql 3 (position-if #'evenp seq :from-end t)) + (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2)) + (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2)) + (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2)) + (null (find-if-not #'plusp seq)) + (eql 0 (position-if-not #'evenp seq)) + (eql 0 (search #(1) seq)) + (eql 1 (search #(4 5) seq :key 'oddp)) + (eql 1 (search #(-2) seq :test (lambda (a b) (= (- a) b)))) + (eql 4 (search #(1) seq :start2 1)) + (null (search #(3) seq :start2 3)) + (eql 2 (search #(3) seq :start2 2)) + (eql 0 (search #(1 2) seq)) + (null (search #(2 1 3) seq)) + (eql 0 (search #(0 1 2 4) seq :start1 1 :end1 3)) + (eql 3 (search #(0 2 1 4) seq :start1 1 :end1 3)) + (eql 4 (search #(1) seq :from-end t)) + (eql 0 (search #(1 2) seq :from-end t)) + (null (search #(1 2) seq :from-end t :start2 1)) + (eql 0 (search #(0 1 2 4) seq :from-end t :start1 1 :end1 3)) + (eql 3 (search #(0 2 1 4) seq :from-end t :start1 1 :end1 3)) + (null (search #(2 1 3) seq :from-end t))))) + +(with-test (:name :seq.4) + (for-every-seq "string test" + '((null (find 0 seq)) + (null (find #\D seq :key #'char-upcase)) + (find #\E seq :key #'char-upcase) + (null (find #\e seq :key #'char-upcase)) + (eql 3 (position #\i seq)) + (eql 0 (position #\s seq :key #'char-downcase)) + (eql 1 (position #\s seq :key #'char-downcase :test #'char/=)) + (eql 9 (position #\s seq :from-end t :test #'char=)) + (eql 10 (position #\s seq :from-end t :test #'char/=)) + (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal)) + (eql 5 (position-if (lambda (c) (equal #\g c)) seq)) + (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t)) + (find-if #'characterp seq) + (find-if (lambda (c) (typep c 'base-char)) seq :from-end t) + (null (find-if 'upper-case-p seq))))) + (with-test (:name :subseq) (let ((avec (make-array 10 :fill-pointer 4 @@ -245,14 +252,14 @@ ;; fixed in sbcl-0.7.4.22 by WHN (assert (null (ignore-errors (aref (subseq avec 1 5) 0)))))) -;;; FILL -(defun test-fill-typecheck (x) - (declare (optimize (safety 3) (space 2) (speed 1))) - (fill (make-string 10) x)) - -(assert (string= (test-fill-typecheck #\@) "@@@@@@@@@@")) -;;; BUG 186, fixed in sbcl-0.7.5.5 -(assert (null (ignore-errors (test-fill-typecheck 4097)))) +(with-test (:name :fill-typecheck) + (checked-compile-and-assert + (:optimize :safe) + `(lambda (x) + (fill (make-string 10) x)) + ((#\@) "@@@@@@@@@@" :test #'equal) + ;; BUG 186, fixed in sbcl-0.7.5.5 + ((4097) (condition 'type-error)))) ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested ;;; result type (BUGs 46a, 46b, 66) @@ -266,7 +273,6 @@ (vector (signed-byte 32)) (simple-bit-vector))) (declare (optimize safety)) - (format t "~&~S~%" type-stub) ;; MAKE-SEQUENCE (assert (= (length (make-sequence `(,@type-stub) 10)) 10)) (assert (= (length (make-sequence `(,@type-stub 10) 10)) 10)) @@ -351,9 +357,9 @@ ;;; with user-defined types until sbcl-0.7.8.11 (deftype list-typeoid () 'list) (with-test (:name :merge-user-types) - (assert (equal '(1 2 3 4) (merge 'list-typeoid (list 1 3) (list 2 4) '<))) -;;; and also with types that weren't precicely LIST - (assert (equal '(1 2 3 4) (merge 'cons (list 1 3) (list 2 4) '<)))) + (assert (equal '(1 2 3 4) (merge 'list-typeoid (list 1 3) (list 2 4) '<))) + ;; and also with types that weren't precicely LIST + (assert (equal '(1 2 3 4) (merge 'cons (list 1 3) (list 2 4) '<)))) ;;; but wait, there's more! The NULL and CONS types also have implicit ;;; length requirements: @@ -408,19 +414,23 @@ ;;; ELT should signal an error of type TYPE-ERROR if its index ;;; argument isn't a valid sequence index for sequence: -(defun test-elt-signal (x) - (elt x 3)) -(assert-error (test-elt-signal "foo") type-error) -(assert (eql (test-elt-signal "foob") #\b)) -(locally - (declare (optimize (safety 3))) - (assert-error (elt (list 1 2 3) 3) type-error)) +(with-test (:name :elt-signal) + (checked-compile-and-assert + (:optimize :safe) + `(lambda (x) (elt x 3)) + (("foo") (condition 'type-error)) + (("foob") #\b)) + (locally + (declare (optimize (safety 3))) + (assert-error (elt (list 1 2 3) 3) type-error))) ;;; confusion in the refactoring led to this signalling an unbound ;;; variable, not a type error. -(defun svrefalike (x) - (svref x 0)) -(assert-error (svrefalike #*0) type-error) +(with-test (:name :svref-type-error) + (checked-compile-and-assert + (:optimize :safe) + `(lambda (x) (svref x 0)) + ((#*0) (condition 'type-error)))) ;;; checks for uniform bounding index handling. ;;; @@ -439,8 +449,6 @@ :initial-element #\a :element-type 'base-char))) ,(car body) - (format t "... BASE-CHAR") - (finish-output) (flet ((reset () (setf (fill-pointer string) 10) (fill string #\a) @@ -455,8 +463,6 @@ :initial-element #\a :element-type 'character))) ,(car body) - (format t "... CHARACTER") - (finish-output) (flet ((reset () (setf (fill-pointer string) 10) (fill string #\a) @@ -464,320 +470,303 @@ (declare (ignorable #'reset)) ,@(cdr body)))))) -;;; Accessor SUBSEQ -(sequence-bounding-indices-test - (format t "~&/Accessor SUBSEQ") - (assert (string= (subseq string 0 5) "aaaaa")) - (assert-error (subseq string 0 6)) - (assert-error (subseq string (opaque-identity -1) 5)) - (assert-error (subseq string 4 2)) - (assert-error (subseq string 6)) - (assert (string= (setf (subseq string 0 5) "abcde") "abcde")) - (assert (string= (subseq string 0 5) "abcde")) - (reset) - (assert-error (setf (subseq string 0 6) "abcdef")) - (assert-error (setf (subseq string (opaque-identity -1) 5) "abcdef")) - (assert-error (setf (subseq string 4 2) "")) - (assert-error (setf (subseq string 6) "ghij"))) - -;;; Function COUNT, COUNT-IF, COUNT-IF-NOT -(sequence-bounding-indices-test - (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT") - (assert (= (count #\a string :start 0 :end nil) 5)) - (assert (= (count #\a string :start 0 :end 5) 5)) - (assert-error (count #\a string :start 0 :end 6)) - (assert-error (count #\a string :start (opaque-identity -1) :end 5)) - (assert-error (count #\a string :start 4 :end 2)) - (assert-error (count #\a string :start 6 :end 9)) - (assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5)) - (assert (= (count-if #'alpha-char-p string :start 0 :end 5) 5)) - (assert-error - (count-if #'alpha-char-p string :start 0 :end 6)) - (assert-error - (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (assert-error - (count-if #'alpha-char-p string :start 4 :end 2)) - (assert-error - (count-if #'alpha-char-p string :start 6 :end 9)) - (assert (= (count-if-not #'alpha-char-p string :start 0 :end nil) 0)) - (assert (= (count-if-not #'alpha-char-p string :start 0 :end 5) 0)) - (assert-error - (count-if-not #'alpha-char-p string :start 0 :end 6)) - (assert-error - (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (assert-error - (count-if-not #'alpha-char-p string :start 4 :end 2)) - (assert-error - (count-if-not #'alpha-char-p string :start 6 :end 9))) - -;;; Function FILL -(sequence-bounding-indices-test - (format t "~&/Function FILL") - (assert (string= (fill string #\b :start 0 :end 5) "bbbbb")) - (assert (string= (fill string #\c :start 0 :end nil) "ccccc")) - (assert-error (fill string #\d :start 0 :end 6)) - (assert-error (fill string #\d :start (opaque-identity -1) :end 5)) - (assert-error (fill string #\d :start 4 :end 2)) - (assert-error (fill string #\d :start 6 :end 9))) - -;;; Function FIND, FIND-IF, FIND-IF-NOT -(sequence-bounding-indices-test - (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT") - (assert (char= (find #\a string :start 0 :end nil) #\a)) - (assert (char= (find #\a string :start 0 :end 5) #\a)) - (assert-error (find #\a string :start 0 :end 6)) - (assert-error (find #\a string :start (opaque-identity -1) :end 5)) - (assert-error (find #\a string :start 4 :end 2)) - (assert-error (find #\a string :start 6 :end 9)) - (assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a)) - (assert (char= (find-if #'alpha-char-p string :start 0 :end 5) #\a)) - (assert-error - (find-if #'alpha-char-p string :start 0 :end 6)) - (assert-error - (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (assert-error - (find-if #'alpha-char-p string :start 4 :end 2)) - (assert-error - (find-if #'alpha-char-p string :start 6 :end 9)) - (assert (eq (find-if-not #'alpha-char-p string :start 0 :end nil) nil)) - (assert (eq (find-if-not #'alpha-char-p string :start 0 :end 5) nil)) - (assert-error - (find-if-not #'alpha-char-p string :start 0 :end 6)) - (assert-error - (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (assert-error - (find-if-not #'alpha-char-p string :start 4 :end 2)) - (assert-error - (find-if-not #'alpha-char-p string :start 6 :end 9))) - -;;; Function MISMATCH -(sequence-bounding-indices-test - (format t "~&/Function MISMATCH") - (assert (null (mismatch string "aaaaa" :start1 0 :end1 nil))) - (assert (= (mismatch "aaab" string :start2 0 :end2 4) 3)) - (assert-error (mismatch "aaaaaa" string :start2 0 :end2 6)) - (assert-error (mismatch string "aaaaaa" :start1 (opaque-identity -1) :end1 5)) - (assert-error (mismatch string "" :start1 4 :end1 2)) - (assert-error (mismatch "aaaa" string :start2 6 :end2 9))) - -;;; Function PARSE-INTEGER -(sequence-bounding-indices-test - (format t "~&/Function PARSE-INTEGER") - (setf (fill-pointer string) 10) - (setf (subseq string 0 10) "1234567890") - (setf (fill-pointer string) 5) - (assert (= (parse-integer string :start 0 :end 5) 12345)) - (assert (= (parse-integer string :start 0 :end nil) 12345)) - (assert-error (parse-integer string :start 0 :end 6)) - (assert-error (parse-integer string :start (opaque-identity -1) :end 5)) - (assert-error (parse-integer string :start 4 :end 2)) - (assert-error (parse-integer string :start 6 :end 9))) - -;;; Function PARSE-NAMESTRING -(sequence-bounding-indices-test - (format t "~&/Function PARSE-NAMESTRING") - (setf (fill-pointer string) 10) - (setf (subseq string 0 10) - #-win32 "/dev/ /tmp" - #+win32 "C:/ NUL") - (setf (fill-pointer string) 5) - (assert (truename (parse-namestring string nil *default-pathname-defaults* - :start 0 :end 5))) - (assert (truename (parse-namestring string nil *default-pathname-defaults* - :start 0 :end nil))) - (assert-error (parse-namestring string nil - *default-pathname-defaults* - :start 0 :end 6)) - (assert-error (parse-namestring string nil - *default-pathname-defaults* - :start (opaque-identity -1) :end 5)) - (assert-error (parse-namestring string nil - *default-pathname-defaults* - :start 4 :end 2)) - (assert-error (parse-namestring string nil - *default-pathname-defaults* - :start 6 :end 9))) - -;;; Function POSITION, POSITION-IF, POSITION-IF-NOT -(sequence-bounding-indices-test - (format t "~&/Function POSITION, POSITION-IF, POSITION-IF-NOT") - - (assert (= (position #\a string :start 0 :end nil) 0)) - (assert (= (position #\a string :start 0 :end 5) 0)) - (assert-error (position #\a string :start 0 :end 6)) - (assert-error (position #\a string :start (opaque-identity -1) :end 5)) - (assert-error (position #\a string :start 4 :end 2)) - (assert-error (position #\a string :start 6 :end 9)) - (assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0)) - (assert (= (position-if #'alpha-char-p string :start 0 :end 5) 0)) - (assert-error - (position-if #'alpha-char-p string :start 0 :end 6)) - (assert-error - (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (assert-error - (position-if #'alpha-char-p string :start 4 :end 2)) - (assert-error - (position-if #'alpha-char-p string :start 6 :end 9)) - (assert (eq (position-if-not #'alpha-char-p string :start 0 :end nil) nil)) - (assert (eq (position-if-not #'alpha-char-p string :start 0 :end 5) nil)) - (assert-error - (position-if-not #'alpha-char-p string :start 0 :end 6)) - (assert-error - (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (assert-error - (position-if-not #'alpha-char-p string :start 4 :end 2)) - (assert-error - (position-if-not #'alpha-char-p string :start 6 :end 9))) - -;;; Function READ-FROM-STRING -(sequence-bounding-indices-test - (format t "~&/Function READ-FROM-STRING") - (setf (subseq string 0 5) "(a b)") - (assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b))) - (assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b))) - (assert-error (read-from-string string nil nil :start 0 :end 6)) - (assert-error (read-from-string string nil nil :start (opaque-identity -1) :end 5)) - (assert-error (read-from-string string nil nil :start 4 :end 2)) - (assert-error (read-from-string string nil nil :start 6 :end 9))) - -;;; Function REDUCE -(sequence-bounding-indices-test - (format t "~&/Function REDUCE") - (setf (subseq string 0 5) "abcde") - (assert (equal (reduce #'list* string :from-end t :start 0 :end nil) - '(#\a #\b #\c #\d . #\e))) - (assert (equal (reduce #'list* string :from-end t :start 0 :end 5) - '(#\a #\b #\c #\d . #\e))) - (assert-error (reduce #'list* string :start 0 :end 6)) - (assert-error (reduce #'list* string :start (opaque-identity -1) :end 5)) - (assert-error (reduce #'list* string :start 4 :end 2)) - (assert-error (reduce #'list* string :start 6 :end 9))) - -;;; Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF, -;;; DELETE-IF-NOT -(sequence-bounding-indices-test - (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...") - (assert (equal (remove #\a string :start 0 :end nil) "")) - (assert (equal (remove #\a string :start 0 :end 5) "")) - (assert-error (remove #\a string :start 0 :end 6)) - (assert-error (remove #\a string :start (opaque-identity -1) :end 5)) - (assert-error (remove #\a string :start 4 :end 2)) - (assert-error (remove #\a string :start 6 :end 9)) - (assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) "")) - (assert (equal (remove-if #'alpha-char-p string :start 0 :end 5) "")) - (assert-error - (remove-if #'alpha-char-p string :start 0 :end 6)) - (assert-error - (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (assert-error - (remove-if #'alpha-char-p string :start 4 :end 2)) - (assert-error - (remove-if #'alpha-char-p string :start 6 :end 9)) - (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end nil) - "aaaaa")) - (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end 5) - "aaaaa")) - (assert-error - (remove-if-not #'alpha-char-p string :start 0 :end 6)) - (assert-error - (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (assert-error - (remove-if-not #'alpha-char-p string :start 4 :end 2)) - (assert-error - (remove-if-not #'alpha-char-p string :start 6 :end 9))) -(sequence-bounding-indices-test - (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT") - (assert (equal (delete #\a string :start 0 :end nil) "")) - (reset) - (assert (equal (delete #\a string :start 0 :end 5) "")) - (reset) - (assert-error (delete #\a string :start 0 :end 6)) - (reset) - (assert-error (delete #\a string :start (opaque-identity -1) :end 5)) - (reset) - (assert-error (delete #\a string :start 4 :end 2)) - (reset) - (assert-error (delete #\a string :start 6 :end 9)) - (reset) - (assert (equal (delete-if #'alpha-char-p string :start 0 :end nil) "")) - (reset) - (assert (equal (delete-if #'alpha-char-p string :start 0 :end 5) "")) - (reset) - (assert-error - (delete-if #'alpha-char-p string :start 0 :end 6)) - (reset) - (assert-error - (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (reset) - (assert-error - (delete-if #'alpha-char-p string :start 4 :end 2)) - (reset) - (assert-error - (delete-if #'alpha-char-p string :start 6 :end 9)) - (reset) - (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end nil) - "aaaaa")) - (reset) - (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end 5) - "aaaaa")) - (reset) - (assert-error - (delete-if-not #'alpha-char-p string :start 0 :end 6)) - (reset) - (assert-error - (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) - (reset) - (assert-error - (delete-if-not #'alpha-char-p string :start 4 :end 2)) - (reset) - (assert-error - (delete-if-not #'alpha-char-p string :start 6 :end 9))) - -;;; Function REMOVE-DUPLICATES, DELETE-DUPLICATES -(sequence-bounding-indices-test - (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES") - (assert (string= (remove-duplicates string :start 0 :end 5) "a")) - (assert (string= (remove-duplicates string :start 0 :end nil) "a")) - (assert-error (remove-duplicates string :start 0 :end 6)) - (assert-error (remove-duplicates string :start (opaque-identity -1) :end 5)) - (assert-error (remove-duplicates string :start 4 :end 2)) - (assert-error (remove-duplicates string :start 6 :end 9)) - (assert (string= (delete-duplicates string :start 0 :end 5) "a")) - (reset) - (assert (string= (delete-duplicates string :start 0 :end nil) "a")) - (reset) - (assert-error (delete-duplicates string :start 0 :end 6)) - (reset) - (assert-error (delete-duplicates string :start (opaque-identity -1) :end 5)) - (reset) - (assert-error (delete-duplicates string :start 4 :end 2)) - (reset) - (assert-error (delete-duplicates string :start 6 :end 9))) - -;;; Function REPLACE -(sequence-bounding-indices-test - (format t "~&/Function REPLACE") - (assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb")) - (assert (string= (replace (copy-seq "ccccc") - string - :start2 0 :end2 nil) "bbbbb")) - (assert-error (replace string "ccccc" :start1 0 :end1 6)) - (assert-error (replace string "ccccc" :start2 (opaque-identity -1) :end2 5)) - (assert-error (replace string "ccccc" :start1 4 :end1 2)) - (assert-error (replace string "ccccc" :start1 6 :end1 9))) - -;;; Function SEARCH -(sequence-bounding-indices-test - (format t "~&/Function SEARCH") - (assert (= (search "aa" string :start2 0 :end2 5) 0)) - (assert (null (search string "aa" :start1 0 :end2 nil))) - (assert-error (search "aa" string :start2 0 :end2 6)) - (assert-error (search "aa" string :start2 (opaque-identity -1) :end2 5)) - (assert-error (search "aa" string :start2 4 :end2 2)) - (assert-error (search "aa" string :start2 6 :end2 9))) +(with-test (:name (:bounding-index subseq)) + (sequence-bounding-indices-test + (assert (string= (subseq string 0 5) "aaaaa")) + (assert-error (subseq string 0 6)) + (assert-error (subseq string (opaque-identity -1) 5)) + (assert-error (subseq string 4 2)) + (assert-error (subseq string 6)) + (assert (string= (setf (subseq string 0 5) "abcde") "abcde")) + (assert (string= (subseq string 0 5) "abcde")) + (reset) + (assert-error (setf (subseq string 0 6) "abcdef")) + (assert-error (setf (subseq string (opaque-identity -1) 5) "abcdef")) + (assert-error (setf (subseq string 4 2) "")) + (assert-error (setf (subseq string 6) "ghij")))) + +(with-test (:name (:bounding-index count)) + (sequence-bounding-indices-test + (assert (= (count #\a string :start 0 :end nil) 5)) + (assert (= (count #\a string :start 0 :end 5) 5)) + (assert-error (count #\a string :start 0 :end 6)) + (assert-error (count #\a string :start (opaque-identity -1) :end 5)) + (assert-error (count #\a string :start 4 :end 2)) + (assert-error (count #\a string :start 6 :end 9)) + (assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5)) + (assert (= (count-if #'alpha-char-p string :start 0 :end 5) 5)) + (assert-error + (count-if #'alpha-char-p string :start 0 :end 6)) + (assert-error + (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (assert-error + (count-if #'alpha-char-p string :start 4 :end 2)) + (assert-error + (count-if #'alpha-char-p string :start 6 :end 9)) + (assert (= (count-if-not #'alpha-char-p string :start 0 :end nil) 0)) + (assert (= (count-if-not #'alpha-char-p string :start 0 :end 5) 0)) + (assert-error + (count-if-not #'alpha-char-p string :start 0 :end 6)) + (assert-error + (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (assert-error + (count-if-not #'alpha-char-p string :start 4 :end 2)) + (assert-error + (count-if-not #'alpha-char-p string :start 6 :end 9)))) + +(with-test (:name (:bounding-index fill)) + (sequence-bounding-indices-test + (assert (string= (fill string #\b :start 0 :end 5) "bbbbb")) + (assert (string= (fill string #\c :start 0 :end nil) "ccccc")) + (assert-error (fill string #\d :start 0 :end 6)) + (assert-error (fill string #\d :start (opaque-identity -1) :end 5)) + (assert-error (fill string #\d :start 4 :end 2)) + (assert-error (fill string #\d :start 6 :end 9)))) + +(with-test (:name (:bounding-index find)) + (sequence-bounding-indices-test + (assert (char= (find #\a string :start 0 :end nil) #\a)) + (assert (char= (find #\a string :start 0 :end 5) #\a)) + (assert-error (find #\a string :start 0 :end 6)) + (assert-error (find #\a string :start (opaque-identity -1) :end 5)) + (assert-error (find #\a string :start 4 :end 2)) + (assert-error (find #\a string :start 6 :end 9)) + (assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a)) + (assert (char= (find-if #'alpha-char-p string :start 0 :end 5) #\a)) + (assert-error + (find-if #'alpha-char-p string :start 0 :end 6)) + (assert-error + (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (assert-error + (find-if #'alpha-char-p string :start 4 :end 2)) + (assert-error + (find-if #'alpha-char-p string :start 6 :end 9)) + (assert (eq (find-if-not #'alpha-char-p string :start 0 :end nil) nil)) + (assert (eq (find-if-not #'alpha-char-p string :start 0 :end 5) nil)) + (assert-error + (find-if-not #'alpha-char-p string :start 0 :end 6)) + (assert-error + (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (assert-error + (find-if-not #'alpha-char-p string :start 4 :end 2)) + (assert-error + (find-if-not #'alpha-char-p string :start 6 :end 9)))) + +(with-test (:name (:bounding-index mismatch)) + (sequence-bounding-indices-test + (assert (null (mismatch string "aaaaa" :start1 0 :end1 nil))) + (assert (= (mismatch "aaab" string :start2 0 :end2 4) 3)) + (assert-error (mismatch "aaaaaa" string :start2 0 :end2 6)) + (assert-error (mismatch string "aaaaaa" :start1 (opaque-identity -1) :end1 5)) + (assert-error (mismatch string "" :start1 4 :end1 2)) + (assert-error (mismatch "aaaa" string :start2 6 :end2 9)))) + +(with-test (:name (:bounding-index parse-integer)) + (sequence-bounding-indices-test + (setf (fill-pointer string) 10) + (setf (subseq string 0 10) "1234567890") + (setf (fill-pointer string) 5) + (assert (= (parse-integer string :start 0 :end 5) 12345)) + (assert (= (parse-integer string :start 0 :end nil) 12345)) + (assert-error (parse-integer string :start 0 :end 6)) + (assert-error (parse-integer string :start (opaque-identity -1) :end 5)) + (assert-error (parse-integer string :start 4 :end 2)) + (assert-error (parse-integer string :start 6 :end 9)))) + +(with-test (:name (:bounding-index parse-namestring)) + (sequence-bounding-indices-test + (setf (fill-pointer string) 10) + (setf (subseq string 0 10) + #-win32 "/dev/ /tmp" + #+win32 "C:/ NUL") + (setf (fill-pointer string) 5) + (assert (truename (parse-namestring string nil *default-pathname-defaults* + :start 0 :end 5))) + (assert (truename (parse-namestring string nil *default-pathname-defaults* + :start 0 :end nil))) + (assert-error (parse-namestring string nil + *default-pathname-defaults* + :start 0 :end 6)) + (assert-error (parse-namestring string nil + *default-pathname-defaults* + :start (opaque-identity -1) :end 5)) + (assert-error (parse-namestring string nil + *default-pathname-defaults* + :start 4 :end 2)) + (assert-error (parse-namestring string nil + *default-pathname-defaults* + :start 6 :end 9)))) + +(with-test (:name (:bounding-index position)) + (sequence-bounding-indices-test + (assert (= (position #\a string :start 0 :end nil) 0)) + (assert (= (position #\a string :start 0 :end 5) 0)) + (assert-error (position #\a string :start 0 :end 6)) + (assert-error (position #\a string :start (opaque-identity -1) :end 5)) + (assert-error (position #\a string :start 4 :end 2)) + (assert-error (position #\a string :start 6 :end 9)) + (assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0)) + (assert (= (position-if #'alpha-char-p string :start 0 :end 5) 0)) + (assert-error + (position-if #'alpha-char-p string :start 0 :end 6)) + (assert-error + (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (assert-error + (position-if #'alpha-char-p string :start 4 :end 2)) + (assert-error + (position-if #'alpha-char-p string :start 6 :end 9)) + (assert (eq (position-if-not #'alpha-char-p string :start 0 :end nil) nil)) + (assert (eq (position-if-not #'alpha-char-p string :start 0 :end 5) nil)) + (assert-error + (position-if-not #'alpha-char-p string :start 0 :end 6)) + (assert-error + (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (assert-error + (position-if-not #'alpha-char-p string :start 4 :end 2)) + (assert-error + (position-if-not #'alpha-char-p string :start 6 :end 9)))) + +(with-test (:name (:bounding-index read-from-string)) + (sequence-bounding-indices-test + (setf (subseq string 0 5) "(a b)") + (assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b))) + (assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b))) + (assert-error (read-from-string string nil nil :start 0 :end 6)) + (assert-error (read-from-string string nil nil :start (opaque-identity -1) :end 5)) + (assert-error (read-from-string string nil nil :start 4 :end 2)) + (assert-error (read-from-string string nil nil :start 6 :end 9)))) + +(with-test (:name (:bounding-index reduce)) + (sequence-bounding-indices-test + (setf (subseq string 0 5) "abcde") + (assert (equal (reduce #'list* string :from-end t :start 0 :end nil) + '(#\a #\b #\c #\d . #\e))) + (assert (equal (reduce #'list* string :from-end t :start 0 :end 5) + '(#\a #\b #\c #\d . #\e))) + (assert-error (reduce #'list* string :start 0 :end 6)) + (assert-error (reduce #'list* string :start (opaque-identity -1) :end 5)) + (assert-error (reduce #'list* string :start 4 :end 2)) + (assert-error (reduce #'list* string :start 6 :end 9)))) + +(with-test (:name (:bounding-index remove)) + (sequence-bounding-indices-test + (assert (equal (remove #\a string :start 0 :end nil) "")) + (assert (equal (remove #\a string :start 0 :end 5) "")) + (assert-error (remove #\a string :start 0 :end 6)) + (assert-error (remove #\a string :start (opaque-identity -1) :end 5)) + (assert-error (remove #\a string :start 4 :end 2)) + (assert-error (remove #\a string :start 6 :end 9)) + (assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) "")) + (assert (equal (remove-if #'alpha-char-p string :start 0 :end 5) "")) + (assert-error + (remove-if #'alpha-char-p string :start 0 :end 6)) + (assert-error + (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (assert-error + (remove-if #'alpha-char-p string :start 4 :end 2)) + (assert-error + (remove-if #'alpha-char-p string :start 6 :end 9)) + (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end nil) + "aaaaa")) + (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end 5) + "aaaaa")) + (assert-error + (remove-if-not #'alpha-char-p string :start 0 :end 6)) + (assert-error + (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (assert-error + (remove-if-not #'alpha-char-p string :start 4 :end 2)) + (assert-error + (remove-if-not #'alpha-char-p string :start 6 :end 9)))) + +(with-test (:name (:bounding-index delete)) + (sequence-bounding-indices-test + (assert (equal (delete #\a string :start 0 :end nil) "")) + (reset) + (assert (equal (delete #\a string :start 0 :end 5) "")) + (reset) + (assert-error (delete #\a string :start 0 :end 6)) + (reset) + (assert-error (delete #\a string :start (opaque-identity -1) :end 5)) + (reset) + (assert-error (delete #\a string :start 4 :end 2)) + (reset) + (assert-error (delete #\a string :start 6 :end 9)) + (reset) + (assert (equal (delete-if #'alpha-char-p string :start 0 :end nil) "")) + (reset) + (assert (equal (delete-if #'alpha-char-p string :start 0 :end 5) "")) + (reset) + (assert-error + (delete-if #'alpha-char-p string :start 0 :end 6)) + (reset) + (assert-error + (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (reset) + (assert-error + (delete-if #'alpha-char-p string :start 4 :end 2)) + (reset) + (assert-error + (delete-if #'alpha-char-p string :start 6 :end 9)) + (reset) + (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end nil) + "aaaaa")) + (reset) + (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end 5) + "aaaaa")) + (reset) + (assert-error + (delete-if-not #'alpha-char-p string :start 0 :end 6)) + (reset) + (assert-error + (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)) + (reset) + (assert-error + (delete-if-not #'alpha-char-p string :start 4 :end 2)) + (reset) + (assert-error + (delete-if-not #'alpha-char-p string :start 6 :end 9)))) + +(with-test (:name (:bounding-index remove-duplicates)) + (sequence-bounding-indices-test + (assert (string= (remove-duplicates string :start 0 :end 5) "a")) + (assert (string= (remove-duplicates string :start 0 :end nil) "a")) + (assert-error (remove-duplicates string :start 0 :end 6)) + (assert-error (remove-duplicates string :start (opaque-identity -1) :end 5)) + (assert-error (remove-duplicates string :start 4 :end 2)) + (assert-error (remove-duplicates string :start 6 :end 9)) + (assert (string= (delete-duplicates string :start 0 :end 5) "a")) + (reset) + (assert (string= (delete-duplicates string :start 0 :end nil) "a")) + (reset) + (assert-error (delete-duplicates string :start 0 :end 6)) + (reset) + (assert-error (delete-duplicates string :start (opaque-identity -1) :end 5)) + (reset) + (assert-error (delete-duplicates string :start 4 :end 2)) + (reset) + (assert-error (delete-duplicates string :start 6 :end 9)))) + +(with-test (:name (:bounding-index replace)) + (sequence-bounding-indices-test + (assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb")) + (assert (string= (replace (copy-seq "ccccc") + string + :start2 0 :end2 nil) "bbbbb")) + (assert-error (replace string "ccccc" :start1 0 :end1 6)) + (assert-error (replace string "ccccc" :start2 (opaque-identity -1) :end2 5)) + (assert-error (replace string "ccccc" :start1 4 :end1 2)) + (assert-error (replace string "ccccc" :start1 6 :end1 9)))) + +(with-test (:name (:bounding-index search)) + (sequence-bounding-indices-test + (assert (= (search "aa" string :start2 0 :end2 5) 0)) + (assert (null (search string "aa" :start1 0 :end2 nil))) + (assert-error (search "aa" string :start2 0 :end2 6)) + (assert-error (search "aa" string :start2 (opaque-identity -1) :end2 5)) + (assert-error (search "aa" string :start2 4 :end2 2)) + (assert-error (search "aa" string :start2 6 :end2 9)))) -;;; Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, -;;; NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE (defmacro string-case-frob (fn) `(progn (assert-error (,fn string :start 0 :end 6)) @@ -785,19 +774,15 @@ (assert-error (,fn string :start 4 :end 2)) (assert-error (,fn string :start 6 :end 9)))) -(sequence-bounding-indices-test - (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...") - (string-case-frob string-upcase) - (string-case-frob string-downcase) - (string-case-frob string-capitalize) - (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE") - (string-case-frob nstring-upcase) - (string-case-frob nstring-downcase) - (string-case-frob nstring-capitalize)) - -;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, -;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP, -;;; STRING-NOT-GREATERP, STRING-NOT-LESSP +(with-test (:name (:bounding-index :string-case)) + (sequence-bounding-indices-test + (string-case-frob string-upcase) + (string-case-frob string-downcase) + (string-case-frob string-capitalize) + (string-case-frob nstring-upcase) + (string-case-frob nstring-downcase) + (string-case-frob nstring-capitalize))) + (defmacro string-predicate-frob (fn) `(progn (,fn string "abcde" :start1 0 :end1 5) @@ -809,161 +794,161 @@ (assert-error (,fn "uvwxy" string :start1 4 :end1 2)) (assert-error (,fn string "z" :start2 6 :end2 9)))) -(sequence-bounding-indices-test - (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...") - (string-predicate-frob string=) - (string-predicate-frob string/=) - (string-predicate-frob string<) - (string-predicate-frob string>) - (string-predicate-frob string<=) - (string-predicate-frob string>=)) -(sequence-bounding-indices-test - (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...") - (string-predicate-frob string-equal) - (string-predicate-frob string-not-equal) - (string-predicate-frob string-lessp)) -(sequence-bounding-indices-test - (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP") - (string-predicate-frob string-greaterp) - (string-predicate-frob string-not-greaterp) - (string-predicate-frob string-not-lessp)) - -;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, -;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT -(sequence-bounding-indices-test - (format t "~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...") - (assert (string= (substitute #\b #\a string :start 0 :end 5) "bbbbb")) - (assert (string= (substitute #\c #\a string :start 0 :end nil) - "ccccc")) - (assert-error (substitute #\b #\a string :start 0 :end 6)) - (assert-error (substitute #\b #\a string :start (opaque-identity -1) :end 5)) - (assert-error (substitute #\b #\a string :start 4 :end 2)) - (assert-error (substitute #\b #\a string :start 6 :end 9)) - (assert (string= (substitute-if #\b #'alpha-char-p string - :start 0 :end 5) - "bbbbb")) - (assert (string= (substitute-if #\c #'alpha-char-p string - :start 0 :end nil) - "ccccc")) - (assert-error (substitute-if #\b #'alpha-char-p string - :start 0 :end 6)) - (assert-error (substitute-if #\b #'alpha-char-p string - :start (opaque-identity -1) :end 5)) - (assert-error (substitute-if #\b #'alpha-char-p string - :start 4 :end 2)) - (assert-error (substitute-if #\b #'alpha-char-p string - :start 6 :end 9)) - (assert (string= (substitute-if-not #\b #'alpha-char-p string - :start 0 :end 5) - "aaaaa")) - (assert (string= (substitute-if-not #\c #'alpha-char-p string - :start 0 :end nil) - "aaaaa")) - (assert-error (substitute-if-not #\b #'alpha-char-p string - :start 0 :end 6)) - (assert-error (substitute-if-not #\b #'alpha-char-p string - :start (opaque-identity -1) :end 5)) - (assert-error (substitute-if-not #\b #'alpha-char-p string - :start 4 :end 2)) - (assert-error (substitute-if-not #\b #'alpha-char-p string - :start 6 :end 9))) -(sequence-bounding-indices-test - (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT") - (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb")) - (reset) - (assert (string= (nsubstitute #\c #\a string :start 0 :end nil) - "ccccc")) - (reset) - (assert-error (nsubstitute #\b #\a string :start 0 :end 6)) - (reset) - (assert-error (nsubstitute #\b #\a string :start (opaque-identity -1) :end 5)) - (reset) - (assert-error (nsubstitute #\b #\a string :start 4 :end 2)) - (reset) - (assert-error (nsubstitute #\b #\a string :start 6 :end 9)) - (reset) - (assert (string= (nsubstitute-if #\b #'alpha-char-p string - :start 0 :end 5) - "bbbbb")) - (reset) - (assert (string= (nsubstitute-if #\c #'alpha-char-p string - :start 0 :end nil) - "ccccc")) - (reset) - (assert-error (nsubstitute-if #\b #'alpha-char-p string +(with-test (:name (:bounding-index string=)) + (sequence-bounding-indices-test + (string-predicate-frob string=) + (string-predicate-frob string/=) + (string-predicate-frob string<) + (string-predicate-frob string>) + (string-predicate-frob string<=) + (string-predicate-frob string>=))) + +(with-test (:name (:bounding-index string-equal)) + (sequence-bounding-indices-test + (string-predicate-frob string-equal) + (string-predicate-frob string-not-equal) + (string-predicate-frob string-lessp))) + +(with-test (:name (:bounding-index string-greaterp)) + (sequence-bounding-indices-test + (string-predicate-frob string-greaterp) + (string-predicate-frob string-not-greaterp) + (string-predicate-frob string-not-lessp))) + +(with-test (:name (:bounding-index substitute)) + (sequence-bounding-indices-test + (assert (string= (substitute #\b #\a string :start 0 :end 5) "bbbbb")) + (assert (string= (substitute #\c #\a string :start 0 :end nil) + "ccccc")) + (assert-error (substitute #\b #\a string :start 0 :end 6)) + (assert-error (substitute #\b #\a string :start (opaque-identity -1) :end 5)) + (assert-error (substitute #\b #\a string :start 4 :end 2)) + (assert-error (substitute #\b #\a string :start 6 :end 9)) + (assert (string= (substitute-if #\b #'alpha-char-p string + :start 0 :end 5) + "bbbbb")) + (assert (string= (substitute-if #\c #'alpha-char-p string + :start 0 :end nil) + "ccccc")) + (assert-error (substitute-if #\b #'alpha-char-p string + :start 0 :end 6)) + (assert-error (substitute-if #\b #'alpha-char-p string + :start (opaque-identity -1) :end 5)) + (assert-error (substitute-if #\b #'alpha-char-p string + :start 4 :end 2)) + (assert-error (substitute-if #\b #'alpha-char-p string + :start 6 :end 9)) + (assert (string= (substitute-if-not #\b #'alpha-char-p string + :start 0 :end 5) + "aaaaa")) + (assert (string= (substitute-if-not #\c #'alpha-char-p string + :start 0 :end nil) + "aaaaa")) + (assert-error (substitute-if-not #\b #'alpha-char-p string + :start 0 :end 6)) + (assert-error (substitute-if-not #\b #'alpha-char-p string + :start (opaque-identity -1) :end 5)) + (assert-error (substitute-if-not #\b #'alpha-char-p string + :start 4 :end 2)) + (assert-error (substitute-if-not #\b #'alpha-char-p string + :start 6 :end 9)))) + +(with-test (:name (:bounding-index nsubstitute)) + (sequence-bounding-indices-test + (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb")) + (reset) + (assert (string= (nsubstitute #\c #\a string :start 0 :end nil) + "ccccc")) + (reset) + (assert-error (nsubstitute #\b #\a string :start 0 :end 6)) + (reset) + (assert-error (nsubstitute #\b #\a string :start (opaque-identity -1) :end 5)) + (reset) + (assert-error (nsubstitute #\b #\a string :start 4 :end 2)) + (reset) + (assert-error (nsubstitute #\b #\a string :start 6 :end 9)) + (reset) + (assert (string= (nsubstitute-if #\b #'alpha-char-p string + :start 0 :end 5) + "bbbbb")) + (reset) + (assert (string= (nsubstitute-if #\c #'alpha-char-p string + :start 0 :end nil) + "ccccc")) + (reset) + (assert-error (nsubstitute-if #\b #'alpha-char-p string + :start 0 :end 6)) + (reset) + (assert-error (nsubstitute-if #\b #'alpha-char-p string + :start (opaque-identity -1) :end 5)) + (reset) + (assert-error (nsubstitute-if #\b #'alpha-char-p string + :start 4 :end 2)) + (reset) + (assert-error (nsubstitute-if #\b #'alpha-char-p string + :start 6 :end 9)) + (reset) + (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string + :start 0 :end 5) + "aaaaa")) + (reset) + (assert (string= (nsubstitute-if-not #\c #'alpha-char-p string + :start 0 :end nil) + "aaaaa")) + (reset) + (assert-error (nsubstitute-if-not #\b #'alpha-char-p string + :start 0 :end 6)) + (reset) + (assert-error (nsubstitute-if-not #\b #'alpha-char-p string + :start (opaque-identity -1) :end 5)) + (reset) + (assert-error (nsubstitute-if-not #\b #'alpha-char-p string + :start 4 :end 2)) + (reset) + (assert-error (nsubstitute-if-not #\b #'alpha-char-p string + :start 6 :end 9)))) + +(with-test (:name (:bounding-index write-string)) + (sequence-bounding-indices-test + (write-string string *standard-output* :start 0 :end 5) + (write-string string *standard-output* :start 0 :end nil) + (assert-error (write-string string *standard-output* :start 0 :end 6)) - (reset) - (assert-error (nsubstitute-if #\b #'alpha-char-p string + (assert-error (write-string string *standard-output* :start (opaque-identity -1) :end 5)) - (reset) - (assert-error (nsubstitute-if #\b #'alpha-char-p string + (assert-error (write-string string *standard-output* :start 4 :end 2)) - (reset) - (assert-error (nsubstitute-if #\b #'alpha-char-p string + (assert-error (write-string string *standard-output* :start 6 :end 9)) - (reset) - (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string - :start 0 :end 5) - "aaaaa")) - (reset) - (assert (string= (nsubstitute-if-not #\c #'alpha-char-p string - :start 0 :end nil) - "aaaaa")) - (reset) - (assert-error (nsubstitute-if-not #\b #'alpha-char-p string - :start 0 :end 6)) - (reset) - (assert-error (nsubstitute-if-not #\b #'alpha-char-p string - :start (opaque-identity -1) :end 5)) - (reset) - (assert-error (nsubstitute-if-not #\b #'alpha-char-p string - :start 4 :end 2)) - (reset) - (assert-error (nsubstitute-if-not #\b #'alpha-char-p string - :start 6 :end 9))) -;;; Function WRITE-STRING, WRITE-LINE -(sequence-bounding-indices-test - (format t "~&/Function WRITE-STRING, WRITE-LINE") - (write-string string *standard-output* :start 0 :end 5) - (write-string string *standard-output* :start 0 :end nil) - (assert-error (write-string string *standard-output* + (write-line string *standard-output* :start 0 :end 5) + (write-line string *standard-output* :start 0 :end nil) + (assert-error (write-line string *standard-output* :start 0 :end 6)) - (assert-error (write-string string *standard-output* + (assert-error (write-line string *standard-output* :start (opaque-identity -1) :end 5)) - (assert-error (write-string string *standard-output* + (assert-error (write-line string *standard-output* :start 4 :end 2)) - (assert-error (write-string string *standard-output* - :start 6 :end 9)) - (write-line string *standard-output* :start 0 :end 5) - (write-line string *standard-output* :start 0 :end nil) - (assert-error (write-line string *standard-output* - :start 0 :end 6)) - (assert-error (write-line string *standard-output* - :start (opaque-identity -1) :end 5)) - (assert-error (write-line string *standard-output* - :start 4 :end 2)) - (assert-error (write-line string *standard-output* - :start 6 :end 9))) - -;;; Macro WITH-INPUT-FROM-STRING -(sequence-bounding-indices-test - (format t "~&/Macro WITH-INPUT-FROM-STRING") - (with-input-from-string (s string :start 0 :end 5) - (assert (char= (read-char s) #\a))) - (with-input-from-string (s string :start 0 :end nil) - (assert (char= (read-char s) #\a))) - (assert-error - (with-input-from-string (s string :start 0 :end 6) - (read-char s))) - (assert-error - (with-input-from-string (s string :start (opaque-identity -1) :end 5) - (read-char s))) - (assert-error - (with-input-from-string (s string :start 4 :end 2) - (read-char s))) - (assert-error - (with-input-from-string (s string :start 6 :end 9) - (read-char s)))) + (assert-error (write-line string *standard-output* + :start 6 :end 9)))) + +(with-test (:name (:bounding-index with-input-from-string)) + (sequence-bounding-indices-test + (with-input-from-string (s string :start 0 :end 5) + (assert (char= (read-char s) #\a))) + (with-input-from-string (s string :start 0 :end nil) + (assert (char= (read-char s) #\a))) + (assert-error + (with-input-from-string (s string :start 0 :end 6) + (read-char s))) + (assert-error + (with-input-from-string (s string :start (opaque-identity -1) :end 5) + (read-char s))) + (assert-error + (with-input-from-string (s string :start 4 :end 2) + (read-char s))) + (assert-error + (with-input-from-string (s string :start 6 :end 9) + (read-char s))))) ;;; testing bit-bashing according to _The Practice of Programming_ (defun fill-bytes-for-testing (bitsize) @@ -992,7 +977,6 @@ (fill-amounts (collect-fill-amounts n-power)) (bash-function (intern (format nil "UB~A-BASH-FILL" bitsize) (find-package "SB-KERNEL")))) - (format t "~&/Function ~A..." bash-function) (loop for offset from padding-amount below (* 2 padding-amount) do (dolist (c (fill-bytes-for-testing bitsize)) (dolist (n fill-amounts) @@ -1025,7 +1009,6 @@ (fill-amounts (collect-fill-amounts n-power)) (bash-function (intern (format nil "UB~A-BASH-COPY" bitsize) (find-package "SB-KERNEL")))) - (format t "~&/Function ~A..." bash-function) (do ((source-offset padding-amount (1+ source-offset))) ((>= source-offset (* padding-amount 2)) ;; success! @@ -1055,18 +1038,19 @@ bashed-dst) (return-from test-copy-bashing nil)))))))) -;; Too slow for the interpreter -#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) -(loop for i = 1 then (* i 2) do - ;; the bare '13' here is fairly arbitrary, except that it's been - ;; reduced from '32', which made the tests take aeons; '8' provides - ;; a good range of lengths over which to fill and copy, which - ;; should tease out most errors in the code (if any exist). (It - ;; also makes this part of the test suite finish reasonably - ;; quickly.) - (assert (time (test-fill-bashing i 13 8))) - (assert (time (test-copy-bashing i 13 8))) - until (= i sb-vm:n-word-bits)) +(with-test (:name :bash + ;; Too slow for the interpreter + :skipped-on :interpreter) + (loop for i = 1 then (* i 2) do + ;; the bare '13' here is fairly arbitrary, except that it's been + ;; reduced from '32', which made the tests take aeons; '8' provides + ;; a good range of lengths over which to fill and copy, which + ;; should tease out most errors in the code (if any exist). (It + ;; also makes this part of the test suite finish reasonably + ;; quickly.) + (assert (test-fill-bashing i 13 8)) + (assert (test-copy-bashing i 13 8)) + until (= i sb-vm:n-word-bits))) (defun test-inlined-bashing (bitsize) ;; We have to compile things separately for each bitsize so the @@ -1117,32 +1101,33 @@ (return-from nil nil)))))))) (funcall (checked-compile lambda-form)))) -#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) -(loop for i = 1 then (* i 2) do - (assert (test-inlined-bashing i)) - until (= i sb-vm:n-word-bits)) +(with-test (:name :inline-bash + :skipped-on :interpreter) + (loop for i = 1 then (* i 2) do + (assert (test-inlined-bashing i)) + until (= i sb-vm:n-word-bits))) ;;; tests from the Sacla test suite via Eric Marsden, 2007-05-07 -(remove-duplicates (vector 1 2 2 1) :test-not (lambda (a b) (not (= a b)))) - -(delete-duplicates (vector #\a #\b #\c #\a) - :test-not (lambda (a b) (not (char-equal a b)))) - -;;; FILL on lists -(let ((l (list 1 2 3))) - (assert (eq l (fill l 0 :start 1 :end 2))) - (assert (equal l '(1 0 3))) - (assert (eq l (fill l 'x :start 2 :end 3))) - (assert (equal l '(1 0 x))) - (assert (eq l (fill l 'y :start 1))) - (assert (equal l '(1 y y))) - (assert (eq l (fill l 'z :end 2))) - (assert (equal l '(z z y))) - (assert (eq l (fill l 1))) - (assert (equal l '(1 1 1))) - (assert-error (fill l 0 :start 4)) - (assert-error (fill l 0 :end 4)) - (assert-error (fill l 0 :start 2 :end 1))) +(with-test (:name :remove-duplicates-test-not) + (remove-duplicates (vector 1 2 2 1) :test-not (lambda (a b) (not (= a b)))) + (delete-duplicates (vector #\a #\b #\c #\a) + :test-not (lambda (a b) (not (char-equal a b))))) + +(with-test (:name :fill-list) + (let ((l (list 1 2 3))) + (assert (eq l (fill l 0 :start 1 :end 2))) + (assert (equal l '(1 0 3))) + (assert (eq l (fill l 'x :start 2 :end 3))) + (assert (equal l '(1 0 x))) + (assert (eq l (fill l 'y :start 1))) + (assert (equal l '(1 y y))) + (assert (eq l (fill l 'z :end 2))) + (assert (equal l '(z z y))) + (assert (eq l (fill l 1))) + (assert (equal l '(1 1 1))) + (assert-error (fill l 0 :start 4)) + (assert-error (fill l 0 :end 4)) + (assert-error (fill l 0 :start 2 :end 1)))) ;;; Both :TEST and :TEST-NOT provided (with-test (:name :test-and-test-not-to-adjoin) diff -Nru sbcl-2.1.10/tests/x86-64-codegen.impure.lisp sbcl-2.1.11/tests/x86-64-codegen.impure.lisp --- sbcl-2.1.10/tests/x86-64-codegen.impure.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/tests/x86-64-codegen.impure.lisp 2021-11-30 16:16:47.000000000 +0000 @@ -998,7 +998,7 @@ (with-test (:name :sap-set-does-not-cons) (loop for (type accessor telltale) in '((sb-vm:word sb-sys:sap-ref-word "ALLOC-UNSIGNED-BIGNUM") - (double-float sb-sys:sap-ref-double "CONS")) + (double-float sb-sys:sap-ref-double "ALLOC-TRAMP")) do (let* ((positive-test (compile nil `(lambda (sap) (,accessor sap 0)))) (negative-test @@ -1099,3 +1099,45 @@ ;; 2 of them are are CONS->RNN and CONS->R11 ;; the other is ENABLE-ALLOC-COUNTER which may or may not be present (assert (<= (length fixups) 3)))) + +(defstruct submarine x y z) +(defstruct (moreslots (:include submarine)) a b c) +(declaim (ftype (function () double-float) get-dbl)) +(with-test (:name :write-combining-instance-set) + (let* ((f (compile nil '(lambda (s) + (setf (submarine-x (truly-the submarine s)) 0 + (submarine-y s) 0 + (submarine-z s) 0)))) + (lines (disassembly-lines f))) + (assert (= 1 (loop for line in lines count (search "MOVUPD" line)))) + (assert (= 1 (loop for line in lines count (search "MOVSD" line))))) + (let* ((f (compile nil '(lambda (s) + (setf (moreslots-a (truly-the moreslots s)) 0 + (submarine-x s) 0 + (moreslots-c s) 0)))) + (lines (disassembly-lines f))) + (assert (= 3 (loop for line in lines count (search "MOVSD" line))))) + ;; This was crashing in the MOV emitter (luckily) because it received + ;; an XMM register due to omission of a MOVE-FROM-DOUBLE to heap-allocate. + (compile nil + '(lambda (sub a) + (declare (submarine sub)) + (let ((fooval (+ (get-dbl) 23d0))) + (setf (submarine-x sub) a + (submarine-y sub) fooval) + a)))) + +#+immobile-code +(with-test (:name :no-static-linkage-if-notinline) + ;; The normal state of the image has no "static" calls to FIND-PACKAGE + ;; but also has no globally proclaimed NOTINLINE, because that would + ;; suppress the optimization for CACHED-FIND-PACKAGE on a constant string. + (assert (not (sb-vm::fdefn-has-static-callers (sb-kernel::find-fdefn 'find-package)))) + (assert (not (sb-int:info :function :inlinep 'find-package)))) + +(sb-vm::define-vop (trythis) + (:generator 1 + (sb-vm::inst and sb-vm::rax-tn (sb-c:make-fixup nil :gc-barrier)))) +(defun zook () + (sb-sys:%primitive trythis) + nil) diff -Nru sbcl-2.1.10/tools-for-build/editcore.lisp sbcl-2.1.11/tools-for-build/editcore.lisp --- sbcl-2.1.10/tools-for-build/editcore.lisp 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/tools-for-build/editcore.lisp 2021-11-30 16:16:47.000000000 +0000 @@ -888,7 +888,7 @@ collect (sap-ref-8 text-sap i))) (when additional-relative-fixups (binding* ((existing-fixups (sb-vm::%code-fixups code)) - ((absolute relative) + ((absolute relative immediate) (sb-c::unpack-code-fixup-locs (if (fixnump existing-fixups) existing-fixups @@ -903,9 +903,8 @@ sb-vm:word-shift)))) additional-relative-fixups) #'<))) - (sb-c::pack-code-fixup-locs - absolute - (merge 'list relative new-sorted #'<)))))) + (sb-c:pack-code-fixup-locs + absolute (merge 'list relative new-sorted #'<) immediate))))) (defconstant +gf-name-slot+ 5) @@ -1751,14 +1750,15 @@ ;; adjust this entry's start page in the new core (decf data-page page-adjust))))) (#.page-table-core-entry-type-code - (aver (= len 3)) - (symbol-macrolet ((nbytes (%vector-raw-bits core-header (1+ ptr))) - (data-page (%vector-raw-bits core-header (+ ptr 2)))) + (aver (= len 4)) + (symbol-macrolet ((n-ptes (%vector-raw-bits core-header (+ ptr 1))) + (nbytes (%vector-raw-bits core-header (+ ptr 2))) + (data-page (%vector-raw-bits core-header (+ ptr 3)))) (aver (= data-page original-total-npages)) (aver (= (ceiling (space-nwords (find dynamic-core-space-id spaces :key #'space-id)) - (/ +backend-page-bytes+ n-word-bytes)) - (%vector-raw-bits core-header ptr))) ; number of PTEs + (/ sb-vm:gencgc-card-bytes n-word-bytes)) + n-ptes)) (when verbose (format t "PTE: page=~5x~40tbytes=~8x~%" data-page nbytes)) (push (cons data-page nbytes) copy-actions) @@ -1900,9 +1900,9 @@ (when (plusp nwords) (push (make-space id addr data-page 0 nwords) spaces)))) (#.page-table-core-entry-type-code - (aver (= len 3)) - (symbol-macrolet ((nbytes (%vector-raw-bits core-header (1+ ptr))) - (data-page (%vector-raw-bits core-header (+ ptr 2)))) + (aver (= len 4)) + (symbol-macrolet ((nbytes (%vector-raw-bits core-header (+ ptr 2))) + (data-page (%vector-raw-bits core-header (+ ptr 3)))) (aver (= data-page total-npages)) (setq core-size (+ (* total-npages +backend-page-bytes+) nbytes)))))) (incf core-size +backend-page-bytes+) ; add in core header page diff -Nru sbcl-2.1.10/version.lisp-expr sbcl-2.1.11/version.lisp-expr --- sbcl-2.1.10/version.lisp-expr 2021-10-28 20:06:01.000000000 +0000 +++ sbcl-2.1.11/version.lisp-expr 2021-11-30 16:16:47.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.1.10" +"2.1.11"