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