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   ;; Not implemented everywhere, yet.
 133   #+(or x86 x86-64 mips)
 134   (let ((cell x))
 135     (declare (dynamic-extent cell))
 136     (flet ((f ()
 137              (incf cell)))
 138       (declare (dynamic-extent #'f))
 139       (true #'f))))
 140
 141 ;;; CONS
 142
 143 (defun-with-dx cons-on-stack (x)
 144   (let ((cons (cons x x)))
 145     (declare (dynamic-extent cons))
 146     (true cons)
 147     nil))
 148
 149 ;;; Nested DX
 150
 151 (defun-with-dx nested-dx-lists ()
 152   (let ((dx (list (list 1 2) (list 3 4))))
 153     (declare (dynamic-extent dx))
 154     (true dx)
 155     nil))
 156
 157 (defun-with-dx nested-dx-conses ()
 158   (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
 159     (declare (dynamic-extent dx))
 160     (true dx)
 161     nil))
 162
 163 (defun-with-dx nested-dx-not-used (x)
 164   (declare (list x))
 165   (let ((l (setf (car x) (list x x x))))
 166     (declare (dynamic-extent l))
 167     (true l)
 168     (true (length l))
 169     nil))
 170
 171 (defun-with-dx nested-evil-dx-used (x)
 172   (declare (list x))
 173   (let ((l (list x x x)))
 174     (declare (dynamic-extent l))
 175     (unwind-protect
 176          (progn
 177            (setf (car x) l)
 178            (true l))
 179       (setf (car x) nil))
 180     nil))
 181
 182 ;;; multiple uses for dx lvar
 183
 184 (defun-with-dx multiple-dx-uses ()
 185   (let ((dx (if (true t)
 186                 (list 1 2 3)
 187                 (list 2 3 4))))
 188     (declare (dynamic-extent dx))
 189     (true dx)
 190     nil))
 191
 192 ;;; with-spinlock should use DX and not cons
 193
 194 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
 195
 196 (defun test-spinlock ()
 197   (sb-thread::with-spinlock (*slock*)
 198     (true *slock*)))
 199
 200 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
 201
 202 (defvar *table* (make-hash-table))
 203
 204 (defun test-hash-table ()
 205   (setf (gethash 5 *table*) 13)
 206   (gethash 5 *table*))
 207 \f
 208 (defmacro assert-no-consing (form &optional times)
 209   `(%assert-no-consing (lambda () ,form) ,times))
 210 (defun %assert-no-consing (thunk &optional times)
 211   (let ((before (get-bytes-consed))
 212         (times (or times 10000)))
 213     (declare (type (integer 1 *) times))
 214     (dotimes (i times)
 215       (funcall thunk))
 216     (assert (< (- (get-bytes-consed) before) times))))
 217
 218 (defmacro assert-consing (form &optional times)
 219   `(%assert-consing (lambda () ,form) ,times))
 220 (defun %assert-consing (thunk &optional times)
 221   (let ((before (get-bytes-consed))
 222         (times (or times 10000)))
 223     (declare (type (integer 1 *) times))
 224     (dotimes (i times)
 225       (funcall thunk))
 226     (assert (not (< (- (get-bytes-consed) before) times)))))
 227
 228 (defvar *a-cons* (cons nil nil))
 229
 230 #+(or x86 x86-64 alpha ppc sparc mips)
 231 (progn
 232   (assert-no-consing (dxclosure 42))
 233   (assert-no-consing (dxlength 1 2 3))
 234   (assert-no-consing (dxlength t t t t t t))
 235   (assert-no-consing (dxlength))
 236   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 237   (assert-no-consing (test-nip-values))
 238   (assert-no-consing (test-let-var-subst1 17))
 239   (assert-no-consing (test-let-var-subst2 17))
 240   (assert-no-consing (test-lvar-subst 11))
 241   (assert-no-consing (dx-value-cell 13))
 242   (assert-no-consing (cons-on-stack 42))
 243   (assert-no-consing (nested-dx-conses))
 244   (assert-no-consing (nested-dx-lists))
 245   (assert-consing (nested-dx-not-used *a-cons*))
 246   (assert-no-consing (nested-evil-dx-used *a-cons*))
 247   (assert-no-consing (multiple-dx-uses))
 248   ;; Not strictly DX..
 249   (assert-no-consing (test-hash-table))
 250   #+sb-thread
 251   (assert-no-consing (test-spinlock)))
 252
 253 \f
 254 ;;; Bugs found by Paul F. Dietz
 255 (assert
 256  (eq
 257   (funcall
 258    (compile
 259     nil
 260     '(lambda (a b)
 261       (declare (optimize (speed 2) (space 0) (safety 0)
 262                 (debug 1) (compilation-speed 3)))
 263       (let* ((v5 (cons b b)))
 264         (declare (dynamic-extent v5))
 265         a)))
 266    'x 'y)
 267   'x))
 268
 269 \f
 270 ;;; other bugs
 271
 272 ;;; bug reported by Svein Ove Aas
 273 (defun svein-2005-ii-07 (x y)
 274   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 275   (let ((args (list* y 1 2 x)))
 276     (declare (dynamic-extent args))
 277     (apply #'aref args)))
 278 (assert (eql
 279          (svein-2005-ii-07
 280           '(0)
 281           #3A(((1 1 1) (1 1 1) (1 1 1))
 282               ((1 1 1) (1 1 1) (4 1 1))
 283               ((1 1 1) (1 1 1) (1 1 1))))
 284          4))
 285
 286 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 287 ;;; filled with zeroes.
 288 (defun-with-dx bdowning-2005-iv-16 ()
 289   (let ((a (make-array 11 :initial-element 0)))
 290     (declare (dynamic-extent a))
 291     (assert (every (lambda (x) (eql x 0)) a))))
 292 (bdowning-2005-iv-16)
 293
 294 \f