mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
208 lines
9.2 KiB
Common Lisp
208 lines
9.2 KiB
Common Lisp
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
;;; the bitvector transforms were buggy prior to sbcl-0.7.3.4 under
|
|
;;; speed-optimizing regimes; in particular, they would fail if the
|
|
;;; vector length were near ARRAY-DIMENSION-LIMIT. Testing this takes
|
|
;;; up a certain amount of time...
|
|
|
|
(with-test (:name (bit-vector bit-not bit-xor bit-and equal :small))
|
|
;; deal with the potential length 0 special case
|
|
(locally
|
|
(declare (optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))
|
|
(let ((a (make-array 0 :element-type 'bit))
|
|
(b (make-array 0 :element-type 'bit)))
|
|
(assert (equal (bit-not a) #*))
|
|
(assert (equal (bit-xor a b a) #*))
|
|
(assert (equal (bit-and a a b) #*)))))
|
|
|
|
(with-test (:name (bit-vector bit-not bit-xor bit-and equal :modification))
|
|
;; also test some return values for sanity
|
|
(locally
|
|
(declare (optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))
|
|
(let ((a (make-array 33 :element-type 'bit :initial-element 0))
|
|
(b (make-array 33 :element-type 'bit :initial-element 0)))
|
|
(assert (equal (bit-not a a) #*111111111111111111111111111111111))
|
|
(setf (aref a 0) 0) ; a = #*011..1
|
|
(setf (aref b 1) 1) ; b = #*010..0
|
|
(assert (equal (bit-xor a b) #*001111111111111111111111111111111))
|
|
(assert (equal (bit-and a b) #*010000000000000000000000000000000)))))
|
|
|
|
(with-test (:name (bit-vector count))
|
|
;; a special COUNT transform on bitvectors; triggers on (>= SPEED
|
|
;; SPACE)
|
|
(locally
|
|
(declare (optimize (speed 3) (space 1)))
|
|
(let ((bv1 (make-array 5 :element-type 'bit :initial-element 0))
|
|
(bv2 (make-array 0 :element-type 'bit :initial-element 0))
|
|
(bv3 (make-array 68 :element-type 'bit :initial-element 0)))
|
|
(declare (type simple-bit-vector bv1 bv2 bv3))
|
|
(setf (sbit bv3 42) 1)
|
|
;; bitvector smaller than the word size
|
|
(assert (= 0 (count 1 bv1)))
|
|
(assert (= 5 (count 0 bv1)))
|
|
;; special case of 0-length bitvectors
|
|
(assert (= 0 (count 1 bv2)))
|
|
(assert (= 0 (count 0 bv2)))
|
|
;; bitvector larger than the word size
|
|
(assert (= 1 (count 1 bv3)))
|
|
(assert (= 67 (count 0 bv3))))))
|
|
|
|
(with-test (:name (bit-vector count :start :end))
|
|
;; a special COUNT transform on bitvectors; triggers on (>= SPEED
|
|
;; SPACE)
|
|
(locally
|
|
(declare (optimize (speed 3) (space 1)))
|
|
(let ((bv1 (make-array 5 :element-type 'bit :initial-element 0))
|
|
(bv2 (make-array 0 :element-type 'bit :initial-element 0)))
|
|
(declare (type simple-bit-vector bv1 bv2))
|
|
;; bitvector smaller than the word size
|
|
(assert (= 0 (count 1 bv1)))
|
|
(assert (= 5 (count 0 bv1)))
|
|
(assert (= 0 (count 1 bv1 :start 0 :end 5)))
|
|
(assert (= 4 (count 0 bv1 :start 1 :end 5)))
|
|
;; special case of 0-length bitvectors
|
|
(assert (= 0 (count 1 bv2)))
|
|
(assert (= 0 (count 0 bv2))))
|
|
(let ((bv3 (make-array 68 :element-type 'bit :initial-element 0)))
|
|
;; bitvector larger than the word size
|
|
(setf (sbit bv3 42) 1)
|
|
(assert (= 1 (count 1 bv3)))
|
|
(assert (= 67 (count 0 bv3)))
|
|
(fill bv3 1)
|
|
(assert (= 0 (count 1 bv3 :start 0 :end 0)))
|
|
(assert (= 1 (count 1 bv3 :start 64 :end 65)))
|
|
(assert (= 0 (count 1 bv3 :start 64 :end 64)))
|
|
(assert (= 0 (count 1 bv3 :start 65 :end 65))))
|
|
;; Displaced bit vectors
|
|
(let ((bv4 (make-array 98 :element-type 'bit :initial-element 0)))
|
|
(fill bv4 1 :start 60 :end 70)
|
|
(assert (= 10 (count 1 (make-array 10 :element-type 'bit :displaced-to bv4 :displaced-index-offset 60))))
|
|
(assert (= 0 (count 1 (make-array 10 :element-type 'bit :displaced-to bv4 :displaced-index-offset 60)
|
|
:start 10))))
|
|
(let ((bv/fp (make-array 10 :element-type 'bit :initial-element 1 :fill-pointer 0)))
|
|
(assert (zerop (count 1 bv/fp))))
|
|
(dotimes (x 10)
|
|
(let* ((len (random 514))
|
|
(start (if (zerop len) 0 (random len)))
|
|
(end (if (zerop len) 0 (random len)))
|
|
(bv (make-array len :element-type 'bit :initial-element 1)))
|
|
(when (> start end) (rotatef start end))
|
|
(assert (= (- end start) (count 1 bv :start start :end end)))
|
|
(fill bv 0)
|
|
(assert (= (- end start) (count 0 bv :start start :end end)))))))
|
|
|
|
;;; now test the biggy, mostly that it works...
|
|
;;;
|
|
;;; except on machines where the arrays won't fit into the dynamic
|
|
;;; space.
|
|
(when (> (sb-ext:dynamic-space-size)
|
|
(truncate (1- array-dimension-limit)
|
|
sb-vm:n-word-bits))
|
|
(push :sufficient-dynamic-space *features*))
|
|
(with-test (:name (bit-vector bit-not bit-and :big)
|
|
:skipped-on (:not :sufficient-dynamic-space))
|
|
(locally
|
|
(declare (optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))
|
|
(let ((a (make-array (1- array-dimension-limit)
|
|
:element-type 'bit :initial-element 0))
|
|
(b (make-array (1- array-dimension-limit)
|
|
:element-type 'bit :initial-element 0)))
|
|
(bit-not a a)
|
|
(assert (= (aref a 0) 1))
|
|
(assert (= (aref a (- array-dimension-limit 2)) 1))
|
|
(bit-and a b a)
|
|
(assert (= (aref a 0) 0))
|
|
(assert (= (aref a (- array-dimension-limit 2)) 0)))))
|
|
|
|
(with-test (:name (bit-vector find :non-bit-from-bit-vector))
|
|
(assert (not (find #\a #*0101)))
|
|
(assert (not (position #\a #*0101)))
|
|
(checked-compile-and-assert ()
|
|
`(lambda (b)
|
|
(find b #*0101))
|
|
((t) nil))
|
|
(checked-compile-and-assert ()
|
|
`(lambda (b)
|
|
(position b #*0101))
|
|
((t) nil))
|
|
(checked-compile-and-assert ()
|
|
`(lambda (b)
|
|
(declare (bit-vector b))
|
|
(find t b))
|
|
((#*010101) nil))
|
|
(checked-compile-and-assert ()
|
|
`(lambda (b)
|
|
(declare (bit-vector b))
|
|
(position t b))
|
|
((#*101010) nil)))
|
|
|
|
#-win32 (require :sb-posix)
|
|
;;; BIT-POSITION would access 1 word beyond a bit-vector's final word
|
|
;;; which could crash if the next page of memory was not readable. To
|
|
;;; produce such a sitution, mmap two pages the second one read
|
|
;;; protected, allocated the vector at the end of the first one and
|
|
;;; see if it touches the second pages.
|
|
#-win32 ;; no sb-posix:mmap
|
|
(with-test (:name :bit-position-overrun)
|
|
(let* ((n-bytes (* 4 sb-vm:n-word-bytes))
|
|
(first (sb-posix:mmap nil (* sb-c:+backend-page-bytes+ 2)
|
|
(logior sb-posix:prot-read
|
|
sb-posix:prot-write)
|
|
(logior sb-posix:map-private sb-posix:map-anon) -1 0))
|
|
(second (sb-sys:sap+ first sb-c:+backend-page-bytes+))
|
|
(addr (sb-sys:sap+ second (- n-bytes)))
|
|
(n-bits (* 2 sb-vm:n-word-bits)))
|
|
(assert (sb-sys:sap=
|
|
second
|
|
(sb-posix:mmap second sb-c:+backend-page-bytes+
|
|
sb-posix:prot-none
|
|
(logior sb-posix:map-private sb-posix:map-anon sb-posix:map-fixed)
|
|
-1 0)))
|
|
(setf (sb-sys:sap-ref-word addr 0) sb-vm:simple-bit-vector-widetag)
|
|
(setf (sb-kernel:%array-fill-pointer
|
|
(sb-kernel:%make-lisp-obj (logior (sb-sys:sap-int addr)
|
|
sb-vm:other-pointer-lowtag)))
|
|
n-bits)
|
|
(let* ((object
|
|
(sb-vm::reconstitute-object
|
|
(sb-c::mask-signed-field
|
|
sb-vm:n-fixnum-bits
|
|
(ash (sb-sys:sap-int addr)
|
|
(- sb-vm:n-fixnum-tag-bits)))))
|
|
(size (sb-ext:primitive-object-size object)))
|
|
(assert (simple-bit-vector-p object))
|
|
(assert (= size n-bytes))
|
|
(assert (not (sb-kernel:%bit-position/1 object nil 0 n-bits)))
|
|
(assert (not (sb-kernel:%bit-position/1 object nil n-bits n-bits))))))
|
|
|
|
;;; Shamelessly piggybacking on the approach above to grab a page
|
|
;;; which adjoins an unreadable page for testing the disassembler.
|
|
#-win32 ;; no sb-posix:mmap
|
|
(with-test (:name :disassembler-overrun :skipped-on (not (or :x86 :x86-64)))
|
|
(let* ((n-bytes 7)
|
|
(first (sb-posix:mmap nil (* sb-c:+backend-page-bytes+ 2)
|
|
(logior sb-posix:prot-read
|
|
sb-posix:prot-write)
|
|
(logior sb-posix:map-private sb-posix:map-anon) -1 0))
|
|
(second (sb-sys:sap+ first sb-c:+backend-page-bytes+))
|
|
(addr (sb-sys:sap+ second (- n-bytes))))
|
|
(assert (sb-sys:sap=
|
|
second
|
|
(sb-posix:mmap second sb-c:+backend-page-bytes+
|
|
sb-posix:prot-none
|
|
(logior sb-posix:map-private sb-posix:map-anon sb-posix:map-fixed)
|
|
-1 0)))
|
|
(loop for byte in '(#x8B #x50 #xFD #x8B #xE5 #xF8 #x5D)
|
|
for i from 0
|
|
do (setf (sb-sys:sap-ref-8 addr i) byte))
|
|
(sb-disassem:disassemble-memory addr 7 :stream (make-broadcast-stream))))
|