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 ;;; Nested DX
 159
 160 (defun-with-dx nested-dx-lists ()
 161   (let ((dx (list (list 1 2) (list 3 4))))
 162     (declare (dynamic-extent dx))
 163     (true dx)
 164     nil))
 165
 166 (defun-with-dx nested-dx-conses ()
 167   (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
 168     (declare (dynamic-extent dx))
 169     (true dx)
 170     nil))
 171
 172 (defun-with-dx nested-dx-not-used (x)
 173   (declare (list x))
 174   (let ((l (setf (car x) (list x x x))))
 175     (declare (dynamic-extent l))
 176     (true l)
 177     (true (length l))
 178     nil))
 179
 180 (defun-with-dx nested-evil-dx-used (x)
 181   (declare (list x))
 182   (let ((l (list x x x)))
 183     (declare (dynamic-extent l))
 184     (unwind-protect
 185          (progn
 186            (setf (car x) l)
 187            (true l))
 188       (setf (car x) nil))
 189     nil))
 190
 191 ;;; multiple uses for dx lvar
 192
 193 (defun-with-dx multiple-dx-uses ()
 194   (let ((dx (if (true t)
 195                 (list 1 2 3)
 196                 (list 2 3 4))))
 197     (declare (dynamic-extent dx))
 198     (true dx)
 199     nil))
 200
 201 ;;; with-spinlock should use DX and not cons
 202
 203 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
 204
 205 (defun test-spinlock ()
 206   (sb-thread::with-spinlock (*slock*)
 207     (true *slock*)))
 208
 209 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
 210
 211 (defvar *table* (make-hash-table))
 212
 213 (defun test-hash-table ()
 214   (setf (gethash 5 *table*) 13)
 215   (gethash 5 *table*))
 216 \f
 217 (defmacro assert-no-consing (form &optional times)
 218   `(%assert-no-consing (lambda () ,form) ,times))
 219 (defun %assert-no-consing (thunk &optional times)
 220   (let ((before (get-bytes-consed))
 221         (times (or times 10000)))
 222     (declare (type (integer 1 *) times))
 223     (dotimes (i times)
 224       (funcall thunk))
 225     (assert (< (- (get-bytes-consed) before) times))))
 226
 227 (defmacro assert-consing (form &optional times)
 228   `(%assert-consing (lambda () ,form) ,times))
 229 (defun %assert-consing (thunk &optional times)
 230   (let ((before (get-bytes-consed))
 231         (times (or times 10000)))
 232     (declare (type (integer 1 *) times))
 233     (dotimes (i times)
 234       (funcall thunk))
 235     (assert (not (< (- (get-bytes-consed) before) times)))))
 236
 237 (defvar *a-cons* (cons nil nil))
 238
 239 #+(or x86 x86-64 alpha ppc sparc mips)
 240 (progn
 241   (assert-no-consing (dxclosure 42))
 242   (assert-no-consing (dxlength 1 2 3))
 243   (assert-no-consing (dxlength t t t t t t))
 244   (assert-no-consing (dxlength))
 245   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 246   (assert-no-consing (test-nip-values))
 247   (assert-no-consing (test-let-var-subst1 17))
 248   (assert-no-consing (test-let-var-subst2 17))
 249   (assert-no-consing (test-lvar-subst 11))
 250   (assert-no-consing (dx-value-cell 13))
 251   (assert-no-consing (cons-on-stack 42))
 252   (assert-no-consing (make-array-on-stack))
 253   (assert-no-consing (nested-dx-conses))
 254   (assert-no-consing (nested-dx-lists))
 255   (assert-consing (nested-dx-not-used *a-cons*))
 256   (assert-no-consing (nested-evil-dx-used *a-cons*))
 257   (assert-no-consing (multiple-dx-uses))
 258   ;; Not strictly DX..
 259   (assert-no-consing (test-hash-table))
 260   #+sb-thread
 261   (assert-no-consing (test-spinlock)))
 262
 263 \f
 264 ;;; Bugs found by Paul F. Dietz
 265 (assert
 266  (eq
 267   (funcall
 268    (compile
 269     nil
 270     '(lambda (a b)
 271       (declare (optimize (speed 2) (space 0) (safety 0)
 272                 (debug 1) (compilation-speed 3)))
 273       (let* ((v5 (cons b b)))
 274         (declare (dynamic-extent v5))
 275         a)))
 276    'x 'y)
 277   'x))
 278
 279 \f
 280 ;;; other bugs
 281
 282 ;;; bug reported by Svein Ove Aas
 283 (defun svein-2005-ii-07 (x y)
 284   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 285   (let ((args (list* y 1 2 x)))
 286     (declare (dynamic-extent args))
 287     (apply #'aref args)))
 288 (assert (eql
 289          (svein-2005-ii-07
 290           '(0)
 291           #3A(((1 1 1) (1 1 1) (1 1 1))
 292               ((1 1 1) (1 1 1) (4 1 1))
 293               ((1 1 1) (1 1 1) (1 1 1))))
 294          4))
 295
 296 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 297 ;;; filled with zeroes.
 298 (defun-with-dx bdowning-2005-iv-16 ()
 299   (let ((a (make-array 11 :initial-element 0)))
 300     (declare (dynamic-extent a))
 301     (assert (every (lambda (x) (eql x 0)) a))))
 302 (assert-no-consing (bdowning-2005-iv-16))
 303
 304
 305 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
 306   (let* ((a (list x y z))
 307          (b (list x y z))
 308          (c (list a b)))
 309     (declare (dynamic-extent c))
 310     (values (first c) (second c))))
 311 (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
 312   (assert (and (equal i j)
 313                (equal i (list 1 2 3)))))
 314
 315 ;;; workaround for bug 419 -- real issue remains, but check that the
 316 ;;; bandaid holds.
 317 (defun-with-dx bug419 (x)
 318   (multiple-value-call #'list
 319     (eval '(values 1 2 3))
 320     (let ((x x))
 321       (declare (dynamic-extent x))
 322       (flet ((mget (y)
 323                (+ x y))
 324              (mset (z)
 325                (incf x z)))
 326         (declare (dynamic-extent #'mget #'mset))
 327         ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
 328 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
 329 \f