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 (load "compiler-test-util.lisp")
  18 (use-package :ctu)
  19
  20 (setq sb-c::*check-consistency* t
  21       sb-ext:*stack-allocate-dynamic-extent* t)
  22
  23 (defmacro defun-with-dx (name arglist &body body)
  24   `(defun ,name ,arglist
  25      ,@body))
  26
  27 (declaim (notinline opaque-identity))
  28 (defun opaque-identity (x)
  29   x)
  30
  31 ;;; &REST lists
  32 (defun-with-dx dxlength (&rest rest)
  33   (declare (dynamic-extent rest))
  34   (length rest))
  35
  36 (assert (= (dxlength 1 2 3) 3))
  37 (assert (= (dxlength t t t t t t) 6))
  38 (assert (= (dxlength) 0))
  39
  40 (defun callee (list)
  41   (destructuring-bind (a b c d e f &rest g) list
  42     (+ a b c d e f (length g))))
  43
  44 (defun-with-dx dxcaller (&rest rest)
  45   (declare (dynamic-extent rest))
  46   (callee rest))
  47 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
  48
  49 (defun-with-dx dxcaller-align-1 (x &rest rest)
  50   (declare (dynamic-extent rest))
  51   (+ x (callee rest)))
  52 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
  53 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40))
  54
  55 ;;; %NIP-VALUES
  56 (defun-with-dx test-nip-values ()
  57   (flet ((bar (x &rest y)
  58            (declare (dynamic-extent y))
  59            (if (> x 0)
  60                (values x (length y))
  61                (values (car y)))))
  62     (multiple-value-call #'values
  63       (bar 1 2 3 4 5 6)
  64       (bar -1 'a 'b))))
  65
  66 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a)))
  67
  68 ;;; LET-variable substitution
  69 (defun-with-dx test-let-var-subst1 (x)
  70   (let ((y (list x (1- x))))
  71     (opaque-identity :foo)
  72     (let ((z (the list y)))
  73       (declare (dynamic-extent z))
  74       (length z))))
  75 (assert (eql (test-let-var-subst1 17) 2))
  76
  77 (defun-with-dx test-let-var-subst2 (x)
  78   (let ((y (list x (1- x))))
  79     (declare (dynamic-extent y))
  80     (opaque-identity :foo)
  81     (let ((z (the list y)))
  82       (length z))))
  83 (assert (eql (test-let-var-subst2 17) 2))
  84
  85 ;;; DX propagation through LET-return.
  86 (defun-with-dx test-lvar-subst (x)
  87   (let ((y (list x (1- x))))
  88     (declare (dynamic-extent y))
  89     (second (let ((z (the list y)))
  90               (opaque-identity :foo)
  91               z))))
  92 (assert (eql (test-lvar-subst 11) 10))
  93
  94 ;;; this code is incorrect, but the compiler should not fail
  95 (defun-with-dx test-let-var-subst-incorrect (x)
  96   (let ((y (list x (1- x))))
  97     (opaque-identity :foo)
  98     (let ((z (the list y)))
  99       (declare (dynamic-extent z))
 100       (opaque-identity :bar)
 101       z)))
 102 \f
 103 ;;; alignment
 104 (defvar *x*)
 105 (defun-with-dx test-alignment-dx-list (form)
 106   (multiple-value-prog1 (eval form)
 107     (let ((l (list 1 2 3 4)))
 108       (declare (dynamic-extent l))
 109       (setq *x* (copy-list l)))))
 110 (dotimes (n 64)
 111   (let* ((res (loop for i below n collect i))
 112          (form `(values ,@res)))
 113     (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
 114     (assert (equal *x* '(1 2 3 4)))))
 115
 116 ;;; closure
 117
 118 (declaim (notinline true))
 119 (defun true (x)
 120   (declare (ignore x))
 121   t)
 122
 123 (defun-with-dx dxclosure (x)
 124   (flet ((f (y)
 125            (+ y x)))
 126     (declare (dynamic-extent #'f))
 127     (true #'f)))
 128
 129 (assert (eq t (dxclosure 13)))
 130
 131 ;;; value-cells
 132
 133 (defun-with-dx dx-value-cell (x)
 134   ;; Not implemented everywhere, yet.
 135   #+(or x86 x86-64 mips hppa)
 136   (let ((cell x))
 137     (declare (sb-int:truly-dynamic-extent cell))
 138     (flet ((f ()
 139              (incf cell)))
 140       (declare (dynamic-extent #'f))
 141       (true #'f))))
 142
 143 ;;; CONS
 144
 145 (defun-with-dx cons-on-stack (x)
 146   (let ((cons (cons x x)))
 147     (declare (dynamic-extent cons))
 148     (true cons)
 149     nil))
 150
 151 ;;; MAKE-ARRAY
 152
 153 (defun force-make-array-on-stack (n)
 154   (declare (optimize safety))
 155   (let ((v (make-array (min n 1))))
 156     (declare (sb-int:truly-dynamic-extent v))
 157     (true v)
 158     nil))
 159
 160 (defun-with-dx make-array-on-stack-1 ()
 161   (let ((v (make-array '(42) :element-type 'single-float)))
 162     (declare (dynamic-extent v))
 163     (true v)
 164     nil))
 165
 166 (defun-with-dx make-array-on-stack-2 (n x)
 167   (declare (integer n))
 168   (let ((v (make-array n :initial-contents x)))
 169     (declare (sb-int:truly-dynamic-extent v))
 170     (true v)
 171     nil))
 172
 173 (defun-with-dx make-array-on-stack-3 (x y z)
 174   (let ((v (make-array 3
 175                        :element-type 'fixnum :initial-contents (list x y z)
 176                        :element-type t :initial-contents x)))
 177     (declare (sb-int:truly-dynamic-extent v))
 178     (true v)
 179     nil))
 180
 181 (defun-with-dx make-array-on-stack-4 ()
 182   (let ((v (make-array 3 :initial-contents '(1 2 3))))
 183     (declare (sb-int:truly-dynamic-extent v))
 184     (true v)
 185     nil))
 186
 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 (defvar *a-cons* (cons nil nil))
 488
 489 (progn
 490   #+stack-allocatable-closures
 491   (assert-no-consing (dxclosure 42))
 492   #+stack-allocatable-lists
 493   (progn
 494     (assert-no-consing (dxlength 1 2 3))
 495     (assert-no-consing (dxlength t t t t t t))
 496     (assert-no-consing (dxlength))
 497     (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 498     (assert-no-consing (test-nip-values))
 499     (assert-no-consing (test-let-var-subst2 17))
 500     (assert-no-consing (test-lvar-subst 11))
 501     (assert-no-consing (nested-dx-lists))
 502     (assert-consing (nested-dx-not-used *a-cons*))
 503     (assert-no-consing (nested-evil-dx-used *a-cons*))
 504     (assert-no-consing (multiple-dx-uses)))
 505   (assert-no-consing (dx-value-cell 13))
 506   #+stack-allocatable-fixed-objects
 507   (progn
 508     (assert-no-consing (cons-on-stack 42))
 509     (assert-no-consing (make-foo1-on-stack 123))
 510     (assert-no-consing (nested-good 42))
 511     (assert-no-consing (nested-dx-conses))
 512     (assert-no-consing (dx-handler-bind 2))
 513     (assert-no-consing (dx-handler-case 2)))
 514   #+stack-allocatable-vectors
 515   (progn
 516     (assert-no-consing (force-make-array-on-stack 128))
 517     (assert-no-consing (make-array-on-stack-1))
 518     (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
 519     (assert-no-consing (make-array-on-stack-3 9 8 7))
 520     (assert-no-consing (make-array-on-stack-4))
 521     (assert-no-consing (make-array-on-stack-5))
 522     (assert-no-consing (vector-on-stack :x :y)))
 523   (let (a b)
 524     (setf a 1.24 b 1.23d0)
 525     (#+raw-instance-init-vops assert-no-consing
 526      #-raw-instance-init-vops progn
 527      (make-foo2-on-stack a b)))
 528   (#+raw-instance-init-vops assert-no-consing
 529    #-raw-instance-init-vops progn
 530    (make-foo3-on-stack))
 531   ;; Not strictly DX..
 532   (assert-no-consing (test-hash-table))
 533   #+sb-thread
 534   (progn
 535     (assert-no-consing (test-spinlock))
 536     (assert-no-consing (test-mutex))))
 537
 538 \f
 539 ;;; Bugs found by Paul F. Dietz
 540 (assert
 541  (eq
 542   (funcall
 543    (compile
 544     nil
 545     '(lambda (a b)
 546       (declare (optimize (speed 2) (space 0) (safety 0)
 547                 (debug 1) (compilation-speed 3)))
 548       (let* ((v5 (cons b b)))
 549         (declare (dynamic-extent v5))
 550         a)))
 551    'x 'y)
 552   'x))
 553
 554 \f
 555 ;;; other bugs
 556
 557 ;;; bug reported by Svein Ove Aas
 558 (defun svein-2005-ii-07 (x y)
 559   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 560   (let ((args (list* y 1 2 x)))
 561     (declare (dynamic-extent args))
 562     (apply #'aref args)))
 563 (assert (eql
 564          (svein-2005-ii-07
 565           '(0)
 566           #3A(((1 1 1) (1 1 1) (1 1 1))
 567               ((1 1 1) (1 1 1) (4 1 1))
 568               ((1 1 1) (1 1 1) (1 1 1))))
 569          4))
 570
 571 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 572 ;;; filled with zeroes.
 573 (defun-with-dx bdowning-2005-iv-16 ()
 574   (let ((a (make-array 11 :initial-element 0)))
 575     (declare (dynamic-extent a))
 576     (assert (every (lambda (x) (eql x 0)) a))))
 577 (with-test (:name :bdowning-2005-iv-16)
 578   #+(or hppa mips x86 x86-64)
 579   (assert-no-consing (bdowning-2005-iv-16))
 580   (bdowning-2005-iv-16))
 581
 582 (declaim (inline my-nconc))
 583 (defun-with-dx my-nconc (&rest lists)
 584   (declare (dynamic-extent lists))
 585   (apply #'nconc lists))
 586 (defun-with-dx my-nconc-caller (a b c)
 587   (let ((l1 (list a b c))
 588         (l2 (list a b c)))
 589     (my-nconc l1 l2)))
 590 (with-test (:name :rest-stops-the-buck)
 591   (let ((list1 (my-nconc-caller 1 2 3))
 592         (list2 (my-nconc-caller 9 8 7)))
 593     (assert (equal list1 '(1 2 3 1 2 3)))
 594     (assert (equal list2 '(9 8 7 9 8 7)))))
 595
 596 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
 597   (let* ((a (list x y z))
 598          (b (list x y z))
 599          (c (list a b)))
 600     (declare (dynamic-extent c))
 601     (values (first c) (second c))))
 602 (with-test (:name :let-converted-vars-dx-allocated-bug)
 603   (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
 604     (assert (and (equal i j)
 605                  (equal i (list 1 2 3))))))
 606
 607 ;;; workaround for bug 419 -- real issue remains, but check that the
 608 ;;; bandaid holds.
 609 (defun-with-dx bug419 (x)
 610   (multiple-value-call #'list
 611     (eval '(values 1 2 3))
 612     (let ((x x))
 613       (declare (dynamic-extent x))
 614       (flet ((mget (y)
 615                (+ x y))
 616              (mset (z)
 617                (incf x z)))
 618         (declare (dynamic-extent #'mget #'mset))
 619         ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
 620 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
 621
 622 ;;; Multiple DX arguments in a local function call
 623 (defun test-dx-flet-test (fun n f1 f2 f3)
 624   (let ((res (with-output-to-string (s)
 625                (assert (eql n (ignore-errors (funcall fun s)))))))
 626     (multiple-value-bind (x pos) (read-from-string res nil)
 627       (assert (equalp f1 x))
 628       (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos)
 629         (assert (equalp f2 y))
 630         (assert (equalp f3 (read-from-string res nil nil :start pos2))))))
 631   #+(or hppa mips x86 x86-64)
 632   (assert-no-consing (assert (eql n (funcall fun nil))))
 633   (assert (eql n (funcall fun nil))))
 634 (macrolet ((def (n f1 f2 f3)
 635              (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n)))
 636                `(progn
 637                   (defun-with-dx ,name (s)
 638                     (flet ((f (x)
 639                              (declare (dynamic-extent x))
 640                              (when s
 641                                (print x s)
 642                                (finish-output s))
 643                              nil))
 644                       (f ,f1)
 645                       (f ,f2)
 646                       (f ,f3)
 647                       ,n))
 648                   (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3)))))
 649   (def 0 (list :one) (list :two) (list :three))
 650   (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list))
 651   (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
 652
 653 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
 654 (defun test-update-uvl-live-sets (x y z)
 655  (declare (optimize speed (safety 0)))
 656  (flet ((bar (a b)
 657           (declare (dynamic-extent a))
 658           (eval `(list (length ',a) ',b))))
 659    (list (bar x y)
 660          (bar (list x y z)                  ; dx push
 661               (list
 662                (multiple-value-call 'list
 663                  (eval '(values 1 2 3))     ; uv push
 664                  (max y z)
 665                )                            ; uv pop
 666                14)
 667          ))))
 668 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
 669
 670 (with-test (:name :regression-1.0.23.38)
 671   (compile nil '(lambda ()
 672                  (flet ((make (x y)
 673                           (let ((res (cons x x)))
 674                             (setf (cdr res) y)
 675                             res)))
 676                    (declaim (inline make))
 677                    (let ((z (make 1 2)))
 678                      (declare (dynamic-extent z))
 679                      (print z)
 680                      t))))
 681   (compile nil '(lambda ()
 682                  (flet ((make (x y)
 683                           (let ((res (cons x x)))
 684                             (setf (cdr res) y)
 685                             (if x res y))))
 686                    (declaim (inline make))
 687                    (let ((z (make 1 2)))
 688                      (declare (dynamic-extent z))
 689                      (print z)
 690                      t)))))
 691
 692 ;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
 693 ;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
 694 ;;; location, leading to all manner of badness. ...reproducing this
 695 ;;; reliably is hard, but this it at least used to break on x86-64.
 696 (defun length-and-words-packed-in-same-tn (m)
 697   (declare (optimize speed (safety 0) (debug 0) (space 0)))
 698   (let ((array (make-array (max 1 m) :element-type 'fixnum)))
 699     (declare (dynamic-extent array))
 700     (array-total-size array)))
 701 (with-test (:name :length-and-words-packed-in-same-tn)
 702   (assert (= 1 (length-and-words-packed-in-same-tn -3))))
 703
 704 (with-test (:name :handler-case-bogus-compiler-note)
 705   (handler-bind ((compiler-note #'error))
 706     ;; Taken from SWANK, used to signal a bogus stack allocation
 707     ;; failure note.
 708     (compile nil
 709              `(lambda (files fasl-dir load)
 710                 (let ((needs-recompile nil))
 711                   (dolist (src files)
 712                     (let ((dest (binary-pathname src fasl-dir)))
 713                       (handler-case
 714                           (progn
 715                             (when (or needs-recompile
 716                                       (not (probe-file dest))
 717                                       (file-newer-p src dest))
 718                               (setq needs-recompile t)
 719                               (ensure-directories-exist dest)
 720                               (compile-file src :output-file dest :print nil :verbose t))
 721                             (when load
 722                               (load dest :verbose t)))
 723                         (serious-condition (c)
 724                           (handle-loadtime-error c dest))))))))))
 725
 726 (declaim (inline foovector barvector))
 727 (defun foovector (x y z)
 728   (let ((v (make-array 3)))
 729     (setf (aref v 0) x
 730           (aref v 1) y
 731           (aref v 2) z)
 732     v))
 733 (defun barvector (x y z)
 734   (make-array 3 :initial-contents (list x y z)))
 735 (with-test (:name :dx-compiler-notes)
 736   (flet ((assert-notes (j lambda)
 737            (let ((n 0))
 738              (handler-bind ((compiler-note (lambda (c)
 739                                              (declare (ignore cc))
 740                                              (incf n))))
 741                (compile nil lambda)
 742                (unless (= j n)
 743                  (error "Wanted ~S notes, got ~S for~%   ~S"
 744                         j n lambda))))))
 745     ;; These ones should complain.
 746     (assert-notes 1 `(lambda (x)
 747                        (let ((v (make-array x)))
 748                          (declare (dynamic-extent v))
 749                          (length v))))
 750     (assert-notes 2 `(lambda (x)
 751                        (let ((y (if (plusp x)
 752                                     (true x)
 753                                     (true (- x)))))
 754                          (declare (dynamic-extent y))
 755                          (print y)
 756                          nil)))
 757     (assert-notes 1 `(lambda (x)
 758                        (let ((y (foovector x x x)))
 759                          (declare (sb-int:truly-dynamic-extent y))
 760                          (print y)
 761                          nil)))
 762     ;; These ones should not complain.
 763     (assert-notes 0 `(lambda (name)
 764                        (with-alien
 765                            ((posix-getenv (function c-string c-string)
 766                                           :EXTERN "getenv"))
 767                          (values
 768                           (alien-funcall posix-getenv name)))))
 769     (assert-notes 0 `(lambda (x)
 770                        (let ((y (barvector x x x)))
 771                          (declare (dynamic-extent y))
 772                          (print y)
 773                          nil)))
 774     (assert-notes 0 `(lambda (list)
 775                        (declare (optimize (space 0)))
 776                        (sort list #'<)))
 777     (assert-notes 0 `(lambda (other)
 778                        #'(lambda (s c n)
 779                            (ignore-errors (funcall other s c n)))))))
 780
 781 ;;; Stack allocating a value cell in HANDLER-CASE would blow up stack
 782 ;;; in an unfortunate loop.
 783 (defun handler-case-eating-stack ()
 784   (let ((sp nil))
 785     (do ((n 0 (logand most-positive-fixnum (1+ n))))
 786         ((>= n 1024))
 787      (multiple-value-bind (value error) (ignore-errors)
 788        (when (and value error) nil))
 789       (if sp
 790           (assert (= sp (sb-c::%primitive sb-c:current-stack-pointer)))
 791           (setf sp (sb-c::%primitive sb-c:current-stack-pointer))))))
 792 (with-test (:name :handler-case-eating-stack)
 793   (assert-no-consing (handler-case-eating-stack)))
 794
 795 ;;; A nasty bug where RECHECK-DYNAMIC-EXTENT-LVARS thought something was going
 796 ;;; to be stack allocated when it was not, leading to a bogus %NIP-VALUES.
 797 ;;; Fixed by making RECHECK-DYNAMIC-EXTENT-LVARS deal properly with nested DX.
 798 (deftype vec ()
 799   `(simple-array single-float (3)))
 800 (declaim (ftype (function (t t t) vec) vec))
 801 (declaim (inline vec))
 802 (defun vec (a b c)
 803   (make-array 3 :element-type 'single-float :initial-contents (list a b c)))
 804 (defun bad-boy (vec)
 805   (declare (type vec vec))
 806   (lambda (fun)
 807     (let ((vec (vec (aref vec 0) (aref vec 1) (aref vec 2))))
 808       (declare (dynamic-extent vec))
 809       (funcall fun vec))))
 810 (with-test (:name :recheck-nested-dx-bug)
 811   (assert (funcall (bad-boy (vec 1.0 2.0 3.3))
 812                    (lambda (vec) (equalp vec (vec 1.0 2.0 3.3)))))
 813   (flet ((foo (x) (declare (ignore x))))
 814     (let ((bad-boy (bad-boy (vec 2.0 3.0 4.0))))
 815       (assert-no-consing (funcall bad-boy #'foo)))))
 816 \f