tests/raw-slots-interleaved.impure.lisp

   1 ;;;; gc tests
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 ;;; More tests of raw slots can be found in 'defstruct.impure.lisp'
  17 ;;; Since those are all passing, it's fair to say that interleaving works.
  18 ;;; But we want also to test what happens in a very specific case that
  19 ;;; is difficult to provoke, when a structure contains enough slots that
  20 ;;; its raw bitmap is a bignum and the bignum is moved during GC.
  21
  22 (macrolet ((defbiggy ()
  23              `(defstruct biggy
  24                 ,@(loop for i from 1 to 62
  25                         collect `(,(sb-int:symbolicate "SLOT" (write-to-string i))
  26                                   0 :type ,(if (> i 60) 'sb-ext:word t))))))
  27   (defbiggy))
  28
  29 (assert (typep (sb-kernel:layout-bitmap
  30                 (sb-kernel::find-layout 'biggy)) 'bignum))
  31
  32 (defvar *x* nil)
  33 (defvar *y* nil)
  34
  35 ;; This test offers "anecdotal evidence" that it works to have
  36 ;; a bignum for raw slot metadata, *and* that the bignum could be
  37 ;; transported by GC, leaving a forwarding pointer,
  38 ;; before transporting an instance of an object whose layout
  39 ;; sees the bignum.
  40
  41 ;; Without extra augmentation of the GC code [such as printf("got here!")]
  42 ;; there is no visible means of determining that this works,
  43 ;; aside from GC not crashing.
  44 ;; Additionally, the test does not work - which is to say, the GC behavior
  45 ;; is different and the desired effect can't be observed - when placed in
  46 ;; a WITH-TEST or any other toplevel "noise"; but even without that,
  47 ;; the test is brittle.
  48 ;; With some extra annotation (printf of otherwise), the line
  49 ;; of code in positive_bignum_logbitp() is seen to be reached 63 times
  50 ;; in each test run, corresponding to the 63 slots (counting the layout)
  51 ;; in each structure instance, times two structure instances.
  52
  53 ;; Run it twice to make sure things really worked.
  54
  55 (let ((*y* (make-biggy))
  56       (*x* (sb-kernel:layout-bitmap
  57             (sb-kernel::find-layout 'biggy))))
  58   (sb-ext:gc :gen 1))
  59 (princ 'did-pass-1) (terpri)
  60 (force-output)
  61
  62 (let ((*y* (make-biggy))
  63       (*x* (sb-kernel:layout-bitmap
  64             (sb-kernel::find-layout 'biggy))))
  65   (sb-ext:gc :gen 1))
  66 (princ 'did-pass-2) (terpri)
  67 (force-output)
  68
  69 ;; Test the C bignum bit extractor.
  70 ;; Surprisingly, there was a bug in it, unrelated to forwarding
  71 ;; pointers that remained dormant until the randomized
  72 ;; HUGE-MANYRAW test in 'defstruct.impure.lisp' found it.
  73 (defun c-bignum-logbitp (index bignum)
  74   (assert (typep bignum 'bignum))
  75   (sb-sys:with-pinned-objects (bignum)
  76     (alien-funcall (extern-alien "positive_bignum_logbitp"
  77                                  (function boolean int system-area-pointer))
  78                    index
  79                    (sb-sys:int-sap
  80                     (- (sb-kernel:get-lisp-obj-address bignum)
  81                        sb-vm:other-pointer-lowtag)))))
  82
  83 (with-test (:name :c-bignum-logbitp)
  84   ;; walking 1 bit
  85   (dotimes (i 256)
  86     (let ((num (ash 1 i)))
  87       (when (typep num 'bignum)
  88         (dotimes (j 257)
  89           (assert (eq (c-bignum-logbitp j num)
  90                      (logbitp j num)))))))
  91   ;; random bits
  92   (let ((max (ash 1 768)))
  93     (dotimes (i 100)
  94       (let ((num (random max)))
  95         (when (typep num 'bignum)
  96           (dotimes (j (* (sb-bignum:%bignum-length num)
  97                          sb-vm:n-word-bits))
  98             (assert (eq (c-bignum-logbitp j num)
  99                        (logbitp j num)))))))))
 100
 101 ;; for testing the comparator
 102 (defstruct foo1
 103   ;;                                  INDICES:    32-bit  64-bit
 104   ;;                                  ========   =======  ======
 105   (df 1d0 :type double-float)                    ;   1,2       1
 106   (a 'aaay)                                      ;     3       2
 107   (sf 1f0 :type single-float)                    ;     4       3
 108   (cdf #c(1d0 1d0) :type (complex double-float)) ;  5..8     4,5
 109   (b 'bee)                                       ;     9       6
 110   (csf #c(2f0 2f0) :type (complex single-float)) ; 10,11       7
 111   (w 0 :type sb-ext:word)                        ;    12       8
 112   (c 'cee))                                      ;    13       9
 113
 114 (defvar *afoo* (make-foo1))
 115 (assert (= (sb-kernel:layout-length (sb-kernel:layout-of *afoo*))
 116            (sb-kernel:%instance-length *afoo*)))
 117 (with-test (:name :tagged-slot-iterator-macro)
 118   ;; on 32-bit, the logical length is 14, which means 15 words (with header),
 119   ;; but slot index 14 (word index 15) exists after padding to 16 memory words.
 120   #-64-bit (progn (assert (= (sb-kernel:%instance-length *afoo*) 14))
 121                   (setf (sb-kernel:%instance-ref *afoo* 14) 'magic))
 122   ;; on 64-bit, the logical length is 10, which means 11 words (with header),
 123   ;; but slot index 10 (word index 11) exists after padding to 12 memory words.
 124   #+64-bit (progn (assert (= (sb-kernel:%instance-length *afoo*) 10))
 125                   (setf (sb-kernel:%instance-ref *afoo* 10) 'magic))
 126
 127   (let (l)
 128     (sb-kernel:do-instance-tagged-slot (i *afoo*)
 129       (push `(,i ,(sb-kernel:%instance-ref *afoo* i)) l))
 130     (assert (equalp (nreverse l)
 131                     #-64-bit `((3 aaay) (9 bee) (13 cee) (14 magic))
 132                     #+64-bit `((2 aaay) (6 bee) (9 cee) (10 magic))))))
 133
 134 (defvar *anotherfoo* (make-foo1))
 135
 136 (with-test (:name :structure-obj-equalp-raw-slots)
 137   ;; these structures are EQUALP even though one of them
 138   ;; has a word of junk in its padding slot, as could happen
 139   ;; if the structure was stack-allocated (I think)
 140   (assert (equalp *anotherfoo* *afoo*)))
 141
 142 (defstruct foo
 143   a
 144   (w 0 :type sb-ext:word)
 145   b
 146   (cdf #c(0d0 0d0) :type (complex double-float))
 147   c)
 148 (sb-kernel:define-structure-slot-addressor
 149  foo-w-ptr :structure foo :slot w)
 150 (sb-kernel:define-structure-slot-addressor
 151  foo-cdf-ptr :structure foo :slot cdf)
 152
 153 (with-test (:name :define-structure-slot-addressor)
 154   (let* ((word (logand sb-ext:most-positive-word #xfeedbad))
 155          (re 4.2d58)
 156          (im 8.93d-10)
 157          (thing (make-foo :cdf (complex re im) :w word)))
 158      (sb-sys:with-pinned-objects (thing)
 159       (assert (= word (sb-sys:sap-ref-word
 160                        (sb-sys:int-sap (foo-w-ptr thing)) 0)))
 161       (assert (= re (sb-sys:sap-ref-double
 162                      (sb-sys:int-sap (foo-cdf-ptr thing)) 0)))
 163       (assert (= im (sb-sys:sap-ref-double
 164                      (sb-sys:int-sap (foo-cdf-ptr thing)) 8))))))
 165
 166 (macrolet ((def ()
 167              `(defstruct foo-lotsaslots
 168                 ,@(loop for i below 100 collect
 169                         `(,(sb-int:symbolicate "S" (write-to-string i))
 170                           0 :type ,(if (oddp i) 'sb-ext:word 't))))))
 171   (def))
 172
 173 (with-test (:name :copy-structure-bignum-bitmap)
 174   (assert (zerop (foo-lotsaslots-s0
 175                   (copy-structure (make-foo-lotsaslots))))))
 176
 177 (load "compiler-test-util.lisp")
 178 (with-test (:name :copy-structure-efficient-case)
 179   (assert (not (ctu:find-named-callees #'copy-structure :name 'ash))))