tests/bit-vector.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 ;;; the bitvector transforms were buggy prior to sbcl-0.7.3.4 under
  13 ;;; speed-optimizing regimes; in particular, they would fail if the
  14 ;;; vector length were near ARRAY-DIMENSION-LIMIT. Testing this takes
  15 ;;; up a certain amount of time...
  16
  17 (with-test (:name (bit-vector bit-not bit-xor bit-and equal :small))
  18   ;; deal with the potential length 0 special case
  19   (locally
  20       (declare (optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))
  21     (let ((a (make-array 0 :element-type 'bit))
  22           (b (make-array 0 :element-type 'bit)))
  23       (assert (equal (bit-not a) #*))
  24       (assert (equal (bit-xor a b a) #*))
  25       (assert (equal (bit-and a a b) #*)))))
  26
  27 (with-test (:name (bit-vector bit-not bit-xor bit-and equal :modification))
  28   ;; also test some return values for sanity
  29   (locally
  30       (declare (optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))
  31     (let ((a (make-array 33 :element-type 'bit :initial-element 0))
  32           (b (make-array 33 :element-type 'bit :initial-element 0)))
  33       (assert (equal (bit-not a a) #*111111111111111111111111111111111))
  34       (setf (aref a 0) 0)               ; a = #*011..1
  35       (setf (aref b 1) 1)               ; b = #*010..0
  36       (assert (equal (bit-xor a b) #*001111111111111111111111111111111))
  37       (assert (equal (bit-and a b) #*010000000000000000000000000000000)))))
  38
  39 (with-test (:name (bit-vector count))
  40   ;; a special COUNT transform on bitvectors; triggers on (>= SPEED
  41   ;; SPACE)
  42   (locally
  43       (declare (optimize (speed 3) (space 1)))
  44     (let ((bv1 (make-array 5 :element-type 'bit))
  45           (bv2 (make-array 0 :element-type 'bit))
  46           (bv3 (make-array 68 :element-type 'bit)))
  47       (declare (type simple-bit-vector bv1 bv2 bv3))
  48       (setf (sbit bv3 42) 1)
  49       ;; bitvector smaller than the word size
  50       (assert (= 0 (count 1 bv1)))
  51       (assert (= 5 (count 0 bv1)))
  52       ;; special case of 0-length bitvectors
  53       (assert (= 0 (count 1 bv2)))
  54       (assert (= 0 (count 0 bv2)))
  55       ;; bitvector larger than the word size
  56       (assert (= 1 (count 1 bv3)))
  57       (assert (= 67 (count 0 bv3))))))
  58
  59 ;;; now test the biggy, mostly that it works...
  60 ;;;
  61 ;;; except on machines where the arrays won't fit into the dynamic
  62 ;;; space.
  63 (when (> (sb-ext:dynamic-space-size)
  64          (truncate (1- array-dimension-limit)
  65                    sb-vm:n-word-bits))
  66   (push :sufficient-dynamic-space *features*))
  67 (with-test (:name (bit-vector bit-not bit-and :big)
  68                   :skipped-on (:not :sufficient-dynamic-space))
  69   (locally
  70       (declare (optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))
  71     (let ((a (make-array (1- array-dimension-limit)
  72                          :element-type 'bit :initial-element 0))
  73           (b (make-array (1- array-dimension-limit)
  74                          :element-type 'bit :initial-element 0)))
  75       (bit-not a a)
  76       (assert (= (aref a 0) 1))
  77       (assert (= (aref a (- array-dimension-limit 2)) 1))
  78       (bit-and a b a)
  79       (assert (= (aref a 0) 0))
  80       (assert (= (aref a (- array-dimension-limit 2)) 0)))))
  81
  82 (with-test (:name (bit-vector find :non-bit-from-bit-vector))
  83   (assert (not (find #\a #*0101)))
  84   (assert (not (position #\a #*0101)))
  85   (checked-compile-and-assert ()
  86       `(lambda (b)
  87          (find b #*0101))
  88     ((t) nil))
  89   (checked-compile-and-assert ()
  90       `(lambda (b)
  91          (position b #*0101))
  92     ((t) nil))
  93   (checked-compile-and-assert ()
  94       `(lambda (b)
  95          (declare (bit-vector b))
  96          (find t b))
  97     ((#*010101) nil))
  98   (checked-compile-and-assert ()
  99       `(lambda (b)
 100          (declare (bit-vector b))
 101          (position t b))
 102     ((#*101010) nil)))
 103
 104 ;;; BIT-POSITION would access 1 word beyond a bit-vector's final word
 105 ;;; which could crash if the next page of memory was not readable. To
 106 ;;; produce such a sitution, mmap two pages the second one read
 107 ;;; protected, allocated the vector at the end of the first one and
 108 ;;; see if it touches the second pages.
 109 #-win32 ;; no sb-posix:mmap
 110 (with-test (:name :bit-position-overrun)
 111   (let* ((n-bytes (* 4 sb-vm:n-word-bytes))
 112          (first (sb-posix:mmap nil (* sb-c:+backend-page-bytes+ 2)
 113                                (logior sb-posix:prot-read
 114                                        sb-posix:prot-write)
 115                                (logior sb-posix:map-private sb-posix:map-anon) -1 0))
 116          (second (sb-sys:sap+ first sb-c:+backend-page-bytes+))
 117          (addr (sb-sys:sap+ second (- n-bytes)))
 118          (n-bits (* 2 sb-vm:n-word-bits)))
 119     (assert (sb-sys:sap=
 120              second
 121              (sb-posix:mmap second sb-c:+backend-page-bytes+
 122                             sb-posix:prot-none
 123                             (logior sb-posix:map-private sb-posix:map-anon sb-posix:map-fixed)
 124                             -1 0)))
 125     (setf (sb-sys:sap-ref-word addr 0) sb-vm:simple-bit-vector-widetag)
 126     (setf (sb-sys:sap-ref-word addr sb-vm:n-word-bytes)
 127           (ash n-bits sb-vm:n-fixnum-tag-bits))
 128     (multiple-value-bind (object widetag size)
 129         (sb-vm::reconstitute-object (sb-c::mask-signed-field
 130                                      sb-vm:n-fixnum-bits
 131                                      (ash (sb-sys:sap-int addr)
 132                                           (- sb-vm:n-fixnum-tag-bits))))
 133       (declare (ignore widetag))
 134       (assert (simple-bit-vector-p object))
 135       (assert (= size n-bytes))
 136       (assert (not (sb-kernel:%bit-position/1 object nil 0 n-bits))))))
 137
 138 ;;; Shamelessly piggybacking on the approach above to grab a page
 139 ;;; which adjoins an unreadable page for testing the disassembler.
 140 #-win32 ;; no sb-posix:mmap
 141 (with-test (:name :disassembler-overrun :skipped-on (not (or :x86 :x86-64)))
 142   (let* ((n-bytes 7)
 143          (first (sb-posix:mmap nil (* sb-c:+backend-page-bytes+ 2)
 144                                (logior sb-posix:prot-read
 145                                        sb-posix:prot-write)
 146                                (logior sb-posix:map-private sb-posix:map-anon) -1 0))
 147          (second (sb-sys:sap+ first sb-c:+backend-page-bytes+))
 148          (addr (sb-sys:sap+ second (- n-bytes))))
 149     (assert (sb-sys:sap=
 150              second
 151              (sb-posix:mmap second sb-c:+backend-page-bytes+
 152                             sb-posix:prot-none
 153                             (logior sb-posix:map-private sb-posix:map-anon sb-posix:map-fixed)
 154                             -1 0)))
 155     (loop for byte in '(#x8B #x50 #xFD #x8B #xE5 #xF8 #x5D)
 156           for i from 0
 157           do (setf (sb-sys:sap-ref-8 addr i) byte))
 158     (sb-disassem:disassemble-memory addr 7 :stream (make-broadcast-stream))))