From: Andy Moreton Date: Sat, 4 Aug 2018 16:28:13 +0000 (-0600) Subject: Make bignums work better when EMACS_INT is larger than long X-Git-Tag: emacs-27.0.90~4598^2~13 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=bc8ff54efee05f4a2769be32046866ed1e152b41;p=emacs.git Make bignums work better when EMACS_INT is larger than long * lisp/international/ccl.el (ccl-fixnum): New function. (ccl-embed-data, ccl-embed-current-address, ccl-dump): Use it. * src/alloc.c (make_number): Handle case where EMACS_INT is larger than long. * src/data.c (bignumcompare): Handle case where EMACS_INT is larger than long. (arith_driver): Likewise. Coerce markers. (float_arith_driver): Coerce markers. (Flogcount): Use mpz_sgn. (ash_lsh_impl): Fix bugs. (Fsub1): Fix underflow check. * src/lisp.h (NUMBERP): Don't check BIGNUMP. (CHECK_FIXNUM_OR_FLOAT_COERCE_MARKER): Fix indentation. * test/lisp/international/ccl-tests.el: New file. --- diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el index d2f490d59cd..d1b82ceb9ce 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el @@ -184,11 +184,17 @@ (defvar ccl-current-ic 0 "The current index for `ccl-program-vector'.") +;; This is needed because CCL assumes the pre-bigint (wrapping) +;; semantics of integer overflow. +(defun ccl-fixnum (code) + "Convert a CCL code word to a fixnum value." + (- (logxor (logand code #x0fffffff) #x08000000) #x08000000)) + (defun ccl-embed-data (data &optional ic) "Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and increment it. If IC is specified, embed DATA at IC." (if ic - (aset ccl-program-vector ic data) + (aset ccl-program-vector ic (ccl-fixnum data)) (let ((len (length ccl-program-vector))) (if (>= ccl-current-ic len) (let ((new (make-vector (* len 2) nil))) @@ -196,7 +202,7 @@ increment it. If IC is specified, embed DATA at IC." (setq len (1- len)) (aset new len (aref ccl-program-vector len))) (setq ccl-program-vector new)))) - (aset ccl-program-vector ccl-current-ic data) + (aset ccl-program-vector ccl-current-ic (ccl-fixnum data)) (setq ccl-current-ic (1+ ccl-current-ic)))) (defun ccl-embed-symbol (symbol prop) @@ -230,7 +236,8 @@ proper index number for SYMBOL. PROP should be `ccl-program-vector' at IC without altering the other bit field." (let ((relative (- ccl-current-ic (1+ ic)))) (aset ccl-program-vector ic - (logior (aref ccl-program-vector ic) (ash relative 8))))) + (logior (aref ccl-program-vector ic) + (ccl-fixnum (ash relative 8)))))) (defun ccl-embed-code (op reg data &optional reg2) "Embed CCL code for the operation OP and arguments REG and DATA in @@ -986,7 +993,8 @@ is a list of CCL-BLOCKs." (defun ccl-get-next-code () "Return a CCL code in `ccl-code' at `ccl-current-ic'." (prog1 - (aref ccl-code ccl-current-ic) + (let ((code (aref ccl-code ccl-current-ic))) + (if (numberp code) (ccl-fixnum code) code)) (setq ccl-current-ic (1+ ccl-current-ic)))) (defun ccl-dump-1 () diff --git a/src/alloc.c b/src/alloc.c index 1dc1bbb031a..367bb73fc15 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3815,6 +3815,34 @@ make_number (mpz_t value) } } + /* Check if fixnum can be larger than long. */ + if (sizeof (EMACS_INT) > sizeof (long)) + { + size_t bits = mpz_sizeinbase (value, 2); + int sign = mpz_sgn (value); + + if (bits < FIXNUM_BITS + (sign < 0)) + { + EMACS_INT v = 0; + size_t limbs = mpz_size (value); + mp_size_t i; + + for (i = 0; i < limbs; i++) + { + mp_limb_t limb = mpz_getlimbn (value, i); + v |= (EMACS_INT) ((EMACS_UINT) limb << (i * GMP_NUMB_BITS)); + } + if (sign < 0) + v = -v; + + if (!FIXNUM_OVERFLOW_P (v)) + { + XSETINT (obj, v); + return obj; + } + } + } + obj = allocate_misc (Lisp_Misc_Bignum); b = XBIGNUM (obj); /* We could mpz_init + mpz_swap here, to avoid a copy, but the diff --git a/src/data.c b/src/data.c index 0deebdca1ae..3d55d9d17d5 100644 --- a/src/data.c +++ b/src/data.c @@ -2409,7 +2409,18 @@ bignumcompare (Lisp_Object num1, Lisp_Object num2, if (FLOATP (num2)) cmp = mpz_cmp_d (XBIGNUM (num1)->value, XFLOAT_DATA (num2)); else if (FIXNUMP (num2)) - cmp = mpz_cmp_si (XBIGNUM (num1)->value, XINT (num2)); + { + if (sizeof (EMACS_INT) > sizeof (long) && XINT (num2) > LONG_MAX) + { + mpz_t tem; + mpz_init (tem); + mpz_set_intmax (tem, XINT (num2)); + cmp = mpz_cmp (XBIGNUM (num1)->value, tem); + mpz_clear (tem); + } + else + cmp = mpz_cmp_si (XBIGNUM (num1)->value, XINT (num2)); + } else { eassume (BIGNUMP (num2)); @@ -2422,10 +2433,19 @@ bignumcompare (Lisp_Object num1, Lisp_Object num2, if (FLOATP (num1)) cmp = - mpz_cmp_d (XBIGNUM (num2)->value, XFLOAT_DATA (num1)); else - { + { eassume (FIXNUMP (num1)); - cmp = - mpz_cmp_si (XBIGNUM (num2)->value, XINT (num1)); - } + if (sizeof (EMACS_INT) > sizeof (long) && XINT (num1) > LONG_MAX) + { + mpz_t tem; + mpz_init (tem); + mpz_set_intmax (tem, XINT (num1)); + cmp = - mpz_cmp (XBIGNUM (num2)->value, tem); + mpz_clear (tem); + } + else + cmp = - mpz_cmp_si (XBIGNUM (num2)->value, XINT (num1)); + } } switch (comparison) @@ -2860,7 +2880,7 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) { /* Using args[argnum] as argument to CHECK_NUMBER... */ val = args[argnum]; - CHECK_NUMBER (val); + CHECK_NUMBER_COERCE_MARKER (val); if (FLOATP (val)) return unbind_to (count, @@ -2871,7 +2891,15 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) case Aadd: if (BIGNUMP (val)) mpz_add (accum, accum, XBIGNUM (val)->value); - else if (XINT (val) < 0) + else if (sizeof (EMACS_INT) > sizeof (long)) + { + mpz_t tem; + mpz_init (tem); + mpz_set_intmax (tem, XINT (val)); + mpz_add (accum, accum, tem); + mpz_clear (tem); + } + else if (XINT (val) < 0) mpz_sub_ui (accum, accum, - XINT (val)); else mpz_add_ui (accum, accum, XINT (val)); @@ -2888,6 +2916,14 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) } else if (BIGNUMP (val)) mpz_sub (accum, accum, XBIGNUM (val)->value); + else if (sizeof (EMACS_INT) > sizeof (long)) + { + mpz_t tem; + mpz_init (tem); + mpz_set_intmax (tem, XINT (val)); + mpz_sub (accum, accum, tem); + mpz_clear (tem); + } else if (XINT (val) < 0) mpz_add_ui (accum, accum, - XINT (val)); else @@ -2896,6 +2932,14 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) case Amult: if (BIGNUMP (val)) mpz_mul (accum, accum, XBIGNUM (val)->value); + else if (sizeof (EMACS_INT) > sizeof (long)) + { + mpz_t tem; + mpz_init (tem); + mpz_set_intmax (tem, XINT (val)); + mpz_mul (accum, accum, tem); + mpz_clear (tem); + } else mpz_mul_si (accum, accum, XINT (val)); break; @@ -2915,6 +2959,14 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) xsignal0 (Qarith_error); if (BIGNUMP (val)) mpz_tdiv_q (accum, accum, XBIGNUM (val)->value); + else if (sizeof (EMACS_INT) > sizeof (long)) + { + mpz_t tem; + mpz_init (tem); + mpz_set_intmax (tem, XINT (val)); + mpz_tdiv_q (accum, accum, tem); + mpz_clear (tem); + } else { EMACS_INT value = XINT (val); @@ -2982,8 +3034,9 @@ float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code, for (; argnum < nargs; argnum++) { - val = args[argnum]; /* using args[argnum] as argument to CHECK_FIXNUM_... */ - CHECK_FIXNUM_OR_FLOAT_COERCE_MARKER (val); + /* using args[argnum] as argument to CHECK_NUMBER_... */ + val = args[argnum]; + CHECK_NUMBER_COERCE_MARKER (val); if (FLOATP (val)) { @@ -3277,7 +3330,7 @@ representation. */) if (BIGNUMP (value)) { - if (mpz_cmp_si (XBIGNUM (value)->value, 0) >= 0) + if (mpz_sgn (XBIGNUM (value)->value) >= 0) return make_fixnum (mpz_popcount (XBIGNUM (value)->value)); mpz_t tem; mpz_init (tem); @@ -3314,8 +3367,10 @@ ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh) mpz_init (result); if (XINT (count) >= 0) mpz_mul_2exp (result, XBIGNUM (value)->value, XINT (count)); - else + else if (lsh) mpz_tdiv_q_2exp (result, XBIGNUM (value)->value, - XINT (count)); + else + mpz_fdiv_q_2exp (result, XBIGNUM (value)->value, - XINT (count)); val = make_number (result); mpz_clear (result); } @@ -3325,14 +3380,21 @@ ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh) mpz_t result; eassume (FIXNUMP (value)); mpz_init (result); - if (lsh) - mpz_set_uintmax (result, XUINT (value)); - else - mpz_set_intmax (result, XINT (value)); + + mpz_set_intmax (result, XINT (value)); + if (XINT (count) >= 0) mpz_mul_2exp (result, result, XINT (count)); - else - mpz_tdiv_q_2exp (result, result, - XINT (count)); + else if (lsh) + { + if (mpz_sgn (result) > 0) + mpz_fdiv_q_2exp (result, result, - XINT (count)); + else + mpz_fdiv_q_2exp (result, result, - XINT (count)); + } + else /* ash */ + mpz_fdiv_q_2exp (result, result, - XINT (count)); + val = make_number (result); mpz_clear (result); } @@ -3414,7 +3476,7 @@ Markers are converted to integers. */) else { eassume (FIXNUMP (number)); - if (XINT (number) > MOST_POSITIVE_FIXNUM) + if (XINT (number) > MOST_NEGATIVE_FIXNUM) XSETINT (number, XINT (number) - 1); else { diff --git a/src/lisp.h b/src/lisp.h index 4208634fa95..b404f9d89aa 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2778,7 +2778,7 @@ NATNUMP (Lisp_Object x) INLINE bool NUMBERP (Lisp_Object x) { - return INTEGERP (x) || FLOATP (x) || BIGNUMP (x); + return INTEGERP (x) || FLOATP (x); } INLINE bool @@ -2947,7 +2947,7 @@ CHECK_INTEGER (Lisp_Object x) if (MARKERP (x)) \ XSETFASTINT (x, marker_position (x)); \ else \ - CHECK_TYPE (FIXED_OR_FLOATP (x), Qnumber_or_marker_p, x); \ + CHECK_TYPE (FIXED_OR_FLOATP (x), Qnumber_or_marker_p, x); \ } while (false) #define CHECK_NUMBER_COERCE_MARKER(x) \ diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el new file mode 100644 index 00000000000..d0c254ce91b --- /dev/null +++ b/test/lisp/international/ccl-tests.el @@ -0,0 +1,219 @@ +(require 'ert) +(require 'ccl) +(require 'seq) + + +(ert-deftest shift () + ;; shift left +ve 5628 #x00000000000015fc + (should (= (ash 5628 8) 1440768)) ; #x000000000015fc00 + (should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00 + + ;; shift left -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400 + (should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400 + + ;; shift right +ve 5628 #x00000000000015fc + (should (= (ash 5628 -8) 21)) ; #x0000000000000015 + (should (= (lsh 5628 -8) 21)) ; #x0000000000000015 + + ;; shift right -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea + + ;; shift right -5628 #x3fffffffffffea04 + (cond + ((fboundp 'bignump) + (should (= (lsh -5628 -8) -22))) ; #x3fffffffffffffea bignum + ((= (logb most-negative-fixnum) 61) + (should (= (lsh -5628 -8) + (string-to-number + "18014398509481962")))) ; #x003fffffffffffea master (64bit) + ((= (logb most-negative-fixnum) 29) + (should (= (lsh -5628 -8) 4194282))) ; #x003fffea master (32bit) + )) + +;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el +(defconst prog-pgg-source + '(1 + ((loop + (read r0) (r1 ^= r0) (r2 ^= 0) + (r5 = 0) + (loop + (r1 <<= 1) + (r1 += ((r2 >> 15) & 1)) + (r2 <<= 1) + (if (r1 & 256) + ((r1 ^= 390) (r2 ^= 19707))) + (if (r5 < 7) + ((r5 += 1) + (repeat)))) + (repeat))))) + +(defconst prog-pgg-code + [1 30 14 114744 114775 0 161 131127 1 148217 15 82167 + 1 1848 131159 1 1595 5 256 114743 390 114775 19707 + 1467 16 7 183 1 -5628 -7164 22]) + +(defconst prog-pgg-dump +"Out-buffer must be as large as in-buffer. +Main-body: + 2:[read-register] read r0 (0 remaining) + 3:[set-assign-expr-register] r1 ^= r0 + 4:[set-assign-expr-const] r2 ^= 0 + 6:[set-short-const] r5 = 0 + 7:[set-assign-expr-const] r1 <<= 1 + 9:[set-expr-const] r7 = r2 >> 15 + 11:[set-assign-expr-const] r7 &= 1 + 13:[set-assign-expr-register] r1 += r7 + 14:[set-assign-expr-const] r2 <<= 1 + 16:[jump-cond-expr-const] if !(r1 & 256), jump to 23(+7) + 19:[set-assign-expr-const] r1 ^= 390 + 21:[set-assign-expr-const] r2 ^= 19707 + 23:[jump-cond-expr-const] if !(r5 < 7), jump to 29(+6) + 26:[set-assign-expr-const] r5 += 1 + 28:[jump] jump to 7(-21) + 29:[jump] jump to 2(-27) +At EOF: + 30:[end] end +") + +(ert-deftest ccl-compile-pgg () + (should (equal (ccl-compile prog-pgg-source) prog-pgg-code))) + +(ert-deftest ccl-dump-pgg () + (with-temp-buffer + (ccl-dump prog-pgg-code) + (should (equal (buffer-string) prog-pgg-dump)))) + +(ert-deftest pgg-parse-crc24 () + ;; Compiler + (require 'pgg) + (should (equal pgg-parse-crc24 prog-pgg-code)) + ;; Interpreter + (should (equal (pgg-parse-crc24-string "foo") (concat [#x4f #xc2 #x55]))) + (should (equal (pgg-parse-crc24-string "bar") (concat [#x51 #xd9 #x53]))) + (should (equal (pgg-parse-crc24-string "baz") (concat [#xf0 #x58 #x6a])))) + +(ert-deftest pgg-parse-crc24-dump () + ;; Disassembler + (require 'pgg) + (with-temp-buffer + (ccl-dump pgg-parse-crc24) + (should (equal (buffer-string) prog-pgg-dump)))) + +;;---------------------------------------------------------------------------- +;; Program from 'midikbd-decoder in midi-kbd-0.2.el GNU ELPA package +(defconst prog-midi-source + '(2 + (loop + (loop + ;; central message receiver loop here. + ;; When it exits, the command to deal with is in r0 + ;; Any arguments are in r1 and r2 + ;; r3 contains: 0 if no arguments are accepted + ;; 1 if 1 argument can be accepted + ;; 2 if 2 arguments can be accepted + ;; 3 if the first of two arguments has been accepted + ;; Arguments are read into r1 and r2. + ;; r4 contains the current running status byte if any. + (read-if (r0 < #x80) + (branch r3 + (repeat) + ((r1 = r0) (r0 = r4) (break)) + ((r1 = r0) (r3 = 3) (repeat)) + ((r2 = r0) (r3 = 2) (r0 = r4) (break)))) + (if (r0 >= #xf8) ; real time message + (break)) + (if (r0 < #xf0) ; channel command + ((r4 = r0) + (if ((r0 & #xe0) == #xc0) + ;; program change and channel pressure take only 1 argument + (r3 = 1) + (r3 = 2)) + (repeat))) + ;; system common message, we swallow those for now + (r3 = 0) + (repeat)) + (if ((r0 & #xf0) == #x90) + (if (r2 == 0) ; Some Midi devices use velocity 0 + ; for switching notes off, + ; so translate into note-off + ; and fall through + (r0 -= #x10) + ((r0 &= #xf) + (write 0) + (write r0 r1 r2) + (repeat)))) + (if ((r0 & #xf0) == #x80) + ((r0 &= #xf) + (write 1) + (write r0 r1 r2) + (repeat))) + (repeat)))) + +(defconst prog-midi-code + [2 72 4893 16 128 1133 5 6 9 12 16 -2556 32 1024 6660 32 865 + -4092 64 609 1024 4868 795 20 248 3844 3099 16 240 128 82169 + 224 1275 18 192 353 260 609 -9468 97 -9980 82169 240 4091 + 18 144 1371 18 0 16407 16 1796 81943 15 20 529 305 81 -14588 + 82169 240 2555 18 128 81943 15 276 529 305 81 -17660 -17916 22]) + +(defconst prog-midi-dump +"Out-buffer must be 2 times bigger than in-buffer. +Main-body: + 2:[read-jump-cond-expr-const] read r0, if !(r0 < 128), jump to 22(+20) + 5:[branch] jump to array[r3] of length 4 + 11 12 15 18 22 + 11:[jump] jump to 2(-9) + 12:[set-register] r1 = r0 + 13:[set-register] r0 = r4 + 14:[jump] jump to 41(+27) + 15:[set-register] r1 = r0 + 16:[set-short-const] r3 = 3 + 17:[jump] jump to 2(-15) + 18:[set-register] r2 = r0 + 19:[set-short-const] r3 = 2 + 20:[set-register] r0 = r4 + 21:[jump] jump to 41(+20) + 22:[jump-cond-expr-const] if !(r0 >= 248), jump to 26(+4) + 25:[jump] jump to 41(+16) + 26:[jump-cond-expr-const] if !(r0 < 240), jump to 39(+13) + 29:[set-register] r4 = r0 + 30:[set-expr-const] r7 = r0 & 224 + 32:[jump-cond-expr-const] if !(r7 == 192), jump to 37(+5) + 35:[set-short-const] r3 = 1 + 36:[jump] jump to 38(+2) + 37:[set-short-const] r3 = 2 + 38:[jump] jump to 2(-36) + 39:[set-short-const] r3 = 0 + 40:[jump] jump to 2(-38) + 41:[set-expr-const] r7 = r0 & 240 + 43:[jump-cond-expr-const] if !(r7 == 144), jump to 59(+16) + 46:[jump-cond-expr-const] if !(r2 == 0), jump to 52(+6) + 49:[set-assign-expr-const] r0 -= 16 + 51:[jump] jump to 59(+8) + 52:[set-assign-expr-const] r0 &= 15 + 54:[write-const-string] write char \"\x00\" + 55:[write-register] write r0 (2 remaining) + 56:[write-register] write r1 (1 remaining) + 57:[write-register] write r2 (0 remaining) + 58:[jump] jump to 2(-56) + 59:[set-expr-const] r7 = r0 & 240 + 61:[jump-cond-expr-const] if !(r7 == 128), jump to 71(+10) + 64:[set-assign-expr-const] r0 &= 15 + 66:[write-const-string] write char \"\x01\" + 67:[write-register] write r0 (2 remaining) + 68:[write-register] write r1 (1 remaining) + 69:[write-register] write r2 (0 remaining) + 70:[jump] jump to 2(-68) + 71:[jump] jump to 2(-69) +At EOF: + 72:[end] end +") + +(ert-deftest ccl-compile-midi () + (should (equal (ccl-compile prog-midi-source) prog-midi-code))) + +(ert-deftest ccl-dump-midi () + (with-temp-buffer + (ccl-dump prog-midi-code) + (should (equal (buffer-string) prog-midi-dump))))