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 :initial-element 0))
  45           (bv2 (make-array 0 :element-type 'bit :initial-element 0))
  46           (bv3 (make-array 68 :element-type 'bit :initial-element 0)))
  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 #-win32 (require :sb-posix)
 105 ;;; BIT-POSITION would access 1 word beyond a bit-vector's final word
 106 ;;; which could crash if the next page of memory was not readable. To
 107 ;;; produce such a sitution, mmap two pages the second one read
 108 ;;; protected, allocated the vector at the end of the first one and
 109 ;;; see if it touches the second pages.
 110 #-win32 ;; no sb-posix:mmap
 111 (with-test (:name :bit-position-overrun)
 112   (let* ((n-bytes (* 4 sb-vm:n-word-bytes))
 113          (first (sb-posix:mmap nil (* sb-c:+backend-page-bytes+ 2)
 114                                (logior sb-posix:prot-read
 115                                        sb-posix:prot-write)
 116                                (logior sb-posix:map-private sb-posix:map-anon) -1 0))
 117          (second (sb-sys:sap+ first sb-c:+backend-page-bytes+))
 118          (addr (sb-sys:sap+ second (- n-bytes)))
 119          (n-bits (* 2 sb-vm:n-word-bits)))
 120     (assert (sb-sys:sap=
 121              second
 122              (sb-posix:mmap second sb-c:+backend-page-bytes+
 123                             sb-posix:prot-none
 124                             (logior sb-posix:map-private sb-posix:map-anon sb-posix:map-fixed)
 125                             -1 0)))
 126     (setf (sb-sys:sap-ref-word addr 0) sb-vm:simple-bit-vector-widetag)
 127     (setf (sb-kernel:%array-fill-pointer
 128            (sb-kernel:%make-lisp-obj (logior (sb-sys:sap-int addr)
 129                                              sb-vm:other-pointer-lowtag)))
 130           n-bits)
 131     (let* ((object
 132              (sb-vm::reconstitute-object
 133               (sb-c::mask-signed-field
 134                                      sb-vm:n-fixnum-bits
 135                                      (ash (sb-sys:sap-int addr)
 136                                           (- sb-vm:n-fixnum-tag-bits)))))
 137            (size (sb-ext:primitive-object-size object)))
 138       (assert (simple-bit-vector-p object))
 139       (assert (= size n-bytes))
 140       (assert (not (sb-kernel:%bit-position/1 object nil 0 n-bits)))
 141       (assert (not (sb-kernel:%bit-position/1 object nil n-bits n-bits))))))
 142
 143 ;;; Shamelessly piggybacking on the approach above to grab a page
 144 ;;; which adjoins an unreadable page for testing the disassembler.
 145 #-win32 ;; no sb-posix:mmap
 146 (with-test (:name :disassembler-overrun :skipped-on (not (or :x86 :x86-64)))
 147   (let* ((n-bytes 7)
 148          (first (sb-posix:mmap nil (* sb-c:+backend-page-bytes+ 2)
 149                                (logior sb-posix:prot-read
 150                                        sb-posix:prot-write)
 151                                (logior sb-posix:map-private sb-posix:map-anon) -1 0))
 152          (second (sb-sys:sap+ first sb-c:+backend-page-bytes+))
 153          (addr (sb-sys:sap+ second (- n-bytes))))
 154     (assert (sb-sys:sap=
 155              second
 156              (sb-posix:mmap second sb-c:+backend-page-bytes+
 157                             sb-posix:prot-none
 158                             (logior sb-posix:map-private sb-posix:map-anon sb-posix:map-fixed)
 159                             -1 0)))
 160     (loop for byte in '(#x8B #x50 #xFD #x8B #xE5 #xF8 #x5D)
 161           for i from 0
 162           do (setf (sb-sys:sap-ref-8 addr i) byte))
 163     (sb-disassem:disassemble-memory addr 7 :stream (make-broadcast-stream))))