From: Mark H Weaver Date: Sun, 21 Jul 2013 14:00:48 +0000 (-0400) Subject: Optimize R6RS bitwise operators. X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/93da406f331a1849f05e63387442b9aaf33f9540 Optimize R6RS bitwise operators. * module/rnrs/arithmetic/bitwise.scm (bitwise-if, bitwise-length, bitwise-first-bit-set, bitwise-bit-field, bitwise-reverse-bit-field): Replace these with aliases to the identical SRFI-60 operators 'bitwise-if', 'integer-length', 'first-set-bit', 'bit-field', and 'reverse-bit-field'. (bitwise-copy-bit, bitwise-copy-bit-field, bitwise-rotate-bit-field): Reimplement these based upon the similar SRFI-60 operators 'copy-bit', 'copy-bit-field', and 'rotate-bit-field'. * test-suite/tests/r6rs-arithmetic-bitwise.test (bitwise-copy-bit): Fix test to conform to the specification, which requires the third argument to be either 0 or 1. * test-suite/tests/r6rs-arithmetic-fixnums.test (fxcopy-bit): Fix test to conform to the specification, which requires the third argument to be either 0 or 1. --- diff --git a/module/rnrs/arithmetic/bitwise.scm b/module/rnrs/arithmetic/bitwise.scm index 0acbc8cb6..5f66cf1c1 100644 --- a/module/rnrs/arithmetic/bitwise.scm +++ b/module/rnrs/arithmetic/bitwise.scm @@ -41,6 +41,18 @@ bitwise-reverse-bit-field) (import (rnrs base (6)) (rnrs control (6)) + (rename (only (srfi srfi-60) bitwise-if + integer-length + first-set-bit + copy-bit + bit-field + copy-bit-field + rotate-bit-field + reverse-bit-field) + (integer-length bitwise-length) + (first-set-bit bitwise-first-bit-set) + (bit-field bitwise-bit-field) + (reverse-bit-field bitwise-reverse-bit-field)) (rename (only (guile) lognot logand logior @@ -60,70 +72,21 @@ (bitwise-not (logcount ei)) (logcount ei))) - (define (bitwise-if ei1 ei2 ei3) - (bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3))) - - (define (bitwise-length ei) - (do ((result 0 (+ result 1)) - (bits (if (negative? ei) (bitwise-not ei) ei) - (bitwise-arithmetic-shift bits -1))) - ((zero? bits) - result))) - - (define (bitwise-first-bit-set ei) - (define (bitwise-first-bit-set-inner bits count) - (cond ((zero? bits) -1) - ((logbit? 0 bits) count) - (else (bitwise-first-bit-set-inner - (bitwise-arithmetic-shift bits -1) (+ count 1))))) - (bitwise-first-bit-set-inner ei 0)) - (define (bitwise-bit-set? ei1 ei2) (logbit? ei2 ei1)) (define (bitwise-copy-bit ei1 ei2 ei3) - (bitwise-if (bitwise-arithmetic-shift-left 1 ei2) - (bitwise-arithmetic-shift-left ei3 ei2) - ei1)) - - (define (bitwise-bit-field ei1 ei2 ei3) - (bitwise-arithmetic-shift-right - (bitwise-and ei1 (bitwise-not (bitwise-arithmetic-shift-left -1 ei3))) - ei2)) + ;; The specification states that ei3 should be either 0 or 1. + ;; However, other values have been tolerated by both Guile 2.0.x and + ;; the sample implementation given the R6RS library document, so for + ;; backward compatibility we continue to permit it. + (copy-bit ei2 ei1 (logbit? 0 ei3))) (define (bitwise-copy-bit-field ei1 ei2 ei3 ei4) - (bitwise-if (bitwise-and (bitwise-arithmetic-shift-left -1 ei2) - (bitwise-not - (bitwise-arithmetic-shift-left -1 ei3))) - (bitwise-arithmetic-shift-left ei4 ei2) - ei1)) + (copy-bit-field ei1 ei4 ei2 ei3)) - (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift) - (define (bitwise-arithmetic-shift-right ei1 ei2) - (bitwise-arithmetic-shift ei1 (- ei2))) - (define (bitwise-rotate-bit-field ei1 ei2 ei3 ei4) - (let ((width (- ei3 ei2))) - (if (positive? width) - (let ((field (bitwise-bit-field ei1 ei2 ei3)) - (count (modulo ei4 width))) - (bitwise-copy-bit-field - ei1 ei2 ei3 - (bitwise-ior (bitwise-arithmetic-shift-left field count) - (bitwise-arithmetic-shift-right - field (- width count))))) - ei1))) + (rotate-bit-field ei1 ei4 ei2 ei3)) - (define (bitwise-reverse-bit-field ei1 ei2 ei3) - (define (reverse-bit-field-recursive n1 n2 len) - (if (> len 0) - (reverse-bit-field-recursive - (bitwise-arithmetic-shift-right n1 1) - (bitwise-copy-bit (bitwise-arithmetic-shift-left n2 1) 0 n1) - (- len 1)) - n2)) - (let ((width (- ei3 ei2))) - (if (positive? width) - (let ((field (bitwise-bit-field ei1 ei2 ei3))) - (bitwise-copy-bit-field - ei1 ei2 ei3 (reverse-bit-field-recursive field 0 width))) - ei1)))) + (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift) + (define (bitwise-arithmetic-shift-right ei1 ei2) + (bitwise-arithmetic-shift ei1 (- ei2)))) diff --git a/test-suite/tests/r6rs-arithmetic-bitwise.test b/test-suite/tests/r6rs-arithmetic-bitwise.test index 3b358461c..3e23d81f0 100644 --- a/test-suite/tests/r6rs-arithmetic-bitwise.test +++ b/test-suite/tests/r6rs-arithmetic-bitwise.test @@ -62,7 +62,7 @@ (with-test-prefix "bitwise-copy-bit" (pass-if "bitwise-copy-bit simple" - (eqv? (bitwise-copy-bit #b010 2 #b111) #b110))) + (eqv? (bitwise-copy-bit #b010 2 1) #b110))) (with-test-prefix "bitwise-bit-field" (pass-if "bitwise-bit-field simple" diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test index 60c3b87e9..2d9b177f7 100644 --- a/test-suite/tests/r6rs-arithmetic-fixnums.test +++ b/test-suite/tests/r6rs-arithmetic-fixnums.test @@ -184,7 +184,7 @@ (pass-if "fxbit-set? is #f on index of unset bit" (not (fxbit-set? 5 1)))) -(with-test-prefix "fxcopy-bit" (pass-if "simple" (fx=? (fxcopy-bit 2 2 7) 6))) +(with-test-prefix "fxcopy-bit" (pass-if "simple" (fx=? (fxcopy-bit 2 2 1) 6))) (with-test-prefix "fxbit-field" (pass-if "simple" (fx=? (fxbit-field 50 1 4) 1)))