1.0.16.29: workaround for bug 419
[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   (declare (optimize sb-c::stack-allocate-value-cells))
133   ;; Not implemented everywhere, yet.
134   #+(or x86 x86-64 mips)
135   (let ((cell x))
136     (declare (dynamic-extent cell))
137     (flet ((f ()
138              (incf cell)))
139       (declare (dynamic-extent #'f))
140       (true #'f))))
141
142 ;;; CONS
143
144 (defun-with-dx cons-on-stack (x)
145   (let ((cons (cons x x)))
146     (declare (dynamic-extent cons))
147     (true cons)
148     nil))
149
150 ;;; MAKE-ARRAY
151
152 (defun-with-dx make-array-on-stack ()
153   (let ((v (make-array '(42) :element-type 'single-float)))
154     (declare (dynamic-extent v))
155     (true v)
156     nil))
157
158 ;;; Nested DX
159
160 (defun-with-dx nested-dx-lists ()
161   (let ((dx (list (list 1 2) (list 3 4))))
162     (declare (dynamic-extent dx))
163     (true dx)
164     nil))
165
166 (defun-with-dx nested-dx-conses ()
167   (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
168     (declare (dynamic-extent dx))
169     (true dx)
170     nil))
171
172 (defun-with-dx nested-dx-not-used (x)
173   (declare (list x))
174   (let ((l (setf (car x) (list x x x))))
175     (declare (dynamic-extent l))
176     (true l)
177     (true (length l))
178     nil))
179
180 (defun-with-dx nested-evil-dx-used (x)
181   (declare (list x))
182   (let ((l (list x x x)))
183     (declare (dynamic-extent l))
184     (unwind-protect
185          (progn
186            (setf (car x) l)
187            (true l))
188       (setf (car x) nil))
189     nil))
190
191 ;;; multiple uses for dx lvar
192
193 (defun-with-dx multiple-dx-uses ()
194   (let ((dx (if (true t)
195                 (list 1 2 3)
196                 (list 2 3 4))))
197     (declare (dynamic-extent dx))
198     (true dx)
199     nil))
200
201 ;;; with-spinlock should use DX and not cons
202
203 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
204
205 (defun test-spinlock ()
206   (sb-thread::with-spinlock (*slock*)
207     (true *slock*)))
208
209 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
210
211 (defvar *table* (make-hash-table))
212
213 (defun test-hash-table ()
214   (setf (gethash 5 *table*) 13)
215   (gethash 5 *table*))
216 \f
217 (defmacro assert-no-consing (form &optional times)
218   `(%assert-no-consing (lambda () ,form) ,times))
219 (defun %assert-no-consing (thunk &optional times)
220   (let ((before (get-bytes-consed))
221         (times (or times 10000)))
222     (declare (type (integer 1 *) times))
223     (dotimes (i times)
224       (funcall thunk))
225     (assert (< (- (get-bytes-consed) before) times))))
226
227 (defmacro assert-consing (form &optional times)
228   `(%assert-consing (lambda () ,form) ,times))
229 (defun %assert-consing (thunk &optional times)
230   (let ((before (get-bytes-consed))
231         (times (or times 10000)))
232     (declare (type (integer 1 *) times))
233     (dotimes (i times)
234       (funcall thunk))
235     (assert (not (< (- (get-bytes-consed) before) times)))))
236
237 (defvar *a-cons* (cons nil nil))
238
239 #+(or x86 x86-64 alpha ppc sparc mips)
240 (progn
241   (assert-no-consing (dxclosure 42))
242   (assert-no-consing (dxlength 1 2 3))
243   (assert-no-consing (dxlength t t t t t t))
244   (assert-no-consing (dxlength))
245   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
246   (assert-no-consing (test-nip-values))
247   (assert-no-consing (test-let-var-subst1 17))
248   (assert-no-consing (test-let-var-subst2 17))
249   (assert-no-consing (test-lvar-subst 11))
250   (assert-no-consing (dx-value-cell 13))
251   (assert-no-consing (cons-on-stack 42))
252   (assert-no-consing (make-array-on-stack))
253   (assert-no-consing (nested-dx-conses))
254   (assert-no-consing (nested-dx-lists))
255   (assert-consing (nested-dx-not-used *a-cons*))
256   (assert-no-consing (nested-evil-dx-used *a-cons*))
257   (assert-no-consing (multiple-dx-uses))
258   ;; Not strictly DX..
259   (assert-no-consing (test-hash-table))
260   #+sb-thread
261   (assert-no-consing (test-spinlock)))
262
263 \f
264 ;;; Bugs found by Paul F. Dietz
265 (assert
266  (eq
267   (funcall
268    (compile
269     nil
270     '(lambda (a b)
271       (declare (optimize (speed 2) (space 0) (safety 0)
272                 (debug 1) (compilation-speed 3)))
273       (let* ((v5 (cons b b)))
274         (declare (dynamic-extent v5))
275         a)))
276    'x 'y)
277   'x))
278
279 \f
280 ;;; other bugs
281
282 ;;; bug reported by Svein Ove Aas
283 (defun svein-2005-ii-07 (x y)
284   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
285   (let ((args (list* y 1 2 x)))
286     (declare (dynamic-extent args))
287     (apply #'aref args)))
288 (assert (eql
289          (svein-2005-ii-07
290           '(0)
291           #3A(((1 1 1) (1 1 1) (1 1 1))
292               ((1 1 1) (1 1 1) (4 1 1))
293               ((1 1 1) (1 1 1) (1 1 1))))
294          4))
295
296 ;;; bug reported by Brian Downing: stack-allocated arrays were not
297 ;;; filled with zeroes.
298 (defun-with-dx bdowning-2005-iv-16 ()
299   (let ((a (make-array 11 :initial-element 0)))
300     (declare (dynamic-extent a))
301     (assert (every (lambda (x) (eql x 0)) a))))
302 (assert-no-consing (bdowning-2005-iv-16))
303
304
305 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
306   (let* ((a (list x y z))
307          (b (list x y z))
308          (c (list a b)))
309     (declare (dynamic-extent c))
310     (values (first c) (second c))))
311 (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
312   (assert (and (equal i j)
313                (equal i (list 1 2 3)))))
314
315 ;;; workaround for bug 419 -- real issue remains, but check that the
316 ;;; bandaid holds.
317 (defun-with-dx bug419 (x)
318   (multiple-value-call #'list
319     (eval '(values 1 2 3))
320     (let ((x x))
321       (declare (dynamic-extent x))
322       (flet ((mget (y)
323                (+ x y))
324              (mset (z)
325                (incf x z)))
326         (declare (dynamic-extent #'mget #'mset))
327         ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
328 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
329 \f