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 #+(or x86 x86-64 alpha ppc sparc mips hppa)
 507 (progn
 508   (assert-no-consing (dxclosure 42))
 509   (assert-no-consing (dxlength 1 2 3))
 510   (assert-no-consing (dxlength t t t t t t))
 511   (assert-no-consing (dxlength))
 512   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 513   (assert-no-consing (test-nip-values))
 514   (assert-no-consing (test-let-var-subst1 17))
 515   (assert-no-consing (test-let-var-subst2 17))
 516   (assert-no-consing (test-lvar-subst 11))
 517   (assert-no-consing (dx-value-cell 13))
 518   ;; Only for platforms with DX FIXED-ALLOC
 519   #+(or hppa mips x86 x86-64)
 520   (progn
 521     (assert-no-consing (cons-on-stack 42))
 522     (assert-no-consing (make-foo1-on-stack 123))
 523     (assert-no-consing (nested-good 42))
 524     (assert-no-consing (nested-dx-conses))
 525     (assert-no-consing (dx-handler-bind 2))
 526     (assert-no-consing (dx-handler-case 2)))
 527   ;; Only for platforms with DX ALLOCATE-VECTOR
 528   #+(or hppa mips x86 x86-64)
 529   (progn
 530     (assert-no-consing (force-make-array-on-stack 128))
 531     (assert-no-consing (make-array-on-stack-1))
 532     (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
 533     (assert-no-consing (make-array-on-stack-3 9 8 7))
 534     (assert-no-consing (make-array-on-stack-4))
 535     (assert-no-consing (make-array-on-stack-5))
 536     (assert-no-consing (vector-on-stack :x :y)))
 537   (#+raw-instance-init-vops assert-no-consing
 538    #-raw-instance-init-vops progn
 539    (make-foo2-on-stack 1.24 1.23d0))
 540   (#+raw-instance-init-vops assert-no-consing
 541    #-raw-instance-init-vops progn
 542    (make-foo3-on-stack))
 543   (assert-no-consing (nested-dx-lists))
 544   (assert-consing (nested-dx-not-used *a-cons*))
 545   (assert-no-consing (nested-evil-dx-used *a-cons*))
 546   (assert-no-consing (multiple-dx-uses))
 547   ;; Not strictly DX..
 548   (assert-no-consing (test-hash-table))
 549   #+sb-thread
 550   (progn
 551     (assert-no-consing (test-spinlock))
 552     (assert-no-consing (test-mutex))))
 553
 554 \f
 555 ;;; Bugs found by Paul F. Dietz
 556 (assert
 557  (eq
 558   (funcall
 559    (compile
 560     nil
 561     '(lambda (a b)
 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))
 566         a)))
 567    'x 'y)
 568   'x))
 569
 570 \f
 571 ;;; other bugs
 572
 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)))
 579 (assert (eql
 580          (svein-2005-ii-07
 581           '(0)
 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))))
 585          4))
 586
 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))
 597
 598 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
 599   (let* ((a (list x y z))
 600          (b (list x y z))
 601          (c (list a b)))
 602     (declare (dynamic-extent c))
 603     (values (first c) (second c))))
 604
 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))))))
 609
 610 ;;; workaround for bug 419 -- real issue remains, but check that the
 611 ;;; bandaid holds.
 612 (defun-with-dx bug419 (x)
 613   (multiple-value-call #'list
 614     (eval '(values 1 2 3))
 615     (let ((x x))
 616       (declare (dynamic-extent x))
 617       (flet ((mget (y)
 618                (+ x y))
 619              (mset (z)
 620                (incf x z)))
 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)))
 624
 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)))
 639                `(progn
 640                   (defun-with-dx ,name (s)
 641                     (flet ((f (x)
 642                              (declare (dynamic-extent x))
 643                              (when s
 644                                (print x s)
 645                                (finish-output s))
 646                              nil))
 647                       (f ,f1)
 648                       (f ,f2)
 649                       (f ,f3)
 650                       ,n))
 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)))
 655
 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)))
 659  (flet ((bar (a b)
 660           (declare (dynamic-extent a))
 661           (eval `(list (length ',a) ',b))))
 662    (list (bar x y)
 663          (bar (list x y z)                  ; dx push
 664               (list
 665                (multiple-value-call 'list
 666                  (eval '(values 1 2 3))     ; uv push
 667                  (max y z)
 668                )                            ; uv pop
 669                14)
 670          ))))
 671 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
 672
 673 (with-test (:name :regression-1.0.23.38)
 674   (compile nil '(lambda ()
 675                  (flet ((make (x y)
 676                           (let ((res (cons x x)))
 677                             (setf (cdr res) y)
 678                             res)))
 679                    (declaim (inline make))
 680                    (let ((z (make 1 2)))
 681                      (declare (dynamic-extent z))
 682                      (print z)
 683                      t))))
 684   (compile nil '(lambda ()
 685                  (flet ((make (x y)
 686                           (let ((res (cons x x)))
 687                             (setf (cdr res) y)
 688                             (if x res y))))
 689                    (declaim (inline make))
 690                    (let ((z (make 1 2)))
 691                      (declare (dynamic-extent z))
 692                      (print z)
 693                      t)))))
 694
 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))))
 706
 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
 710     ;; failure note.
 711     (compile nil
 712              `(lambda (files fasl-dir load)
 713                 (let ((needs-recompile nil))
 714                   (dolist (src files)
 715                     (let ((dest (binary-pathname src fasl-dir)))
 716                       (handler-case
 717                           (progn
 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))
 724                             (when load
 725                               (load dest :verbose t)))
 726                         (serious-condition (c)
 727                           (handle-loadtime-error c dest))))))))))
 728
 729 (declaim (inline foovector barvector))
 730 (defun foovector (x y z)
 731   (let ((v (make-array 3)))
 732     (setf (aref v 0) x
 733           (aref v 1) y
 734           (aref v 2) z)
 735     v))
 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)
 740            (let ((n 0))
 741              (handler-bind ((compiler-note (lambda (c)
 742                                              (declare (ignore cc))
 743                                              (incf n))))
 744                (compile nil lambda)
 745                (unless (= j n)
 746                  (error "Wanted ~S notes, got ~S for~%   ~S"
 747                         j n lambda))))))
 748     ;; These ones should complain.
 749     (assert-notes 1 `(lambda (x)
 750                        (let ((v (make-array x)))
 751                          (declare (dynamic-extent v))
 752                          (length v))))
 753     (assert-notes 2 `(lambda (x)
 754                        (let ((y (if (plusp x)
 755                                     (true x)
 756                                     (true (- x)))))
 757                          (declare (dynamic-extent y))
 758                          (print y)
 759                          nil)))
 760     (assert-notes 1 `(lambda (x)
 761                        (let ((y (foovector x x x)))
 762                          (declare (sb-int:truly-dynamic-extent y))
 763                          (print y)
 764                          nil)))
 765     ;; These ones should not complain.
 766     (assert-notes 0 `(lambda (name)
 767                        (with-alien
 768                            ((posix-getenv (function c-string c-string)
 769                                           :EXTERN "getenv"))
 770                          (values
 771                           (alien-funcall posix-getenv name)))))
 772     (assert-notes 0 `(lambda (x)
 773                        (let ((y (barvector x x x)))
 774                          (declare (dynamic-extent y))
 775                          (print y)
 776                          nil)))
 777     (assert-notes 0 `(lambda (list)
 778                        (declare (optimize (space 0)))
 779                        (sort list #'<)))
 780     (assert-notes 0 `(lambda (other)
 781                        #'(lambda (s c n)
 782                            (ignore-errors (funcall other s c n)))))))
 783
 784 ;;; Stack allocating a value cell in HANDLER-CASE would blow up stack
 785 ;;; in an unfortunate loop.
 786 (defun handler-case-eating-stack ()
 787   (let ((sp nil))
 788     (do ((n 0 (logand most-positive-fixnum (1+ n))))
 789         ((>= n 1024))
 790      (multiple-value-bind (value error) (ignore-errors)
 791        (when (and value error) nil))
 792       (if sp
 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)))
 797 \f