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 ;;; Unfortunately VECTOR-FILL* conses right now, so this one
 185 ;;; doesn't pass yet.
 186 #+nil
 187 (defun-with-dx make-array-on-stack-5 ()
 188   (let ((v (make-array 3 :initial-element 12 :element-type t)))
 189     (declare (sb-int:truly-dynamic-extent v))
 190     (true v)
 191     nil))
 192
 193 (defun-with-dx vector-on-stack (x y)
 194   (let ((v (vector 1 x 2 y 3)))
 195     (declare (sb-int:truly-dynamic-extent v))
 196     (true v)
 197     nil))
 198
 199 ;;; MAKE-STRUCTURE
 200
 201 (declaim (inline make-fp-struct-1))
 202 (defstruct fp-struct-1
 203   (s 0.0 :type single-float)
 204   (d 0.0d0 :type double-float))
 205
 206 (defun-with-dx test-fp-struct-1.1 (s d)
 207   (let ((fp (make-fp-struct-1 :s s)))
 208     (declare (dynamic-extent fp))
 209     (assert (eql s (fp-struct-1-s fp)))
 210     (assert (eql 0.0d0 (fp-struct-1-d fp)))))
 211
 212 (defun-with-dx test-fp-struct-1.2 (s d)
 213   (let ((fp (make-fp-struct-1 :d d)))
 214     (declare (dynamic-extent fp))
 215     (assert (eql 0.0 (fp-struct-1-s fp)))
 216     (assert (eql d (fp-struct-1-d fp)))))
 217
 218 (defun-with-dx test-fp-struct-1.3 (s d)
 219   (let ((fp (make-fp-struct-1 :d d :s s)))
 220     (declare (dynamic-extent fp))
 221     (assert (eql s (fp-struct-1-s fp)))
 222     (assert (eql d (fp-struct-1-d fp)))))
 223
 224 (defun-with-dx test-fp-struct-1.4 (s d)
 225   (let ((fp (make-fp-struct-1 :s s :d d)))
 226     (declare (dynamic-extent fp))
 227     (assert (eql s (fp-struct-1-s fp)))
 228     (assert (eql d (fp-struct-1-d fp)))))
 229
 230 (test-fp-struct-1.1 123.456 876.243d0)
 231 (test-fp-struct-1.2 123.456 876.243d0)
 232 (test-fp-struct-1.3 123.456 876.243d0)
 233 (test-fp-struct-1.4 123.456 876.243d0)
 234
 235 (declaim (inline make-fp-struct-2))
 236 (defstruct fp-struct-2
 237   (d 0.0d0 :type double-float)
 238   (s 0.0 :type single-float))
 239
 240 (defun-with-dx test-fp-struct-2.1 (s d)
 241   (let ((fp (make-fp-struct-2 :s s)))
 242     (declare (dynamic-extent fp))
 243     (assert (eql s (fp-struct-2-s fp)))
 244     (assert (eql 0.0d0 (fp-struct-2-d fp)))))
 245
 246 (defun-with-dx test-fp-struct-2.2 (s d)
 247   (let ((fp (make-fp-struct-2 :d d)))
 248     (declare (dynamic-extent fp))
 249     (assert (eql 0.0 (fp-struct-2-s fp)))
 250     (assert (eql d (fp-struct-2-d fp)))))
 251
 252 (defun-with-dx test-fp-struct-2.3 (s d)
 253   (let ((fp (make-fp-struct-2 :d d :s s)))
 254     (declare (dynamic-extent fp))
 255     (assert (eql s (fp-struct-2-s fp)))
 256     (assert (eql d (fp-struct-2-d fp)))))
 257
 258 (defun-with-dx test-fp-struct-2.4 (s d)
 259   (let ((fp (make-fp-struct-2 :s s :d d)))
 260     (declare (dynamic-extent fp))
 261     (assert (eql s (fp-struct-2-s fp)))
 262     (assert (eql d (fp-struct-2-d fp)))))
 263
 264 (test-fp-struct-2.1 123.456 876.243d0)
 265 (test-fp-struct-2.2 123.456 876.243d0)
 266 (test-fp-struct-2.3 123.456 876.243d0)
 267 (test-fp-struct-2.4 123.456 876.243d0)
 268
 269 (declaim (inline make-cfp-struct-1))
 270 (defstruct cfp-struct-1
 271   (s (complex 0.0) :type (complex single-float))
 272   (d (complex 0.0d0) :type (complex double-float)))
 273
 274 (defun-with-dx test-cfp-struct-1.1 (s d)
 275   (let ((cfp (make-cfp-struct-1 :s s)))
 276     (declare (dynamic-extent cfp))
 277     (assert (eql s (cfp-struct-1-s cfp)))
 278     (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
 279
 280 (defun-with-dx test-cfp-struct-1.2 (s d)
 281   (let ((cfp (make-cfp-struct-1 :d d)))
 282     (declare (dynamic-extent cfp))
 283     (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
 284     (assert (eql d (cfp-struct-1-d cfp)))))
 285
 286 (defun-with-dx test-cfp-struct-1.3 (s d)
 287   (let ((cfp (make-cfp-struct-1 :d d :s s)))
 288     (declare (dynamic-extent cfp))
 289     (assert (eql s (cfp-struct-1-s cfp)))
 290     (assert (eql d (cfp-struct-1-d cfp)))))
 291
 292 (defun-with-dx test-cfp-struct-1.4 (s d)
 293   (let ((cfp (make-cfp-struct-1 :s s :d d)))
 294     (declare (dynamic-extent cfp))
 295     (assert (eql s (cfp-struct-1-s cfp)))
 296     (assert (eql d (cfp-struct-1-d cfp)))))
 297
 298 (test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 299 (test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 300 (test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 301 (test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 302
 303 (declaim (inline make-cfp-struct-2))
 304 (defstruct cfp-struct-2
 305   (d (complex 0.0d0) :type (complex double-float))
 306   (s (complex 0.0) :type (complex single-float)))
 307
 308 (defun-with-dx test-cfp-struct-2.1 (s d)
 309   (let ((cfp (make-cfp-struct-2 :s s)))
 310     (declare (dynamic-extent cfp))
 311     (assert (eql s (cfp-struct-2-s cfp)))
 312     (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
 313
 314 (defun-with-dx test-cfp-struct-2.2 (s d)
 315   (let ((cfp (make-cfp-struct-2 :d d)))
 316     (declare (dynamic-extent cfp))
 317     (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
 318     (assert (eql d (cfp-struct-2-d cfp)))))
 319
 320 (defun-with-dx test-cfp-struct-2.3 (s d)
 321   (let ((cfp (make-cfp-struct-2 :d d :s s)))
 322     (declare (dynamic-extent cfp))
 323     (assert (eql s (cfp-struct-2-s cfp)))
 324     (assert (eql d (cfp-struct-2-d cfp)))))
 325
 326 (defun-with-dx test-cfp-struct-2.4 (s d)
 327   (let ((cfp (make-cfp-struct-2 :s s :d d)))
 328     (declare (dynamic-extent cfp))
 329     (assert (eql s (cfp-struct-2-s cfp)))
 330     (assert (eql d (cfp-struct-2-d cfp)))))
 331
 332 (test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 333 (test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 334 (test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 335 (test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 336
 337 (declaim (inline make-foo1 make-foo2 make-foo3))
 338 (defstruct foo1 x)
 339
 340 (defun-with-dx make-foo1-on-stack (x)
 341   (let ((foo (make-foo1 :x x)))
 342     (declare (dynamic-extent foo))
 343     (assert (eql x (foo1-x foo)))))
 344
 345 (defstruct foo2
 346   (x 0.0 :type single-float)
 347   (y 0.0d0 :type double-float)
 348   a
 349   b
 350   c)
 351
 352 (defmacro assert-eql (expected got)
 353   `(let ((exp ,expected)
 354          (got ,got))
 355      (unless (eql exp got)
 356        (error "Expected ~S, got ~S!" exp got))))
 357
 358 (defun-with-dx make-foo2-on-stack (x y)
 359   (let ((foo (make-foo2 :y y :c 'c)))
 360     (declare (dynamic-extent foo))
 361     (assert-eql 0.0 (foo2-x foo))
 362     (assert-eql y (foo2-y foo))
 363     (assert-eql 'c (foo2-c foo))
 364     (assert-eql nil (foo2-b foo))))
 365
 366 ;;; Check that constants work out as argument for all relevant
 367 ;;; slot types.
 368 (defstruct foo3
 369   (a 0 :type t)
 370   (b 1 :type fixnum)
 371   (c 2 :type sb-vm:word)
 372   (d 3.0 :type single-float)
 373   (e 4.0d0 :type double-float))
 374 (defun-with-dx make-foo3-on-stack ()
 375   (let ((foo (make-foo3)))
 376     (declare (dynamic-extent foo))
 377     (assert (eql 0 (foo3-a foo)))
 378     (assert (eql 1 (foo3-b foo)))
 379     (assert (eql 2 (foo3-c foo)))
 380     (assert (eql 3.0 (foo3-d foo)))
 381     (assert (eql 4.0d0 (foo3-e foo)))))
 382
 383 ;;; Nested DX
 384
 385 (defun-with-dx nested-dx-lists ()
 386   (let ((dx (list (list 1 2) (list 3 4))))
 387     (declare (dynamic-extent dx))
 388     (true dx)
 389     nil))
 390
 391 (defun-with-dx nested-dx-conses ()
 392   (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
 393     (declare (dynamic-extent dx))
 394     (true dx)
 395     nil))
 396
 397 (defun-with-dx nested-dx-not-used (x)
 398   (declare (list x))
 399   (let ((l (setf (car x) (list x x x))))
 400     (declare (dynamic-extent l))
 401     (true l)
 402     (true (length l))
 403     nil))
 404
 405 (defun-with-dx nested-evil-dx-used (x)
 406   (declare (list x))
 407   (let ((l (list x x x)))
 408     (declare (dynamic-extent l))
 409     (unwind-protect
 410          (progn
 411            (setf (car x) l)
 412            (true l))
 413       (setf (car x) nil))
 414     nil))
 415
 416 (defparameter *bar* nil)
 417 (declaim (inline make-nested-bad make-nested-good))
 418 (defstruct (nested (:constructor make-nested-bad (&key bar &aux (bar (setf *bar* bar))))
 419                    (:constructor make-nested-good (&key bar)))
 420   bar)
 421
 422 (defun-with-dx nested-good (y)
 423   (let ((x (list (list (make-nested-good :bar (list (list (make-nested-good :bar (list y)))))))))
 424     (declare (dynamic-extent x))
 425     (true x)))
 426
 427 (defun-with-dx nested-bad (y)
 428   (let ((x (list (list (make-nested-bad :bar (list (list (make-nested-bad :bar (list y)))))))))
 429     (declare (dynamic-extent x))
 430     (unless (equalp (caar x) (make-nested-good :bar *bar*))
 431       (error "got ~S, wanted ~S" (caar x) (make-nested-good :bar *bar*)))
 432     (caar x)))
 433
 434 (with-test (:name :conservative-nested-dx)
 435   ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
 436   (assert (equalp (nested-bad 42) (make-nested-good :bar *bar*)))
 437   (assert (equalp *bar* (list (list (make-nested-bad :bar (list 42)))))))
 438
 439 ;;; multiple uses for dx lvar
 440
 441 (defun-with-dx multiple-dx-uses ()
 442   (let ((dx (if (true t)
 443                 (list 1 2 3)
 444                 (list 2 3 4))))
 445     (declare (dynamic-extent dx))
 446     (true dx)
 447     nil))
 448
 449 ;;; handler-case and handler-bind should use DX internally
 450
 451 (defun dx-handler-bind (x)
 452   (handler-bind ((error
 453                   (lambda (c) (break "OOPS: ~S caused ~S" x c)))
 454                  ((and serious-condition (not error))
 455                   #'(lambda (c) (break "OOPS2: ~S did ~S" x c))))
 456     (/ 2 x)))
 457
 458 (defun dx-handler-case (x)
 459   (assert (zerop (handler-case (/ 2 x)
 460                    (error (c)
 461                      (break "OOPS: ~S caused ~S" x c))
 462                    (:no-error (res)
 463                      (1- res))))))
 464
 465 ;;; with-spinlock and with-mutex should use DX and not cons
 466
 467 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
 468
 469 (defun test-spinlock ()
 470   (sb-thread::with-spinlock (*slock*)
 471     (true *slock*)))
 472
 473 (defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
 474
 475 (defun test-mutex ()
 476   (sb-thread:with-mutex (*mutex*)
 477     (true *mutex*)))
 478
 479 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
 480
 481 (defvar *table* (make-hash-table))
 482
 483 (defun test-hash-table ()
 484   (setf (gethash 5 *table*) 13)
 485   (gethash 5 *table*))
 486 \f
 487 (defmacro assert-no-consing (form &optional times)
 488   `(%assert-no-consing (lambda () ,form) ,times))
 489 (defun %assert-no-consing (thunk &optional times)
 490   (let ((before (get-bytes-consed))
 491         (times (or times 10000)))
 492     (declare (type (integer 1 *) times))
 493     (dotimes (i times)
 494       (funcall thunk))
 495     (assert (< (- (get-bytes-consed) before) times))))
 496
 497 (defmacro assert-consing (form &optional times)
 498   `(%assert-consing (lambda () ,form) ,times))
 499 (defun %assert-consing (thunk &optional times)
 500   (let ((before (get-bytes-consed))
 501         (times (or times 10000)))
 502     (declare (type (integer 1 *) times))
 503     (dotimes (i times)
 504       (funcall thunk))
 505     (assert (not (< (- (get-bytes-consed) before) times)))))
 506
 507 (defvar *a-cons* (cons nil nil))
 508
 509 #+(or x86 x86-64 alpha ppc sparc mips hppa)
 510 (progn
 511   (assert-no-consing (dxclosure 42))
 512   (assert-no-consing (dxlength 1 2 3))
 513   (assert-no-consing (dxlength t t t t t t))
 514   (assert-no-consing (dxlength))
 515   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 516   (assert-no-consing (test-nip-values))
 517   (assert-no-consing (test-let-var-subst1 17))
 518   (assert-no-consing (test-let-var-subst2 17))
 519   (assert-no-consing (test-lvar-subst 11))
 520   (assert-no-consing (dx-value-cell 13))
 521   ;; Only for platforms with DX FIXED-ALLOC
 522   #+(or hppa mips x86 x86-64)
 523   (progn
 524     (assert-no-consing (cons-on-stack 42))
 525     (assert-no-consing (make-foo1-on-stack 123))
 526     (assert-no-consing (nested-good 42))
 527     (assert-no-consing (nested-dx-conses))
 528     (assert-no-consing (dx-handler-bind 2))
 529     (assert-no-consing (dx-handler-case 2)))
 530   ;; Only for platforms with DX ALLOCATE-VECTOR
 531   #+(or hppa mips x86 x86-64)
 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     #+nil
 539     (assert-no-consing (make-array-on-stack-5))
 540     (assert-no-consing (vector-on-stack :x :y)))
 541   (#+raw-instance-init-vops assert-no-consing
 542    #-raw-instance-init-vops progn
 543    (make-foo2-on-stack 1.24 1.23d0))
 544   (#+raw-instance-init-vops assert-no-consing
 545    #-raw-instance-init-vops progn
 546    (make-foo3-on-stack))
 547   (assert-no-consing (nested-dx-lists))
 548   (assert-consing (nested-dx-not-used *a-cons*))
 549   (assert-no-consing (nested-evil-dx-used *a-cons*))
 550   (assert-no-consing (multiple-dx-uses))
 551   ;; Not strictly DX..
 552   (assert-no-consing (test-hash-table))
 553   #+sb-thread
 554   (progn
 555     (assert-no-consing (test-spinlock))
 556     (assert-no-consing (test-mutex))))
 557
 558 \f
 559 ;;; Bugs found by Paul F. Dietz
 560 (assert
 561  (eq
 562   (funcall
 563    (compile
 564     nil
 565     '(lambda (a b)
 566       (declare (optimize (speed 2) (space 0) (safety 0)
 567                 (debug 1) (compilation-speed 3)))
 568       (let* ((v5 (cons b b)))
 569         (declare (dynamic-extent v5))
 570         a)))
 571    'x 'y)
 572   'x))
 573
 574 \f
 575 ;;; other bugs
 576
 577 ;;; bug reported by Svein Ove Aas
 578 (defun svein-2005-ii-07 (x y)
 579   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 580   (let ((args (list* y 1 2 x)))
 581     (declare (dynamic-extent args))
 582     (apply #'aref args)))
 583 (assert (eql
 584          (svein-2005-ii-07
 585           '(0)
 586           #3A(((1 1 1) (1 1 1) (1 1 1))
 587               ((1 1 1) (1 1 1) (4 1 1))
 588               ((1 1 1) (1 1 1) (1 1 1))))
 589          4))
 590
 591 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 592 ;;; filled with zeroes.
 593 (defun-with-dx bdowning-2005-iv-16 ()
 594   (let ((a (make-array 11 :initial-element 0)))
 595     (declare (dynamic-extent a))
 596     (assert (every (lambda (x) (eql x 0)) a))))
 597 (with-test (:name :bdowning-2005-iv-16)
 598   #+(or hppa mips x86 x86-64)
 599   (assert-no-consing (bdowning-2005-iv-16))
 600   (bdowning-2005-iv-16))
 601
 602 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
 603   (let* ((a (list x y z))
 604          (b (list x y z))
 605          (c (list a b)))
 606     (declare (dynamic-extent c))
 607     (values (first c) (second c))))
 608
 609 (with-test (:name :let-converted-vars-dx-allocated-bug)
 610   (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
 611     (assert (and (equal i j)
 612                  (equal i (list 1 2 3))))))
 613
 614 ;;; workaround for bug 419 -- real issue remains, but check that the
 615 ;;; bandaid holds.
 616 (defun-with-dx bug419 (x)
 617   (multiple-value-call #'list
 618     (eval '(values 1 2 3))
 619     (let ((x x))
 620       (declare (dynamic-extent x))
 621       (flet ((mget (y)
 622                (+ x y))
 623              (mset (z)
 624                (incf x z)))
 625         (declare (dynamic-extent #'mget #'mset))
 626         ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
 627 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
 628
 629 ;;; Multiple DX arguments in a local function call
 630 (defun test-dx-flet-test (fun n f1 f2 f3)
 631   (let ((res (with-output-to-string (s)
 632                (assert (eql n (ignore-errors (funcall fun s)))))))
 633     (multiple-value-bind (x pos) (read-from-string res nil)
 634       (assert (equalp f1 x))
 635       (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos)
 636         (assert (equalp f2 y))
 637         (assert (equalp f3 (read-from-string res nil nil :start pos2))))))
 638   #+(or hppa mips x86 x86-64)
 639   (assert-no-consing (assert (eql n (funcall fun nil))))
 640   (assert (eql n (funcall fun nil))))
 641 (macrolet ((def (n f1 f2 f3)
 642              (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n)))
 643                `(progn
 644                   (defun-with-dx ,name (s)
 645                     (flet ((f (x)
 646                              (declare (dynamic-extent x))
 647                              (when s
 648                                (print x s)
 649                                (finish-output s))
 650                              nil))
 651                       (f ,f1)
 652                       (f ,f2)
 653                       (f ,f3)
 654                       ,n))
 655                   (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3)))))
 656   (def 0 (list :one) (list :two) (list :three))
 657   (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list))
 658   (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
 659
 660 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
 661 (defun test-update-uvl-live-sets (x y z)
 662  (declare (optimize speed (safety 0)))
 663  (flet ((bar (a b)
 664           (declare (dynamic-extent a))
 665           (eval `(list (length ',a) ',b))))
 666    (list (bar x y)
 667          (bar (list x y z)                  ; dx push
 668               (list
 669                (multiple-value-call 'list
 670                  (eval '(values 1 2 3))     ; uv push
 671                  (max y z)
 672                )                            ; uv pop
 673                14)
 674          ))))
 675 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
 676
 677 (with-test (:name :regression-1.0.23.38)
 678   (compile nil '(lambda ()
 679                  (flet ((make (x y)
 680                           (let ((res (cons x x)))
 681                             (setf (cdr res) y)
 682                             res)))
 683                    (declaim (inline make))
 684                    (let ((z (make 1 2)))
 685                      (declare (dynamic-extent z))
 686                      (print z)
 687                      t))))
 688   (compile nil '(lambda ()
 689                  (flet ((make (x y)
 690                           (let ((res (cons x x)))
 691                             (setf (cdr res) y)
 692                             (if x res y))))
 693                    (declaim (inline make))
 694                    (let ((z (make 1 2)))
 695                      (declare (dynamic-extent z))
 696                      (print z)
 697                      t)))))
 698
 699 ;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
 700 ;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
 701 ;;; location, leading to all manner of badness. ...reproducing this
 702 ;;; reliably is hard, but this it at least used to break on x86-64.
 703 (defun length-and-words-packed-in-same-tn (m)
 704   (declare (optimize speed (safety 0) (debug 0) (space 0)))
 705   (let ((array (make-array (max 1 m) :element-type 'fixnum)))
 706     (declare (dynamic-extent array))
 707     (array-total-size array)))
 708 (with-test (:name :length-and-words-packed-in-same-tn)
 709   (assert (= 1 (length-and-words-packed-in-same-tn -3))))
 710
 711 (with-test (:name :handler-case-bogus-compiler-note)
 712   (handler-bind ((compiler-note #'error))
 713     ;; Taken from SWANK, used to signal a bogus stack allocation
 714     ;; failure note.
 715     (compile nil
 716              `(lambda (files fasl-dir load)
 717                 (let ((needs-recompile nil))
 718                   (dolist (src files)
 719                     (let ((dest (binary-pathname src fasl-dir)))
 720                       (handler-case
 721                           (progn
 722                             (when (or needs-recompile
 723                                       (not (probe-file dest))
 724                                       (file-newer-p src dest))
 725                               (setq needs-recompile t)
 726                               (ensure-directories-exist dest)
 727                               (compile-file src :output-file dest :print nil :verbose t))
 728                             (when load
 729                               (load dest :verbose t)))
 730                         (serious-condition (c)
 731                           (handle-loadtime-error c dest))))))))))
 732
 733 (declaim (inline foovector barvector))
 734 (defun foovector (x y z)
 735   (let ((v (make-array 3)))
 736     (setf (aref v 0) x
 737           (aref v 1) y
 738           (aref v 2) z)
 739     v))
 740 (defun barvector (x y z)
 741   (make-array 3 :initial-contents (list x y z)))
 742 (with-test (:name :dx-compiler-notes)
 743   (flet ((assert-notes (j lambda)
 744            (let ((n 0))
 745              (handler-bind ((compiler-note (lambda (c)
 746                                              (declare (ignore cc))
 747                                              (incf n))))
 748                (compile nil lambda)
 749                (unless (= j n)
 750                  (error "Wanted ~S notes, got ~S for~%   ~S"
 751                         j n lambda))))))
 752     ;; These ones should complain.
 753     (assert-notes 1 `(lambda (x)
 754                        (let ((v (make-array x)))
 755                          (declare (dynamic-extent v))
 756                          (length v))))
 757     (assert-notes 2 `(lambda (x)
 758                        (let ((y (if (plusp x)
 759                                     (true x)
 760                                     (true (- x)))))
 761                          (declare (dynamic-extent y))
 762                          (print y)
 763                          nil)))
 764     (assert-notes 1 `(lambda (x)
 765                        (let ((y (foovector x x x)))
 766                          (declare (sb-int:truly-dynamic-extent y))
 767                          (print y)
 768                          nil)))
 769     ;; These ones should not complain.
 770     (assert-notes 0 `(lambda (name)
 771                        (with-alien
 772                            ((posix-getenv (function c-string c-string)
 773                                           :EXTERN "getenv"))
 774                          (values
 775                           (alien-funcall posix-getenv name)))))
 776     (assert-notes 0 `(lambda (x)
 777                        (let ((y (barvector x x x)))
 778                          (declare (dynamic-extent y))
 779                          (print y)
 780                          nil)))
 781     (assert-notes 0 `(lambda (list)
 782                        (declare (optimize (space 0)))
 783                        (sort list #'<)))
 784     (assert-notes 0 `(lambda (other)
 785                        #'(lambda (s c n)
 786                            (ignore-errors (funcall other s c n)))))))
 787 \f