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
  19 (defmacro defun-with-dx (name arglist &body body)
  20   `(locally
  21      (declare (optimize sb-c::stack-allocate-dynamic-extent))
  22      (defun ,name ,arglist
  23        ,@body)))
  24
  25 (declaim (notinline opaque-identity))
  26 (defun opaque-identity (x)
  27   x)
  28
  29 ;;; &REST lists
  30 (defun-with-dx dxlength (&rest rest)
  31   (declare (dynamic-extent rest))
  32   (length rest))
  33
  34 (assert (= (dxlength 1 2 3) 3))
  35 (assert (= (dxlength t t t t t t) 6))
  36 (assert (= (dxlength) 0))
  37
  38 (defun callee (list)
  39   (destructuring-bind (a b c d e f &rest g) list
  40     (+ a b c d e f (length g))))
  41
  42 (defun-with-dx dxcaller (&rest rest)
  43   (declare (dynamic-extent rest))
  44   (callee rest))
  45 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
  46
  47 (defun-with-dx dxcaller-align-1 (x &rest rest)
  48   (declare (dynamic-extent rest))
  49   (+ x (callee rest)))
  50 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
  51 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40))
  52
  53 ;;; %NIP-VALUES
  54 (defun-with-dx test-nip-values ()
  55   (flet ((bar (x &rest y)
  56            (declare (dynamic-extent y))
  57            (if (> x 0)
  58                (values x (length y))
  59                (values (car y)))))
  60     (multiple-value-call #'values
  61       (bar 1 2 3 4 5 6)
  62       (bar -1 'a 'b))))
  63
  64 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a)))
  65
  66 ;;; LET-variable substitution
  67 (defun-with-dx test-let-var-subst1 (x)
  68   (let ((y (list x (1- x))))
  69     (opaque-identity :foo)
  70     (let ((z (the list y)))
  71       (declare (dynamic-extent z))
  72       (length z))))
  73 (assert (eql (test-let-var-subst1 17) 2))
  74
  75 (defun-with-dx test-let-var-subst2 (x)
  76   (let ((y (list x (1- x))))
  77     (declare (dynamic-extent y))
  78     (opaque-identity :foo)
  79     (let ((z (the list y)))
  80       (length z))))
  81 (assert (eql (test-let-var-subst2 17) 2))
  82
  83 ;;; DX propagation through LET-return.
  84 (defun-with-dx test-lvar-subst (x)
  85   (let ((y (list x (1- x))))
  86     (declare (dynamic-extent y))
  87     (second (let ((z (the list y)))
  88               (opaque-identity :foo)
  89               z))))
  90 (assert (eql (test-lvar-subst 11) 10))
  91
  92 ;;; this code is incorrect, but the compiler should not fail
  93 (defun-with-dx test-let-var-subst-incorrect (x)
  94   (let ((y (list x (1- x))))
  95     (opaque-identity :foo)
  96     (let ((z (the list y)))
  97       (declare (dynamic-extent z))
  98       (opaque-identity :bar)
  99       z)))
 100 \f
 101 ;;; alignment
 102 (defvar *x*)
 103 (defun-with-dx test-alignment-dx-list (form)
 104   (multiple-value-prog1 (eval form)
 105     (let ((l (list 1 2 3 4)))
 106       (declare (dynamic-extent l))
 107       (setq *x* (copy-list l)))))
 108 (dotimes (n 64)
 109   (let* ((res (loop for i below n collect i))
 110          (form `(values ,@res)))
 111     (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
 112     (assert (equal *x* '(1 2 3 4)))))
 113
 114 ;;; closure
 115
 116 (declaim (notinline true))
 117 (defun true (x)
 118   (declare (ignore x))
 119   t)
 120
 121 (defun-with-dx dxclosure (x)
 122   (flet ((f (y)
 123            (+ y x)))
 124     (declare (dynamic-extent #'f))
 125     (true #'f)))
 126
 127 (assert (eq t (dxclosure 13)))
 128
 129 ;;; value-cells
 130
 131 (defun-with-dx dx-value-cell (x)
 132   (declare (optimize sb-c::stack-allocate-value-cells))
 133   ;; Not implemented everywhere, yet.
 134   #+(or x86 x86-64 mips)
 135   (let ((cell x))
 136     (declare (dynamic-extent cell))
 137     (flet ((f ()
 138              (incf cell)))
 139       (declare (dynamic-extent #'f))
 140       (true #'f))))
 141
 142 ;;; CONS
 143
 144 (defun-with-dx cons-on-stack (x)
 145   (let ((cons (cons x x)))
 146     (declare (dynamic-extent cons))
 147     (true cons)
 148     nil))
 149
 150 ;;; MAKE-ARRAY
 151
 152 (defun-with-dx make-array-on-stack ()
 153   (let ((v (make-array '(42) :element-type 'single-float)))
 154     (declare (dynamic-extent v))
 155     (true v)
 156     nil))
 157
 158 ;;; MAKE-STRUCTURE
 159
 160 (declaim (inline make-fp-struct-1))
 161 (defstruct fp-struct-1
 162   (s 0.0 :type single-float)
 163   (d 0.0d0 :type double-float))
 164
 165 (defun-with-dx test-fp-struct-1.1 (s d)
 166   (let ((fp (make-fp-struct-1 :s s)))
 167     (declare (dynamic-extent fp))
 168     (assert (eql s (fp-struct-1-s fp)))
 169     (assert (eql 0.0d0 (fp-struct-1-d fp)))))
 170
 171 (defun-with-dx test-fp-struct-1.2 (s d)
 172   (let ((fp (make-fp-struct-1 :d d)))
 173     (declare (dynamic-extent fp))
 174     (assert (eql 0.0 (fp-struct-1-s fp)))
 175     (assert (eql d (fp-struct-1-d fp)))))
 176
 177 (defun-with-dx test-fp-struct-1.3 (s d)
 178   (let ((fp (make-fp-struct-1 :d d :s s)))
 179     (declare (dynamic-extent fp))
 180     (assert (eql s (fp-struct-1-s fp)))
 181     (assert (eql d (fp-struct-1-d fp)))))
 182
 183 (defun-with-dx test-fp-struct-1.4 (s d)
 184   (let ((fp (make-fp-struct-1 :s s :d d)))
 185     (declare (dynamic-extent fp))
 186     (assert (eql s (fp-struct-1-s fp)))
 187     (assert (eql d (fp-struct-1-d fp)))))
 188
 189 (test-fp-struct-1.1 123.456 876.243d0)
 190 (test-fp-struct-1.2 123.456 876.243d0)
 191 (test-fp-struct-1.3 123.456 876.243d0)
 192 (test-fp-struct-1.4 123.456 876.243d0)
 193
 194 (declaim (inline make-fp-struct-2))
 195 (defstruct fp-struct-2
 196   (d 0.0d0 :type double-float)
 197   (s 0.0 :type single-float))
 198
 199 (defun-with-dx test-fp-struct-2.1 (s d)
 200   (let ((fp (make-fp-struct-2 :s s)))
 201     (declare (dynamic-extent fp))
 202     (assert (eql s (fp-struct-2-s fp)))
 203     (assert (eql 0.0d0 (fp-struct-2-d fp)))))
 204
 205 (defun-with-dx test-fp-struct-2.2 (s d)
 206   (let ((fp (make-fp-struct-2 :d d)))
 207     (declare (dynamic-extent fp))
 208     (assert (eql 0.0 (fp-struct-2-s fp)))
 209     (assert (eql d (fp-struct-2-d fp)))))
 210
 211 (defun-with-dx test-fp-struct-2.3 (s d)
 212   (let ((fp (make-fp-struct-2 :d d :s s)))
 213     (declare (dynamic-extent fp))
 214     (assert (eql s (fp-struct-2-s fp)))
 215     (assert (eql d (fp-struct-2-d fp)))))
 216
 217 (defun-with-dx test-fp-struct-2.4 (s d)
 218   (let ((fp (make-fp-struct-2 :s s :d d)))
 219     (declare (dynamic-extent fp))
 220     (assert (eql s (fp-struct-2-s fp)))
 221     (assert (eql d (fp-struct-2-d fp)))))
 222
 223 (test-fp-struct-2.1 123.456 876.243d0)
 224 (test-fp-struct-2.2 123.456 876.243d0)
 225 (test-fp-struct-2.3 123.456 876.243d0)
 226 (test-fp-struct-2.4 123.456 876.243d0)
 227
 228 (declaim (inline make-cfp-struct-1))
 229 (defstruct cfp-struct-1
 230   (s (complex 0.0) :type (complex single-float))
 231   (d (complex 0.0d0) :type (complex double-float)))
 232
 233 (defun-with-dx test-cfp-struct-1.1 (s d)
 234   (let ((cfp (make-cfp-struct-1 :s s)))
 235     (declare (dynamic-extent cfp))
 236     (assert (eql s (cfp-struct-1-s cfp)))
 237     (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
 238
 239 (defun-with-dx test-cfp-struct-1.2 (s d)
 240   (let ((cfp (make-cfp-struct-1 :d d)))
 241     (declare (dynamic-extent cfp))
 242     (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
 243     (assert (eql d (cfp-struct-1-d cfp)))))
 244
 245 (defun-with-dx test-cfp-struct-1.3 (s d)
 246   (let ((cfp (make-cfp-struct-1 :d d :s s)))
 247     (declare (dynamic-extent cfp))
 248     (assert (eql s (cfp-struct-1-s cfp)))
 249     (assert (eql d (cfp-struct-1-d cfp)))))
 250
 251 (defun-with-dx test-cfp-struct-1.4 (s d)
 252   (let ((cfp (make-cfp-struct-1 :s s :d d)))
 253     (declare (dynamic-extent cfp))
 254     (assert (eql s (cfp-struct-1-s cfp)))
 255     (assert (eql d (cfp-struct-1-d cfp)))))
 256
 257 (test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 258 (test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 259 (test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 260 (test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 261
 262 (declaim (inline make-cfp-struct-2))
 263 (defstruct cfp-struct-2
 264   (d (complex 0.0d0) :type (complex double-float))
 265   (s (complex 0.0) :type (complex single-float)))
 266
 267 (defun-with-dx test-cfp-struct-2.1 (s d)
 268   (let ((cfp (make-cfp-struct-2 :s s)))
 269     (declare (dynamic-extent cfp))
 270     (assert (eql s (cfp-struct-2-s cfp)))
 271     (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
 272
 273 (defun-with-dx test-cfp-struct-2.2 (s d)
 274   (let ((cfp (make-cfp-struct-2 :d d)))
 275     (declare (dynamic-extent cfp))
 276     (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
 277     (assert (eql d (cfp-struct-2-d cfp)))))
 278
 279 (defun-with-dx test-cfp-struct-2.3 (s d)
 280   (let ((cfp (make-cfp-struct-2 :d d :s s)))
 281     (declare (dynamic-extent cfp))
 282     (assert (eql s (cfp-struct-2-s cfp)))
 283     (assert (eql d (cfp-struct-2-d cfp)))))
 284
 285 (defun-with-dx test-cfp-struct-2.4 (s d)
 286   (let ((cfp (make-cfp-struct-2 :s s :d d)))
 287     (declare (dynamic-extent cfp))
 288     (assert (eql s (cfp-struct-2-s cfp)))
 289     (assert (eql d (cfp-struct-2-d cfp)))))
 290
 291 (test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 292 (test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 293 (test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 294 (test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
 295
 296 (declaim (inline make-foo1 make-foo2 make-foo3))
 297 (defstruct foo1 x)
 298
 299 (defun-with-dx make-foo1-on-stack (x)
 300   (let ((foo (make-foo1 :x x)))
 301     (declare (dynamic-extent foo))
 302     (assert (eql x (foo1-x foo)))))
 303
 304 (defstruct foo2
 305   (x 0.0 :type single-float)
 306   (y 0.0d0 :type double-float)
 307   a
 308   b
 309   c)
 310
 311 (defmacro assert-eql (expected got)
 312   `(let ((exp ,expected)
 313          (got ,got))
 314      (unless (eql exp got)
 315        (error "Expected ~S, got ~S!" exp got))))
 316
 317 (defun-with-dx make-foo2-on-stack (x y)
 318   (let ((foo (make-foo2 :y y :c 'c)))
 319     (declare (dynamic-extent foo))
 320     (assert-eql 0.0 (foo2-x foo))
 321     (assert-eql y (foo2-y foo))
 322     (assert-eql 'c (foo2-c foo))
 323     (assert-eql nil (foo2-b foo))))
 324
 325 ;;; Check that constants work out as argument for all relevant
 326 ;;; slot types.
 327 (defstruct foo3
 328   (a 0 :type t)
 329   (b 1 :type fixnum)
 330   (c 2 :type sb-vm:word)
 331   (d 3.0 :type single-float)
 332   (e 4.0d0 :type double-float))
 333 (defun-with-dx make-foo3-on-stack ()
 334   (let ((foo (make-foo3)))
 335     (declare (dynamic-extent foo))
 336     (assert (eql 0 (foo3-a foo)))
 337     (assert (eql 1 (foo3-b foo)))
 338     (assert (eql 2 (foo3-c foo)))
 339     (assert (eql 3.0 (foo3-d foo)))
 340     (assert (eql 4.0d0 (foo3-e foo)))))
 341
 342 ;;; Nested DX
 343
 344 (defun-with-dx nested-dx-lists ()
 345   (let ((dx (list (list 1 2) (list 3 4))))
 346     (declare (dynamic-extent dx))
 347     (true dx)
 348     nil))
 349
 350 (defun-with-dx nested-dx-conses ()
 351   (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
 352     (declare (dynamic-extent dx))
 353     (true dx)
 354     nil))
 355
 356 (defun-with-dx nested-dx-not-used (x)
 357   (declare (list x))
 358   (let ((l (setf (car x) (list x x x))))
 359     (declare (dynamic-extent l))
 360     (true l)
 361     (true (length l))
 362     nil))
 363
 364 (defun-with-dx nested-evil-dx-used (x)
 365   (declare (list x))
 366   (let ((l (list x x x)))
 367     (declare (dynamic-extent l))
 368     (unwind-protect
 369          (progn
 370            (setf (car x) l)
 371            (true l))
 372       (setf (car x) nil))
 373     nil))
 374
 375 ;;; multiple uses for dx lvar
 376
 377 (defun-with-dx multiple-dx-uses ()
 378   (let ((dx (if (true t)
 379                 (list 1 2 3)
 380                 (list 2 3 4))))
 381     (declare (dynamic-extent dx))
 382     (true dx)
 383     nil))
 384
 385 ;;; handler-case and handler-bind should use DX internally
 386
 387 (defun dx-handler-bind (x)
 388   (handler-bind ((error (lambda (c) (break "OOPS: ~S caused ~S" x c)))
 389                  ((and serious-condition (not error))
 390                   #'(lambda (c) (break "OOPS2: ~S did ~S" x c))))
 391     (/ 2 x)))
 392
 393 (defun dx-handler-case (x)
 394   (assert (zerop (handler-case (/ 2 x)
 395                    (error (c)
 396                      (break "OOPS: ~S caused ~S" x c))
 397                    (:no-error (res)
 398                      (1- res))))))
 399
 400 ;;; with-spinlock should use DX and not cons
 401
 402 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
 403
 404 (defun test-spinlock ()
 405   (sb-thread::with-spinlock (*slock*)
 406     (true *slock*)))
 407
 408 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
 409
 410 (defvar *table* (make-hash-table))
 411
 412 (defun test-hash-table ()
 413   (setf (gethash 5 *table*) 13)
 414   (gethash 5 *table*))
 415 \f
 416 (defmacro assert-no-consing (form &optional times)
 417   `(%assert-no-consing (lambda () ,form) ,times))
 418 (defun %assert-no-consing (thunk &optional times)
 419   (let ((before (get-bytes-consed))
 420         (times (or times 10000)))
 421     (declare (type (integer 1 *) times))
 422     (dotimes (i times)
 423       (funcall thunk))
 424     (assert (< (- (get-bytes-consed) before) times))))
 425
 426 (defmacro assert-consing (form &optional times)
 427   `(%assert-consing (lambda () ,form) ,times))
 428 (defun %assert-consing (thunk &optional times)
 429   (let ((before (get-bytes-consed))
 430         (times (or times 10000)))
 431     (declare (type (integer 1 *) times))
 432     (dotimes (i times)
 433       (funcall thunk))
 434     (assert (not (< (- (get-bytes-consed) before) times)))))
 435
 436 (defvar *a-cons* (cons nil nil))
 437
 438 #+(or x86 x86-64 alpha ppc sparc mips)
 439 (progn
 440   (assert-no-consing (dxclosure 42))
 441   (assert-no-consing (dxlength 1 2 3))
 442   (assert-no-consing (dxlength t t t t t t))
 443   (assert-no-consing (dxlength))
 444   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 445   (assert-no-consing (test-nip-values))
 446   (assert-no-consing (test-let-var-subst1 17))
 447   (assert-no-consing (test-let-var-subst2 17))
 448   (assert-no-consing (test-lvar-subst 11))
 449   (assert-no-consing (dx-value-cell 13))
 450   (assert-no-consing (cons-on-stack 42))
 451   (assert-no-consing (make-array-on-stack))
 452   (assert-no-consing (make-foo1-on-stack 123))
 453   (#+raw-instance-init-vops assert-no-consing
 454    #-raw-instance-init-vops progn
 455    (make-foo2-on-stack 1.24 1.23d0))
 456   (#+raw-instance-init-vops assert-no-consing
 457    #-raw-instance-init-vops progn
 458    (make-foo3-on-stack))
 459   (assert-no-consing (nested-dx-conses))
 460   (assert-no-consing (nested-dx-lists))
 461   (assert-consing (nested-dx-not-used *a-cons*))
 462   (assert-no-consing (nested-evil-dx-used *a-cons*))
 463   (assert-no-consing (multiple-dx-uses))
 464   (assert-no-consing (dx-handler-bind 2))
 465   (assert-no-consing (dx-handler-case 2))
 466   ;; Not strictly DX..
 467   (assert-no-consing (test-hash-table))
 468   #+sb-thread
 469   (assert-no-consing (test-spinlock)))
 470
 471 \f
 472 ;;; Bugs found by Paul F. Dietz
 473 (assert
 474  (eq
 475   (funcall
 476    (compile
 477     nil
 478     '(lambda (a b)
 479       (declare (optimize (speed 2) (space 0) (safety 0)
 480                 (debug 1) (compilation-speed 3)))
 481       (let* ((v5 (cons b b)))
 482         (declare (dynamic-extent v5))
 483         a)))
 484    'x 'y)
 485   'x))
 486
 487 \f
 488 ;;; other bugs
 489
 490 ;;; bug reported by Svein Ove Aas
 491 (defun svein-2005-ii-07 (x y)
 492   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 493   (let ((args (list* y 1 2 x)))
 494     (declare (dynamic-extent args))
 495     (apply #'aref args)))
 496 (assert (eql
 497          (svein-2005-ii-07
 498           '(0)
 499           #3A(((1 1 1) (1 1 1) (1 1 1))
 500               ((1 1 1) (1 1 1) (4 1 1))
 501               ((1 1 1) (1 1 1) (1 1 1))))
 502          4))
 503
 504 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 505 ;;; filled with zeroes.
 506 (defun-with-dx bdowning-2005-iv-16 ()
 507   (let ((a (make-array 11 :initial-element 0)))
 508     (declare (dynamic-extent a))
 509     (assert (every (lambda (x) (eql x 0)) a))))
 510 (assert-no-consing (bdowning-2005-iv-16))
 511
 512
 513 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
 514   (let* ((a (list x y z))
 515          (b (list x y z))
 516          (c (list a b)))
 517     (declare (dynamic-extent c))
 518     (values (first c) (second c))))
 519 (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
 520   (assert (and (equal i j)
 521                (equal i (list 1 2 3)))))
 522
 523 ;;; workaround for bug 419 -- real issue remains, but check that the
 524 ;;; bandaid holds.
 525 (defun-with-dx bug419 (x)
 526   (multiple-value-call #'list
 527     (eval '(values 1 2 3))
 528     (let ((x x))
 529       (declare (dynamic-extent x))
 530       (flet ((mget (y)
 531                (+ x y))
 532              (mset (z)
 533                (incf x z)))
 534         (declare (dynamic-extent #'mget #'mset))
 535         ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
 536 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
 537 \f