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
 112
 113 \f
 114 (defmacro assert-no-consing (form &optional times)
 115   `(%assert-no-consing (lambda () ,form ,times)))
 116 (defun %assert-no-consing (thunk &optional times)
 117   (let ((before (get-bytes-consed))
 118         (times (or times 10000)))
 119     (declare (type (integer 1 *) times))
 120     (dotimes (i times)
 121       (funcall thunk))
 122     (assert (< (- (get-bytes-consed) before) times))))
 123
 124 #+(or x86 x86-64 alpha ppc)
 125 (progn
 126   (assert-no-consing (dxlength 1 2 3))
 127   (assert-no-consing (dxlength t t t t t t))
 128   (assert-no-consing (dxlength))
 129   (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
 130   #-ppc
 131   (assert-no-consing (test-nip-values))
 132   #-ppc
 133   (assert-no-consing (test-let-var-subst1 17))
 134   #-ppc
 135   (assert-no-consing (test-let-var-subst2 17))
 136   #-ppc
 137   (assert-no-consing (test-lvar-subst 11)))
 138
 139 \f
 140 ;;; Bugs found by Paul F. Dietz
 141 (assert
 142  (eq
 143   (funcall
 144    (compile
 145     nil
 146     '(lambda (a b)
 147       (declare (optimize (speed 2) (space 0) (safety 0)
 148                 (debug 1) (compilation-speed 3)))
 149       (let* ((v5 (cons b b)))
 150         (declare (dynamic-extent v5))
 151         a)))
 152    'x 'y)
 153   'x))
 154
 155 \f
 156 ;;; other bugs
 157
 158 ;;; bug reported by Svein Ove Aas
 159 (defun svein-2005-ii-07 (x y)
 160   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 161   (let ((args (list* y 1 2 x)))
 162     (declare (dynamic-extent args))
 163     (apply #'aref args)))
 164 (assert (eql
 165          (svein-2005-ii-07
 166           '(0)
 167           #3A(((1 1 1) (1 1 1) (1 1 1))
 168               ((1 1 1) (1 1 1) (4 1 1))
 169               ((1 1 1) (1 1 1) (1 1 1))))
 170          4))
 171
 172 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 173 ;;; filled with zeroes.
 174 (defun-with-dx bdowning-2005-iv-16 ()
 175   (let ((a (make-array 11 :initial-element 0)))
 176     (declare (dynamic-extent a))
 177     (assert (every (lambda (x) (eql x 0)) a))))
 178 (bdowning-2005-iv-16)
 179
 180 \f
 181 (sb-ext:quit :unix-status 104)