tests/layouts.pure.lisp

   1
   2 (defun list-all-layouts ()
   3   #+permgen
   4   (let (list)
   5     ;; I should probably incorporate permgen into the set of spaces
   6     ;; that can be listed, but until then ...
   7     (sb-vm::map-objects-in-range
   8      (lambda (obj widetag size)
   9        (declare (ignore widetag size))
  10        (when (sb-kernel::layout-p obj)
  11          (push obj list)))
  12      (sb-kernel:%make-lisp-obj sb-vm:permgen-space-start)
  13      (sb-kernel:%make-lisp-obj (sb-sys:sap-int sb-vm:*permgen-space-free-pointer*)))
  14     list)
  15   #-permgen
  16   (sb-vm:list-allocated-objects :all :type sb-vm:instance-widetag
  17                                      :test #'sb-kernel::layout-p))
  18
  19 (with-test (:name :funinstance-layout-bitmaps-all-same)
  20   (let* ((list (list-all-layouts))
  21          (fun-layouts
  22           (remove-if-not (lambda (x) (find (sb-kernel:find-layout 'function)
  23                                            (sb-kernel:layout-inherits x)))
  24                          list))
  25          (bitmaps (mapcar 'sb-kernel::%layout-bitmap fun-layouts)))
  26     (assert (= (length (remove-duplicates bitmaps)) 1))))
  27
  28 (with-test (:name :stream-layout-bits)
  29   (loop for wrapper being each hash-value
  30         of (sb-kernel:classoid-subclasses (sb-kernel:find-classoid 't))
  31         do (flet ((check-bit (bit ancestor-type)
  32                     (let ((ancestor (sb-kernel:find-layout ancestor-type)))
  33                       (when (or (eq wrapper ancestor)
  34                                 (find ancestor (sb-kernel:layout-inherits wrapper)))
  35                         (assert (logtest bit (sb-kernel:layout-flags wrapper)))))))
  36               (check-bit sb-kernel:+stream-layout-flag+ 'stream)
  37               (check-bit sb-kernel:+string-stream-layout-flag+ 'string-stream)
  38               (check-bit sb-kernel:+file-stream-layout-flag+ 'file-stream))))
  39
  40 (with-test (:name :boxed-layout-bits)
  41   ;; Negative test
  42   (dolist (name '(hash-table sb-thread:thread sb-thread::avlnode))
  43     (let ((layout (sb-kernel:find-layout name)))
  44       (assert (not (logtest (sb-kernel:layout-flags layout)
  45                             sb-kernel:+strictly-boxed-flag+)))))
  46   ;; Positive test, just a small sampling
  47   (dolist (name '(condition warning error
  48                   pathname logical-pathname
  49                   sb-impl::string-output-stream
  50                   structure-object sb-c::node
  51                   fundamental-stream))
  52     (let ((layout (sb-kernel:find-layout name)))
  53       (assert (logtest (sb-kernel:layout-flags layout)
  54                        sb-kernel:+strictly-boxed-flag+)))))
  55
  56 ;;; Test some aspects of bitmaps, and the iterator.
  57
  58 ;;; A layout-bitmap has the same representation as a BIGNUM-
  59 ;;; least-significant word first, native endian within the word.
  60 ;;; Like a bignum, all but the last word are unsigned, and the last is signed.
  61 ;;; This representation allows trailing slots to be either all tagged
  62 ;;; or all untagged.
  63
  64 (defstruct d2)
  65 (defstruct (d3 (:include d2)))
  66 (defstruct (d4 (:include d3)))
  67 (defstruct (d5 (:include d4)))
  68 (defstruct (d6 (:include d5)))
  69 (defstruct (d7 (:include d6)))
  70 (defstruct (d8 (:include d7)))
  71 (defstruct (d9 (:include d8)))
  72 (defstruct (d10 (:include d9)))
  73 (defstruct (d11 (:include d10)))
  74 (defstruct (d12 (:include d11)))
  75 (defstruct (d13 (:include d12)))
  76 (defstruct (d14 (:include d13)))
  77 (defstruct (d15 (:include d14)))
  78
  79 (defparameter *test-layouts*
  80   (coerce (list* (sb-kernel:find-layout 't)
  81                  (sb-kernel:find-layout 'structure-object)
  82                  (loop for i from 2 to 15
  83                     collect (sb-kernel:find-layout (intern (format nil "D~D" i)))))
  84           'vector))
  85
  86 ;;; Assert that BITMAP-NWORDS is insensitive to depthoid
  87 (with-test (:name :bitmap-nwords-1)
  88   (loop for depthoid from 3 to 16
  89      do
  90        (let ((layout (sb-kernel:make-layout
  91                       1 ; random hash
  92                       (sb-kernel:make-undefined-classoid 'blah)
  93                       :depthoid depthoid
  94                       :bitmap #+64-bit #x6fffffffeeeeff02 ; 1-word bignum
  95                               #-64-bit #x70ffe123
  96                       :inherits (subseq *test-layouts* 0 depthoid)
  97                       :flags sb-kernel:+structure-layout-flag+)))
  98          (assert (= (sb-kernel:bitmap-nwords layout) 1)))))
  99 (with-test (:name :bitmap-nwords-2)
 100   (loop for depthoid from 3 to 16
 101      do
 102        (let ((layout (sb-kernel:make-layout
 103                       1 ; random hash
 104                       (sb-kernel:make-undefined-classoid 'blah)
 105                       :depthoid depthoid
 106                       :bitmap #+64-bit #xffffffffeeeeff02 ; 2-word bignum
 107                               #-64-bit #x80ffe123
 108                       :inherits (subseq *test-layouts* 0 depthoid)
 109                       :flags sb-kernel:+structure-layout-flag+)))
 110          (assert (= (sb-kernel:bitmap-nwords layout) 2)))))
 111
 112 (defun layout-id-vector-sap (layout)
 113   (sb-sys:sap+ (sb-sys:int-sap (sb-kernel:get-lisp-obj-address layout))
 114                (- (ash (+ sb-vm:instance-slots-offset
 115                           (sb-kernel:get-dsd-index sb-kernel:layout sb-kernel::id-word0))
 116                        sb-vm:word-shift)
 117                   sb-vm:instance-pointer-lowtag)))
 118
 119 ;;;; Ensure ID uniqueness and that layout ID words match the ID's in the INHERITS vector.
 120 (defparameter *all-wrappers*
 121   (delete-if
 122    ;; temporary layouts (created for parsing DEFSTRUCT)
 123    ;; must be be culled out.
 124    (lambda (x)
 125      (and (typep (sb-kernel:layout-classoid x)
 126                  'sb-kernel:structure-classoid)
 127           (eq (sb-kernel:layout-equalp-impl x)
 128               #'sb-kernel::equalp-err)))
 129    (sb-vm::list-allocated-objects :all
 130                                   :type sb-vm:instance-widetag
 131                                   :test #'sb-kernel::layout-p)))
 132
 133 ;;; Assert no overlaps on ID
 134 (with-test (:name :id-uniqueness)
 135   (let ((hash (make-hash-table)))
 136     (dolist (wrapper *all-wrappers*)
 137       (let ((id (sb-kernel:layout-id wrapper)))
 138         (sb-int:awhen (gethash id hash)
 139           (error "ID ~D is ~A and ~A" id sb-int:it wrapper))
 140         (setf (gethash id hash) wrapper)))))
 141
 142 ;;; Assert that IDs are right
 143 (with-test (:name :id-versus-inherits)
 144   (let ((structure-object (sb-kernel:find-layout 'structure-object)))
 145     (dolist (wrapper *all-wrappers*)
 146       (when (find structure-object (sb-kernel:layout-inherits wrapper))
 147         (let* ((layout wrapper)
 148                (ids
 149                 (sb-sys:with-pinned-objects (layout)
 150                   (let ((sap (layout-id-vector-sap layout)))
 151                     (loop for depthoid from 2 to (sb-kernel:layout-depthoid wrapper)
 152                        collect (sb-sys:signed-sap-ref-32 sap (ash (- depthoid 2) 2))))))
 153                (expected
 154                 (map 'list 'sb-kernel:layout-id (sb-kernel:layout-inherits wrapper))))
 155           (unless (equal (list* (sb-kernel:layout-id (sb-kernel:find-layout 't))
 156                                 (sb-kernel:layout-id (sb-kernel:find-layout 'structure-object))
 157                                 ids)
 158                          (append expected (list (sb-kernel:layout-id wrapper))))
 159             (error "Wrong IDs for ~A: expect ~D actual ~D~%"
 160                    wrapper expected ids)))))))
 161
 162 (makunbound '*all-wrappers*)
 163
 164 (defun random-bitmap (nwords random-state sign-bit)
 165   (let ((integer 0)
 166         (position 0))
 167     ;; Deposit N-WORD-BITS bits into INTEGER NWORDS times,
 168     ;; then make sure the sign bit is as requested.
 169     (dotimes (i nwords)
 170       (setf (ldb (byte sb-vm:n-word-bits position) integer)
 171             ;; If the PRNG generates a 0 word, change it to 1.
 172             (max 1 (random (ash 1 sb-vm:n-word-bits) random-state)))
 173       (incf position sb-vm:n-word-bits))
 174     ;; If INSTANCE-DATA-START is 1, then the 0th bitmap bit must be 0
 175     ;; because we don't want LAYOUT to be lumped in with tagged slots
 176     ;; (even though it's of course tagged)
 177     (when (and (= sb-vm:instance-data-start 1) (oddp integer))
 178       (setq integer (logxor integer 1)))
 179     (ecase sign-bit
 180       (:positive
 181        (ldb (byte (1- (* nwords sb-vm:n-word-bits)) 0) integer))
 182       (:negative
 183        (dpb integer (byte (1- (* nwords sb-vm:n-word-bits)) 0) -1)))))
 184 (compile'random-bitmap)
 185
 186 ;;; Check the random bitmap generator a little.
 187 (with-test (:name :check-random-bitmaps)
 188   (loop for nwords from 2 to 8
 189      do (dolist (sign '(:positive :negative))
 190           (dotimes (i 100)
 191             (let ((b (random-bitmap nwords *random-state* sign)))
 192               (assert (= (sb-bignum:%bignum-length b) nwords)))))))
 193
 194 (defun make-layout-for-test (depthoid bitmap)
 195   (sb-kernel:make-layout 1 ; random hash
 196                          (sb-kernel:make-undefined-classoid 'blah)
 197                          :depthoid depthoid
 198                          :bitmap bitmap
 199                          :inherits (subseq *test-layouts* 0 depthoid)
 200                          :flags sb-kernel:+structure-layout-flag+))
 201 (compile 'make-layout-for-test)
 202
 203 (defun test-bitmap-iterator (layout instance-length reference-bitmap)
 204   (let ((count 0))
 205     (declare (fixnum count))
 206     (sb-kernel:do-layout-bitmap (slot-index taggedp layout instance-length)
 207       (incf count)
 208       (sb-int:aver (eq (logbitp slot-index reference-bitmap) taggedp)))
 209     (sb-int:aver (= count (- instance-length sb-vm:instance-data-start)))))
 210 (compile 'test-bitmap-iterator)
 211
 212 ;;; Now randomly test bitmaps of varying length in words
 213 ;;; and for both values of the sign bit in the last word.
 214 ;;; Test with instances that are longer than the bitmap's significant bit count
 215 ;;; so that we can verify infinite sign-extension.
 216 ;;; And test with shorter to make sure the loop is properly bounded
 217 ;;; by the instance length.
 218 (with-test (:name :random-bitmaps)
 219   (let ((rs (make-random-state t)))
 220     ;; Modulate the depthoid so that BITMAP-START is at different indices.
 221     (loop for depthoid from 6 to 10
 222        do (loop for n-bitmap-words from 1 to 6
 223                 do
 224              (dolist (sign '(:positive :negative))
 225                (let* ((bitmap (random-bitmap n-bitmap-words rs sign))
 226                       (layout (make-layout-for-test depthoid bitmap)))
 227                  (loop for instance-length from 5 to (* (+ n-bitmap-words 2)
 228                                                         sb-vm:n-word-bits)
 229                        do (test-bitmap-iterator layout instance-length bitmap))))))))