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 #-interleaved-raw-slots
(invoke-restart 'run-tests
::skip-file
)
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.
24 (macrolet ((defbiggy ()
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
))))))
31 (assert (typep (sb-kernel:layout-raw-slot-metadata
32 (sb-kernel::find-layout
'biggy
)) 'bignum
))
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
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.
55 ;; Run it twice to make sure things really worked.
57 (let ((*y
* (make-biggy))
58 (*x
* (sb-kernel:layout-raw-slot-metadata
59 (sb-kernel::find-layout
'biggy
))))
61 (princ 'did-pass-1
) (terpri)
64 (let ((*y
* (make-biggy))
65 (*x
* (sb-kernel:layout-raw-slot-metadata
66 (sb-kernel::find-layout
'biggy
))))
68 (princ 'did-pass-2
) (terpri)
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 boolean int system-area-pointer
))
82 (- (sb-kernel:get-lisp-obj-address bignum
)
83 sb-vm
:other-pointer-lowtag
)))))
85 (with-test (:name
:c-bignum-logbitp
)
88 (let ((num (ash 1 i
)))
89 (when (typep num
'bignum
)
91 (assert (eq (c-bignum-logbitp j num
)
94 (let ((max (ash 1 768)))
96 (let ((num (random max
)))
97 (when (typep num
'bignum
)
98 (dotimes (j (* (sb-bignum:%bignum-length num
)
100 (assert (eq (c-bignum-logbitp j num
)
101 (logbitp j num
)))))))))
103 ;; for testing the comparator
105 ;; INDICES: 32-bit 64-bit
106 ;; ======== ======= ======
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 (with-test (:name
:tagged-slot-iterator-macro
)
118 ;; on 32-bit, slots 1 through 14 exist, keeping the total length even.
119 #-
64-bit
(setf (sb-kernel:%instance-ref
*afoo
* 14) 'magic
)
120 ;; on 64-bit, slots 1 through 10 exist, keeping the total length even.
121 #+64-bit
(setf (sb-kernel:%instance-ref
*afoo
* 10) 'magic
)
123 (sb-kernel:do-instance-tagged-slot
(i *afoo
*)
124 (push `(,i
,(sb-kernel:%instance-ref
*afoo
* i
)) l
))
125 (assert (oddp (sb-kernel:%instance-length
*afoo
*)))
126 (assert (= (sb-kernel:layout-length
(sb-kernel:layout-of
*afoo
*))
127 (1- (sb-kernel:%instance-length
*afoo
*))))
128 (assert (equalp (nreverse l
)
130 `((3 aaay
) (9 bee
) (13 cee
) (14 magic
))
132 `((2 aaay
) (6 bee
) (9 cee
) (10 magic
))))))
134 (defvar *anotherfoo
* (make-foo1))
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
*)))
144 (w 0 :type sb-ext
:word
)
146 (cdf #c
(0d0 0d0
) :type
(complex double-float
))
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
)
153 (with-test (:name
:define-structure-slot-addressor
)
154 (let* ((word (logand sb-ext
:most-positive-word
#xfeedbad
))
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))))))
166 (load "compiler-test-util.lisp")
167 (with-test (:name
:copy-structure-efficient-case
)
168 (assert (not (ctu:find-named-callees
#'copy-structure
:name
'ash
))))