[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-devel
Subject: Re: [Sbcl-devel] [Sbcl-commits] master: Fix DO-LAYOUT-BITMAP
From: Stas Boukarev <stassats () gmail ! com>
Date: 2022-04-25 15:32:55
Message-ID: CAF63=11ohT9_TktkfdDomaE6sxhrVcdo5j=cvvq1AGCzXctvCA () mail ! gmail ! com
[Download RAW message or body]
with sb-fasteval:
::: Running :DD-BITMAP-VS-LAYOUT-BITMAP
::: UNEXPECTED-FAILURE :DD-BITMAP-VS-LAYOUT-BITMAP due to UNDEFINED-FUNCTION:
"The function SB-BIGNUM:%BIGNUM-LENGTH is undefined."
On Mon, Apr 25, 2022 at 5:41 PM Douglas Katzman via Sbcl-commits
<sbcl-commits@lists.sourceforge.net> wrote:
>
> The branch "master" has been updated in SBCL:
> via e7bd68671fcdd98382c78eb31c4d45738e9edc99 (commit)
> from 1bbd98ffa3357b85d36177b6181c573b9f96133d (commit)
>
> - Log -----------------------------------------------------------------
> commit e7bd68671fcdd98382c78eb31c4d45738e9edc99
> Author: Douglas Katzman <dougk@google.com>
> Date: Mon Apr 25 10:36:39 2022 -0400
>
> Fix DO-LAYOUT-BITMAP
>
> When implementing variable-length trailing bitmaps, I half forgot that
> there were variable-length data for the layout IDs of :INCLUDEd types.
> C code was right but some Lisp code wasn't. BITMAP-NWORDS was right
> if the depthoid did not require appending to the reserved ID words.
> There is space for 6 included IDs by default (STRUCTURE-OBJECT being
> implicit), so for typical structure definitions, no bug was evident.
> ---
> src/code/class.lisp | 14 ++--
> src/code/early-classoid.lisp | 14 ++--
> src/code/early-raw-slots.lisp | 30 +++++++
> src/code/target-defstruct.lisp | 10 ++-
> src/cold/exports.lisp | 1 +
> tests/defstruct.impure.lisp | 57 +++----------
> tests/layouts.pure.lisp | 178 +++++++++++++++++++++++++++++++++++++++++
> 7 files changed, 238 insertions(+), 66 deletions(-)
>
> diff --git a/src/code/class.lisp b/src/code/class.lisp
> index fe389a819..cd7b48aa6 100644
> --- a/src/code/class.lisp
> +++ b/src/code/class.lisp
> @@ -343,22 +343,18 @@ between the ~A definition and the ~A definition"
> table))
> nil)
>
> -;;; Record LAYOUT as the layout for its class, adding it as a subtype
> +;;; Record WRAPPER as the layout for its class, adding it as a subtype
> ;;; of all superclasses. This is the operation that "installs" a
> ;;; layout for a class in the type system, clobbering any old layout.
> ;;; However, this does not modify the class namespace; that is a
> ;;; separate operation (think anonymous classes.)
> ;;; -- If INVALIDATE, then all the layouts for any old definition
> ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
> -;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
> -;;; destructively modified to hold the same type information.
> +;;; -- If MODIFY is given, then it is some old layout, and is to be
> +;;; destructively altered to hold the same data as WRAPPER.
> (macrolet ((set-bitmap-from-layout (to-layout from-layout)
> - `(let ((to-index
> - (+ (type-dd-length sb-vm:layout)
> - (calculate-extra-id-words (layout-depthoid ,to-layout))))
> - (from-index
> - (+ (type-dd-length sb-vm:layout)
> - (calculate-extra-id-words (layout-depthoid ,from-layout)))))
> + `(let ((to-index (bitmap-start ,to-layout))
> + (from-index (bitmap-start ,from-layout)))
> (dotimes (i (bitmap-nwords ,from-layout))
> (%raw-instance-set/word ,to-layout (+ to-index i)
> (%raw-instance-ref/word ,from-layout (+ from-index i)))))))
> diff --git a/src/code/early-classoid.lisp b/src/code/early-classoid.lisp
> index 4f0c0c4bb..1bcc4b6b6 100644
> --- a/src/code/early-classoid.lisp
> +++ b/src/code/early-classoid.lisp
> @@ -376,17 +376,21 @@
>
> #-sb-xc-host
> (progn
> -(declaim (inline bitmap-nwords bitmap-all-taggedp))
> +(declaim (inline bitmap-start bitmap-nwords bitmap-all-taggedp))
> +(defun bitmap-start (layout)
> + (+ (type-dd-length sb-vm:layout)
> + (calculate-extra-id-words (layout-depthoid layout))))
> (defun bitmap-nwords (layout)
> (declare (sb-vm:layout layout))
> - (- (%instance-length layout) (type-dd-length sb-vm:layout)))
> -
> + (- (%instance-length layout)
> + (calculate-extra-id-words (layout-depthoid layout))
> + (type-dd-length sb-vm:layout)))
> (defun bitmap-all-taggedp (layout)
> ;; All bitmaps have at least 1 word; read that first.
> - (and (= (%raw-instance-ref/signed-word layout (type-dd-length sb-vm:layout))
> + (and (= (%raw-instance-ref/signed-word layout (bitmap-start layout))
> +layout-all-tagged+)
> ;; Then check that there are no additional words.
> - (= (%instance-length layout) (1+ (type-dd-length sb-vm:layout)))))
> + (= (bitmap-nwords layout) 1)))
>
> #+metaspace ; If metaspace, then WRAPPER has no flags; they're in the LAYOUT.
> (defmacro wrapper-flags (x) `(layout-flags (wrapper-friend ,x)))
> diff --git a/src/code/early-raw-slots.lisp b/src/code/early-raw-slots.lisp
> index 11d8ddac1..d70407fa3 100644
> --- a/src/code/early-raw-slots.lisp
> +++ b/src/code/early-raw-slots.lisp
> @@ -241,3 +241,33 @@
> (when (logbitp 0 ,mask) ,@body)
> (setq ,mask (ash ,mask -1)
> ,nbits (truly-the fixnum (1- ,nbits)))))))
> +
> +;;; FIXME: at the earliest opportunity, either express DO-INSTANCE-TAGGED-SLOT
> +;;; in terms of DO-LAYOUT-BITMAP or apply this diff:
> +#|
> +--- a/src/code/early-raw-slots.lisp
> ++++ b/src/code/early-raw-slots.lisp
> +@@ -194,6 +194,7 @@
> + ;;; I have a love/hate relationship with this macro.
> + ;;; It's more efficient than iterating over DSD-SLOTS, and editcore would
> + ;;; have a harder time using DSD-SLOTS. But it's too complicated.
> + #-sb-xc-host
> + (defmacro do-instance-tagged-slot ((index-var thing &optional (pad t) layout-expr)
> + &body body)
> +@@ -210,12 +211,12 @@
> + (%instance-ref ,instance 0)))
> + (truly-the sb-vm:layout
> + (if (eql l 0) #.(find-layout 't) l)))))
> ++ (,bitmap-index (bitmap-start ,layout))
> + ;; Shift out 1 bit if skipping bit 0 of the 0th mask word
> + ;; because it's not user-visible data.
> +- (,mask (ash (%raw-instance-ref/signed-word ,layout (type-dd-length sb-vm:layout))
> ++ (,mask (ash (%raw-instance-ref/signed-word
> ++ ,layout (prog1 ,bitmap-index (incf ,bitmap-index)))
> + (- sb-vm:instance-data-start)))
> +- ;; Start counting from the next bitmap word as we've consumed one already
> +- (,bitmap-index (1+ (type-dd-length sb-vm:layout)))
> + (,bitmap-limit (%instance-length ,layout))
> + ;; If this was the last word of the bitmap, then the high bit
> + ;; is infinitely sign-extended, and we can keep right-shifting
> +|#
> diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
> index ca4e32aea..f076868f9 100644
> --- a/src/code/target-defstruct.lisp
> +++ b/src/code/target-defstruct.lisp
> @@ -320,12 +320,12 @@
> ;;; Similar to DO-INSTANCE-TAGGED-SLOT but iterating over all words.
> (defmacro do-layout-bitmap ((index-var taggedp-var layout count) &body guts)
> `(let* ((layout ,layout)
> - ;; Start counting from the next bitmap word as we've consumed one already
> - (bitmap-word-index ,(1+ (type-dd-length sb-vm:layout)))
> + (bitmap-word-index (bitmap-start layout))
> (bitmap-word-limit (%instance-length layout))
> ;; Shift out 1 bit if skipping bit 0 of the 0th mask word
> ;; because it's not user-visible data.
> - (mask (ash (%raw-instance-ref/signed-word layout ,(type-dd-length sb-vm:layout))
> + (mask (ash (%raw-instance-ref/signed-word
> + layout (prog1 bitmap-word-index (incf bitmap-word-index)))
> ,(- sb-vm:instance-data-start)))
> ;; If this was the last word of the bitmap, then the high bit
> ;; is infinitely sign-extended, and we can keep right-shifting
> @@ -338,7 +338,7 @@
> (do ((,index-var sb-vm:instance-data-start (1+ ,index-var))
> (end ,count))
> ((>= ,index-var end))
> - (declare (type (unsigned-byte 14) ,index-var))
> + (declare (type (unsigned-byte 14) ,index-var end))
> ;; If mask was fully consumed, fetch the next bitmap word
> (when (zerop nbits)
> (setq mask (%raw-instance-ref/signed-word layout bitmap-word-index)
> @@ -376,6 +376,8 @@
> (fast-loop))
> (let ((res (%make-instance/mixed len)))
> (%set-instance-layout res layout)
> + ;; DO-LAYOUT-BITMAP does not visit the LAYOUT itself
> + ;; (if that occupies a whole slot vs. being in the header)
> (do-layout-bitmap (i taggedp layout len)
> (if taggedp
> (%instance-set res i (%instance-ref structure i))
> diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
> index 50025f2ca..3f5b5f181 100644
> --- a/src/cold/exports.lisp
> +++ b/src/cold/exports.lisp
> @@ -2038,6 +2038,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
> "DIVISION-BY-ZERO-ERROR"
> "DO-REST-ARG"
> "DO-INSTANCE-TAGGED-SLOT"
> + "DO-LAYOUT-BITMAP"
> "DOUBLE-FLOAT-EXPONENT"
> "DOUBLE-FLOAT-BITS"
> "DOUBLE-FLOAT-HIGH-BITS" "DOUBLE-FLOAT-INT-EXPONENT"
> diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
> index 63f912635..a24704637 100644
> --- a/tests/defstruct.impure.lisp
> +++ b/tests/defstruct.impure.lisp
> @@ -11,54 +11,6 @@
>
> (load "compiler-test-util.lisp")
>
> -;;;; Better ensure nothing in messed up in the ID space
> -;;;; or else everything is suspect.
> -(defun layout-id-vector-sap (layout)
> - (sb-sys:sap+ (sb-sys:int-sap (sb-kernel:get-lisp-obj-address layout))
> - (- (ash (+ sb-vm:instance-slots-offset
> - (sb-kernel:get-dsd-index sb-vm:layout sb-kernel::id-word0))
> - sb-vm:word-shift)
> - sb-vm:instance-pointer-lowtag)))
> -
> -(let ((hash (make-hash-table)))
> - ;; assert that all layout IDs are unique
> - (let ((all-wrappers
> - (delete-if
> - ;; temporary layouts (created for parsing DEFSTRUCT)
> - ;; must be be culled out.
> - (lambda (x)
> - (and (typep (sb-kernel:wrapper-classoid x)
> - 'sb-kernel:structure-classoid)
> - (eq (sb-kernel:wrapper-equalp-impl x)
> - #'sb-kernel::equalp-err)))
> - (sb-vm::list-allocated-objects :all
> - :type sb-vm:instance-widetag
> - :test #'sb-kernel::wrapper-p))))
> - (dolist (wrapper all-wrappers)
> - (let ((id (sb-kernel:layout-id wrapper)))
> - (sb-int:awhen (gethash id hash)
> - (error "ID ~D is ~A and ~A" id sb-int:it wrapper))
> - (setf (gethash id hash) wrapper)))
> - ;; assert that all inherited ID vectors match the layout-inherits vector
> - (let ((structure-object
> - (sb-kernel:find-layout 'structure-object)))
> - (dolist (wrapper all-wrappers)
> - (when (find structure-object (sb-kernel:wrapper-inherits wrapper))
> - (let* ((layout (sb-kernel:wrapper-friend wrapper))
> - (ids
> - (sb-sys:with-pinned-objects (layout)
> - (let ((sap (layout-id-vector-sap layout)))
> - (loop for depthoid from 2 to (sb-kernel:wrapper-depthoid wrapper)
> - collect (sb-sys:signed-sap-ref-32 sap (ash (- depthoid 2) 2))))))
> - (expected
> - (map 'list 'sb-kernel:layout-id (sb-kernel:wrapper-inherits wrapper))))
> - (unless (equal (list* (sb-kernel:layout-id (sb-kernel:find-layout 't))
> - (sb-kernel:layout-id (sb-kernel:find-layout 'structure-object))
> - ids)
> - (append expected (list (sb-kernel:layout-id wrapper))))
> - (error "Wrong IDs for ~A: expect ~D actual ~D~%"
> - wrapper expected ids))))))))
> -
> ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
>
> ;;; Type mismatch of slot default init value isn't an error until the
> @@ -575,6 +527,15 @@
> (sb-kernel:dd-slots
> (sb-kernel:find-defstruct-description 'hugest-manyraw))))))
>
> +(with-test (:name :dd-bitmap-vs-layout-bitmap)
> + (dolist (typename '(huge-manyraw hugest-manyraw))
> + (let* ((layout (sb-kernel:find-layout typename))
> + (info (sb-kernel:wrapper-dd layout))
> + (bitmap (sb-kernel::dd-bitmap info)))
> + (assert (typep bitmap 'bignum))
> + (assert (= (sb-bignum:%bignum-length bitmap)
> + (sb-kernel:bitmap-nwords layout))))))
> +
> (defun check-huge-manyraw (s)
> (assert (and (eql (huge-manyraw-df s) 8.207880688335944d-304)
> (eql (huge-manyraw-aaa s) 'aaa)
> diff --git a/tests/layouts.pure.lisp b/tests/layouts.pure.lisp
> index 9bc11a4c5..dfd3800a8 100644
> --- a/tests/layouts.pure.lisp
> +++ b/tests/layouts.pure.lisp
> @@ -25,3 +25,181 @@
> (let ((layout (sb-kernel:find-layout name)))
> (assert (logtest (sb-kernel:wrapper-flags layout)
> sb-kernel:+strictly-boxed-flag+)))))
> +
> +;;; Test some aspects of bitmaps, and the iterator.
> +
> +;;; A layout-bitmap has the same representation as a BIGNUM-
> +;;; least-significant word first, native endian within the word.
> +;;; Like a bignum, all but the last word are unsigned, and the last is signed.
> +;;; This representation allows trailing slots to be either all tagged
> +;;; or all untagged.
> +
> +(defun ld (x) (sb-kernel:layout-depthoid (truly-the sb-vm::layout x)))
> +(compile 'ld)
> +
> +(defstruct d2)
> +(defstruct (d3 (:include d2)))
> +(defstruct (d4 (:include d3)))
> +(defstruct (d5 (:include d4)))
> +(defstruct (d6 (:include d5)))
> +(defstruct (d7 (:include d6)))
> +(defstruct (d8 (:include d7)))
> +(defstruct (d9 (:include d8)))
> +(defstruct (d10 (:include d9)))
> +(defstruct (d11 (:include d10)))
> +(defstruct (d12 (:include d11)))
> +(defstruct (d13 (:include d12)))
> +(defstruct (d14 (:include d13)))
> +(defstruct (d15 (:include d14)))
> +
> +(defparameter *test-layouts*
> + (coerce (list* (sb-kernel:find-layout 't)
> + (sb-kernel:find-layout 'structure-object)
> + (loop for i from 2 to 15
> + collect (sb-kernel:find-layout (intern (format nil "D~D" i)))))
> + 'vector))
> +
> +;;; Assert that BITMAP-NWORDS is insensitive to depthoid
> +(with-test (:name :bitmap-nwords-1)
> + (loop for depthoid from 3 to 16
> + do
> + (let ((layout (sb-kernel:make-layout
> + 1 ; random hash
> + (sb-kernel:make-undefined-classoid 'blah)
> + :depthoid depthoid
> + :bitmap #+64-bit #x6fffffffeeeeff02 ; 1-word bignum
> + #-64-bit #x70ffe123
> + :inherits (subseq *test-layouts* 0 depthoid)
> + :flags sb-kernel:+structure-layout-flag+)))
> + (assert (= (sb-kernel:bitmap-nwords layout) 1)))))
> +(with-test (:name :bitmap-nwords-2)
> + (loop for depthoid from 3 to 16
> + do
> + (let ((layout (sb-kernel:make-layout
> + 1 ; random hash
> + (sb-kernel:make-undefined-classoid 'blah)
> + :depthoid depthoid
> + :bitmap #+64-bit #xffffffffeeeeff02 ; 2-word bignum
> + #-64-bit #x80ffe123
> + :inherits (subseq *test-layouts* 0 depthoid)
> + :flags sb-kernel:+structure-layout-flag+)))
> + (assert (= (sb-kernel:bitmap-nwords layout) 2)))))
> +
> +(defun layout-id-vector-sap (layout)
> + (sb-sys:sap+ (sb-sys:int-sap (sb-kernel:get-lisp-obj-address layout))
> + (- (ash (+ sb-vm:instance-slots-offset
> + (sb-kernel:get-dsd-index sb-vm:layout sb-kernel::id-word0))
> + sb-vm:word-shift)
> + sb-vm:instance-pointer-lowtag)))
> +
> +;;;; Ensure ID uniqueness and that layout ID words match the ID's in the INHERITS vector.
> +(defparameter *all-wrappers*
> + (delete-if
> + ;; temporary layouts (created for parsing DEFSTRUCT)
> + ;; must be be culled out.
> + (lambda (x)
> + (and (typep (sb-kernel:wrapper-classoid x)
> + 'sb-kernel:structure-classoid)
> + (eq (sb-kernel:wrapper-equalp-impl x)
> + #'sb-kernel::equalp-err)))
> + (sb-vm::list-allocated-objects :all
> + :type sb-vm:instance-widetag
> + :test #'sb-kernel::wrapper-p)))
> +
> +;;; Assert no overlaps on ID
> +(with-test (:name :id-uniqueness)
> + (let ((hash (make-hash-table)))
> + (dolist (wrapper *all-wrappers*)
> + (let ((id (sb-kernel:layout-id wrapper)))
> + (sb-int:awhen (gethash id hash)
> + (error "ID ~D is ~A and ~A" id sb-int:it wrapper))
> + (setf (gethash id hash) wrapper)))))
> +
> +;;; Assert that IDs are right
> +(with-test (:name :id-versus-inherits)
> + (let ((structure-object (sb-kernel:find-layout 'structure-object)))
> + (dolist (wrapper *all-wrappers*)
> + (when (find structure-object (sb-kernel:wrapper-inherits wrapper))
> + (let* ((layout (sb-kernel:wrapper-friend wrapper))
> + (ids
> + (sb-sys:with-pinned-objects (layout)
> + (let ((sap (layout-id-vector-sap layout)))
> + (loop for depthoid from 2 to (sb-kernel:wrapper-depthoid wrapper)
> + collect (sb-sys:signed-sap-ref-32 sap (ash (- depthoid 2) 2))))))
> + (expected
> + (map 'list 'sb-kernel:layout-id (sb-kernel:wrapper-inherits wrapper))))
> + (unless (equal (list* (sb-kernel:layout-id (sb-kernel:find-layout 't))
> + (sb-kernel:layout-id (sb-kernel:find-layout 'structure-object))
> + ids)
> + (append expected (list (sb-kernel:layout-id wrapper))))
> + (error "Wrong IDs for ~A: expect ~D actual ~D~%"
> + wrapper expected ids)))))))
> +
> +(makunbound '*all-wrappers*)
> +
> +(defun random-bitmap (nwords random-state sign-bit)
> + (let ((integer 0)
> + (position 0))
> + ;; Deposit N-WORD-BITS bits into INTEGER NWORDS times,
> + ;; then make sure the sign bit is as requested.
> + (dotimes (i nwords)
> + (setf (ldb (byte sb-vm:n-word-bits position) integer)
> + ;; If the PRNG generates a 0 word, change it to 1.
> + (max 1 (random (ash 1 sb-vm:n-word-bits) random-state)))
> + (incf position sb-vm:n-word-bits))
> + ;; If INSTANCE-DATA-START is 1, then the 0th bitmap bit must be 0
> + ;; because we don't want LAYOUT to be lumped in with tagged slots
> + ;; (even though it's of course tagged)
> + (when (and (= sb-vm:instance-data-start 1) (oddp integer))
> + (setq integer (logxor integer 1)))
> + (ecase sign-bit
> + (:positive
> + (ldb (byte (1- (* nwords sb-vm:n-word-bits)) 0) integer))
> + (:negative
> + (dpb integer (byte (1- (* nwords sb-vm:n-word-bits)) 0) -1)))))
> +(compile'random-bitmap)
> +
> +;;; Check the random bitmap generator a little.
> +(with-test (:name :check-random-bitmaps)
> + (loop for nwords from 2 to 8
> + do (dolist (sign '(:positive :negative))
> + (dotimes (i 100)
> + (let ((b (random-bitmap nwords *random-state* sign)))
> + (assert (= (sb-bignum:%bignum-length b) nwords)))))))
> +
> +(defun make-layout-for-test (depthoid bitmap)
> + (sb-kernel:make-layout 1 ; random hash
> + (sb-kernel:make-undefined-classoid 'blah)
> + :depthoid depthoid
> + :bitmap bitmap
> + :inherits (subseq *test-layouts* 0 depthoid)
> + :flags sb-kernel:+structure-layout-flag+))
> +(compile 'make-layout-for-test)
> +
> +(defun test-bitmap-iterator (layout instance-length reference-bitmap)
> + (let ((count 0))
> + (declare (fixnum count))
> + (sb-kernel:do-layout-bitmap (slot-index taggedp layout instance-length)
> + (incf count)
> + (sb-int:aver (eq (logbitp slot-index reference-bitmap) taggedp)))
> + (sb-int:aver (= count (- instance-length sb-vm:instance-data-start)))))
> +(compile 'test-bitmap-iterator)
> +
> +;;; Now randomly test bitmaps of varying length in words
> +;;; and for both values of the sign bit in the last word.
> +;;; Test with instances that are longer than the bitmap's significant bit count
> +;;; so that we can verify infinite sign-extension.
> +;;; And test with shorter to make sure the loop is properly bounded
> +;;; by the instance length.
> +(with-test (:name :random-bitmaps)
> + (let ((rs (make-random-state t)))
> + ;; Modulate the depthoid so that BITMAP-START is at different indices.
> + (loop for depthoid from 6 to 10
> + do (loop for n-bitmap-words from 1 to 6
> + do
> + (dolist (sign '(:positive :negative))
> + (let* ((bitmap (random-bitmap n-bitmap-words rs sign))
> + (layout (make-layout-for-test depthoid bitmap)))
> + (loop for instance-length from 5 to (* (+ n-bitmap-words 2)
> + sb-vm:n-word-bits)
> + do (test-bitmap-iterator layout instance-length bitmap))))))))
>
> -----------------------------------------------------------------------
>
>
> hooks/post-receive
> --
> SBCL
>
>
> _______________________________________________
> Sbcl-commits mailing list
> Sbcl-commits@lists.sourceforge.net
> https://lists.sourceforge.net/lists/listinfo/sbcl-commits
_______________________________________________
Sbcl-devel mailing list
Sbcl-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-devel
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic