>From 16ca1ed41ecb23a69fbd421f2f7d380bcdc82fd0 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 15 Feb 2011 07:34:54 -0500 Subject: [PATCH 3/3] Add `round-ash', a rounding arithmetic shift operator * libguile/numbers.c (left_shift_exact_integer, floor_right_shift_exact_integer, round_right_shift_exact_integer): New internal static functions to efficiently compute n * 2^count, floor(n / 2^count), and round(n / 2^count), respectively, for exact integer N and positive exact integer COUNT. Used to combine the implementations of `ash' and `round-ash' with minimal code duplication. (scm_ash): Reimplement in terms of left_shift_exact_integer and floor_right_shift_exact_integer. Note that this function efficiently computes floor(n * 2^count). (scm_round_ash): New procedure to efficiently compute round(n * 2^count), for exact integers N and COUNT. Implemented in terms of left_shift_exact_integer and round_right_shift_exact_integer. * libguile/numbers.h: Add prototype for scm_round_ash. Change the name of scm_ash's second formal parameter from `cnt' to `count'. * test-suite/tests/numbers.test (round-ash, ash): Add new unified testing framework for `ash' and `round-ash'. Previously, the tests for `ash' were not very comprehensive; for example, they did not include a single test where the number to be shifted was a bignum. * doc/ref/api-data.texi (Bitwise Operations): Add documentation for `round-ash'. Improve documentation for `ash'. * NEWS: Add NEWS entry. --- NEWS | 12 ++ doc/ref/api-data.texi | 44 ++++++-- libguile/numbers.c | 230 ++++++++++++++++++++++++++++------------- libguile/numbers.h | 3 +- test-suite/tests/numbers.test | 114 +++++++++------------ 5 files changed, 251 insertions(+), 152 deletions(-) diff --git a/NEWS b/NEWS index b53386a..c21e17c 100644 --- a/NEWS +++ b/NEWS @@ -1051,6 +1051,18 @@ R5RS integer-only operators `quotient' and `remainder'. For `round-quotient', `round-remainder', and `round/', Q is rounded to the nearest integer, with ties going to the nearest even integer. +*** New procedure: `round-ash', a rounding arithmetic shift operator + +round-ash is similar to ash, the arithmetic shift operator, except +that round-ash rounds to the nearest integer, with ties going to the +nearest even integer, whereas ash rounds toward negative infinity. + +Note that: (round-ash N COUNT) = round(N * 2^COUNT), +compared with: (ash N COUNT) = floor(N * 2^COUNT), + +except that round-ash and ash are computed more efficiently, and +require that N and COUNT be exact integers. + *** Complex number changes Guile is now able to represent non-real complex numbers whose diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 5bef926..8f7c35a 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1659,19 +1659,16 @@ starts from 0 for the least significant bit. @end lisp @end deffn address@hidden {Scheme Procedure} ash n cnt address@hidden {C Function} scm_ash (n, cnt) -Return @var{n} shifted left by @var{cnt} bits, or shifted right if address@hidden is negative. This is an ``arithmetic'' shift. - -This is effectively a multiplication by @m{2^{cnt}, address@hidden, and -when @var{cnt} is negative it's a division, rounded towards negative -infinity. (Note that this is not the same rounding as @code{quotient} -does.) address@hidden {Scheme Procedure} ash n count address@hidden {C Function} scm_ash (n, count) +Return @math{floor(@var{n} * address@hidden)}, but computed +more efficiently. @var{n} and @var{count} must be exact +integers. -With @var{n} viewed as an infinite precision twos complement, address@hidden means a left shift introducing zero bits, or a right shift -dropping bits. +With @var{n} viewed as an infinite-precision twos-complement +integer, @code{ash} means a left shift introducing zero bits +when @var{count} is positive, or a right shift dropping bits +when @var{count} is negative. This is an ``arithmetic'' shift. @lisp (number->string (ash #b1 3) 2) @result{} "1000" @@ -1682,6 +1679,29 @@ dropping bits. @end lisp @end deffn address@hidden {Scheme Procedure} round-ash n count address@hidden {C Function} scm_round_ash (n, count) +Return @math{round(@var{n} * address@hidden)}, but computed +more efficiently. @var{n} and @var{count} must be exact +integers. + +With @var{n} viewed as an infinite-precision twos-complement +integer, @code{round-ash} means a left shift introducing zero +bits when @var{count} is positive, or a right shift rounding +to the nearest integer (with ties going to the nearest even +integer) when @var{count} is negative. This is a rounded +``arithmetic'' shift. + address@hidden +(number->string (round-ash #b1 3) 2) @result{} \"1000\" +(number->string (round-ash #b1010 -1) 2) @result{} \"101\" +(number->string (round-ash #b1010 -2) 2) @result{} \"10\" +(number->string (round-ash #b1011 -2) 2) @result{} \"11\" +(number->string (round-ash #b1101 -2) 2) @result{} \"11\" +(number->string (round-ash #b1110 -2) 2) @result{} \"100\" address@hidden lisp address@hidden deffn + @deffn {Scheme Procedure} logcount n @deffnx {C Function} scm_logcount (n) Return the number of bits in integer @var{n}. If @var{n} is diff --git a/libguile/numbers.c b/libguile/numbers.c index d0aacb7..4893790 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4680,19 +4680,122 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, } #undef FUNC_NAME +/* n must be an exact integer, and count > 0. + Returns n * 2^count. */ +static SCM +left_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + + /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always + overflow a non-zero fixnum. For smaller shifts we check the + bits going into positions above SCM_I_FIXNUM_BIT-1. If they're + all 0s for nn>=0, or all 1s for nn<0 then there's no overflow. + Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - + count)". */ + + if (nn == 0) + return n; + else if (count < SCM_I_FIXNUM_BIT-1 && + ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1) + <= 1)) + { + return SCM_I_MAKINUM (nn << count); + } + else + { + SCM result = scm_i_inum2big (nn); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), + count); + return result; + } + } + else if (SCM_BIGP (n)) + { + SCM result = scm_i_mkbig (); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), + count); + scm_remember_upto_here_1 (n); + return result; + } + else + scm_syserror ("left_shift_exact_integer"); +} + +/* n must be an exact integer, and count > 0. + Returns floor(n / 2^count). */ +static SCM +floor_right_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + + if (count >= SCM_I_FIXNUM_BIT) + return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM (-1)); + else + return SCM_I_MAKINUM (SCM_SRS (nn, count)); + } + else if (SCM_BIGP (n)) + { + SCM result = scm_i_mkbig (); + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), + count); + scm_remember_upto_here_1 (n); + return scm_i_normbig (result); + } + else + scm_syserror ("floor_right_shift_exact_integer"); +} + +/* n must be an exact integer, and count > 0. + Returns round(n / 2^count). */ +static SCM +round_right_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + scm_t_inum qq = SCM_SRS (nn, count); + + if (count >= SCM_I_FIXNUM_BIT) + return SCM_INUM0; + else if (0 == (nn & (1L << (count-1)))) + return SCM_I_MAKINUM (qq); /* round down */ + else if (nn & ((1L << (count-1)) - 1)) + return SCM_I_MAKINUM (qq + 1); /* round up */ + else + return SCM_I_MAKINUM ((~1L) & (qq + 1)); /* round to even */ + } + else if (SCM_BIGP (n)) + { + SCM q = scm_i_mkbig (); + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), count); + if (mpz_tstbit (SCM_I_BIG_MPZ (n), count-1)) + { + if ((mpz_scan1 (SCM_I_BIG_MPZ (n), 0) < count-1) || + (mpz_odd_p (SCM_I_BIG_MPZ (q)))) + mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1); + } + scm_remember_upto_here_1 (n); + return scm_i_normbig (q); + } + else + scm_syserror ("round_right_shift_exact_integer"); +} + SCM_DEFINE (scm_ash, "ash", 2, 0, 0, - (SCM n, SCM cnt), - "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n" - "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n" - "\n" - "This is effectively a multiplication by address@hidden, and when\n" - "@var{cnt} is negative it's a division, rounded towards negative\n" - "infinity. (Note that this is not the same rounding as\n" - "@code{quotient} does.)\n" + (SCM n, SCM count), + "Return @math{floor(@var{n} * address@hidden)}, but computed\n" + "more efficiently. @var{n} and @var{count} must be exact\n" + "integers.\n" "\n" - "With @var{n} viewed as an infinite precision twos complement,\n" - "@code{ash} means a left shift introducing zero bits, or a right\n" - "shift dropping bits.\n" + "With @var{n} viewed as an infinite-precision twos-complement\n" + "integer, @code{ash} means a left shift introducing zero bits\n" + "when @var{count} is positive, or a right shift dropping bits\n" + "when @var{count} is negative. This is an ``arithmetic'' shift.\n" "\n" "@lisp\n" "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" @@ -4703,79 +4806,58 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_ash { - long bits_to_shift; - bits_to_shift = scm_to_long (cnt); - - if (SCM_I_INUMP (n)) + if (SCM_I_INUMP (n) || SCM_BIGP (n)) { - scm_t_inum nn = SCM_I_INUM (n); + long bits_to_shift = scm_to_long (count); if (bits_to_shift > 0) - { - /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always - overflow a non-zero fixnum. For smaller shifts we check the - bits going into positions above SCM_I_FIXNUM_BIT-1. If they're - all 0s for nn>=0, or all 1s for nn<0 then there's no overflow. - Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - - bits_to_shift)". */ - - if (nn == 0) - return n; - - if (bits_to_shift < SCM_I_FIXNUM_BIT-1 - && ((scm_t_bits) - (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1) - <= 1)) - { - return SCM_I_MAKINUM (nn << bits_to_shift); - } - else - { - SCM result = scm_i_inum2big (nn); - mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), - bits_to_shift); - return result; - } - } + return left_shift_exact_integer (n, bits_to_shift); + else if (SCM_LIKELY (bits_to_shift < 0)) + return floor_right_shift_exact_integer (n, -bits_to_shift); else - { - bits_to_shift = -bits_to_shift; - if (bits_to_shift >= SCM_LONG_BIT) - return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1)); - else - return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift)); - } - + return n; } - else if (SCM_BIGP (n)) - { - SCM result; + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); +} +#undef FUNC_NAME - if (bits_to_shift == 0) - return n; +SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0, + (SCM n, SCM count), + "Return @math{round(@var{n} * address@hidden)}, but computed\n" + "more efficiently. @var{n} and @var{count} must be exact\n" + "integers.\n" + "\n" + "With @var{n} viewed as an infinite-precision twos-complement\n" + "integer, @code{round-ash} means a left shift introducing zero\n" + "bits when @var{count} is positive, or a right shift rounding\n" + "to the nearest integer (with ties going to the nearest even\n" + "integer) when @var{count} is negative. This is a rounded\n" + "``arithmetic'' shift.\n" + "\n" + "@lisp\n" + "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n" + "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n" + "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n" + "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n" + "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n" + "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n" + "@end lisp") +#define FUNC_NAME s_scm_round_ash +{ + if (SCM_I_INUMP (n) || SCM_BIGP (n)) + { + long bits_to_shift = scm_to_long (count); - result = scm_i_mkbig (); - if (bits_to_shift >= 0) - { - mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), - bits_to_shift); - return result; - } + if (bits_to_shift > 0) + return left_shift_exact_integer (n, bits_to_shift); + else if (SCM_LIKELY (bits_to_shift < 0)) + return round_right_shift_exact_integer (n, -bits_to_shift); else - { - /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so - we have to allocate a bignum even if the result is going to be a - fixnum. */ - mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), - -bits_to_shift); - return scm_i_normbig (result); - } - + return n; } else - { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n); - } + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); } #undef FUNC_NAME diff --git a/libguile/numbers.h b/libguile/numbers.h index ab96981..16d351e 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -204,7 +204,8 @@ SCM_API SCM scm_logbit_p (SCM n1, SCM n2); SCM_API SCM scm_lognot (SCM n); SCM_API SCM scm_modulo_expt (SCM n, SCM k, SCM m); SCM_API SCM scm_integer_expt (SCM z1, SCM z2); -SCM_API SCM scm_ash (SCM n, SCM cnt); +SCM_API SCM scm_ash (SCM n, SCM count); +SCM_API SCM scm_round_ash (SCM n, SCM count); SCM_API SCM scm_bit_extract (SCM n, SCM start, SCM end); SCM_API SCM scm_logcount (SCM n); SCM_API SCM scm_integer_length (SCM n); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index cb582ed..9a7d85b 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -201,71 +201,6 @@ (eqv? -2305843009213693953 (1- -2305843009213693952)))) ;;; -;;; ash -;;; - -(with-test-prefix "ash" - - (pass-if "documented?" - (documented? ash)) - - (pass-if (eqv? 0 (ash 0 0))) - (pass-if (eqv? 0 (ash 0 1))) - (pass-if (eqv? 0 (ash 0 1000))) - (pass-if (eqv? 0 (ash 0 -1))) - (pass-if (eqv? 0 (ash 0 -1000))) - - (pass-if (eqv? 1 (ash 1 0))) - (pass-if (eqv? 2 (ash 1 1))) - (pass-if (eqv? 340282366920938463463374607431768211456 (ash 1 128))) - (pass-if (eqv? 0 (ash 1 -1))) - (pass-if (eqv? 0 (ash 1 -1000))) - - (pass-if (eqv? -1 (ash -1 0))) - (pass-if (eqv? -2 (ash -1 1))) - (pass-if (eqv? -340282366920938463463374607431768211456 (ash -1 128))) - (pass-if (eqv? -1 (ash -1 -1))) - (pass-if (eqv? -1 (ash -1 -1000))) - - (pass-if (eqv? -3 (ash -3 0))) - (pass-if (eqv? -6 (ash -3 1))) - (pass-if (eqv? -1020847100762815390390123822295304634368 (ash -3 128))) - (pass-if (eqv? -2 (ash -3 -1))) - (pass-if (eqv? -1 (ash -3 -1000))) - - (pass-if (eqv? -6 (ash -23 -2))) - - (pass-if (eqv? most-positive-fixnum (ash most-positive-fixnum 0))) - (pass-if (eqv? (* 2 most-positive-fixnum) (ash most-positive-fixnum 1))) - (pass-if (eqv? (* 4 most-positive-fixnum) (ash most-positive-fixnum 2))) - (pass-if - (eqv? (* most-positive-fixnum 340282366920938463463374607431768211456) - (ash most-positive-fixnum 128))) - (pass-if (eqv? (quotient most-positive-fixnum 2) - (ash most-positive-fixnum -1))) - (pass-if (eqv? 0 (ash most-positive-fixnum -1000))) - - (let ((mpf4 (quotient most-positive-fixnum 4))) - (pass-if (eqv? (* 2 mpf4) (ash mpf4 1))) - (pass-if (eqv? (* 4 mpf4) (ash mpf4 2))) - (pass-if (eqv? (* 8 mpf4) (ash mpf4 3)))) - - (pass-if (eqv? most-negative-fixnum (ash most-negative-fixnum 0))) - (pass-if (eqv? (* 2 most-negative-fixnum) (ash most-negative-fixnum 1))) - (pass-if (eqv? (* 4 most-negative-fixnum) (ash most-negative-fixnum 2))) - (pass-if - (eqv? (* most-negative-fixnum 340282366920938463463374607431768211456) - (ash most-negative-fixnum 128))) - (pass-if (eqv? (quotient-floor most-negative-fixnum 2) - (ash most-negative-fixnum -1))) - (pass-if (eqv? -1 (ash most-negative-fixnum -1000))) - - (let ((mnf4 (quotient-floor most-negative-fixnum 4))) - (pass-if (eqv? (* 2 mnf4) (ash mnf4 1))) - (pass-if (eqv? (* 4 mnf4) (ash mnf4 2))) - (pass-if (eqv? (* 8 mnf4) (ash mnf4 3))))) - -;;; ;;; exact? ;;; @@ -4814,3 +4749,52 @@ round-quotient round-remainder valid-round-answer?))) + +;;; +;;; ash +;;; round-ash +;;; + +(let () + (define (test-ash-variant name ash-variant round-variant) + (with-test-prefix name + (define (test n count) + (pass-if (list n count) + (eqv? (ash-variant n count) + (round-variant (* n (expt 2 count)))))) + + (pass-if "documented?" + (documented? ash-variant)) + + (for-each (lambda (n) + (for-each (lambda (count) (test n count)) + '(-1000 -3 -2 -1 0 1 2 3 1000))) + (list 0 1 3 23 -1 -3 -23 + fixnum-max + (1+ fixnum-max) + (1- fixnum-max) + (* fixnum-max 4) + (quotient fixnum-max 4) + fixnum-min + (1+ fixnum-min) + (1- fixnum-min) + (* fixnum-min 4) + (quotient fixnum-min 4))) + + (do ((count -2 (1- count)) + (vals '(1 3 5 7 9 11) + (map (lambda (n) (* 2 n)) vals))) + ((> (car vals) (* 2 fixnum-max)) 'done) + (for-each (lambda (n) + (test n count) + (test (- n) count)) + vals)) + + ;; Test rounding + (for-each (lambda (base) + (for-each (lambda (offset) (test (+ base offset) -3)) + '(#b11001 #b11100 #b11101 #b10001 #b10100 #b10101))) + (list 0 64 -64 (* 64 fixnum-max) (* 64 fixnum-min))))) + + (test-ash-variant 'ash ash floor) + (test-ash-variant 'round-ash round-ash round)) -- 1.7.1