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 hppa)
 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 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))
 154     (true v)
 155     nil))
 156
 157 (defun-with-dx make-array-on-stack-1 ()
 158   (let ((v (make-array '(42) :element-type 'single-float)))
 159     (declare (dynamic-extent v))
 160     (true v)
 161     nil))
 162
 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))
 167     (true v)
 168     nil))
 169
 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))
 175     (true v)
 176     nil))
 177
 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))
 181     (true v)
 182     nil))
 183
 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))
 187     (true v)
 188     nil))
 189
 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))
 193     (true v)
 194     nil))
 195
 196 ;;; MAKE-STRUCTURE
 197
 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))
 202
 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)))))
 208
 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)))))
 214
 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)))))
 220
 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)))))
 226
 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)
 231
 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))
 236
 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)))))
 242
 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)))))
 248
 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)))))
 254
 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)))))
 260
 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)
 265
 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)))
 270
 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)))))
 276
 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)))))
 282
 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)))))
 288
 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)))))
 294
 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))
 299
 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)))
 304
 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)))))
 310
 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)))))
 316
 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)))))
 322
 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)))))
 328
 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))
 333
 334 (declaim (inline make-foo1 make-foo2 make-foo3))
 335 (defstruct foo1 x)
 336
 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)))))
 341
 342 (defstruct foo2
 343   (x 0.0 :type single-float)
 344   (y 0.0d0 :type double-float)
 345   a
 346   b
 347   c)
 348
 349 (defmacro assert-eql (expected got)
 350   `(let ((exp ,expected)
 351          (got ,got))
 352      (unless (eql exp got)
 353        (error "Expected ~S, got ~S!" exp got))))
 354
 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))))
 362
 363 ;;; Check that constants work out as argument for all relevant
 364 ;;; slot types.
 365 (defstruct foo3
 366   (a 0 :type t)
 367   (b 1 :type fixnum)
 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)))))
 379
 380 ;;; Nested DX
 381
 382 (defun-with-dx nested-dx-lists ()
 383   (let ((dx (list (list 1 2) (list 3 4))))
 384     (declare (dynamic-extent dx))
 385     (true dx)
 386     nil))
 387
 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))
 391     (true dx)
 392     nil))
 393
 394 (defun-with-dx nested-dx-not-used (x)
 395   (declare (list x))
 396   (let ((l (setf (car x) (list x x x))))
 397     (declare (dynamic-extent l))
 398     (true l)
 399     (true (length l))
 400     nil))
 401
 402 (defun-with-dx nested-evil-dx-used (x)
 403   (declare (list x))
 404   (let ((l (list x x x)))
 405     (declare (dynamic-extent l))
 406     (unwind-protect
 407          (progn
 408            (setf (car x) l)
 409            (true l))
 410       (setf (car x) nil))
 411     nil))
 412
 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)))
 417   bar)
 418
 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))
 422     (true x)))
 423
 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*)))
 429     (caar x)))
 430
 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)))))))
 435
 436 ;;; multiple uses for dx lvar
 437
 438 (defun-with-dx multiple-dx-uses ()
 439   (let ((dx (if (true t)
 440                 (list 1 2 3)
 441                 (list 2 3 4))))
 442     (declare (dynamic-extent dx))
 443     (true dx)
 444     nil))
 445
 446 ;;; handler-case and handler-bind should use DX internally
 447
 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))))
 453     (/ 2 x)))
 454
 455 (defun dx-handler-case (x)
 456   (assert (zerop (handler-case (/ 2 x)
 457                    (error (c)
 458                      (break "OOPS: ~S caused ~S" x c))
 459                    (:no-error (res)
 460                      (1- res))))))
 461
 462 ;;; with-spinlock and with-mutex should use DX and not cons
 463
 464 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
 465
 466 (defun test-spinlock ()
 467   (sb-thread::with-spinlock (*slock*)
 468     (true *slock*)))
 469
 470 (defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
 471
 472 (defun test-mutex ()
 473   (sb-thread:with-mutex (*mutex*)
 474     (true *mutex*)))
 475
 476 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
 477
 478 (defvar *table* (make-hash-table))
 479
 480 (defun test-hash-table ()
 481   (setf (gethash 5 *table*) 13)
 482   (gethash 5 *table*))
 483 \f
 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))
 490     (dotimes (i times)
 491       (funcall thunk))
 492     (assert (< (- (get-bytes-consed) before) times))))
 493
 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))
 500     (dotimes (i times)
 501       (funcall thunk))
 502     (assert (not (< (- (get-bytes-consed) before) times)))))
 503
 504 (defvar *a-cons* (cons nil nil))
 505
 506 (progn
 507   #+stack-allocatable-closures
 508   (assert-no-consing (dxclosure 42))
 509   #+stack-allocatable-lists
 510   (progn
 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-subst2 17))
 517     (assert-no-consing (test-lvar-subst 11))
 518     (assert-no-consing (nested-dx-lists))
 519     (assert-consing (nested-dx-not-used *a-cons*))
 520     (assert-no-consing (nested-evil-dx-used *a-cons*))
 521     (assert-no-consing (multiple-dx-uses)))
 522   (assert-no-consing (dx-value-cell 13))
 523   #+stack-allocatable-fixed-objects
 524   (progn
 525     (assert-no-consing (cons-on-stack 42))
 526     (assert-no-consing (make-foo1-on-stack 123))
 527     (assert-no-consing (nested-good 42))
 528     (assert-no-consing (nested-dx-conses))
 529     (assert-no-consing (dx-handler-bind 2))
 530     (assert-no-consing (dx-handler-case 2)))
 531   #+stack-allocatable-vectors
 532   (progn
 533     (assert-no-consing (force-make-array-on-stack 128))
 534     (assert-no-consing (make-array-on-stack-1))
 535     (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
 536     (assert-no-consing (make-array-on-stack-3 9 8 7))
 537     (assert-no-consing (make-array-on-stack-4))
 538     (assert-no-consing (make-array-on-stack-5))
 539     (assert-no-consing (vector-on-stack :x :y)))
 540   (let (a b)
 541     (setf a 1.24 b 1.23d0)
 542     (#+raw-instance-init-vops assert-no-consing
 543      #-raw-instance-init-vops progn
 544      (make-foo2-on-stack a b)))
 545   (#+raw-instance-init-vops assert-no-consing
 546    #-raw-instance-init-vops progn
 547    (make-foo3-on-stack))
 548   ;; Not strictly DX..
 549   (assert-no-consing (test-hash-table))
 550   #+sb-thread
 551   (progn
 552     (assert-no-consing (test-spinlock))
 553     (assert-no-consing (test-mutex))))
 554
 555 \f
 556 ;;; Bugs found by Paul F. Dietz
 557 (assert
 558  (eq
 559   (funcall
 560    (compile
 561     nil
 562     '(lambda (a b)
 563       (declare (optimize (speed 2) (space 0) (safety 0)
 564                 (debug 1) (compilation-speed 3)))
 565       (let* ((v5 (cons b b)))
 566         (declare (dynamic-extent v5))
 567         a)))
 568    'x 'y)
 569   'x))
 570
 571 \f
 572 ;;; other bugs
 573
 574 ;;; bug reported by Svein Ove Aas
 575 (defun svein-2005-ii-07 (x y)
 576   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 577   (let ((args (list* y 1 2 x)))
 578     (declare (dynamic-extent args))
 579     (apply #'aref args)))
 580 (assert (eql
 581          (svein-2005-ii-07
 582           '(0)
 583           #3A(((1 1 1) (1 1 1) (1 1 1))
 584               ((1 1 1) (1 1 1) (4 1 1))
 585               ((1 1 1) (1 1 1) (1 1 1))))
 586          4))
 587
 588 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 589 ;;; filled with zeroes.
 590 (defun-with-dx bdowning-2005-iv-16 ()
 591   (let ((a (make-array 11 :initial-element 0)))
 592     (declare (dynamic-extent a))
 593     (assert (every (lambda (x) (eql x 0)) a))))
 594 (with-test (:name :bdowning-2005-iv-16)
 595   #+(or hppa mips x86 x86-64)
 596   (assert-no-consing (bdowning-2005-iv-16))
 597   (bdowning-2005-iv-16))
 598
 599 (declaim (inline my-nconc))
 600 (defun-with-dx my-nconc (&rest lists)
 601   (declare (dynamic-extent lists))
 602   (apply #'nconc lists))
 603 (defun-with-dx my-nconc-caller (a b c)
 604   (let ((l1 (list a b c))
 605         (l2 (list a b c)))
 606     (my-nconc l1 l2)))
 607 (with-test (:name :rest-stops-the-buck)
 608   (let ((list1 (my-nconc-caller 1 2 3))
 609         (list2 (my-nconc-caller 9 8 7)))
 610     (assert (equal list1 '(1 2 3 1 2 3)))
 611     (assert (equal list2 '(9 8 7 9 8 7)))))
 612
 613 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
 614   (let* ((a (list x y z))
 615          (b (list x y z))
 616          (c (list a b)))
 617     (declare (dynamic-extent c))
 618     (values (first c) (second c))))
 619 (with-test (:name :let-converted-vars-dx-allocated-bug)
 620   (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
 621     (assert (and (equal i j)
 622                  (equal i (list 1 2 3))))))
 623
 624 ;;; workaround for bug 419 -- real issue remains, but check that the
 625 ;;; bandaid holds.
 626 (defun-with-dx bug419 (x)
 627   (multiple-value-call #'list
 628     (eval '(values 1 2 3))
 629     (let ((x x))
 630       (declare (dynamic-extent x))
 631       (flet ((mget (y)
 632                (+ x y))
 633              (mset (z)
 634                (incf x z)))
 635         (declare (dynamic-extent #'mget #'mset))
 636         ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
 637 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
 638
 639 ;;; Multiple DX arguments in a local function call
 640 (defun test-dx-flet-test (fun n f1 f2 f3)
 641   (let ((res (with-output-to-string (s)
 642                (assert (eql n (ignore-errors (funcall fun s)))))))
 643     (multiple-value-bind (x pos) (read-from-string res nil)
 644       (assert (equalp f1 x))
 645       (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos)
 646         (assert (equalp f2 y))
 647         (assert (equalp f3 (read-from-string res nil nil :start pos2))))))
 648   #+(or hppa mips x86 x86-64)
 649   (assert-no-consing (assert (eql n (funcall fun nil))))
 650   (assert (eql n (funcall fun nil))))
 651 (macrolet ((def (n f1 f2 f3)
 652              (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n)))
 653                `(progn
 654                   (defun-with-dx ,name (s)
 655                     (flet ((f (x)
 656                              (declare (dynamic-extent x))
 657                              (when s
 658                                (print x s)
 659                                (finish-output s))
 660                              nil))
 661                       (f ,f1)
 662                       (f ,f2)
 663                       (f ,f3)
 664                       ,n))
 665                   (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3)))))
 666   (def 0 (list :one) (list :two) (list :three))
 667   (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list))
 668   (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
 669
 670 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
 671 (defun test-update-uvl-live-sets (x y z)
 672  (declare (optimize speed (safety 0)))
 673  (flet ((bar (a b)
 674           (declare (dynamic-extent a))
 675           (eval `(list (length ',a) ',b))))
 676    (list (bar x y)
 677          (bar (list x y z)                  ; dx push
 678               (list
 679                (multiple-value-call 'list
 680                  (eval '(values 1 2 3))     ; uv push
 681                  (max y z)
 682                )                            ; uv pop
 683                14)
 684          ))))
 685 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
 686
 687 (with-test (:name :regression-1.0.23.38)
 688   (compile nil '(lambda ()
 689                  (flet ((make (x y)
 690                           (let ((res (cons x x)))
 691                             (setf (cdr res) y)
 692                             res)))
 693                    (declaim (inline make))
 694                    (let ((z (make 1 2)))
 695                      (declare (dynamic-extent z))
 696                      (print z)
 697                      t))))
 698   (compile nil '(lambda ()
 699                  (flet ((make (x y)
 700                           (let ((res (cons x x)))
 701                             (setf (cdr res) y)
 702                             (if x res y))))
 703                    (declaim (inline make))
 704                    (let ((z (make 1 2)))
 705                      (declare (dynamic-extent z))
 706                      (print z)
 707                      t)))))
 708
 709 ;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
 710 ;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
 711 ;;; location, leading to all manner of badness. ...reproducing this
 712 ;;; reliably is hard, but this it at least used to break on x86-64.
 713 (defun length-and-words-packed-in-same-tn (m)
 714   (declare (optimize speed (safety 0) (debug 0) (space 0)))
 715   (let ((array (make-array (max 1 m) :element-type 'fixnum)))
 716     (declare (dynamic-extent array))
 717     (array-total-size array)))
 718 (with-test (:name :length-and-words-packed-in-same-tn)
 719   (assert (= 1 (length-and-words-packed-in-same-tn -3))))
 720
 721 (with-test (:name :handler-case-bogus-compiler-note)
 722   (handler-bind ((compiler-note #'error))
 723     ;; Taken from SWANK, used to signal a bogus stack allocation
 724     ;; failure note.
 725     (compile nil
 726              `(lambda (files fasl-dir load)
 727                 (let ((needs-recompile nil))
 728                   (dolist (src files)
 729                     (let ((dest (binary-pathname src fasl-dir)))
 730                       (handler-case
 731                           (progn
 732                             (when (or needs-recompile
 733                                       (not (probe-file dest))
 734                                       (file-newer-p src dest))
 735                               (setq needs-recompile t)
 736                               (ensure-directories-exist dest)
 737                               (compile-file src :output-file dest :print nil :verbose t))
 738                             (when load
 739                               (load dest :verbose t)))
 740                         (serious-condition (c)
 741                           (handle-loadtime-error c dest))))))))))
 742
 743 (declaim (inline foovector barvector))
 744 (defun foovector (x y z)
 745   (let ((v (make-array 3)))
 746     (setf (aref v 0) x
 747           (aref v 1) y
 748           (aref v 2) z)
 749     v))
 750 (defun barvector (x y z)
 751   (make-array 3 :initial-contents (list x y z)))
 752 (with-test (:name :dx-compiler-notes)
 753   (flet ((assert-notes (j lambda)
 754            (let ((n 0))
 755              (handler-bind ((compiler-note (lambda (c)
 756                                              (declare (ignore cc))
 757                                              (incf n))))
 758                (compile nil lambda)
 759                (unless (= j n)
 760                  (error "Wanted ~S notes, got ~S for~%   ~S"
 761                         j n lambda))))))
 762     ;; These ones should complain.
 763     (assert-notes 1 `(lambda (x)
 764                        (let ((v (make-array x)))
 765                          (declare (dynamic-extent v))
 766                          (length v))))
 767     (assert-notes 2 `(lambda (x)
 768                        (let ((y (if (plusp x)
 769                                     (true x)
 770                                     (true (- x)))))
 771                          (declare (dynamic-extent y))
 772                          (print y)
 773                          nil)))
 774     (assert-notes 1 `(lambda (x)
 775                        (let ((y (foovector x x x)))
 776                          (declare (sb-int:truly-dynamic-extent y))
 777                          (print y)
 778                          nil)))
 779     ;; These ones should not complain.
 780     (assert-notes 0 `(lambda (name)
 781                        (with-alien
 782                            ((posix-getenv (function c-string c-string)
 783                                           :EXTERN "getenv"))
 784                          (values
 785                           (alien-funcall posix-getenv name)))))
 786     (assert-notes 0 `(lambda (x)
 787                        (let ((y (barvector x x x)))
 788                          (declare (dynamic-extent y))
 789                          (print y)
 790                          nil)))
 791     (assert-notes 0 `(lambda (list)
 792                        (declare (optimize (space 0)))
 793                        (sort list #'<)))
 794     (assert-notes 0 `(lambda (other)
 795                        #'(lambda (s c n)
 796                            (ignore-errors (funcall other s c n)))))))
 797
 798 ;;; Stack allocating a value cell in HANDLER-CASE would blow up stack
 799 ;;; in an unfortunate loop.
 800 (defun handler-case-eating-stack ()
 801   (let ((sp nil))
 802     (do ((n 0 (logand most-positive-fixnum (1+ n))))
 803         ((>= n 1024))
 804      (multiple-value-bind (value error) (ignore-errors)
 805        (when (and value error) nil))
 806       (if sp
 807           (assert (= sp (sb-c::%primitive sb-c:current-stack-pointer)))
 808           (setf sp (sb-c::%primitive sb-c:current-stack-pointer))))))
 809 (with-test (:name :handler-case-eating-stack)
 810   (assert-no-consing (handler-case-eating-stack)))
 811
 812 ;;; A nasty bug where RECHECK-DYNAMIC-EXTENT-LVARS thought something was going
 813 ;;; to be stack allocated when it was not, leading to a bogus %NIP-VALUES.
 814 ;;; Fixed by making RECHECK-DYNAMIC-EXTENT-LVARS deal properly with nested DX.
 815 (deftype vec ()
 816   `(simple-array single-float (3)))
 817 (declaim (ftype (function (t t t) vec) vec))
 818 (declaim (inline vec))
 819 (defun vec (a b c)
 820   (make-array 3 :element-type 'single-float :initial-contents (list a b c)))
 821 (defun bad-boy (vec)
 822   (declare (type vec vec))
 823   (lambda (fun)
 824     (let ((vec (vec (aref vec 0) (aref vec 1) (aref vec 2))))
 825       (declare (dynamic-extent vec))
 826       (funcall fun vec))))
 827 (with-test (:name :recheck-nested-dx-bug)
 828   (assert (funcall (bad-boy (vec 1.0 2.0 3.3))
 829                    (lambda (vec) (equalp vec (vec 1.0 2.0 3.3)))))
 830   (flet ((foo (x) (declare (ignore x))))
 831     (let ((bad-boy (bad-boy (vec 2.0 3.0 4.0))))
 832       (assert-no-consing (funcall bad-boy #'foo)))))
 833 \f