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)
 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   (assert-no-consing (test-nip-values))
 131   (assert-no-consing (test-let-var-subst1 17))
 132   (assert-no-consing (test-let-var-subst2 17))
 133   (assert-no-consing (test-lvar-subst 11))
 134   )
 135
 136 \f
 137 ;;; Bugs found by Paul F. Dietz
 138 (assert
 139  (eq
 140   (funcall
 141    (compile
 142     nil
 143     '(lambda (a b)
 144       (declare (optimize (speed 2) (space 0) (safety 0)
 145                 (debug 1) (compilation-speed 3)))
 146       (let* ((v5 (cons b b)))
 147         (declare (dynamic-extent v5))
 148         a)))
 149    'x 'y)
 150   'x))
 151
 152 \f
 153 ;;; other bugs
 154
 155 ;;; bug reported by Svein Ove Aas
 156 (defun svein-2005-ii-07 (x y)
 157   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 158   (let ((args (list* y 1 2 x)))
 159     (declare (dynamic-extent args))
 160     (apply #'aref args)))
 161 (assert (eql
 162          (svein-2005-ii-07
 163           '(0)
 164           #3A(((1 1 1) (1 1 1) (1 1 1))
 165               ((1 1 1) (1 1 1) (4 1 1))
 166               ((1 1 1) (1 1 1) (1 1 1))))
 167          4))
 168
 169 ;;; bug reported by Brian Downing: stack-allocated arrays were not
 170 ;;; filled with zeroes.
 171 (defun-with-dx bdowning-2005-iv-16 ()
 172   (let ((a (make-array 11 :initial-element 0)))
 173     (declare (dynamic-extent a))
 174     (assert (every (lambda (x) (eql x 0)) a))))
 175 (bdowning-2005-iv-16)
 176
 177 \f
 178 (sb-ext:quit :unix-status 104)