1 ;;;; tests that dynamic-extent functionality works.
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 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (when (eq sb-ext
:*evaluator-mode
* :interpret
)
15 (sb-ext:quit
:unix-status
104))
17 (setq sb-c
::*check-consistency
* t
18 sb-ext
:*stack-allocate-dynamic-extent
* t
)
20 (defmacro defun-with-dx
(name arglist
&body body
)
21 `(defun ,name
,arglist
24 (declaim (notinline opaque-identity
))
25 (defun opaque-identity (x)
29 (defun-with-dx dxlength
(&rest rest
)
30 (declare (dynamic-extent rest
))
33 (assert (= (dxlength 1 2 3) 3))
34 (assert (= (dxlength t t t t t t
) 6))
35 (assert (= (dxlength) 0))
38 (destructuring-bind (a b c d e f
&rest g
) list
39 (+ a b c d e f
(length g
))))
41 (defun-with-dx dxcaller
(&rest rest
)
42 (declare (dynamic-extent rest
))
44 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
46 (defun-with-dx dxcaller-align-1
(x &rest rest
)
47 (declare (dynamic-extent 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))
53 (defun-with-dx test-nip-values
()
54 (flet ((bar (x &rest y
)
55 (declare (dynamic-extent y
))
59 (multiple-value-call #'values
63 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a
)))
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
))
72 (assert (eql (test-let-var-subst1 17) 2))
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
)))
80 (assert (eql (test-let-var-subst2 17) 2))
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
)
89 (assert (eql (test-lvar-subst 11) 10))
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
)
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
)))))
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)))))
115 (declaim (notinline true
))
120 (defun-with-dx dxclosure
(x)
123 (declare (dynamic-extent #'f
))
126 (assert (eq t
(dxclosure 13)))
130 (defun-with-dx dx-value-cell
(x)
131 ;; Not implemented everywhere, yet.
132 #+(or x86 x86-64 mips hppa
)
134 (declare (sb-int:truly-dynamic-extent cell
))
137 (declare (dynamic-extent #'f
))
142 (defun-with-dx cons-on-stack
(x)
143 (let ((cons (cons x x
)))
144 (declare (dynamic-extent cons
))
150 (defun force-make-array-on-stack (n)
151 (declare (optimize safety
))
152 (let ((v (make-array (min n
1))))
153 (declare (sb-int:truly-dynamic-extent v
))
157 (defun-with-dx make-array-on-stack-1
()
158 (let ((v (make-array '(42) :element-type
'single-float
)))
159 (declare (dynamic-extent v
))
163 (defun-with-dx make-array-on-stack-2
(n x
)
164 (declare (integer n
))
165 (let ((v (make-array n
:initial-contents x
)))
166 (declare (sb-int:truly-dynamic-extent v
))
170 (defun-with-dx make-array-on-stack-3
(x y z
)
171 (let ((v (make-array 3
172 :element-type
'fixnum
:initial-contents
(list x y z
)
173 :element-type t
:initial-contents x
)))
174 (declare (sb-int:truly-dynamic-extent v
))
178 (defun-with-dx make-array-on-stack-4
()
179 (let ((v (make-array 3 :initial-contents
'(1 2 3))))
180 (declare (sb-int:truly-dynamic-extent v
))
184 (defun-with-dx make-array-on-stack-5
()
185 (let ((v (make-array 3 :initial-element
12 :element-type t
)))
186 (declare (sb-int:truly-dynamic-extent v
))
190 (defun-with-dx vector-on-stack
(x y
)
191 (let ((v (vector 1 x
2 y
3)))
192 (declare (sb-int:truly-dynamic-extent v
))
198 (declaim (inline make-fp-struct-1
))
199 (defstruct fp-struct-1
200 (s 0.0 :type single-float
)
201 (d 0.0d0
:type double-float
))
203 (defun-with-dx test-fp-struct-1.1
(s d
)
204 (let ((fp (make-fp-struct-1 :s s
)))
205 (declare (dynamic-extent fp
))
206 (assert (eql s
(fp-struct-1-s fp
)))
207 (assert (eql 0.0d0
(fp-struct-1-d fp
)))))
209 (defun-with-dx test-fp-struct-1.2
(s d
)
210 (let ((fp (make-fp-struct-1 :d d
)))
211 (declare (dynamic-extent fp
))
212 (assert (eql 0.0 (fp-struct-1-s fp
)))
213 (assert (eql d
(fp-struct-1-d fp
)))))
215 (defun-with-dx test-fp-struct-1.3
(s d
)
216 (let ((fp (make-fp-struct-1 :d d
:s s
)))
217 (declare (dynamic-extent fp
))
218 (assert (eql s
(fp-struct-1-s fp
)))
219 (assert (eql d
(fp-struct-1-d fp
)))))
221 (defun-with-dx test-fp-struct-1.4
(s d
)
222 (let ((fp (make-fp-struct-1 :s s
:d d
)))
223 (declare (dynamic-extent fp
))
224 (assert (eql s
(fp-struct-1-s fp
)))
225 (assert (eql d
(fp-struct-1-d fp
)))))
227 (test-fp-struct-1.1
123.456 876.243d0
)
228 (test-fp-struct-1.2
123.456 876.243d0
)
229 (test-fp-struct-1.3
123.456 876.243d0
)
230 (test-fp-struct-1.4
123.456 876.243d0
)
232 (declaim (inline make-fp-struct-2
))
233 (defstruct fp-struct-2
234 (d 0.0d0
:type double-float
)
235 (s 0.0 :type single-float
))
237 (defun-with-dx test-fp-struct-2.1
(s d
)
238 (let ((fp (make-fp-struct-2 :s s
)))
239 (declare (dynamic-extent fp
))
240 (assert (eql s
(fp-struct-2-s fp
)))
241 (assert (eql 0.0d0
(fp-struct-2-d fp
)))))
243 (defun-with-dx test-fp-struct-2.2
(s d
)
244 (let ((fp (make-fp-struct-2 :d d
)))
245 (declare (dynamic-extent fp
))
246 (assert (eql 0.0 (fp-struct-2-s fp
)))
247 (assert (eql d
(fp-struct-2-d fp
)))))
249 (defun-with-dx test-fp-struct-2.3
(s d
)
250 (let ((fp (make-fp-struct-2 :d d
:s s
)))
251 (declare (dynamic-extent fp
))
252 (assert (eql s
(fp-struct-2-s fp
)))
253 (assert (eql d
(fp-struct-2-d fp
)))))
255 (defun-with-dx test-fp-struct-2.4
(s d
)
256 (let ((fp (make-fp-struct-2 :s s
:d d
)))
257 (declare (dynamic-extent fp
))
258 (assert (eql s
(fp-struct-2-s fp
)))
259 (assert (eql d
(fp-struct-2-d fp
)))))
261 (test-fp-struct-2.1
123.456 876.243d0
)
262 (test-fp-struct-2.2
123.456 876.243d0
)
263 (test-fp-struct-2.3
123.456 876.243d0
)
264 (test-fp-struct-2.4
123.456 876.243d0
)
266 (declaim (inline make-cfp-struct-1
))
267 (defstruct cfp-struct-1
268 (s (complex 0.0) :type
(complex single-float
))
269 (d (complex 0.0d0
) :type
(complex double-float
)))
271 (defun-with-dx test-cfp-struct-1.1
(s d
)
272 (let ((cfp (make-cfp-struct-1 :s s
)))
273 (declare (dynamic-extent cfp
))
274 (assert (eql s
(cfp-struct-1-s cfp
)))
275 (assert (eql (complex 0.0d0
) (cfp-struct-1-d cfp
)))))
277 (defun-with-dx test-cfp-struct-1.2
(s d
)
278 (let ((cfp (make-cfp-struct-1 :d d
)))
279 (declare (dynamic-extent cfp
))
280 (assert (eql (complex 0.0) (cfp-struct-1-s cfp
)))
281 (assert (eql d
(cfp-struct-1-d cfp
)))))
283 (defun-with-dx test-cfp-struct-1.3
(s d
)
284 (let ((cfp (make-cfp-struct-1 :d d
:s s
)))
285 (declare (dynamic-extent cfp
))
286 (assert (eql s
(cfp-struct-1-s cfp
)))
287 (assert (eql d
(cfp-struct-1-d cfp
)))))
289 (defun-with-dx test-cfp-struct-1.4
(s d
)
290 (let ((cfp (make-cfp-struct-1 :s s
:d d
)))
291 (declare (dynamic-extent cfp
))
292 (assert (eql s
(cfp-struct-1-s cfp
)))
293 (assert (eql d
(cfp-struct-1-d cfp
)))))
295 (test-cfp-struct-1.1
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
296 (test-cfp-struct-1.2
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
297 (test-cfp-struct-1.3
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
298 (test-cfp-struct-1.4
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
300 (declaim (inline make-cfp-struct-2
))
301 (defstruct cfp-struct-2
302 (d (complex 0.0d0
) :type
(complex double-float
))
303 (s (complex 0.0) :type
(complex single-float
)))
305 (defun-with-dx test-cfp-struct-2.1
(s d
)
306 (let ((cfp (make-cfp-struct-2 :s s
)))
307 (declare (dynamic-extent cfp
))
308 (assert (eql s
(cfp-struct-2-s cfp
)))
309 (assert (eql (complex 0.0d0
) (cfp-struct-2-d cfp
)))))
311 (defun-with-dx test-cfp-struct-2.2
(s d
)
312 (let ((cfp (make-cfp-struct-2 :d d
)))
313 (declare (dynamic-extent cfp
))
314 (assert (eql (complex 0.0) (cfp-struct-2-s cfp
)))
315 (assert (eql d
(cfp-struct-2-d cfp
)))))
317 (defun-with-dx test-cfp-struct-2.3
(s d
)
318 (let ((cfp (make-cfp-struct-2 :d d
:s s
)))
319 (declare (dynamic-extent cfp
))
320 (assert (eql s
(cfp-struct-2-s cfp
)))
321 (assert (eql d
(cfp-struct-2-d cfp
)))))
323 (defun-with-dx test-cfp-struct-2.4
(s d
)
324 (let ((cfp (make-cfp-struct-2 :s s
:d d
)))
325 (declare (dynamic-extent cfp
))
326 (assert (eql s
(cfp-struct-2-s cfp
)))
327 (assert (eql d
(cfp-struct-2-d cfp
)))))
329 (test-cfp-struct-2.1
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
330 (test-cfp-struct-2.2
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
331 (test-cfp-struct-2.3
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
332 (test-cfp-struct-2.4
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
334 (declaim (inline make-foo1 make-foo2 make-foo3
))
337 (defun-with-dx make-foo1-on-stack
(x)
338 (let ((foo (make-foo1 :x x
)))
339 (declare (dynamic-extent foo
))
340 (assert (eql x
(foo1-x foo
)))))
343 (x 0.0 :type single-float
)
344 (y 0.0d0
:type double-float
)
349 (defmacro assert-eql
(expected got
)
350 `(let ((exp ,expected
)
352 (unless (eql exp got
)
353 (error "Expected ~S, got ~S!" exp got
))))
355 (defun-with-dx make-foo2-on-stack
(x y
)
356 (let ((foo (make-foo2 :y y
:c
'c
)))
357 (declare (dynamic-extent foo
))
358 (assert-eql 0.0 (foo2-x foo
))
359 (assert-eql y
(foo2-y foo
))
360 (assert-eql 'c
(foo2-c foo
))
361 (assert-eql nil
(foo2-b foo
))))
363 ;;; Check that constants work out as argument for all relevant
368 (c 2 :type sb-vm
:word
)
369 (d 3.0 :type single-float
)
370 (e 4.0d0
:type double-float
))
371 (defun-with-dx make-foo3-on-stack
()
372 (let ((foo (make-foo3)))
373 (declare (dynamic-extent foo
))
374 (assert (eql 0 (foo3-a foo
)))
375 (assert (eql 1 (foo3-b foo
)))
376 (assert (eql 2 (foo3-c foo
)))
377 (assert (eql 3.0 (foo3-d foo
)))
378 (assert (eql 4.0d0
(foo3-e foo
)))))
382 (defun-with-dx nested-dx-lists
()
383 (let ((dx (list (list 1 2) (list 3 4))))
384 (declare (dynamic-extent dx
))
388 (defun-with-dx nested-dx-conses
()
389 (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t
) nil
))))))
390 (declare (dynamic-extent dx
))
394 (defun-with-dx nested-dx-not-used
(x)
396 (let ((l (setf (car x
) (list x x x
))))
397 (declare (dynamic-extent l
))
402 (defun-with-dx nested-evil-dx-used
(x)
404 (let ((l (list x x x
)))
405 (declare (dynamic-extent l
))
413 (defparameter *bar
* nil
)
414 (declaim (inline make-nested-bad make-nested-good
))
415 (defstruct (nested (:constructor make-nested-bad
(&key bar
&aux
(bar (setf *bar
* bar
))))
416 (:constructor make-nested-good
(&key bar
)))
419 (defun-with-dx nested-good
(y)
420 (let ((x (list (list (make-nested-good :bar
(list (list (make-nested-good :bar
(list y
)))))))))
421 (declare (dynamic-extent x
))
424 (defun-with-dx nested-bad
(y)
425 (let ((x (list (list (make-nested-bad :bar
(list (list (make-nested-bad :bar
(list y
)))))))))
426 (declare (dynamic-extent x
))
427 (unless (equalp (caar x
) (make-nested-good :bar
*bar
*))
428 (error "got ~S, wanted ~S" (caar x
) (make-nested-good :bar
*bar
*)))
431 (with-test (:name
:conservative-nested-dx
)
432 ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
433 (assert (equalp (nested-bad 42) (make-nested-good :bar
*bar
*)))
434 (assert (equalp *bar
* (list (list (make-nested-bad :bar
(list 42)))))))
436 ;;; multiple uses for dx lvar
438 (defun-with-dx multiple-dx-uses
()
439 (let ((dx (if (true t
)
442 (declare (dynamic-extent dx
))
446 ;;; handler-case and handler-bind should use DX internally
448 (defun dx-handler-bind (x)
449 (handler-bind ((error
450 (lambda (c) (break "OOPS: ~S caused ~S" x c
)))
451 ((and serious-condition
(not error
))
452 #'(lambda (c) (break "OOPS2: ~S did ~S" x c
))))
455 (defun dx-handler-case (x)
456 (assert (zerop (handler-case (/ 2 x
)
458 (break "OOPS: ~S caused ~S" x c
))
462 ;;; with-spinlock and with-mutex should use DX and not cons
464 (defvar *slock
* (sb-thread::make-spinlock
:name
"slocklock"))
466 (defun test-spinlock ()
467 (sb-thread::with-spinlock
(*slock
*)
470 (defvar *mutex
* (sb-thread::make-mutex
:name
"mutexlock"))
473 (sb-thread:with-mutex
(*mutex
*)
476 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
478 (defvar *table
* (make-hash-table))
480 (defun test-hash-table ()
481 (setf (gethash 5 *table
*) 13)
484 (defmacro assert-no-consing
(form &optional times
)
485 `(%assert-no-consing
(lambda () ,form
) ,times
))
486 (defun %assert-no-consing
(thunk &optional times
)
487 (let ((before (get-bytes-consed))
488 (times (or times
10000)))
489 (declare (type (integer 1 *) times
))
492 (assert (< (- (get-bytes-consed) before
) times
))))
494 (defmacro assert-consing
(form &optional times
)
495 `(%assert-consing
(lambda () ,form
) ,times
))
496 (defun %assert-consing
(thunk &optional times
)
497 (let ((before (get-bytes-consed))
498 (times (or times
10000)))
499 (declare (type (integer 1 *) times
))
502 (assert (not (< (- (get-bytes-consed) before
) times
)))))
504 (defvar *a-cons
* (cons nil nil
))
507 #+stack-allocatable-closures
508 (assert-no-consing (dxclosure 42))
509 #+stack-allocatable-lists
511 (assert-no-consing (dxlength 1 2 3))
512 (assert-no-consing (dxlength t t t t t t
))
513 (assert-no-consing (dxlength))
514 (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
515 (assert-no-consing (test-nip-values))
516 (assert-no-consing (test-let-var-subst1 17))
517 (assert-no-consing (test-let-var-subst2 17))
518 (assert-no-consing (test-lvar-subst 11))
519 (assert-no-consing (nested-dx-lists))
520 (assert-consing (nested-dx-not-used *a-cons
*))
521 (assert-no-consing (nested-evil-dx-used *a-cons
*))
522 (assert-no-consing (multiple-dx-uses)))
523 (assert-no-consing (dx-value-cell 13))
524 #+stack-allocatable-fixed-objects
526 (assert-no-consing (cons-on-stack 42))
527 (assert-no-consing (make-foo1-on-stack 123))
528 (assert-no-consing (nested-good 42))
529 (assert-no-consing (nested-dx-conses))
530 (assert-no-consing (dx-handler-bind 2))
531 (assert-no-consing (dx-handler-case 2)))
532 #+stack-allocatable-vectors
534 (assert-no-consing (force-make-array-on-stack 128))
535 (assert-no-consing (make-array-on-stack-1))
536 (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
537 (assert-no-consing (make-array-on-stack-3 9 8 7))
538 (assert-no-consing (make-array-on-stack-4))
539 (assert-no-consing (make-array-on-stack-5))
540 (assert-no-consing (vector-on-stack :x
:y
)))
541 (#+raw-instance-init-vops assert-no-consing
542 #-raw-instance-init-vops progn
543 (make-foo2-on-stack 1.24 1.23d0
))
544 (#+raw-instance-init-vops assert-no-consing
545 #-raw-instance-init-vops progn
546 (make-foo3-on-stack))
548 (assert-no-consing (test-hash-table))
551 (assert-no-consing (test-spinlock))
552 (assert-no-consing (test-mutex))))
555 ;;; Bugs found by Paul F. Dietz
562 (declare (optimize (speed 2) (space 0) (safety 0)
563 (debug 1) (compilation-speed 3)))
564 (let* ((v5 (cons b b
)))
565 (declare (dynamic-extent v5
))
573 ;;; bug reported by Svein Ove Aas
574 (defun svein-2005-ii-07 (x y
)
575 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
576 (let ((args (list* y
1 2 x
)))
577 (declare (dynamic-extent args
))
578 (apply #'aref args
)))
582 #3A
(((1 1 1) (1 1 1) (1 1 1))
583 ((1 1 1) (1 1 1) (4 1 1))
584 ((1 1 1) (1 1 1) (1 1 1))))
587 ;;; bug reported by Brian Downing: stack-allocated arrays were not
588 ;;; filled with zeroes.
589 (defun-with-dx bdowning-2005-iv-16
()
590 (let ((a (make-array 11 :initial-element
0)))
591 (declare (dynamic-extent a
))
592 (assert (every (lambda (x) (eql x
0)) a
))))
593 (with-test (:name
:bdowning-2005-iv-16
)
594 #+(or hppa mips x86 x86-64
)
595 (assert-no-consing (bdowning-2005-iv-16))
596 (bdowning-2005-iv-16))
598 (defun-with-dx let-converted-vars-dx-allocated-bug
(x y z
)
599 (let* ((a (list x y z
))
602 (declare (dynamic-extent c
))
603 (values (first c
) (second c
))))
605 (with-test (:name
:let-converted-vars-dx-allocated-bug
)
606 (multiple-value-bind (i j
) (let-converted-vars-dx-allocated-bug 1 2 3)
607 (assert (and (equal i j
)
608 (equal i
(list 1 2 3))))))
610 ;;; workaround for bug 419 -- real issue remains, but check that the
612 (defun-with-dx bug419
(x)
613 (multiple-value-call #'list
614 (eval '(values 1 2 3))
616 (declare (dynamic-extent x
))
621 (declare (dynamic-extent #'mget
#'mset
))
622 ((lambda (f g
) (eval `(progn ,f
,g
(values 4 5 6)))) #'mget
#'mset
)))))
623 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
625 ;;; Multiple DX arguments in a local function call
626 (defun test-dx-flet-test (fun n f1 f2 f3
)
627 (let ((res (with-output-to-string (s)
628 (assert (eql n
(ignore-errors (funcall fun s
)))))))
629 (multiple-value-bind (x pos
) (read-from-string res nil
)
630 (assert (equalp f1 x
))
631 (multiple-value-bind (y pos2
) (read-from-string res nil nil
:start pos
)
632 (assert (equalp f2 y
))
633 (assert (equalp f3
(read-from-string res nil nil
:start pos2
))))))
634 #+(or hppa mips x86 x86-64
)
635 (assert-no-consing (assert (eql n
(funcall fun nil
))))
636 (assert (eql n
(funcall fun nil
))))
637 (macrolet ((def (n f1 f2 f3
)
638 (let ((name (sb-pcl::format-symbol
:cl-user
"DX-FLET-TEST.~A" n
)))
640 (defun-with-dx ,name
(s)
642 (declare (dynamic-extent x
))
651 (test-dx-flet-test #',name
,n
,f1
,f2
,f3
)))))
652 (def 0 (list :one
) (list :two
) (list :three
))
653 (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list
))
654 (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
656 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
657 (defun test-update-uvl-live-sets (x y z
)
658 (declare (optimize speed
(safety 0)))
660 (declare (dynamic-extent a
))
661 (eval `(list (length ',a
) ',b
))))
663 (bar (list x y z
) ; dx push
665 (multiple-value-call 'list
666 (eval '(values 1 2 3)) ; uv push
671 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
673 (with-test (:name
:regression-1.0
.23.38)
674 (compile nil
'(lambda ()
676 (let ((res (cons x x
)))
679 (declaim (inline make
))
680 (let ((z (make 1 2)))
681 (declare (dynamic-extent z
))
684 (compile nil
'(lambda ()
686 (let ((res (cons x x
)))
689 (declaim (inline make
))
690 (let ((z (make 1 2)))
691 (declare (dynamic-extent z
))
695 ;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
696 ;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
697 ;;; location, leading to all manner of badness. ...reproducing this
698 ;;; reliably is hard, but this it at least used to break on x86-64.
699 (defun length-and-words-packed-in-same-tn (m)
700 (declare (optimize speed
(safety 0) (debug 0) (space 0)))
701 (let ((array (make-array (max 1 m
) :element-type
'fixnum
)))
702 (declare (dynamic-extent array
))
703 (array-total-size array
)))
704 (with-test (:name
:length-and-words-packed-in-same-tn
)
705 (assert (= 1 (length-and-words-packed-in-same-tn -
3))))
707 (with-test (:name
:handler-case-bogus-compiler-note
)
708 (handler-bind ((compiler-note #'error
))
709 ;; Taken from SWANK, used to signal a bogus stack allocation
712 `(lambda (files fasl-dir load
)
713 (let ((needs-recompile nil
))
715 (let ((dest (binary-pathname src fasl-dir
)))
718 (when (or needs-recompile
719 (not (probe-file dest
))
720 (file-newer-p src dest
))
721 (setq needs-recompile t
)
722 (ensure-directories-exist dest
)
723 (compile-file src
:output-file dest
:print nil
:verbose t
))
725 (load dest
:verbose t
)))
726 (serious-condition (c)
727 (handle-loadtime-error c dest
))))))))))
729 (declaim (inline foovector barvector
))
730 (defun foovector (x y z
)
731 (let ((v (make-array 3)))
736 (defun barvector (x y z
)
737 (make-array 3 :initial-contents
(list x y z
)))
738 (with-test (:name
:dx-compiler-notes
)
739 (flet ((assert-notes (j lambda
)
741 (handler-bind ((compiler-note (lambda (c)
742 (declare (ignore cc
))
746 (error "Wanted ~S notes, got ~S for~% ~S"
748 ;; These ones should complain.
749 (assert-notes 1 `(lambda (x)
750 (let ((v (make-array x
)))
751 (declare (dynamic-extent v
))
753 (assert-notes 2 `(lambda (x)
754 (let ((y (if (plusp x
)
757 (declare (dynamic-extent y
))
760 (assert-notes 1 `(lambda (x)
761 (let ((y (foovector x x x
)))
762 (declare (sb-int:truly-dynamic-extent y
))
765 ;; These ones should not complain.
766 (assert-notes 0 `(lambda (name)
768 ((posix-getenv (function c-string c-string
)
771 (alien-funcall posix-getenv name
)))))
772 (assert-notes 0 `(lambda (x)
773 (let ((y (barvector x x x
)))
774 (declare (dynamic-extent y
))
777 (assert-notes 0 `(lambda (list)
778 (declare (optimize (space 0)))
780 (assert-notes 0 `(lambda (other)
782 (ignore-errors (funcall other s c n
)))))))
784 ;;; Stack allocating a value cell in HANDLER-CASE would blow up stack
785 ;;; in an unfortunate loop.
786 (defun handler-case-eating-stack ()
788 (do ((n 0 (logand most-positive-fixnum
(1+ n
))))
790 (multiple-value-bind (value error
) (ignore-errors)
791 (when (and value error
) nil
))
793 (assert (= sp
(sb-c::%primitive sb-c
:current-stack-pointer
)))
794 (setf sp
(sb-c::%primitive sb-c
:current-stack-pointer
))))))
795 (with-test (:name
:handler-case-eating-stack
)
796 (assert-no-consing (handler-case-eating-stack)))