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