3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
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.
22 (macrolet ((defbiggy ()
24 ,@(loop for i from
1 to
64
25 collect
`(,(sb-int:symbolicate
"SLOT" (write-to-string i
))
26 0 :type
,(if (= i
64) 'sb-ext
:word t
))))))
29 (assert (typep (sb-kernel:layout-bitmap
30 (sb-kernel::find-layout
'biggy
)) 'bignum
))
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
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.
53 ;; Run it twice to make sure things really worked.
55 (let ((*y
* (make-biggy))
56 (*x
* (sb-kernel:layout-bitmap
57 (sb-kernel::find-layout
'biggy
))))
59 (princ 'did-pass-1
) (terpri)
62 (let ((*y
* (make-biggy))
63 (*x
* (sb-kernel:layout-bitmap
64 (sb-kernel::find-layout
'biggy
))))
66 (princ 'did-pass-2
) (terpri)
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
))
80 (- (sb-kernel:get-lisp-obj-address bignum
)
81 sb-vm
:other-pointer-lowtag
)))))
83 (with-test (:name
:c-bignum-logbitp
)
86 (let ((num (ash 1 i
)))
87 (when (typep num
'bignum
)
89 (assert (eq (c-bignum-logbitp j num
)
92 (let ((max (ash 1 768)))
94 (let ((num (random max
)))
95 (when (typep num
'bignum
)
96 (dotimes (j (* (sb-bignum:%bignum-length num
)
98 (assert (eq (c-bignum-logbitp j num
)
99 (logbitp j num
)))))))))
101 ;; for testing the comparator
103 ;; INDICES: 32-bit 64-bit
104 ;; ======== ======= ======
105 #+compact-instance-header
106 (fluff 0 :type sb-ext
:word
) ; 0
107 (df 1d0
:type double-float
) ; 1,2 1
109 (sf 1f0
:type single-float
) ; 4 3
110 (cdf #c
(1d0 1d0
) :type
(complex double-float
)) ; 5..8 4,5
112 (csf #c
(2f0 2f0
) :type
(complex single-float
)) ; 10,11 7
113 (w 0 :type sb-ext
:word
) ; 12 8
116 (defvar *afoo
* (make-foo1))
117 (assert (= (sb-kernel:layout-length
(sb-kernel:layout-of
*afoo
*))
118 (sb-kernel:%instance-length
*afoo
*)))
119 (with-test (:name
:tagged-slot-iterator-macro
)
120 ;; on 32-bit, the logical length is 14, which means 15 words (with header),
121 ;; but slot index 14 (word index 15) exists after padding to 16 memory words.
122 #-
64-bit
(progn (assert (= (sb-kernel:%instance-length
*afoo
*) 14))
123 (setf (sb-kernel:%instance-ref
*afoo
* 14) 'magic
))
124 ;; on 64-bit, the logical length is 10, which means 11 words (with header),
125 ;; but slot index 10 (word index 11) exists after padding to 12 memory words.
126 #+64-bit
(progn (assert (= (sb-kernel:%instance-length
*afoo
*) 10))
127 (setf (sb-kernel:%instance-ref
*afoo
* 10) 'magic
))
130 (sb-kernel:do-instance-tagged-slot
(i *afoo
*)
131 (push `(,i
,(sb-kernel:%instance-ref
*afoo
* i
)) l
))
132 (assert (equalp (nreverse l
)
133 #-
64-bit
`((3 aaay
) (9 bee
) (13 cee
) (14 magic
))
134 #+64-bit
`((2 aaay
) (6 bee
) (9 cee
) (10 magic
))))))
136 (defvar *anotherfoo
* (make-foo1))
138 (with-test (:name
:structure-obj-equalp-raw-slots
)
139 ;; these structures are EQUALP even though one of them
140 ;; has a word of junk in its padding slot, as could happen
141 ;; if the structure was stack-allocated
142 (assert (equalp *anotherfoo
* *afoo
*)))
146 (w 0 :type sb-ext
:word
)
148 (cdf #c
(0d0 0d0
) :type
(complex double-float
))
150 (sb-kernel:define-structure-slot-addressor
151 foo-w-ptr
:structure foo
:slot w
)
152 (sb-kernel:define-structure-slot-addressor
153 foo-cdf-ptr
:structure foo
:slot cdf
)
155 (with-test (:name
:define-structure-slot-addressor
)
156 (let* ((word (logand sb-ext
:most-positive-word
#xfeedbad
))
159 (thing (make-foo :cdf
(complex re im
) :w word
)))
160 (sb-sys:with-pinned-objects
(thing)
161 (assert (= word
(sb-sys:sap-ref-word
162 (sb-sys:int-sap
(foo-w-ptr thing
)) 0)))
163 (assert (= re
(sb-sys:sap-ref-double
164 (sb-sys:int-sap
(foo-cdf-ptr thing
)) 0)))
165 (assert (= im
(sb-sys:sap-ref-double
166 (sb-sys:int-sap
(foo-cdf-ptr thing
)) 8))))))
169 `(defstruct foo-lotsaslots
170 ,@(loop for i below
100 collect
171 `(,(sb-int:symbolicate
"S" (write-to-string i
))
172 0 :type
,(if (oddp i
) 'sb-ext
:word
't
))))))
175 (with-test (:name
:copy-structure-bignum-bitmap
)
176 (assert (zerop (foo-lotsaslots-s0
177 (copy-structure (make-foo-lotsaslots))))))
179 (load "compiler-test-util.lisp")
180 (with-test (:name
:copy-structure-efficient-case
)
181 (assert (not (ctu:find-named-callees
#'copy-structure
:name
'ash
))))