1.0.16.26: dx allocation thru CAST nodes
[sbcl.git] / tests / dynamic-extent.impure.lisp
1 ;;;; tests that dynamic-extent functionality works.
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 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
13
14 (when (eq sb-ext:*evaluator-mode* :interpret)
15   (sb-ext:quit :unix-status 104))
16
17 (setq sb-c::*check-consistency* t)
18
19 (defmacro defun-with-dx (name arglist &body body)
20   `(locally
21      (declare (optimize sb-c::stack-allocate-dynamic-extent))
22      (defun ,name ,arglist
23        ,@body)))
24
25 (declaim (notinline opaque-identity))
26 (defun opaque-identity (x)
27   x)
28
29 ;;; &REST lists
30 (defun-with-dx dxlength (&rest rest)
31   (declare (dynamic-extent rest))
32   (length rest))
33
34 (assert (= (dxlength 1 2 3) 3))
35 (assert (= (dxlength t t t t t t) 6))
36 (assert (= (dxlength) 0))
37
38 (defun callee (list)
39   (destructuring-bind (a b c d e f &rest g) list
40     (+ a b c d e f (length g))))
41
42 (defun-with-dx dxcaller (&rest rest)
43   (declare (dynamic-extent rest))
44   (callee rest))
45 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
46
47 (defun-with-dx dxcaller-align-1 (x &rest rest)
48   (declare (dynamic-extent rest))
49   (+ x (callee rest)))
50 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
51 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40))
52
53 ;;; %NIP-VALUES
54 (defun-with-dx test-nip-values ()
55   (flet ((bar (x &rest y)
56            (declare (dynamic-extent y))
57            (if (> x 0)
58                (values x (length y))
59                (values (car y)))))
60     (multiple-value-call #'values
61       (bar 1 2 3 4 5 6)
62       (bar -1 'a 'b))))
63
64 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a)))
65
66 ;;; LET-variable substitution
67 (defun-with-dx test-let-var-subst1 (x)
68   (let ((y (list x (1- x))))
69     (opaque-identity :foo)
70     (let ((z (the list y)))
71       (declare (dynamic-extent z))
72       (length z))))
73 (assert (eql (test-let-var-subst1 17) 2))
74
75 (defun-with-dx test-let-var-subst2 (x)
76   (let ((y (list x (1- x))))
77     (declare (dynamic-extent y))
78     (opaque-identity :foo)
79     (let ((z (the list y)))
80       (length z))))
81 (assert (eql (test-let-var-subst2 17) 2))
82
83 ;;; DX propagation through LET-return.
84 (defun-with-dx test-lvar-subst (x)
85   (let ((y (list x (1- x))))
86     (declare (dynamic-extent y))
87     (second (let ((z (the list y)))
88               (opaque-identity :foo)
89               z))))
90 (assert (eql (test-lvar-subst 11) 10))
91
92 ;;; this code is incorrect, but the compiler should not fail
93 (defun-with-dx test-let-var-subst-incorrect (x)
94   (let ((y (list x (1- x))))
95     (opaque-identity :foo)
96     (let ((z (the list y)))
97       (declare (dynamic-extent z))
98       (opaque-identity :bar)
99       z)))
100 \f
101 ;;; alignment
102 (defvar *x*)
103 (defun-with-dx test-alignment-dx-list (form)
104   (multiple-value-prog1 (eval form)
105     (let ((l (list 1 2 3 4)))
106       (declare (dynamic-extent l))
107       (setq *x* (copy-list l)))))
108 (dotimes (n 64)
109   (let* ((res (loop for i below n collect i))
110          (form `(values ,@res)))
111     (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
112     (assert (equal *x* '(1 2 3 4)))))
113
114 ;;; closure
115
116 (declaim (notinline true))
117 (defun true (x)
118   (declare (ignore x))
119   t)
120
121 (defun-with-dx dxclosure (x)
122   (flet ((f (y)
123            (+ y x)))
124     (declare (dynamic-extent #'f))
125     (true #'f)))
126
127 (assert (eq t (dxclosure 13)))
128
129 ;;; value-cells
130
131 (defun-with-dx dx-value-cell (x)
132   ;; Not implemented everywhere, yet.
133   #+(or x86 x86-64 mips)
134   (let ((cell x))
135     (declare (dynamic-extent cell))
136     (flet ((f ()
137              (incf cell)))
138       (declare (dynamic-extent #'f))
139       (true #'f))))
140
141 ;;; CONS
142
143 (defun-with-dx cons-on-stack (x)
144   (let ((cons (cons x x)))
145     (declare (dynamic-extent cons))
146     (true cons)
147     nil))
148
149 ;;; MAKE-ARRAY
150
151 (defun-with-dx make-array-on-stack ()
152   (let ((v (make-array '(42) :element-type 'single-float)))
153     (declare (dynamic-extent v))
154     (true v)
155     nil))
156
157 ;;; Nested DX
158
159 (defun-with-dx nested-dx-lists ()
160   (let ((dx (list (list 1 2) (list 3 4))))
161     (declare (dynamic-extent dx))
162     (true dx)
163     nil))
164
165 (defun-with-dx nested-dx-conses ()
166   (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
167     (declare (dynamic-extent dx))
168     (true dx)
169     nil))
170
171 (defun-with-dx nested-dx-not-used (x)
172   (declare (list x))
173   (let ((l (setf (car x) (list x x x))))
174     (declare (dynamic-extent l))
175     (true l)
176     (true (length l))
177     nil))
178
179 (defun-with-dx nested-evil-dx-used (x)
180   (declare (list x))
181   (let ((l (list x x x)))
182     (declare (dynamic-extent l))
183     (unwind-protect
184          (progn
185            (setf (car x) l)
186            (true l))
187       (setf (car x) nil))
188     nil))
189
190 ;;; multiple uses for dx lvar
191
192 (defun-with-dx multiple-dx-uses ()
193   (let ((dx (if (true t)
194                 (list 1 2 3)
195                 (list 2 3 4))))
196     (declare (dynamic-extent dx))
197     (true dx)
198     nil))
199
200 ;;; with-spinlock should use DX and not cons
201
202 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
203
204 (defun test-spinlock ()
205   (sb-thread::with-spinlock (*slock*)
206     (true *slock*)))
207
208 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
209
210 (defvar *table* (make-hash-table))
211
212 (defun test-hash-table ()
213   (setf (gethash 5 *table*) 13)
214   (gethash 5 *table*))
215 \f
216 (defmacro assert-no-consing (form &optional times)
217   `(%assert-no-consing (lambda () ,form) ,times))
218 (defun %assert-no-consing (thunk &optional times)
219   (let ((before (get-bytes-consed))
220         (times (or times 10000)))
221     (declare (type (integer 1 *) times))
222     (dotimes (i times)
223       (funcall thunk))
224     (assert (< (- (get-bytes-consed) before) times))))
225
226 (defmacro assert-consing (form &optional times)
227   `(%assert-consing (lambda () ,form) ,times))
228 (defun %assert-consing (thunk &optional times)
229   (let ((before (get-bytes-consed))
230         (times (or times 10000)))
231     (declare (type (integer 1 *) times))
232     (dotimes (i times)
233       (funcall thunk))
234     (assert (not (< (- (get-bytes-consed) before) times)))))
235
236 (defvar *a-cons* (cons nil nil))
237
238 #+(or x86 x86-64 alpha ppc sparc mips)
239 (progn
240   (assert-no-consing (dxclosure 42))
241   (assert-no-consing (dxlength 1 2 3))
242   (assert-no-consing (dxlength t t t t t t))
243   (assert-no-consing (dxlength))
244   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
245   (assert-no-consing (test-nip-values))
246   (assert-no-consing (test-let-var-subst1 17))
247   (assert-no-consing (test-let-var-subst2 17))
248   (assert-no-consing (test-lvar-subst 11))
249   (assert-no-consing (dx-value-cell 13))
250   (assert-no-consing (cons-on-stack 42))
251   (assert-no-consing (make-array-on-stack))
252   (assert-no-consing (nested-dx-conses))
253   (assert-no-consing (nested-dx-lists))
254   (assert-consing (nested-dx-not-used *a-cons*))
255   (assert-no-consing (nested-evil-dx-used *a-cons*))
256   (assert-no-consing (multiple-dx-uses))
257   ;; Not strictly DX..
258   (assert-no-consing (test-hash-table))
259   #+sb-thread
260   (assert-no-consing (test-spinlock)))
261
262 \f
263 ;;; Bugs found by Paul F. Dietz
264 (assert
265  (eq
266   (funcall
267    (compile
268     nil
269     '(lambda (a b)
270       (declare (optimize (speed 2) (space 0) (safety 0)
271                 (debug 1) (compilation-speed 3)))
272       (let* ((v5 (cons b b)))
273         (declare (dynamic-extent v5))
274         a)))
275    'x 'y)
276   'x))
277
278 \f
279 ;;; other bugs
280
281 ;;; bug reported by Svein Ove Aas
282 (defun svein-2005-ii-07 (x y)
283   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
284   (let ((args (list* y 1 2 x)))
285     (declare (dynamic-extent args))
286     (apply #'aref args)))
287 (assert (eql
288          (svein-2005-ii-07
289           '(0)
290           #3A(((1 1 1) (1 1 1) (1 1 1))
291               ((1 1 1) (1 1 1) (4 1 1))
292               ((1 1 1) (1 1 1) (1 1 1))))
293          4))
294
295 ;;; bug reported by Brian Downing: stack-allocated arrays were not
296 ;;; filled with zeroes.
297 (defun-with-dx bdowning-2005-iv-16 ()
298   (let ((a (make-array 11 :initial-element 0)))
299     (declare (dynamic-extent a))
300     (assert (every (lambda (x) (eql x 0)) a))))
301 (assert-no-consing (bdowning-2005-iv-16))
302
303
304 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
305   (let* ((a (list x y z))
306          (b (list x y z))
307          (c (list a b)))
308     (declare (dynamic-extent c))
309     (values (first c) (second c))))
310 (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
311   (assert (and (equal i j)
312                (equal i (list 1 2 3)))))
313 \f