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 (setq sb-c::*check-consistency* t)
  15
  16 (defmacro defun-with-dx (name arglist &body body)
  17   `(locally
  18      (declare (optimize sb-c::stack-allocate-dynamic-extent))
  19      (defun ,name ,arglist
  20        ,@body)))
  21
  22 (declaim (notinline opaque-identity))
  23 (defun opaque-identity (x)
  24   x)
  25
  26 ;;; &REST lists
  27 (defun-with-dx dxlength (&rest rest)
  28   (declare (dynamic-extent rest))
  29   (length rest))
  30
  31 (assert (= (dxlength 1 2 3) 3))
  32 (assert (= (dxlength t t t t t t) 6))
  33 (assert (= (dxlength) 0))
  34
  35 (defun callee (list)
  36   (destructuring-bind (a b c d e f &rest g) list
  37     (+ a b c d e f (length g))))
  38
  39 (defun-with-dx dxcaller (&rest rest)
  40   (declare (dynamic-extent rest))
  41   (callee rest))
  42 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
  43
  44 (defun-with-dx dxcaller-align-1 (x &rest rest)
  45   (declare (dynamic-extent rest))
  46   (+ x (callee rest)))
  47 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
  48 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40))
  49
  50 ;;; %NIP-VALUES
  51 (defun-with-dx test-nip-values ()
  52   (flet ((bar (x &rest y)
  53            (declare (dynamic-extent y))
  54            (if (> x 0)
  55                (values x (length y))
  56                (values (car y)))))
  57     (multiple-value-call #'values
  58       (bar 1 2 3 4 5 6)
  59       (bar -1 'a 'b))))
  60
  61 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a)))
  62
  63 ;;; LET-variable substitution
  64 (defun-with-dx test-let-var-subst1 (x)
  65   (let ((y (list x (1- x))))
  66     (opaque-identity :foo)
  67     (let ((z (the list y)))
  68       (declare (dynamic-extent z))
  69       (length z))))
  70 (assert (eql (test-let-var-subst1 17) 2))
  71
  72 (defun-with-dx test-let-var-subst2 (x)
  73   (let ((y (list x (1- x))))
  74     (declare (dynamic-extent y))
  75     (opaque-identity :foo)
  76     (let ((z (the list y)))
  77       (length z))))
  78 (assert (eql (test-let-var-subst2 17) 2))
  79
  80 ;;; DX propagation through LET-return.
  81 (defun-with-dx test-lvar-subst (x)
  82   (let ((y (list x (1- x))))
  83     (declare (dynamic-extent y))
  84     (second (let ((z (the list y)))
  85               (opaque-identity :foo)
  86               z))))
  87 (assert (eql (test-lvar-subst 11) 10))
  88
  89 ;;; this code is incorrect, but the compiler should not fail
  90 (defun-with-dx test-let-var-subst-incorrect (x)
  91   (let ((y (list x (1- x))))
  92     (opaque-identity :foo)
  93     (let ((z (the list y)))
  94       (declare (dynamic-extent z))
  95       (opaque-identity :bar)
  96       z)))
  97 \f
  98 ;;; alignment
  99 (defvar *x*)
 100 (defun-with-dx test-alignment-dx-list (form)
 101   (multiple-value-prog1 (eval form)
 102     (let ((l (list 1 2 3 4)))
 103       (declare (dynamic-extent l))
 104       (setq *x* (copy-list l)))))
 105 (dotimes (n 64)
 106   (let* ((res (loop for i below n collect i))
 107          (form `(values ,@res)))
 108     (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
 109     (assert (equal *x* '(1 2 3 4)))))
 110
 111 ;;; closure
 112
 113 (declaim (notinline true))
 114 (defun true (x)
 115   (declare (ignore x))
 116   t)
 117
 118 (defun-with-dx dxclosure (x)
 119   (flet ((f (y)
 120            (+ y x)))
 121     (declare (dynamic-extent #'f))
 122     (true #'f)))
 123
 124 (assert (eq t (dxclosure 13)))
 125
 126 \f
 127 (defmacro assert-no-consing (form &optional times)
 128   `(%assert-no-consing (lambda () ,form) ,times))
 129 (defun %assert-no-consing (thunk &optional times)
 130   (let ((before (get-bytes-consed))
 131         (times (or times 10000)))
 132     (declare (type (integer 1 *) times))
 133     (dotimes (i times)
 134       (funcall thunk))
 135     (assert (< (- (get-bytes-consed) before) times))))
 136
 137 #+(or x86 x86-64 alpha ppc sparc)
 138 (progn
 139   (assert-no-consing (dxclosure 42))
 140   (assert-no-consing (dxlength 1 2 3))
 141   (assert-no-consing (dxlength t t t t t t))
 142   (assert-no-consing (dxlength))
 143   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 144   (assert-no-consing (test-nip-values))
 145   (assert-no-consing (test-let-var-subst1 17))
 146   (assert-no-consing (test-let-var-subst2 17))
 147   (assert-no-consing (test-lvar-subst 11)))
 148
 149 \f
 150 ;;; Bugs found by Paul F. Dietz
 151 (assert
 152  (eq
 153   (funcall
 154    (compile
 155     nil
 156     '(lambda (a b)
 157       (declare (optimize (speed 2) (space 0) (safety 0)
 158                 (debug 1) (compilation-speed 3)))
 159       (let* ((v5 (cons b b)))
 160         (declare (dynamic-extent v5))
 161         a)))
 162    'x 'y)
 163   'x))
 164
 165 \f
 166 ;;; other bugs
 167
 168 ;;; bug reported by Svein Ove Aas
 169 (defun svein-2005-ii-07 (x y)
 170   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 171   (let ((args (list* y 1 2 x)))
 172     (declare (dynamic-extent args))
 173     (apply #'aref args)))
 174 (assert (eql
 175          (svein-2005-ii-07
 176           '(0)
 177           #3A(((1 1 1) (1 1 1) (1 1 1))
 178               ((1 1 1) (1 1 1) (4 1 1))
 179               ((1 1 1) (1 1 1) (1 1 1))))
 180          4))
 181
 182 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 183 ;;; filled with zeroes.
 184 (defun-with-dx bdowning-2005-iv-16 ()
 185   (let ((a (make-array 11 :initial-element 0)))
 186     (declare (dynamic-extent a))
 187     (assert (every (lambda (x) (eql x 0)) a))))
 188 (bdowning-2005-iv-16)
 189
 190 \f
 191 (sb-ext:quit :unix-status 104)