x86-64: put vector widetag and maybe length w/byte-sized store
[sbcl.git] / tests / dynamic-extent.impure.lisp
blob1fd0a446f53b92e10ea68379e11148bb18e7378b
1 ;;;; tests that dynamic-extent functionality works.
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.
14 (when (eq sb-ext:*evaluator-mode* :interpret)
15 (sb-ext:exit :code 104))
17 (load "compiler-test-util.lisp")
18 (use-package :ctu)
20 (setq sb-c::*check-consistency* t
21 sb-ext:*stack-allocate-dynamic-extent* t)
23 (defun crashme (a)
24 (declare (optimize (speed 3) (safety 0) (space 0)))
25 (declare (muffle-conditions style-warning)) ; re F1 and F2
26 (restart-case
27 (progn (ignore-errors (error "Foo")) (write-char #\.))
28 (retry () (f1 a))
29 (use-value (new) (f2 new))))
31 ;; lp#1530390
32 (with-test (:name :do-not-dxify-restarts)
33 (let ((a (make-array 100))) (unwind-protect (crashme 'bork) (fill a 0)))
34 (let ((a (make-array 100))) (unwind-protect (crashme 'bork) (fill a 0)))
35 (let ((a (make-array 100))) (unwind-protect (crashme 'bork) (fill a 0)))
36 (let ((a (make-array 100))) (unwind-protect (crashme 'bork) (fill a 0)))
39 (defmacro defun-with-dx (name arglist &body body)
40 (let ((debug-name (sb-int:symbolicate name "-HIGH-DEBUG"))
41 (default-name (sb-int:symbolicate name "-DEFAULT")))
42 `(progn
43 (defun ,debug-name ,arglist
44 (declare (optimize debug))
45 ,@body)
46 (defun ,default-name ,arglist
47 ,@body)
48 (defun ,name (&rest args)
49 (apply #',debug-name args)
50 (apply #',default-name args)))))
52 (declaim (notinline opaque-identity))
53 (defun opaque-identity (x)
56 ;;; &REST lists
58 (defun-with-dx dxlength (&rest rest)
59 (declare (dynamic-extent rest))
60 (length rest))
62 (with-test (:name (:dx-&rest :basics))
63 (assert (= (dxlength 1 2 3) 3))
64 (assert (= (dxlength t t t t t t) 6))
65 (assert (= (dxlength) 0)))
67 (defun callee (list)
68 (destructuring-bind (a b c d e f &rest g) list
69 (+ a b c d e f (length g))))
71 (defun-with-dx dxcaller (&rest rest)
72 (declare (dynamic-extent rest))
73 (callee rest))
75 (with-test (:name (:dx-&rest :pass-down-to-callee :tail-call))
76 (assert (= (dxcaller 1 2 3 4 5 6 7) 22)))
78 (defun-with-dx dxcaller-align-1 (x &rest rest)
79 (declare (dynamic-extent rest))
80 (+ x (callee rest)))
82 (with-test (:name (:dx-&rest :pass-down-to-callee :non-tail-call))
83 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
84 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40)))
86 ;;; %NIP-VALUES
88 (defun-with-dx test-nip-values ()
89 (flet ((bar (x &rest y)
90 (declare (dynamic-extent y))
91 (if (> x 0)
92 (values x (length y))
93 (values (car y)))))
94 (multiple-value-call #'values
95 (bar 1 2 3 4 5 6)
96 (bar -1 'a 'b))))
98 (with-test (:name (:nip-values))
99 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a))))
101 ;;; LET-variable substitution
103 (defun-with-dx test-let-var-subst1 (x)
104 (let ((y (list x (1- x))))
105 (opaque-identity :foo)
106 (let ((z (the list y)))
107 (declare (dynamic-extent z))
108 (length z))))
110 (with-test (:name (:let-variable-substitution))
111 (assert (eql (test-let-var-subst1 17) 2)))
113 (defun-with-dx test-let-var-subst2 (x)
114 (let ((y (list x (1- x))))
115 (declare (dynamic-extent y))
116 (opaque-identity :foo)
117 (let ((z (the list y)))
118 (length z))))
120 (with-test (:name (:let-variable-substitution-2))
121 (assert (eql (test-let-var-subst2 17) 2)))
124 ;;; DX propagation through LET-return.
126 (defun-with-dx test-lvar-subst (x)
127 (let ((y (list x (1- x))))
128 (declare (dynamic-extent y))
129 (second (let ((z (the list y)))
130 (opaque-identity :foo)
131 z))))
133 (with-test (:name (:dx-propagation-through-let-return))
134 (assert (eql (test-lvar-subst 11) 10)))
136 ;;; this code is incorrect, but the compiler should not fail
137 (defun-with-dx test-let-var-subst-incorrect (x)
138 (let ((y (list x (1- x))))
139 (opaque-identity :foo)
140 (let ((z (the list y)))
141 (declare (dynamic-extent z))
142 (opaque-identity :bar)
143 z)))
145 ;;; alignment
147 (defvar *x*)
148 (defun-with-dx test-alignment-dx-list (form)
149 (multiple-value-prog1 (eval form)
150 (let ((l (list 1 2 3 4)))
151 (declare (dynamic-extent l))
152 (setq *x* (copy-list l)))))
154 (with-test (:name (:dx-list :alignment))
155 (dotimes (n 64)
156 (let* ((res (loop for i below n collect i))
157 (form `(values ,@res)))
158 (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
159 (assert (equal *x* '(1 2 3 4))))))
161 ;;; closure
163 (declaim (notinline true))
164 (defun true (x)
165 (declare (ignore x))
168 (defun-with-dx dxclosure (x)
169 (flet ((f (y)
170 (+ y x)))
171 (declare (dynamic-extent #'f))
172 (true #'f)))
174 (with-test (:name (:dx-closure))
175 (assert (eq t (dxclosure 13))))
177 ;;; value-cells
179 (defun-with-dx dx-value-cell (x)
180 ;; Not implemented everywhere, yet.
181 #+(or x86 x86-64 mips hppa)
182 (let ((cell x))
183 (declare (sb-int:truly-dynamic-extent cell))
184 (flet ((f ()
185 (incf cell)))
186 (declare (dynamic-extent #'f))
187 (true #'f))))
189 ;;; CONS
191 (defun-with-dx cons-on-stack (x)
192 (let ((cons (cons x x)))
193 (declare (dynamic-extent cons))
194 (true cons)
195 nil))
197 ;;; MAKE-ARRAY
199 (defun force-make-array-on-stack (n)
200 (declare (optimize safety))
201 (let ((v (make-array (min n 1))))
202 (declare (sb-int:truly-dynamic-extent v))
203 (true v)
204 (true v)
205 nil))
207 (defun-with-dx make-array-on-stack-1 ()
208 (let ((v (make-array '(42) :element-type 'single-float)))
209 (declare (dynamic-extent v))
210 (true v)
211 (true v)
212 nil))
214 (defun-with-dx make-array-on-stack-2 (n x)
215 (declare (integer n))
216 (let ((v (make-array n :initial-contents x)))
217 (declare (sb-int:truly-dynamic-extent v))
218 (true v)
219 (true v)
220 nil))
222 (defun-with-dx make-array-on-stack-3 (x y z)
223 (let ((v (make-array 3
224 :element-type 'fixnum :initial-contents (list x y z)
225 :element-type t :initial-contents x)))
226 (declare (sb-int:truly-dynamic-extent v))
227 (true v)
228 (true v)
229 nil))
231 (defun-with-dx make-array-on-stack-4 ()
232 (let ((v (make-array 3 :initial-contents '(1 2 3))))
233 (declare (sb-int:truly-dynamic-extent v))
234 (true v)
235 (true v)
236 nil))
238 (defun-with-dx make-array-on-stack-5 ()
239 (let ((v (make-array 3 :initial-element 12 :element-type t)))
240 (declare (sb-int:truly-dynamic-extent v))
241 (true v)
242 (true v)
243 nil))
245 (defun-with-dx make-array-on-stack-6 ()
246 (let ((v (make-array 3 :initial-element 12 :element-type '(unsigned-byte 8))))
247 (declare (sb-int:truly-dynamic-extent v))
248 (true v)
249 (true v)
250 nil))
252 (defun-with-dx make-array-on-stack-7 ()
253 (let ((v (make-array 3 :initial-element 12 :element-type '(signed-byte 8))))
254 (declare (sb-int:truly-dynamic-extent v))
255 (true v)
256 (true v)
257 nil))
259 (defun-with-dx make-array-on-stack-8 ()
260 (let ((v (make-array 3 :initial-element 12 :element-type 'word)))
261 (declare (sb-int:truly-dynamic-extent v))
262 (true v)
263 (true v)
264 nil))
266 (defun-with-dx make-array-on-stack-9 ()
267 (let ((v (make-array 3 :initial-element 12.0 :element-type 'single-float)))
268 (declare (sb-int:truly-dynamic-extent v))
269 (true v)
270 (true v)
271 nil))
273 (defun-with-dx make-array-on-stack-10 ()
274 (let ((v (make-array 3 :initial-element 12.0d0 :element-type 'double-float)))
275 (declare (sb-int:truly-dynamic-extent v))
276 (true v)
277 (true v)
278 nil))
280 (defun-with-dx make-array-on-stack-11 ()
281 (let ((v (make-array (the integer (opaque-identity 3)) :initial-element 12.0d0 :element-type 'double-float)))
282 (declare (sb-int:truly-dynamic-extent v))
283 (true v)
284 (true v)
285 nil))
287 (defun-with-dx vector-on-stack (x y)
288 (let ((v (vector 1 x 2 y 3)))
289 (declare (sb-int:truly-dynamic-extent v))
290 (true v)
291 nil))
293 (defun-with-dx make-3d-fixed-array-on-stack-1 ()
294 (let ((a (make-array '(4 8 3) :initial-element 12 :element-type t)))
295 (declare (sb-int:truly-dynamic-extent a))
296 (true a)
297 (true a)
298 nil))
299 (defun-with-dx make-3d-fixed-array-on-stack-2 (a b c d)
300 (sb-int:dx-let ((a (make-array '(2 2 1)
301 :element-type 'bit
302 :initial-contents `(#((,a) (,b)) (#(,c) (,d))))))
303 (true a)
304 (true a)
305 nil))
307 (defun-with-dx make-2d-variable-array-on-stack ()
308 (let* ((n (opaque-identity 5))
309 (a (make-array `(,n 2) :initial-element 12 :element-type t)))
310 (declare (sb-int:truly-dynamic-extent a))
311 (true a)
312 (true a)
313 nil))
315 (defun 2d-array-initializer (n)
316 (ecase n
317 (1 '((a)))
318 (2 '((a b) (c d)))
319 (3 '((a b c) (c d e) (f g h)))))
321 (defun-with-dx make-2d-array-function-initializer (n)
322 (let* ((x (opaque-identity n))
323 (y (opaque-identity x))
324 (a (make-array `(,x ,y) :initial-contents (2d-array-initializer x))))
325 (declare (sb-int:truly-dynamic-extent a))
326 (true a)
327 (true a)
328 nil))
330 ;;; MAKE-LIST
332 (declaim (inline make-list-container))
333 (defstruct list-container listy-slot)
334 (defun make-var-length-dx-list (n thunk)
335 (sb-int:dx-let ((s (make-list-container :listy-slot (make-list n))))
336 (funcall thunk s)))
337 ;; :stack-allocatable-lists is necessary but not sufficient
338 (with-test (:name (:dx-list :make-list) :skipped-on '(not :x86-64))
339 (assert (null (ctu:find-named-callees #'make-var-length-dx-list)))
340 (assert-no-consing (make-var-length-dx-list
341 50 (lambda (x) (declare (ignore x))))))
343 ;;; MAKE-STRUCTURE
345 (declaim (inline make-fp-struct-1))
346 (defstruct fp-struct-1
347 (s 0.0 :type single-float)
348 (d 0.0d0 :type double-float))
350 (defun-with-dx test-fp-struct-1.1 (s d)
352 (let ((fp (make-fp-struct-1 :s s)))
353 (declare (dynamic-extent fp))
354 (assert (eql s (fp-struct-1-s fp)))
355 (assert (eql 0.0d0 (fp-struct-1-d fp)))))
357 (defun-with-dx test-fp-struct-1.2 (s d)
359 (let ((fp (make-fp-struct-1 :d d)))
360 (declare (dynamic-extent fp))
361 (assert (eql 0.0 (fp-struct-1-s fp)))
362 (assert (eql d (fp-struct-1-d fp)))))
364 (defun-with-dx test-fp-struct-1.3 (s d)
365 (let ((fp (make-fp-struct-1 :d d :s s)))
366 (declare (dynamic-extent fp))
367 (assert (eql s (fp-struct-1-s fp)))
368 (assert (eql d (fp-struct-1-d fp)))))
370 (defun-with-dx test-fp-struct-1.4 (s d)
371 (let ((fp (make-fp-struct-1 :s s :d d)))
372 (declare (dynamic-extent fp))
373 (assert (eql s (fp-struct-1-s fp)))
374 (assert (eql d (fp-struct-1-d fp)))))
376 (with-test (:name (:test-fp-struct-1.1))
377 (test-fp-struct-1.1 123.456 876.243d0))
378 (with-test (:name (:test-fp-struct-1.2))
379 (test-fp-struct-1.2 123.456 876.243d0))
380 (with-test (:name (:test-fp-struct-1.3))
381 (test-fp-struct-1.3 123.456 876.243d0))
382 (with-test (:name (:test-fp-struct-1.4))
383 (test-fp-struct-1.4 123.456 876.243d0))
385 (declaim (inline make-fp-struct-2))
386 (defstruct fp-struct-2
387 (d 0.0d0 :type double-float)
388 (s 0.0 :type single-float))
390 (defun-with-dx test-fp-struct-2.1 (s d)
392 (let ((fp (make-fp-struct-2 :s s)))
393 (declare (dynamic-extent fp))
394 (assert (eql s (fp-struct-2-s fp)))
395 (assert (eql 0.0d0 (fp-struct-2-d fp)))))
397 (defun-with-dx test-fp-struct-2.2 (s d)
399 (let ((fp (make-fp-struct-2 :d d)))
400 (declare (dynamic-extent fp))
401 (assert (eql 0.0 (fp-struct-2-s fp)))
402 (assert (eql d (fp-struct-2-d fp)))))
404 (defun-with-dx test-fp-struct-2.3 (s d)
405 (let ((fp (make-fp-struct-2 :d d :s s)))
406 (declare (dynamic-extent fp))
407 (assert (eql s (fp-struct-2-s fp)))
408 (assert (eql d (fp-struct-2-d fp)))))
410 (defun-with-dx test-fp-struct-2.4 (s d)
411 (let ((fp (make-fp-struct-2 :s s :d d)))
412 (declare (dynamic-extent fp))
413 (assert (eql s (fp-struct-2-s fp)))
414 (assert (eql d (fp-struct-2-d fp)))))
416 (with-test (:name (:test-fp-struct-2.1))
417 (test-fp-struct-2.1 123.456 876.243d0))
418 (with-test (:name (:test-fp-struct-2.2))
419 (test-fp-struct-2.2 123.456 876.243d0))
420 (with-test (:name (:test-fp-struct-2.3))
421 (test-fp-struct-2.3 123.456 876.243d0))
422 (with-test (:name (:test-fp-struct-2.4))
423 (test-fp-struct-2.4 123.456 876.243d0))
425 (declaim (inline make-cfp-struct-1))
426 (defstruct cfp-struct-1
427 (s (complex 0.0) :type (complex single-float))
428 (d (complex 0.0d0) :type (complex double-float)))
430 (defun-with-dx test-cfp-struct-1.1 (s d)
432 (let ((cfp (make-cfp-struct-1 :s s)))
433 (declare (dynamic-extent cfp))
434 (assert (eql s (cfp-struct-1-s cfp)))
435 (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
437 (defun-with-dx test-cfp-struct-1.2 (s d)
439 (let ((cfp (make-cfp-struct-1 :d d)))
440 (declare (dynamic-extent cfp))
441 (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
442 (assert (eql d (cfp-struct-1-d cfp)))))
444 (defun-with-dx test-cfp-struct-1.3 (s d)
445 (let ((cfp (make-cfp-struct-1 :d d :s s)))
446 (declare (dynamic-extent cfp))
447 (assert (eql s (cfp-struct-1-s cfp)))
448 (assert (eql d (cfp-struct-1-d cfp)))))
450 (defun-with-dx test-cfp-struct-1.4 (s d)
451 (let ((cfp (make-cfp-struct-1 :s s :d d)))
452 (declare (dynamic-extent cfp))
453 (assert (eql s (cfp-struct-1-s cfp)))
454 (assert (eql d (cfp-struct-1-d cfp)))))
456 (with-test (:name (:test-cfp-struct-1.1))
457 (test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
458 (with-test (:name (:test-cfp-struct-1.2))
459 (test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
460 (with-test (:name (:test-cfp-struct-1.3))
461 (test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
462 (with-test (:name (:test-cfp-struct-1.4))
463 (test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
465 (declaim (inline make-cfp-struct-2))
466 (defstruct cfp-struct-2
467 (d (complex 0.0d0) :type (complex double-float))
468 (s (complex 0.0) :type (complex single-float)))
470 (defun-with-dx test-cfp-struct-2.1 (s d)
472 (let ((cfp (make-cfp-struct-2 :s s)))
473 (declare (dynamic-extent cfp))
474 (assert (eql s (cfp-struct-2-s cfp)))
475 (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
477 (defun-with-dx test-cfp-struct-2.2 (s d)
479 (let ((cfp (make-cfp-struct-2 :d d)))
480 (declare (dynamic-extent cfp))
481 (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
482 (assert (eql d (cfp-struct-2-d cfp)))))
484 (defun-with-dx test-cfp-struct-2.3 (s d)
485 (let ((cfp (make-cfp-struct-2 :d d :s s)))
486 (declare (dynamic-extent cfp))
487 (assert (eql s (cfp-struct-2-s cfp)))
488 (assert (eql d (cfp-struct-2-d cfp)))))
490 (defun-with-dx test-cfp-struct-2.4 (s d)
491 (let ((cfp (make-cfp-struct-2 :s s :d d)))
492 (declare (dynamic-extent cfp))
493 (assert (eql s (cfp-struct-2-s cfp)))
494 (assert (eql d (cfp-struct-2-d cfp)))))
496 (with-test (:name (:test-cfp-struct-2.1))
497 (test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
498 (with-test (:name (:test-cfp-struct-2.2))
499 (test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
500 (with-test (:name (:test-cfp-struct-2.3))
501 (test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
502 (with-test (:name (:test-cfp-struct-2.4))
503 (test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
505 ;; It works to declare a structure constructor INLINE after the DEFSTRUCT
506 ;; was processed, as long as it was in the null lexical environment.
507 ;; In a perfect world, we'd figure out that a variable declared DX which
508 ;; receives the value of a structure constructor defined in the same file
509 ;; and neither expressly INLINE nor NOTINLINE should be locally inlined.
510 ;; But at least this shows that a declaration at the intended use point
511 ;; is sufficient, without also a bracketing INLINE/NOTINLINE at the DEFSTRUCT.
513 ;; Verify the precondition for the assertions that claim that DXifying works
514 ;; even though the MAKE- function was not expressly INLINE when its DEFSTRUCT
515 ;; was compiled.
516 (dolist (s '(make-foo1 make-foo2 make-foo3))
517 (assert (null (sb-int:info :function :inline-expansion-designator s))))
519 (defstruct foo1 x)
521 (defun-with-dx make-foo1-on-stack (x)
522 (declare (inline make-foo1))
523 (let ((foo (make-foo1 :x x)))
524 (declare (dynamic-extent foo))
525 (assert (eql x (foo1-x foo)))))
527 (defstruct foo2
528 (x 0.0 :type single-float)
529 (y 0.0d0 :type double-float)
534 (defun-with-dx make-foo2-on-stack (x y)
535 (declare (inline make-foo2))
537 (let ((foo (make-foo2 :y y :c 'c)))
538 (declare (dynamic-extent foo))
539 (assert (eql 0.0 (foo2-x foo)))
540 (assert (eql y (foo2-y foo)))
541 (assert (eql 'c (foo2-c foo)))
542 (assert (eql nil (foo2-b foo)))))
544 ;;; Check that constants work out as argument for all relevant
545 ;;; slot types.
546 (defstruct foo3
547 (a 0 :type t)
548 (b 1 :type fixnum)
549 (c 2 :type sb-vm:word)
550 (d 3.0 :type single-float)
551 (e 4.0d0 :type double-float))
553 (defun-with-dx make-foo3-on-stack ()
554 (declare (inline make-foo3))
555 (let ((foo (make-foo3)))
556 (declare (dynamic-extent foo))
557 (assert (eql 0 (foo3-a foo)))
558 (assert (eql 1 (foo3-b foo)))
559 (assert (eql 2 (foo3-c foo)))
560 (assert (eql 3.0 (foo3-d foo)))
561 (assert (eql 4.0d0 (foo3-e foo)))))
563 ;;; Nested DX
565 (defun-with-dx nested-dx-lists ()
566 (let ((dx (list (list 1 2) (list 3 4))))
567 (declare (dynamic-extent dx))
568 (true dx)
569 nil))
571 (defun-with-dx nested-dx-conses ()
572 (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
573 (declare (dynamic-extent dx))
574 (true dx)
575 nil))
577 (defun-with-dx nested-dx-not-used (x)
578 (declare (list x))
579 (let ((l (setf (car x) (list x x x))))
580 (declare (dynamic-extent l))
581 (true l)
582 (true (length l))
583 nil))
585 (defun-with-dx nested-evil-dx-used (x)
586 (declare (list x))
587 (let ((l (list x x x)))
588 (declare (dynamic-extent l))
589 (unwind-protect
590 (progn
591 (setf (car x) l)
592 (true l))
593 (setf (car x) nil))
594 nil))
596 (defparameter *bar* nil)
597 (declaim (inline make-nested-bad make-nested-good))
598 (defstruct (nested (:constructor make-nested-bad (&key bar &aux (bar (setf *bar* bar))))
599 (:constructor make-nested-good (&key bar)))
600 bar)
602 (defun-with-dx nested-good (y)
603 (let ((x (list (list (make-nested-good :bar (list (list (make-nested-good :bar (list y)))))))))
604 (declare (dynamic-extent x))
605 (true x)))
607 (defun-with-dx nested-bad (y)
608 (let ((x (list (list (make-nested-bad :bar (list (list (make-nested-bad :bar (list y)))))))))
609 (declare (dynamic-extent x))
610 (unless (equalp (caar x) (make-nested-good :bar *bar*))
611 (error "got ~S, wanted ~S" (caar x) (make-nested-good :bar *bar*)))
612 ;; the NESTED instance itself *should* be DX!
613 (copy-nested (caar x))))
615 (with-test (:name :conservative-nested-dx)
616 ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
617 (assert (equalp (nested-bad 42) (make-nested-good :bar *bar*)))
618 (assert (equalp *bar* (list (list (make-nested-bad :bar (list 42)))))))
620 ;;; multiple uses for dx lvar
622 (defun-with-dx multiple-dx-uses ()
623 (let ((dx (if (true t)
624 (list 1 2 3)
625 (list 2 3 4))))
626 (declare (dynamic-extent dx))
627 (true dx)
628 nil))
630 ;;; mapfoo should make the initial cons dx
632 (defun mapcar-negate (x) (mapcar #'- x))
633 (defun mapcan-reverse (x) (mapcan #'reverse x))
635 ;;; handler-case and handler-bind should use DX internally
637 (defun dx-handler-bind (x)
638 (handler-bind ((error
639 #'(lambda (c)
640 (break "OOPS: ~S caused ~S" x c)))
641 ((and serious-condition (not error))
642 #'(lambda (c)
643 (break "OOPS2: ~S did ~S" x c))))
644 (/ 2 x)))
646 (defun dx-handler-case (x)
647 (assert (zerop (handler-case (/ 2 x)
648 (error (c)
649 (break "OOPS: ~S caused ~S" x c)
651 (:no-error (res)
652 (1- res))))))
654 (defun list-delete-some-stuff ()
655 ;; opaque-identity hides the fact that we are calling a destructive function
656 ;; on a constant, which is technically illegal. But no deletion occurs,
657 ;; so it's innocuous. Also these aren't tests of DX, but oh well...
658 (declare (muffle-conditions style-warning))
659 (delete 'a (opaque-identity '(x y)))
660 (delete 'a (opaque-identity '(x y)) :from-end t)
661 (delete-duplicates (opaque-identity '(x y))))
663 (defvar *a-cons* (cons nil nil))
665 (with-test (:name (:no-consing :dx-closures) :skipped-on '(not :stack-allocatable-closures))
666 (assert-no-consing (dxclosure 42)))
668 (with-test (:name (:no-consing :dx-lists)
669 :skipped-on '(not (and :stack-allocatable-lists
670 :stack-allocatable-fixed-objects)))
671 (assert-no-consing (dxlength 1 2 3))
672 (assert-no-consing (dxlength t t t t t t))
673 (assert-no-consing (dxlength))
674 (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
675 (assert-no-consing (test-nip-values))
676 (assert-no-consing (test-let-var-subst2 17))
677 (assert-no-consing (test-lvar-subst 11))
678 (assert-no-consing (nested-dx-lists))
679 (assert-consing (nested-dx-not-used *a-cons*))
680 (assert-no-consing (nested-evil-dx-used *a-cons*))
681 (assert-no-consing (mapcar-negate nil))
682 (assert-no-consing (mapcan-reverse nil))
683 (assert-no-consing (list-delete-some-stuff))
684 (assert-no-consing (multiple-dx-uses)))
686 (with-test (:name (:no-consing :dx-value-cell)
687 :skipped-on '(not :stack-allocatable-closures))
688 (assert-no-consing (dx-value-cell 13)))
690 (with-test (:name (:no-consing :dx-fixed-objects)
691 :skipped-on '(not (and :stack-allocatable-fixed-objects
692 :stack-allocatable-closures)))
693 (assert-no-consing (cons-on-stack 42))
694 (assert-no-consing (make-foo1-on-stack 123))
695 (assert-no-consing (nested-good 42))
696 (assert-no-consing (nested-dx-conses))
697 (assert-no-consing (dx-handler-bind 2))
698 (assert-no-consing (dx-handler-case 2)))
700 (with-test (:name (:no-consing :dx-vectors) :skipped-on '(not :stack-allocatable-vectors))
701 (assert-no-consing (force-make-array-on-stack 128))
702 (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
703 (assert-no-consing (make-array-on-stack-3 9 8 7))
704 (assert-no-consing (make-array-on-stack-4))
705 (assert-no-consing (make-array-on-stack-5))
706 (assert-no-consing (vector-on-stack :x :y)))
708 (with-test (:name (:no-consing :dx-arrays) :skipped-on '(not :stack-allocatable-vectors))
709 (assert-no-consing (make-3d-fixed-array-on-stack-1))
710 (assert-no-consing (make-3d-fixed-array-on-stack-2 0 0 1 1))
711 (assert-no-consing (make-2d-variable-array-on-stack))
712 (assert-no-consing (make-2d-array-function-initializer 1))
713 (assert-no-consing (make-2d-array-function-initializer 2))
714 (assert-no-consing (make-2d-array-function-initializer 3)))
716 (with-test (:name (:no-consing :specialized-dx-vectors)
717 :skipped-on `(not (and :stack-allocatable-vectors
718 :c-stack-is-control-stack)))
719 (assert-no-consing (make-array-on-stack-1))
720 (assert-no-consing (make-array-on-stack-6))
721 (assert-no-consing (make-array-on-stack-7))
722 (assert-no-consing (make-array-on-stack-8))
723 (assert-no-consing (make-array-on-stack-9))
724 (assert-no-consing (make-array-on-stack-10))
725 (assert-no-consing (make-array-on-stack-11)))
727 (with-test (:name (:no-consing :dx-raw-instances) :skipped-on '(or (not :raw-instance-init-vops)
728 (not (and :gencgc :c-stack-is-control-stack))))
729 (let (a b)
730 (setf a 1.24 b 1.23d0)
731 (assert-no-consing (make-foo2-on-stack a b)))
732 (assert-no-consing (make-foo3-on-stack)))
734 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
736 (defvar *table* (make-hash-table))
738 (defun test-hash-table ()
739 (setf (gethash 5 *table*) 13)
740 (gethash 5 *table*))
742 (with-test (:name (:no-consing :hash-tables))
743 (assert-no-consing (test-hash-table)))
745 ;;; Both with-pinned-objects and without-gcing should not cons
747 (defun call-without-gcing (fun)
748 (sb-sys:without-gcing (funcall fun)))
750 (defun call-with-pinned-object (fun obj)
751 (sb-sys:with-pinned-objects (obj)
752 (funcall fun obj)))
754 (with-test (:name (:no-consing :without-gcing))
755 (assert-no-consing (call-without-gcing (lambda ()))))
757 (with-test (:name (:no-consing :with-pinned-objects))
758 (assert-no-consing (call-with-pinned-object #'identity 42)))
760 ;;; with-mutex should use DX and not cons
762 (defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
764 (defun test-mutex ()
765 (sb-thread:with-mutex (*mutex*)
766 (true *mutex*)))
768 (with-test (:name (:no-consing :mutex) :skipped-on '(not :sb-thread))
769 (assert-no-consing (test-mutex)))
772 ;;; Bugs found by Paul F. Dietz
774 (with-test (:name (:dx-bug-misc :pfdietz))
775 (assert
777 (funcall
778 (compile
780 '(lambda (a b)
781 (declare (optimize (speed 2) (space 0) (safety 0)
782 (debug 1) (compilation-speed 3)))
783 (let* ((v5 (cons b b)))
784 (declare (dynamic-extent v5))
786 a)))
787 'x 'y)
788 'x)))
790 ;;; bug reported by Svein Ove Aas
791 (defun svein-2005-ii-07 (x y)
792 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
793 (let ((args (list* y 1 2 x)))
794 (declare (dynamic-extent args))
795 (apply #'aref args)))
797 (with-test (:name (:dx-bugs-misc :svein-2005-ii-07))
798 (assert (eql
799 (svein-2005-ii-07
800 '(0)
801 #3A(((1 1 1) (1 1 1) (1 1 1))
802 ((1 1 1) (1 1 1) (4 1 1))
803 ((1 1 1) (1 1 1) (1 1 1))))
804 4)))
806 ;;; bug reported by Brian Downing: stack-allocated arrays were not
807 ;;; filled with zeroes.
808 (defun-with-dx bdowning-2005-iv-16 ()
809 (let ((a (make-array 11 :initial-element 0)))
810 (declare (dynamic-extent a))
811 (assert (every (lambda (x) (eql x 0)) a))))
813 (with-test (:name (:dx-bug-misc :bdowning-2005-iv-16))
814 #+(or hppa mips x86 x86-64)
815 (assert-no-consing (bdowning-2005-iv-16))
816 (bdowning-2005-iv-16))
818 (declaim (inline my-nconc))
819 (defun my-nconc (&rest lists)
820 (declare (dynamic-extent lists))
821 (apply #'nconc lists))
822 (defun-with-dx my-nconc-caller (a b c)
823 (let ((l1 (list a b c))
824 (l2 (list a b c)))
825 (my-nconc l1 l2)))
826 (with-test (:name :rest-stops-the-buck)
827 (let ((list1 (my-nconc-caller 1 2 3))
828 (list2 (my-nconc-caller 9 8 7)))
829 (assert (equal list1 '(1 2 3 1 2 3)))
830 (assert (equal list2 '(9 8 7 9 8 7)))))
832 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
833 (let* ((a (list x y z))
834 (b (list x y z))
835 (c (list a b)))
836 (declare (dynamic-extent c))
837 (values (first c) (second c))))
838 (with-test (:name :let-converted-vars-dx-allocated-bug)
839 (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
840 (assert (and (equal i j)
841 (equal i (list 1 2 3))))))
843 ;;; workaround for bug 419 -- real issue remains, but check that the
844 ;;; bandaid holds.
845 (defun-with-dx bug419 (x)
846 (multiple-value-call #'list
847 (eval '(values 1 2 3))
848 (let ((x x))
849 (declare (dynamic-extent x))
850 (flet ((mget (y)
851 (+ x y))
852 (mset (z)
853 (incf x z)))
854 (declare (dynamic-extent #'mget #'mset))
855 ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
857 (with-test (:name (:dx-bug-misc :bug419))
858 (assert (equal (bug419 42) '(1 2 3 4 5 6))))
860 ;;; Multiple DX arguments in a local function call
861 (defun test-dx-flet-test (fun n f1 f2 f3)
862 (let ((res (with-output-to-string (s)
863 (assert (eql n (ignore-errors (funcall fun s)))))))
864 (multiple-value-bind (x pos) (read-from-string res nil)
865 (assert (equalp f1 x))
866 (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos)
867 (assert (equalp f2 y))
868 (assert (equalp f3 (read-from-string res nil nil :start pos2))))))
869 #+(or hppa mips x86 x86-64)
870 (assert-no-consing (assert (eql n (funcall fun nil))))
871 (assert (eql n (funcall fun nil))))
873 (macrolet ((def (n f1 f2 f3)
874 (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n)))
875 `(progn
876 (defun-with-dx ,name (s)
877 (flet ((f (x)
878 (declare (dynamic-extent x))
879 (when s
880 (print x s)
881 (finish-output s))
882 nil))
883 (f ,f1)
884 (f ,f2)
885 (f ,f3)
886 ,n))
887 (with-test (:name (:dx-flet-test ,n))
888 (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3))))))
889 (def 0 (list :one) (list :two) (list :three))
890 (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list))
891 (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
893 ;;; Test that unknown-values coming after a DX value won't mess up the
894 ;;; stack analysis
895 (defun test-update-uvl-live-sets (x y z)
896 (declare (optimize speed (safety 0)))
897 (flet ((bar (a b)
898 (declare (dynamic-extent a))
899 (eval `(list (length ',a) ',b))))
900 (list (bar x y)
901 (bar (list x y z) ; dx push
902 (list
903 (multiple-value-call 'list
904 (eval '(values 1 2 3)) ; uv push
905 (max y z)
906 ) ; uv pop
908 ))))
910 (with-test (:name (:update-uvl-live-sets))
911 (assert (equal '((0 4) (3 ((1 2 3 5) 14)))
912 (test-update-uvl-live-sets #() 4 5))))
914 (with-test (:name :regression-1.0.23.38)
915 (compile nil '(lambda ()
916 (declare (muffle-conditions compiler-note))
917 (flet ((make (x y)
918 (let ((res (cons x x)))
919 (setf (cdr res) y)
920 res)))
921 (declare (inline make))
922 (let ((z (make 1 2)))
923 (declare (dynamic-extent z))
924 (print z)
925 t))))
926 (compile nil '(lambda ()
927 (declare (muffle-conditions compiler-note))
928 (flet ((make (x y)
929 (let ((res (cons x x)))
930 (setf (cdr res) y)
931 (if x res y))))
932 (declare (inline make))
933 (let ((z (make 1 2)))
934 (declare (dynamic-extent z))
935 (print z)
936 t)))))
938 ;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
939 ;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
940 ;;; location, leading to all manner of badness. ...reproducing this
941 ;;; reliably is hard, but this it at least used to break on x86-64.
942 (defun length-and-words-packed-in-same-tn (m)
943 (declare (optimize speed (safety 0) (debug 0) (space 0)))
944 (let ((array (make-array (max 1 m) :element-type 'fixnum)))
945 (declare (dynamic-extent array))
946 (array-total-size array)))
947 (with-test (:name :length-and-words-packed-in-same-tn)
948 (assert (= 1 (length-and-words-packed-in-same-tn -3))))
950 (with-test (:name :handler-case-bogus-compiler-note
951 :skipped-on '(not (and :stack-allocatable-fixed-objects
952 :stack-allocatable-closures)))
953 (handler-bind
954 ((compiler-note (lambda (note)
955 (error "compiler issued note ~S during test" note))))
956 ;; Taken from SWANK, used to signal a bogus stack allocation
957 ;; failure note.
958 (compile nil
959 `(lambda (files fasl-dir load)
960 (declare (muffle-conditions style-warning))
961 (let ((needs-recompile nil))
962 (dolist (src files)
963 (let ((dest (binary-pathname src fasl-dir)))
964 (handler-case
965 (progn
966 (when (or needs-recompile
967 (not (probe-file dest))
968 (file-newer-p src dest))
969 (setq needs-recompile t)
970 (ensure-directories-exist dest)
971 (compile-file src :output-file dest :print nil :verbose t))
972 (when load
973 (load dest :verbose t)))
974 (serious-condition (c)
975 (handle-loadtime-error c dest))))))))))
977 (declaim (inline foovector barvector))
978 (defun foovector (x y z)
979 (let ((v (make-array 3)))
980 (setf (aref v 0) x
981 (aref v 1) y
982 (aref v 2) z)
984 (defun barvector (x y z)
985 (make-array 3 :initial-contents (list x y z)))
986 (with-test (:name :dx-compiler-notes
987 :skipped-on '(not (and :stack-allocatable-vectors
988 :stack-allocatable-closures)))
989 (flet ((assert-notes (j lambda)
990 (let ((n 0))
991 (handler-bind ((compiler-note (lambda (c)
992 (declare (ignore c))
993 (incf n))))
994 (let ((*error-output* (make-broadcast-stream)))
995 (compile nil lambda))
996 (unless (= j n)
997 (error "Wanted ~S notes, got ~S for~% ~S"
998 j n lambda))))))
999 ;; These ones should complain.
1000 (assert-notes 1 `(lambda (x)
1001 (let ((v (make-array x)))
1002 (declare (dynamic-extent v))
1003 (length v))))
1004 (assert-notes 2 `(lambda (x)
1005 (let ((y (if (plusp x)
1006 (true x)
1007 (true (- x)))))
1008 (declare (dynamic-extent y))
1009 (print y)
1010 nil)))
1011 (assert-notes 1 `(lambda (x)
1012 (let ((y (foovector x x x)))
1013 (declare (sb-int:truly-dynamic-extent y))
1014 (print y)
1015 nil)))
1016 ;; These ones should not complain.
1017 (assert-notes 0 `(lambda (name)
1018 (with-alien
1019 ((posix-getenv (function c-string c-string)
1020 :EXTERN "getenv"))
1021 (values
1022 (alien-funcall posix-getenv name)))))
1023 (assert-notes 0 `(lambda (x)
1024 (let ((y (barvector x x x)))
1025 (declare (dynamic-extent y))
1026 (print y)
1027 nil)))
1028 (assert-notes 0 `(lambda (list)
1029 (declare (optimize (space 0)))
1030 (sort list (lambda (x y) ; shut unrelated notes up
1031 (< (truly-the fixnum x)
1032 (truly-the fixnum y))))))
1033 (assert-notes 0 `(lambda (other)
1034 #'(lambda (s c n)
1035 (ignore-errors (funcall other s c n)))))))
1037 ;;; Stack allocating a value cell in HANDLER-CASE would blow up stack
1038 ;;; in an unfortunate loop.
1039 (defun handler-case-eating-stack ()
1040 (declare (muffle-conditions warning)) ; "dead code detected ... IR1-PHASES"
1041 (let ((sp nil))
1042 (do ((n 0 (logand most-positive-fixnum (1+ n))))
1043 ((>= n 1024))
1044 (multiple-value-bind (value error) (ignore-errors)
1045 (when (and value error) nil))
1046 (if sp
1047 (assert (= sp (sb-c::%primitive sb-c:current-stack-pointer)))
1048 (setf sp (sb-c::%primitive sb-c:current-stack-pointer))))))
1049 (with-test (:name :handler-case-eating-stack
1050 :skipped-on '(not (and :stack-allocatable-fixed-objects
1051 :stack-allocatable-closures)))
1052 (assert-no-consing (handler-case-eating-stack)))
1054 ;;; A nasty bug where RECHECK-DYNAMIC-EXTENT-LVARS thought something was going
1055 ;;; to be stack allocated when it was not, leading to a bogus %NIP-VALUES.
1056 ;;; Fixed by making RECHECK-DYNAMIC-EXTENT-LVARS deal properly with nested DX.
1057 (deftype vec ()
1058 `(simple-array t (3)))
1059 (declaim (ftype (function (t t t) vec) vec))
1060 (declaim (inline vec))
1061 (defun vec (a b c)
1062 (make-array 3 :initial-contents (list a b c)))
1063 (defun bad-boy (vec)
1064 (declare (type vec vec))
1065 (lambda (fun)
1066 (let ((vec (vec (aref vec 0) (aref vec 1) (aref vec 2))))
1067 (declare (dynamic-extent vec))
1068 (funcall fun vec))))
1069 (with-test (:name :recheck-nested-dx-bug
1070 :skipped-on '(not :stack-allocatable-vectors))
1071 (assert (funcall (bad-boy (vec 1.0 2.0 3.3))
1072 (lambda (vec) (equalp vec (vec 1.0 2.0 3.3)))))
1073 (flet ((foo (x) (declare (ignore x))))
1074 (let ((bad-boy (bad-boy (vec 2.0 3.0 4.0))))
1075 (assert-no-consing (funcall bad-boy #'foo)))))
1077 (with-test (:name :bug-497321)
1078 (flet ((test (lambda type)
1079 (let ((n 0))
1080 (handler-bind ((condition (lambda (c)
1081 (incf n)
1082 (unless (typep c type)
1083 (error "wanted ~S for~% ~S~%got ~S"
1084 type lambda (type-of c))))))
1085 (let ((*error-output* (make-broadcast-stream)))
1086 (compile nil lambda)))
1087 (assert (= n 1)))))
1088 (test `(lambda () (declare (dynamic-extent #'bar)))
1089 'style-warning)
1090 (test `(lambda () (declare (dynamic-extent bar)))
1091 'style-warning)
1092 (test `(lambda (bar) (cons bar (lambda () (declare (dynamic-extent bar)))))
1093 'sb-ext:compiler-note)
1094 (test `(lambda ()
1095 (flet ((bar () t))
1096 (cons #'bar (lambda () (declare (dynamic-extent #'bar))))))
1097 'sb-ext:compiler-note)))
1099 (with-test (:name :bug-586105
1100 :skipped-on '(not (and :stack-allocatable-vectors
1101 :stack-allocatable-lists)))
1102 (flet ((test (x)
1103 (let ((vec1 (make-array 1 :initial-contents (list (list x))))
1104 (vec2 (make-array 1 :initial-contents `((,x))))
1105 (vec3 (make-array 1 :initial-contents `#((,x))))
1106 (vec4 (make-array 1 :initial-contents `(#(,x)))))
1107 (declare (dynamic-extent vec1 vec2 vec3 vec4))
1108 (assert (eql x (car (aref vec1 0))))
1109 (assert (eql x (car (aref vec2 0))))
1110 (assert (eql x (car (aref vec3 0))))
1111 (assert (eql x (elt (aref vec4 0) 0))))))
1112 (assert-no-consing (test 42))))
1114 (defun bug-681092 ()
1115 (declare (optimize speed))
1116 (let ((c 0))
1117 (flet ((bar () c))
1118 (declare (dynamic-extent #'bar))
1119 (do () ((list) (bar))
1120 (setf c 10)
1121 (return (bar))))))
1122 (with-test (:name :bug-681092)
1123 (assert (= 10 (bug-681092))))
1125 ;;;; Including a loop in the flow graph between a DX-allocation and
1126 ;;;; the start of its environment would, for a while, cause executing
1127 ;;;; any of the code in the loop to discard the value. Found via
1128 ;;;; attempting to DX-allocate an array, which triggered the FILL
1129 ;;;; transform, which inserted such a loop.
1130 (defun bug-1472785 (x)
1131 (let ((y (let ((z (cons nil nil)))
1132 (let ((i 0))
1133 (tagbody
1135 (when (= x i) (go b2))
1136 (incf i)
1137 (go b1)
1138 b2))
1140 (w (cons t t)))
1141 (declare (dynamic-extent y w))
1142 (eq y w)))
1143 (with-test (:name :bug-1472785)
1144 (assert (null (bug-1472785 1))))
1146 ;;;; &REST lists should stop DX propagation -- not required by ANSI,
1147 ;;;; but required by sanity.
1149 (declaim (inline rest-stops-dx))
1150 (defun-with-dx rest-stops-dx (&rest args)
1151 (declare (dynamic-extent args))
1152 (apply #'opaque-identity args))
1154 (defun-with-dx rest-stops-dx-ok ()
1155 (equal '(:foo) (rest-stops-dx (list :foo))))
1157 (with-test (:name :rest-stops-dynamic-extent)
1158 (assert (rest-stops-dx-ok)))
1160 ;;;; These tests aren't strictly speaking DX, but rather &REST -> &MORE
1161 ;;;; conversion.
1162 (with-test (:name :rest-to-more-conversion)
1163 (let ((f1 (compile nil `(lambda (f &rest args)
1164 (apply f args)))))
1165 (assert-no-consing (assert (eql f1 (funcall f1 #'identity f1)))))
1166 (let ((f2 (compile nil `(lambda (f1 f2 &rest args)
1167 (values (apply f1 args) (apply f2 args))))))
1168 (assert-no-consing (multiple-value-bind (a b)
1169 (funcall f2 (lambda (x y z) (+ x y z)) (lambda (x y z) (- x y z))
1170 1 2 3)
1171 (assert (and (eql 6 a) (eql -4 b))))))
1172 (let ((f3 (compile nil `(lambda (f &optional x &rest args)
1173 (when x
1174 (apply f x args))))))
1175 (assert-no-consing (assert (eql 42 (funcall f3
1176 (lambda (a b c) (+ a b c))
1179 21)))))
1180 (let ((f4
1181 (let ((*error-output* (make-broadcast-stream)))
1182 (compile nil `(lambda (f &optional x &rest args
1183 &key y &allow-other-keys)
1184 (apply f y x args))))))
1185 (assert-no-consing (funcall f4 (lambda (y x yk y2 b c)
1186 (assert (eq y 'y))
1187 (assert (= x 2))
1188 (assert (eq :y yk))
1189 (assert (eq y2 'y))
1190 (assert (eq b 'b))
1191 (assert (eq c 'c)))
1192 2 :y 'y 'b 'c)))
1193 (let ((f5 (compile nil `(lambda (a b c &rest args)
1194 (apply #'list* a b c args)))))
1195 (assert (equal '(1 2 3 4 5 6 7) (funcall f5 1 2 3 4 5 6 '(7)))))
1196 (let ((f6 (compile nil `(lambda (x y)
1197 (declare (optimize speed))
1198 (concatenate 'string x y)))))
1199 (assert (equal "foobar" (funcall f6 "foo" "bar"))))
1200 (let ((f7 (compile nil `(lambda (&rest args)
1201 (lambda (f)
1202 (apply f args))))))
1203 (assert (equal '(a b c d e f) (funcall (funcall f7 'a 'b 'c 'd 'e 'f) 'list))))
1204 (let ((f8 (compile nil `(lambda (&rest args)
1205 (flet ((foo (f)
1206 (apply f args)))
1207 #'foo)))))
1208 (assert (equal '(a b c d e f) (funcall (funcall f8 'a 'b 'c 'd 'e 'f) 'list))))
1209 (let ((f9 (compile nil `(lambda (f &rest args)
1210 (flet ((foo (g)
1211 (apply g args)))
1212 (declare (dynamic-extent #'foo))
1213 (funcall f #'foo))))))
1214 (assert (equal '(a b c d e f)
1215 (funcall f9 (lambda (f) (funcall f 'list)) 'a 'b 'c 'd 'e 'f))))
1216 (let ((f10 (compile nil `(lambda (f &rest args)
1217 (flet ((foo (g)
1218 (apply g args)))
1219 (funcall f #'foo))))))
1220 (assert (equal '(a b c d e f)
1221 (funcall f10 (lambda (f) (funcall f 'list)) 'a 'b 'c 'd 'e 'f))))
1222 (let ((f11 (compile nil `(lambda (x y z)
1223 (block out
1224 (labels ((foo (x &rest rest)
1225 (apply (lambda (&rest rest2)
1226 (return-from out (values-list rest2)))
1227 x rest)))
1228 (if x
1229 (foo x y z)
1230 (foo y z x))))))))
1231 (multiple-value-bind (a b c) (funcall f11 1 2 3)
1232 (assert (eql a 1))
1233 (assert (eql b 2))
1234 (assert (eql c 3)))))
1236 (defun opaque-funcall (function &rest arguments)
1237 (apply function arguments))
1239 (with-test (:name :implicit-value-cells)
1240 (flet ((test-it (type input output)
1241 (let ((f (compile nil `(lambda (x)
1242 (declare (type ,type x))
1243 (flet ((inc ()
1244 (incf x)))
1245 (declare (dynamic-extent #'inc))
1246 (list (opaque-funcall #'inc) x))))))
1247 (assert (equal (funcall f input)
1248 (list output output))))))
1249 (let ((width sb-vm:n-word-bits))
1250 (test-it t (1- most-positive-fixnum) most-positive-fixnum)
1251 (test-it `(unsigned-byte ,(1- width)) (ash 1 (- width 2)) (1+ (ash 1 (- width 2))))
1252 (test-it `(signed-byte ,width) (ash -1 (- width 2)) (1+ (ash -1 (- width 2))))
1253 (test-it `(unsigned-byte ,width) (ash 1 (1- width)) (1+ (ash 1 (1- width))))
1254 (test-it 'single-float 3f0 4f0)
1255 (test-it 'double-float 3d0 4d0)
1256 (test-it '(complex single-float) #c(3f0 4f0) #c(4f0 4f0))
1257 (test-it '(complex double-float) #c(3d0 4d0) #c(4d0 4d0)))))
1259 (with-test (:name :sap-implicit-value-cells)
1260 (let ((f (compile nil `(lambda (x)
1261 (declare (type system-area-pointer x))
1262 (flet ((inc ()
1263 (setf x (sb-sys:sap+ x 16))))
1264 (declare (dynamic-extent #'inc))
1265 (list (opaque-funcall #'inc) x)))))
1266 (width sb-vm:n-machine-word-bits))
1267 (assert (every (lambda (x)
1268 (sb-sys:sap= x (sb-sys:int-sap (+ 16 (ash 1 (1- width))))))
1269 (funcall f (sb-sys:int-sap (ash 1 (1- width))))))))
1271 (with-test (:name :&more-bounds)
1272 ;; lp#1154946
1273 (assert (not (funcall (compile nil '(lambda (&rest args) (car args))))))
1274 (assert (not (funcall (compile nil '(lambda (&rest args) (nth 6 args))))))
1275 (assert (not (funcall (compile nil '(lambda (&rest args) (elt args 10))))))
1276 (assert (not (funcall (compile nil '(lambda (&rest args) (cadr args))))))
1277 (assert (not (funcall (compile nil '(lambda (&rest args) (third args)))))))