1.0.23.21: Stack allocated conses for MIPS.
[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       sb-ext:*stack-allocate-dynamic-extent* t)
19
20 (defmacro defun-with-dx (name arglist &body body)
21   `(defun ,name ,arglist
22      ,@body))
23
24 (declaim (notinline opaque-identity))
25 (defun opaque-identity (x)
26   x)
27
28 ;;; &REST lists
29 (defun-with-dx dxlength (&rest rest)
30   (declare (dynamic-extent rest))
31   (length rest))
32
33 (assert (= (dxlength 1 2 3) 3))
34 (assert (= (dxlength t t t t t t) 6))
35 (assert (= (dxlength) 0))
36
37 (defun callee (list)
38   (destructuring-bind (a b c d e f &rest g) list
39     (+ a b c d e f (length g))))
40
41 (defun-with-dx dxcaller (&rest rest)
42   (declare (dynamic-extent rest))
43   (callee rest))
44 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
45
46 (defun-with-dx dxcaller-align-1 (x &rest rest)
47   (declare (dynamic-extent rest))
48   (+ x (callee rest)))
49 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
50 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40))
51
52 ;;; %NIP-VALUES
53 (defun-with-dx test-nip-values ()
54   (flet ((bar (x &rest y)
55            (declare (dynamic-extent y))
56            (if (> x 0)
57                (values x (length y))
58                (values (car y)))))
59     (multiple-value-call #'values
60       (bar 1 2 3 4 5 6)
61       (bar -1 'a 'b))))
62
63 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a)))
64
65 ;;; LET-variable substitution
66 (defun-with-dx test-let-var-subst1 (x)
67   (let ((y (list x (1- x))))
68     (opaque-identity :foo)
69     (let ((z (the list y)))
70       (declare (dynamic-extent z))
71       (length z))))
72 (assert (eql (test-let-var-subst1 17) 2))
73
74 (defun-with-dx test-let-var-subst2 (x)
75   (let ((y (list x (1- x))))
76     (declare (dynamic-extent y))
77     (opaque-identity :foo)
78     (let ((z (the list y)))
79       (length z))))
80 (assert (eql (test-let-var-subst2 17) 2))
81
82 ;;; DX propagation through LET-return.
83 (defun-with-dx test-lvar-subst (x)
84   (let ((y (list x (1- x))))
85     (declare (dynamic-extent y))
86     (second (let ((z (the list y)))
87               (opaque-identity :foo)
88               z))))
89 (assert (eql (test-lvar-subst 11) 10))
90
91 ;;; this code is incorrect, but the compiler should not fail
92 (defun-with-dx test-let-var-subst-incorrect (x)
93   (let ((y (list x (1- x))))
94     (opaque-identity :foo)
95     (let ((z (the list y)))
96       (declare (dynamic-extent z))
97       (opaque-identity :bar)
98       z)))
99 \f
100 ;;; alignment
101 (defvar *x*)
102 (defun-with-dx test-alignment-dx-list (form)
103   (multiple-value-prog1 (eval form)
104     (let ((l (list 1 2 3 4)))
105       (declare (dynamic-extent l))
106       (setq *x* (copy-list l)))))
107 (dotimes (n 64)
108   (let* ((res (loop for i below n collect i))
109          (form `(values ,@res)))
110     (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
111     (assert (equal *x* '(1 2 3 4)))))
112
113 ;;; closure
114
115 (declaim (notinline true))
116 (defun true (x)
117   (declare (ignore x))
118   t)
119
120 (defun-with-dx dxclosure (x)
121   (flet ((f (y)
122            (+ y x)))
123     (declare (dynamic-extent #'f))
124     (true #'f)))
125
126 (assert (eq t (dxclosure 13)))
127
128 ;;; value-cells
129
130 (defun-with-dx dx-value-cell (x)
131   ;; Not implemented everywhere, yet.
132   #+(or x86 x86-64 mips)
133   (let ((cell x))
134     (declare (sb-int:truly-dynamic-extent cell))
135     (flet ((f ()
136              (incf cell)))
137       (declare (dynamic-extent #'f))
138       (true #'f))))
139
140 ;;; CONS
141
142 (defun-with-dx cons-on-stack (x)
143   (let ((cons (cons x x)))
144     (declare (dynamic-extent cons))
145     (true cons)
146     nil))
147
148 ;;; MAKE-ARRAY
149
150 (defun-with-dx make-array-on-stack ()
151   (let ((v (make-array '(42) :element-type 'single-float)))
152     (declare (dynamic-extent v))
153     (true v)
154     nil))
155
156 ;;; MAKE-STRUCTURE
157
158 (declaim (inline make-fp-struct-1))
159 (defstruct fp-struct-1
160   (s 0.0 :type single-float)
161   (d 0.0d0 :type double-float))
162
163 (defun-with-dx test-fp-struct-1.1 (s d)
164   (let ((fp (make-fp-struct-1 :s s)))
165     (declare (dynamic-extent fp))
166     (assert (eql s (fp-struct-1-s fp)))
167     (assert (eql 0.0d0 (fp-struct-1-d fp)))))
168
169 (defun-with-dx test-fp-struct-1.2 (s d)
170   (let ((fp (make-fp-struct-1 :d d)))
171     (declare (dynamic-extent fp))
172     (assert (eql 0.0 (fp-struct-1-s fp)))
173     (assert (eql d (fp-struct-1-d fp)))))
174
175 (defun-with-dx test-fp-struct-1.3 (s d)
176   (let ((fp (make-fp-struct-1 :d d :s s)))
177     (declare (dynamic-extent fp))
178     (assert (eql s (fp-struct-1-s fp)))
179     (assert (eql d (fp-struct-1-d fp)))))
180
181 (defun-with-dx test-fp-struct-1.4 (s d)
182   (let ((fp (make-fp-struct-1 :s s :d d)))
183     (declare (dynamic-extent fp))
184     (assert (eql s (fp-struct-1-s fp)))
185     (assert (eql d (fp-struct-1-d fp)))))
186
187 (test-fp-struct-1.1 123.456 876.243d0)
188 (test-fp-struct-1.2 123.456 876.243d0)
189 (test-fp-struct-1.3 123.456 876.243d0)
190 (test-fp-struct-1.4 123.456 876.243d0)
191
192 (declaim (inline make-fp-struct-2))
193 (defstruct fp-struct-2
194   (d 0.0d0 :type double-float)
195   (s 0.0 :type single-float))
196
197 (defun-with-dx test-fp-struct-2.1 (s d)
198   (let ((fp (make-fp-struct-2 :s s)))
199     (declare (dynamic-extent fp))
200     (assert (eql s (fp-struct-2-s fp)))
201     (assert (eql 0.0d0 (fp-struct-2-d fp)))))
202
203 (defun-with-dx test-fp-struct-2.2 (s d)
204   (let ((fp (make-fp-struct-2 :d d)))
205     (declare (dynamic-extent fp))
206     (assert (eql 0.0 (fp-struct-2-s fp)))
207     (assert (eql d (fp-struct-2-d fp)))))
208
209 (defun-with-dx test-fp-struct-2.3 (s d)
210   (let ((fp (make-fp-struct-2 :d d :s s)))
211     (declare (dynamic-extent fp))
212     (assert (eql s (fp-struct-2-s fp)))
213     (assert (eql d (fp-struct-2-d fp)))))
214
215 (defun-with-dx test-fp-struct-2.4 (s d)
216   (let ((fp (make-fp-struct-2 :s s :d d)))
217     (declare (dynamic-extent fp))
218     (assert (eql s (fp-struct-2-s fp)))
219     (assert (eql d (fp-struct-2-d fp)))))
220
221 (test-fp-struct-2.1 123.456 876.243d0)
222 (test-fp-struct-2.2 123.456 876.243d0)
223 (test-fp-struct-2.3 123.456 876.243d0)
224 (test-fp-struct-2.4 123.456 876.243d0)
225
226 (declaim (inline make-cfp-struct-1))
227 (defstruct cfp-struct-1
228   (s (complex 0.0) :type (complex single-float))
229   (d (complex 0.0d0) :type (complex double-float)))
230
231 (defun-with-dx test-cfp-struct-1.1 (s d)
232   (let ((cfp (make-cfp-struct-1 :s s)))
233     (declare (dynamic-extent cfp))
234     (assert (eql s (cfp-struct-1-s cfp)))
235     (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
236
237 (defun-with-dx test-cfp-struct-1.2 (s d)
238   (let ((cfp (make-cfp-struct-1 :d d)))
239     (declare (dynamic-extent cfp))
240     (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
241     (assert (eql d (cfp-struct-1-d cfp)))))
242
243 (defun-with-dx test-cfp-struct-1.3 (s d)
244   (let ((cfp (make-cfp-struct-1 :d d :s s)))
245     (declare (dynamic-extent cfp))
246     (assert (eql s (cfp-struct-1-s cfp)))
247     (assert (eql d (cfp-struct-1-d cfp)))))
248
249 (defun-with-dx test-cfp-struct-1.4 (s d)
250   (let ((cfp (make-cfp-struct-1 :s s :d d)))
251     (declare (dynamic-extent cfp))
252     (assert (eql s (cfp-struct-1-s cfp)))
253     (assert (eql d (cfp-struct-1-d cfp)))))
254
255 (test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
256 (test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
257 (test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
258 (test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
259
260 (declaim (inline make-cfp-struct-2))
261 (defstruct cfp-struct-2
262   (d (complex 0.0d0) :type (complex double-float))
263   (s (complex 0.0) :type (complex single-float)))
264
265 (defun-with-dx test-cfp-struct-2.1 (s d)
266   (let ((cfp (make-cfp-struct-2 :s s)))
267     (declare (dynamic-extent cfp))
268     (assert (eql s (cfp-struct-2-s cfp)))
269     (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
270
271 (defun-with-dx test-cfp-struct-2.2 (s d)
272   (let ((cfp (make-cfp-struct-2 :d d)))
273     (declare (dynamic-extent cfp))
274     (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
275     (assert (eql d (cfp-struct-2-d cfp)))))
276
277 (defun-with-dx test-cfp-struct-2.3 (s d)
278   (let ((cfp (make-cfp-struct-2 :d d :s s)))
279     (declare (dynamic-extent cfp))
280     (assert (eql s (cfp-struct-2-s cfp)))
281     (assert (eql d (cfp-struct-2-d cfp)))))
282
283 (defun-with-dx test-cfp-struct-2.4 (s d)
284   (let ((cfp (make-cfp-struct-2 :s s :d d)))
285     (declare (dynamic-extent cfp))
286     (assert (eql s (cfp-struct-2-s cfp)))
287     (assert (eql d (cfp-struct-2-d cfp)))))
288
289 (test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
290 (test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
291 (test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
292 (test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
293
294 (declaim (inline make-foo1 make-foo2 make-foo3))
295 (defstruct foo1 x)
296
297 (defun-with-dx make-foo1-on-stack (x)
298   (let ((foo (make-foo1 :x x)))
299     (declare (dynamic-extent foo))
300     (assert (eql x (foo1-x foo)))))
301
302 (defstruct foo2
303   (x 0.0 :type single-float)
304   (y 0.0d0 :type double-float)
305   a
306   b
307   c)
308
309 (defmacro assert-eql (expected got)
310   `(let ((exp ,expected)
311          (got ,got))
312      (unless (eql exp got)
313        (error "Expected ~S, got ~S!" exp got))))
314
315 (defun-with-dx make-foo2-on-stack (x y)
316   (let ((foo (make-foo2 :y y :c 'c)))
317     (declare (dynamic-extent foo))
318     (assert-eql 0.0 (foo2-x foo))
319     (assert-eql y (foo2-y foo))
320     (assert-eql 'c (foo2-c foo))
321     (assert-eql nil (foo2-b foo))))
322
323 ;;; Check that constants work out as argument for all relevant
324 ;;; slot types.
325 (defstruct foo3
326   (a 0 :type t)
327   (b 1 :type fixnum)
328   (c 2 :type sb-vm:word)
329   (d 3.0 :type single-float)
330   (e 4.0d0 :type double-float))
331 (defun-with-dx make-foo3-on-stack ()
332   (let ((foo (make-foo3)))
333     (declare (dynamic-extent foo))
334     (assert (eql 0 (foo3-a foo)))
335     (assert (eql 1 (foo3-b foo)))
336     (assert (eql 2 (foo3-c foo)))
337     (assert (eql 3.0 (foo3-d foo)))
338     (assert (eql 4.0d0 (foo3-e foo)))))
339
340 ;;; Nested DX
341
342 (defun-with-dx nested-dx-lists ()
343   (let ((dx (list (list 1 2) (list 3 4))))
344     (declare (dynamic-extent dx))
345     (true dx)
346     nil))
347
348 (defun-with-dx nested-dx-conses ()
349   (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
350     (declare (dynamic-extent dx))
351     (true dx)
352     nil))
353
354 (defun-with-dx nested-dx-not-used (x)
355   (declare (list x))
356   (let ((l (setf (car x) (list x x x))))
357     (declare (dynamic-extent l))
358     (true l)
359     (true (length l))
360     nil))
361
362 (defun-with-dx nested-evil-dx-used (x)
363   (declare (list x))
364   (let ((l (list x x x)))
365     (declare (dynamic-extent l))
366     (unwind-protect
367          (progn
368            (setf (car x) l)
369            (true l))
370       (setf (car x) nil))
371     nil))
372
373 ;;; multiple uses for dx lvar
374
375 (defun-with-dx multiple-dx-uses ()
376   (let ((dx (if (true t)
377                 (list 1 2 3)
378                 (list 2 3 4))))
379     (declare (dynamic-extent dx))
380     (true dx)
381     nil))
382
383 ;;; handler-case and handler-bind should use DX internally
384
385 (defun dx-handler-bind (x)
386   (handler-bind ((error
387                   (lambda (c) (break "OOPS: ~S caused ~S" x c)))
388                  ((and serious-condition (not error))
389                   #'(lambda (c) (break "OOPS2: ~S did ~S" x c))))
390     (/ 2 x)))
391
392 (defun dx-handler-case (x)
393   (assert (zerop (handler-case (/ 2 x)
394                    (error (c)
395                      (break "OOPS: ~S caused ~S" x c))
396                    (:no-error (res)
397                      (1- res))))))
398
399 ;;; with-spinlock and with-mutex should use DX and not cons
400
401 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
402
403 (defun test-spinlock ()
404   (sb-thread::with-spinlock (*slock*)
405     (true *slock*)))
406
407 (defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
408
409 (defun test-mutex ()
410   (sb-thread:with-mutex (*mutex*)
411     (true *mutex*)))
412
413 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
414
415 (defvar *table* (make-hash-table))
416
417 (defun test-hash-table ()
418   (setf (gethash 5 *table*) 13)
419   (gethash 5 *table*))
420 \f
421 (defmacro assert-no-consing (form &optional times)
422   `(%assert-no-consing (lambda () ,form) ,times))
423 (defun %assert-no-consing (thunk &optional times)
424   (let ((before (get-bytes-consed))
425         (times (or times 10000)))
426     (declare (type (integer 1 *) times))
427     (dotimes (i times)
428       (funcall thunk))
429     (assert (< (- (get-bytes-consed) before) times))))
430
431 (defmacro assert-consing (form &optional times)
432   `(%assert-consing (lambda () ,form) ,times))
433 (defun %assert-consing (thunk &optional times)
434   (let ((before (get-bytes-consed))
435         (times (or times 10000)))
436     (declare (type (integer 1 *) times))
437     (dotimes (i times)
438       (funcall thunk))
439     (assert (not (< (- (get-bytes-consed) before) times)))))
440
441 (defvar *a-cons* (cons nil nil))
442
443 #+(or x86 x86-64 alpha ppc sparc mips)
444 (progn
445   (assert-no-consing (dxclosure 42))
446   (assert-no-consing (dxlength 1 2 3))
447   (assert-no-consing (dxlength t t t t t t))
448   (assert-no-consing (dxlength))
449   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
450   (assert-no-consing (test-nip-values))
451   (assert-no-consing (test-let-var-subst1 17))
452   (assert-no-consing (test-let-var-subst2 17))
453   (assert-no-consing (test-lvar-subst 11))
454   (assert-no-consing (dx-value-cell 13))
455   (assert-no-consing (cons-on-stack 42))
456   (assert-no-consing (make-array-on-stack))
457   (assert-no-consing (make-foo1-on-stack 123))
458   (#+raw-instance-init-vops assert-no-consing
459    #-raw-instance-init-vops progn
460    (make-foo2-on-stack 1.24 1.23d0))
461   (#+raw-instance-init-vops assert-no-consing
462    #-raw-instance-init-vops progn
463    (make-foo3-on-stack))
464   (assert-no-consing (nested-dx-conses))
465   (assert-no-consing (nested-dx-lists))
466   (assert-consing (nested-dx-not-used *a-cons*))
467   (assert-no-consing (nested-evil-dx-used *a-cons*))
468   (assert-no-consing (multiple-dx-uses))
469   (assert-no-consing (dx-handler-bind 2))
470   (assert-no-consing (dx-handler-case 2))
471   ;; Not strictly DX..
472   (assert-no-consing (test-hash-table))
473   #+sb-thread
474   (progn
475     (assert-no-consing (test-spinlock))
476     (assert-no-consing (test-mutex))))
477
478 \f
479 ;;; Bugs found by Paul F. Dietz
480 (assert
481  (eq
482   (funcall
483    (compile
484     nil
485     '(lambda (a b)
486       (declare (optimize (speed 2) (space 0) (safety 0)
487                 (debug 1) (compilation-speed 3)))
488       (let* ((v5 (cons b b)))
489         (declare (dynamic-extent v5))
490         a)))
491    'x 'y)
492   'x))
493
494 \f
495 ;;; other bugs
496
497 ;;; bug reported by Svein Ove Aas
498 (defun svein-2005-ii-07 (x y)
499   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
500   (let ((args (list* y 1 2 x)))
501     (declare (dynamic-extent args))
502     (apply #'aref args)))
503 (assert (eql
504          (svein-2005-ii-07
505           '(0)
506           #3A(((1 1 1) (1 1 1) (1 1 1))
507               ((1 1 1) (1 1 1) (4 1 1))
508               ((1 1 1) (1 1 1) (1 1 1))))
509          4))
510
511 ;;; bug reported by Brian Downing: stack-allocated arrays were not
512 ;;; filled with zeroes.
513 (defun-with-dx bdowning-2005-iv-16 ()
514   (let ((a (make-array 11 :initial-element 0)))
515     (declare (dynamic-extent a))
516     (assert (every (lambda (x) (eql x 0)) a))))
517 (assert-no-consing (bdowning-2005-iv-16))
518
519
520 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
521   (let* ((a (list x y z))
522          (b (list x y z))
523          (c (list a b)))
524     (declare (dynamic-extent c))
525     (values (first c) (second c))))
526 (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
527   (assert (and (equal i j)
528                (equal i (list 1 2 3)))))
529
530 ;;; workaround for bug 419 -- real issue remains, but check that the
531 ;;; bandaid holds.
532 (defun-with-dx bug419 (x)
533   (multiple-value-call #'list
534     (eval '(values 1 2 3))
535     (let ((x x))
536       (declare (dynamic-extent x))
537       (flet ((mget (y)
538                (+ x y))
539              (mset (z)
540                (incf x z)))
541         (declare (dynamic-extent #'mget #'mset))
542         ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
543 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
544
545 ;;; Multiple DX arguments in a local function call
546 (defun test-dx-flet-test (fun n f1 f2 f3)
547   (let ((res (with-output-to-string (s)
548                (assert (eql n (ignore-errors (funcall fun s)))))))
549     (multiple-value-bind (x pos) (read-from-string res nil)
550       (assert (equalp f1 x))
551       (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos)
552         (assert (equalp f2 y))
553         (assert (equalp f3 (read-from-string res nil nil :start pos2))))))
554   (assert-no-consing (assert (eql n (funcall fun nil)))))
555 (macrolet ((def (n f1 f2 f3)
556              (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n)))
557                `(progn
558                   (defun-with-dx ,name (s)
559                     (flet ((f (x)
560                              (declare (dynamic-extent x))
561                              (when s
562                                (print x s)
563                                (finish-output s))
564                              nil))
565                       (f ,f1)
566                       (f ,f2)
567                       (f ,f3)
568                       ,n))
569                   (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3)))))
570   (def 0 (list :one) (list :two) (list :three))
571   (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list))
572   (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
573
574 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
575 (defun test-update-uvl-live-sets (x y z)
576  (declare (optimize speed (safety 0)))
577  (flet ((bar (a b)
578           (declare (dynamic-extent a))
579           (eval `(list (length ',a) ',b))))
580    (list (bar x y)
581          (bar (list x y z)                  ; dx push
582               (list
583                (multiple-value-call 'list
584                  (eval '(values 1 2 3))     ; uv push
585                  (max y z)
586                )                            ; uv pop
587                14)
588          ))))
589 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
590 \f