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