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