From b61003dec6f5af2b03549439155676666186283e Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 9 Oct 2003 11:05:11 +0000 Subject: [PATCH] 0.8.4.12: I'm not proud of this. HEALTH WARNING: this may not work. It does for me, on Linux/PPC. If your sourceforge-fu is strong, please try it. HEALTH WARNING: this is ugly as sin. Unexported symbols, special assumptions, KLUDGEs thrown in with gay abandon. In partial mitigation, it does fix a bug :-) Fix for lying-to-the-compiler bug in UB32-STRENGTH-REDUCE-CONSTANT-MULTIPLY ... turn TRULY-THEs into suitable LOGANDs (inefficient in compile-time space; we only need one LOGAND wrapping the resulting form) ... likewise in x86 OPTIMIZE-MULTIPLY (even less efficient: constant mask is first :-) but that would be slow at runtime if we just left it there, so ... add - as a modular function (that was easy) ... add preliminary support for ASH as a modular function (for constant right shifts): ... delete ASH-RIGHT-[UN]SIGNED from the sparc backend (will be restored eventually, fear not, probably more cross-platformly) ... hack in special knowledge about ASH into CUT-TO-WIDTH ... ensure that all backends have a suitable VOP for translation of new ASH function ... (alpha version is 64bit, oh yes) ... don't forget out-of-line version (for xc also!) (aside: might we not need out-of-line versions of other modular functions in the xc?) --- src/code/cross-misc.lisp | 12 +- src/code/numbers.lisp | 19 ++++ src/compiler/alpha/arith.lisp | 9 +- src/compiler/generic/vm-tran.lisp | 2 +- src/compiler/hppa/arith.lisp | 11 ++ src/compiler/mips/arith.lisp | 11 ++ src/compiler/ppc/arith.lisp | 64 +++++++---- src/compiler/sparc/arith.lisp | 228 +++++++++++++------------------------ src/compiler/srctran.lisp | 63 +++++++--- src/compiler/x86/arith.lisp | 27 +++-- tests/compiler.pure.lisp | 15 +++ version.lisp-expr | 2 +- 12 files changed, 252 insertions(+), 211 deletions(-) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 0d68f25..838c63b 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -145,9 +145,9 @@ (assert (typep array '(simple-array * (*)))) (values array start end 0)) -#!+sparc -(progn - (defun sb!vm::ash-right-signed (num shift) - (ash num (- shift))) - (defun sb!vm::ash-right-unsigned (num shift) - (ash num (- shift)))) +#!-alpha +(defun sb!vm::ash-left-constant-mod32 (integer amount) + (ldb (byte 32 0) (ash integer amount))) +#!+alpha +(defun sb!vm::ash-left-constant-mod64 (integer amount) + (ldb (byte 64 0) (ash integer amount))) diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 5522134..a9987d6 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -1377,3 +1377,22 @@ for pattern = (1- (ash 1 width)) do (forms (definition name lambda-list width pattern))))) `(progn ,@(forms))) + +;;; KLUDGE: these out-of-line definitions can't use the modular +;;; arithmetic, as that is only (currently) defined for constant +;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more +;;; discussion of this hack. -- CSR, 2003-10-09 +#!-alpha +(defun sb!vm::ash-left-constant-mod32 (integer amount) + (etypecase integer + ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount))) + (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount))) + (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount))))) +#!+alpha +(defun sb!vm::ash-left-constant-mod64 (integer amount) + (etypecase integer + ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount))) + (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount))) + (bignum (ldb (byte 64 0) + (ash (logand integer #xffffffffffffffff) amount))))) + diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp index c680c61..9eece3c 100644 --- a/src/compiler/alpha/arith.lisp +++ b/src/compiler/alpha/arith.lisp @@ -364,11 +364,17 @@ (:generator 1 (inst not x res))) +(defknown ash-left-constant-mod64 (integer (integer 0)) (unsigned-byte 64) + (foldable flushable movable)) +(define-vop (fast-ash-left-constant-mod64/unsigned=>unsigned + fast-ash-c/unsigned=>unsigned) + (:translate ash-left-constant-mod64)) + (macrolet ((define-modular-backend (fun &optional constantp) (let ((mfun-name (symbolicate fun '-mod64)) (modvop (symbolicate 'fast- fun '-mod64/unsigned=>unsigned)) - (modcvop (symbolicate 'fast- fun 'mod64-c/unsigned=>unsigned)) + (modcvop (symbolicate 'fast- fun '-mod64-c/unsigned=>unsigned)) (vop (symbolicate 'fast- fun '/unsigned=>unsigned)) (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned))) `(progn @@ -379,6 +385,7 @@ `((define-vop (,modcvop ,cvop) (:translate ,mfun-name)))))))) (define-modular-backend + t) + (define-modular-backend - t) (define-modular-backend logxor t) (define-modular-backend logeqv t) (define-modular-backend logandc1) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 9365c72..f8e7bda 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -456,7 +456,7 @@ (declare (type (unsigned-byte 32) num)) (let ((adds 0) (shifts 0) (result nil) first-one) - (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x)) + (labels ((tub32 (x) `(logand ,x #xffffffff)) ; uses modular arithmetic (add (next-factor) (setf result (tub32 diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp index d47fc76..c09800b 100644 --- a/src/compiler/hppa/arith.lisp +++ b/src/compiler/hppa/arith.lisp @@ -582,6 +582,17 @@ (:translate +-mod32)) (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned) (:translate +-mod32)) +(define-modular-fun --mod32 (x y) - 32) +(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned) + (:translate --mod32)) +(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned) + (:translate --mod32)) + +(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) + (foldable flushable movable)) +(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned + fast-ash-c/unsigned=>unsigned) + (:translate ash-left-constant-mod32)) (define-modular-fun lognot-mod32 (x) lognot 32) (define-vop (lognot-mod32/unsigned=>unsigned) diff --git a/src/compiler/mips/arith.lisp b/src/compiler/mips/arith.lisp index 1d1ee7e..e38cffe 100644 --- a/src/compiler/mips/arith.lisp +++ b/src/compiler/mips/arith.lisp @@ -684,6 +684,17 @@ (:translate +-mod32)) (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned) (:translate +-mod32)) +(define-modular-fun --mod32 (x y) - 32) +(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned) + (:translate --mod32)) +(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned) + (:translate --mod32)) + +(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) + (foldable flushable movable)) +(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned + fast-ash-c/unsigned=>unsigned) + (:translate ash-left-constant-mod32)) ;;; logical operations (define-modular-fun lognot-mod32 (x) lognot 32) diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp index 1cfa927..8dab1bb 100644 --- a/src/compiler/ppc/arith.lisp +++ b/src/compiler/ppc/arith.lisp @@ -333,38 +333,45 @@ (define-vop (fast-ash/unsigned=>unsigned) (:note "inline ASH") (:args (number :scs (unsigned-reg) :to :save) - (amount :scs (signed-reg immediate))) + (amount :scs (signed-reg))) (:arg-types (:or unsigned-num) signed-num) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:translate ash) (:policy :fast-safe) (:temporary (:sc non-descriptor-reg) ndesc) - (:generator 3 - (sc-case amount - (signed-reg - (let ((positive (gen-label)) - (done (gen-label))) - (inst cmpwi amount 0) - (inst neg ndesc amount) - (inst bge positive) - (inst cmpwi ndesc 31) - (inst srw result number ndesc) - (inst ble done) - (move result zero-tn) - (inst b done) - - (emit-label positive) - ;; The result-type assures us that this shift will not overflow. - (inst slw result number amount) + (:generator 5 + (let ((positive (gen-label)) + (done (gen-label))) + (inst cmpwi amount 0) + (inst neg ndesc amount) + (inst bge positive) + (inst cmpwi ndesc 31) + (inst srw result number ndesc) + (inst ble done) + (move result zero-tn) + (inst b done) + + (emit-label positive) + ;; The result-type assures us that this shift will not overflow. + (inst slw result number amount) + + (emit-label done)))) - (emit-label done))) - (immediate - (let ((amount (tn-value amount))) - (cond - ((and (minusp amount) (< amount -31)) (move result zero-tn)) - ((minusp amount) (inst srwi result number (- amount))) - (t (inst slwi result number amount)))))))) +(define-vop (fast-ash-c/unsigned=>unsigned) + (:note "inline constant ASH") + (:args (number :scs (unsigned-reg))) + (:info amount) + (:arg-types unsigned-num (:constant integer)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate ash) + (:policy :fast-safe) + (:generator 4 + (cond + ((and (minusp amount) (< amount -31)) (move result zero-tn)) + ((minusp amount) (inst srwi result number (- amount))) + (t (inst slwi result number amount))))) (define-vop (fast-ash/signed=>signed) (:note "inline ASH") @@ -462,6 +469,12 @@ (:generator 1 (inst not res x))) +(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) + (foldable flushable movable)) +(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned + fast-ash-c/unsigned=>unsigned) + (:translate ash-left-constant-mod32)) + (macrolet ((define-modular-backend (fun &optional constantp) (let ((mfun-name (symbolicate fun '-mod32)) @@ -477,6 +490,7 @@ `((define-vop (,modcvop ,cvop) (:translate ,mfun-name)))))))) (define-modular-backend + t) + (define-modular-backend - t) (define-modular-backend logxor t) (define-modular-backend logeqv) (define-modular-backend lognand) diff --git a/src/compiler/sparc/arith.lisp b/src/compiler/sparc/arith.lisp index 1887090..65f35be 100644 --- a/src/compiler/sparc/arith.lisp +++ b/src/compiler/sparc/arith.lisp @@ -387,7 +387,7 @@ (define-vop (fast-ash/signed=>signed) (:note "inline ASH") (:args (number :scs (signed-reg) :to :save) - (amount :scs (signed-reg immediate) :to :save)) + (amount :scs (signed-reg) :to :save)) (:arg-types signed-num signed-num) (:results (result :scs (signed-reg))) (:result-types signed-num) @@ -395,32 +395,43 @@ (:policy :fast-safe) (:temporary (:sc non-descriptor-reg) ndesc) (:generator 5 - (sc-case amount - (signed-reg - (let ((done (gen-label))) - (inst cmp amount) - (inst b :ge done) - ;; The result-type assures us that this shift will not - ;; overflow. - (inst sll result number amount) - (inst neg ndesc amount) - (inst cmp ndesc 31) - (if (member :sparc-v9 *backend-subfeatures*) - (progn - (inst cmove :ge ndesc 31) - (inst sra result number ndesc)) - (progn - (inst b :le done) - (inst sra result number ndesc) - (inst sra result number 31))) - (emit-label done))) - (immediate - (bug "IMMEDIATE case in ASH VOP; should have been transformed"))))) + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst sll result number amount) + (inst neg ndesc amount) + (inst cmp ndesc 31) + (if (member :sparc-v9 *backend-subfeatures*) + (progn + (inst cmove :ge ndesc 31) + (inst sra result number ndesc)) + (progn + (inst b :le done) + (inst sra result number ndesc) + (inst sra result number 31))) + (emit-label done)))) + +(define-vop (fast-ash-c/signed=>signed) + (:note "inline constant ASH") + (:args (number :scs (signed-reg))) + (:info count) + (:arg-types signed-num (:constant integer)) + (:results (result :scs (signed-reg))) + (:result-types signed-num) + (:translate ash) + (:policy :fast-safe) + (:generator 4 + (cond + ((< count 0) (inst sra result number (min (- count) 31))) + ((> count 0) (inst sll result number (min count 31))) + (t (bug "identity ASH not transformed away"))))) (define-vop (fast-ash/unsigned=>unsigned) (:note "inline ASH") (:args (number :scs (unsigned-reg) :to :save) - (amount :scs (signed-reg immediate) :to :save)) + (amount :scs (signed-reg) :to :save)) (:arg-types unsigned-num signed-num) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) @@ -428,27 +439,39 @@ (:policy :fast-safe) (:temporary (:sc non-descriptor-reg) ndesc) (:generator 5 - (sc-case amount - (signed-reg - (let ((done (gen-label))) - (inst cmp amount) - (inst b :ge done) - ;; The result-type assures us that this shift will not - ;; overflow. - (inst sll result number amount) - (inst neg ndesc amount) - (inst cmp ndesc 32) - (if (member :sparc-v9 *backend-subfeatures*) - (progn - (inst srl result number ndesc) - (inst cmove :ge result zero-tn)) - (progn - (inst b :lt done) - (inst srl result number ndesc) - (move result zero-tn))) - (emit-label done))) - (immediate - (bug "IMMEDIATE case in ASH VOP; should have been transformed"))))) + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst sll result number amount) + (inst neg ndesc amount) + (inst cmp ndesc 32) + (if (member :sparc-v9 *backend-subfeatures*) + (progn + (inst srl result number ndesc) + (inst cmove :ge result zero-tn)) + (progn + (inst b :lt done) + (inst srl result number ndesc) + (move result zero-tn))) + (emit-label done)))) + +(define-vop (fast-ash-c/unsigned=>unsigned) + (:note "inline constant ASH") + (:args (number :scs (unsigned-reg))) + (:info count) + (:arg-types unsigned-num (:constant integer)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate ash) + (:policy :fast-safe) + (:generator 4 + (cond + ((< count -31) (move result zero-tn)) + ((< count 0) (inst srl result number (min (- count) 31))) + ((> count 0) (inst sll result number (min count 31))) + (t (bug "identity ASH not transformed away"))))) ;; Some special cases where we know we want a left shift. Just do the ;; shift, instead of checking for the sign of the shift. @@ -472,70 +495,12 @@ (inst sll result number amount)) (immediate (let ((amount (tn-value amount))) - (assert (>= amount 0)) + (aver (>= amount 0)) (inst sll result number amount)))))))) (frob fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3) (frob fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2) (frob fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3)) -(defknown ash-right-signed ((signed-byte #.sb!vm:n-word-bits) - (and fixnum unsigned-byte)) - (signed-byte #.sb!vm:n-word-bits) - (movable foldable flushable)) - -(defknown ash-right-unsigned ((unsigned-byte #.sb!vm:n-word-bits) - (and fixnum unsigned-byte)) - (unsigned-byte #.sb!vm:n-word-bits) - (movable foldable flushable)) - -;; Some special cases where we want a right shift. Just do the shift. -;; (Needs appropriate deftransforms to call these, though.) - -(macrolet - ((frob (trans name sc-type type shift-inst cost) - `(define-vop (,name) - (:note "inline right ASH") - (:translate ,trans) - (:args (number :scs (,sc-type)) - (amount :scs (signed-reg unsigned-reg immediate))) - (:arg-types ,type positive-fixnum) - (:results (result :scs (,sc-type))) - (:result-types ,type) - (:policy :fast-safe) - (:generator ,cost - (sc-case amount - ((signed-reg unsigned-reg) - (inst ,shift-inst result number amount)) - (immediate - (let ((amt (tn-value amount))) - (inst ,shift-inst result number amt)))))))) - (frob ash-right-signed fast-ash-right/signed=>signed - signed-reg signed-num sra 3) - (frob ash-right-unsigned fast-ash-right/unsigned=>unsigned - unsigned-reg unsigned-num srl 3)) - -(define-vop (fast-ash-right/fixnum=>fixnum) - (:note "inline right ASH") - (:translate ash-right-signed) - (:args (number :scs (any-reg)) - (amount :scs (signed-reg unsigned-reg immediate))) - (:arg-types tagged-num positive-fixnum) - (:results (result :scs (any-reg))) - (:result-types tagged-num) - (:temporary (:sc non-descriptor-reg :target result) temp) - (:policy :fast-safe) - (:generator 2 - ;; Shift the fixnum right by the desired amount. Then zap out the - ;; 2 LSBs to make it a fixnum again. (Those bits are junk.) - (sc-case amount - ((signed-reg unsigned-reg) - (inst sra temp number amount)) - (immediate - (inst sra temp number (tn-value amount)))) - (inst andn result temp fixnum-tag-mask))) - - - (define-vop (signed-byte-32-len) (:translate integer-length) @@ -691,7 +656,7 @@ ((define-modular-backend (fun &optional constantp) (let ((mfun-name (symbolicate fun '-mod32)) (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned)) - (modcvop (symbolicate 'fast- fun 'mod32-c/unsigned=>unsigned)) + (modcvop (symbolicate 'fast- fun '-mod32-c/unsigned=>unsigned)) (vop (symbolicate 'fast- fun '/unsigned=>unsigned)) (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned))) `(progn @@ -702,6 +667,7 @@ `((define-vop (,modcvop ,cvop) (:translate ,mfun-name)))))))) (define-modular-backend + t) + (define-modular-backend - t) (define-modular-backend logxor t) (define-modular-backend logeqv t) (define-modular-backend logandc1) @@ -713,6 +679,12 @@ `(lognot (logand ,x ,y))) (define-source-transform lognor (x y) `(lognot (logior ,x ,y))) + +(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) + (foldable flushable movable)) +(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned + fast-ash-c/unsigned=>unsigned) + (:translate ash-left-constant-mod32)) ;;;; Binary conditional VOPs: @@ -827,7 +799,6 @@ ;;;; 32-bit logical operations - (define-vop (merge-bits) (:translate merge-bits) (:args (shift :scs (signed-reg unsigned-reg)) @@ -904,7 +875,6 @@ (inst srl r num amount))) ;;;; Bignum stuff. - (define-vop (bignum-length get-header-data) (:translate sb!bignum::%bignum-length) (:policy :fast-safe)) @@ -971,7 +941,6 @@ (inst movr result null-tn digit :lz) (inst movr result temp digit :gez))) - (define-vop (add-w/carry) (:translate sb!bignum::%add-with-carry) (:policy :fast-safe) @@ -1202,7 +1171,6 @@ (signed-reg (move res digit))))) - (define-vop (digit-ashr) (:translate sb!bignum::%ashr) (:policy :fast-safe) @@ -1250,17 +1218,6 @@ (define-static-fun two-arg-eqv (x y) :translate logeqv) -;; Need these so constant folding works with the deftransform. - -;; FIXME KLUDGE ew yuk. -#-sb-xc-host -(progn - (defun ash-right-signed (num shift) - (ash-right-signed num shift)) - - (defun ash-right-unsigned (num shuft) - (ash-right-unsigned num shift))) - (in-package "SB!C") (deftransform * ((x y) @@ -1281,36 +1238,3 @@ (when (> (+ adds shifts) 9) (give-up-ir1-transform)))) (or result 0)))) - -;; If we can prove that we have a right shift, just do the right shift -;; instead of calling the inline ASH which has to check for the -;; direction of the shift at run-time. -(deftransform ash ((num shift) (integer integer)) - (let ((num-type (lvar-type num)) - (shift-type (lvar-type shift))) - ;; Can only handle right shifts - (unless (csubtypep shift-type (specifier-type '(integer * 0))) - (give-up-ir1-transform)) - - ;; If we can prove the shift is so large that all bits are shifted - ;; out, return the appropriate constant. If the shift is small - ;; enough, call the VOP. Otherwise, check for the shift size and - ;; do the appropriate thing. (Hmm, could we just leave the IF - ;; s-expr and depend on other parts of the compiler to delete the - ;; unreachable parts, if any?) - (cond ((csubtypep num-type (specifier-type '(signed-byte #.sb!vm:n-word-bits))) - ;; A right shift by 31 is the same as a right shift by - ;; larger amount. We get just the sign. - (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0))) - ;; FIXME: ash-right-{un,}signed package problems - `(sb!vm::ash-right-signed num (- shift)) - `(sb!vm::ash-right-signed num (min (- shift) #.(1- sb!vm:n-word-bits))))) - ((csubtypep num-type (specifier-type '(unsigned-byte #.sb!vm:n-word-bits))) - (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0))) - `(sb!vm::ash-right-unsigned num (- shift)) - `(if (<= shift #.(- sb!vm:n-word-bits)) - 0 - (sb!vm::ash-right-unsigned num (- shift))))) - (t - (give-up-ir1-transform))))) - diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index fe7f950..8df9c25 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2539,23 +2539,52 @@ (modular-fun (find-modular-version fun-name width)) (name (and (modular-fun-info-p modular-fun) (modular-fun-info-name modular-fun)))) - (when (and modular-fun - (not (and (eq name 'logand) - (csubtypep - (single-value-type (node-derived-type node)) - (specifier-type `(unsigned-byte ,width)))))) - (unless (eq modular-fun :good) - (setq did-something t) - (change-ref-leaf - fun-ref - (find-free-fun name "in a strange place")) - (setf (combination-kind node) :full)) - (dolist (arg (basic-combination-args node)) - (when (cut-lvar arg) - (setq did-something t))) - (when did-something - (reoptimize-node node fun-name)) - did-something)))) + (cond + ((and modular-fun + (not (and (eq name 'logand) + (csubtypep + (single-value-type (node-derived-type node)) + (specifier-type `(unsigned-byte ,width)))))) + (unless (eq modular-fun :good) + (setq did-something t) + (change-ref-leaf + fun-ref + (find-free-fun name "in a strange place")) + (setf (combination-kind node) :full)) + (dolist (arg (basic-combination-args node)) + (when (cut-lvar arg) + (setq did-something t))) + (when did-something + (reoptimize-node node fun-name)) + did-something) + ;; FIXME: This clause is a workaround for a fairly + ;; critical bug. Prior to this, strength reduction + ;; of constant (unsigned-byte 32) multiplication + ;; achieved modular arithmetic by lying to the + ;; compiler with TRULY-THE. Since we now have an + ;; understanding of modular arithmetic, we can stop + ;; lying to the compiler, at the cost of + ;; uglification of this code. Probably we want to + ;; generalize the modular arithmetic mechanism to + ;; be able to deal with more complex operands (ASH, + ;; EXPT, ...?) -- CSR, 2003-10-09 + ((and + (eq fun-name 'ash) + ;; FIXME: only constants for now, but this + ;; complicates implementation of the out of line + ;; version of modular ASH. -- CSR, 2003-10-09 + (constant-lvar-p (second (basic-combination-args node))) + (> (lvar-value (second (basic-combination-args node))) 0)) + (setq did-something t) + (change-ref-leaf + fun-ref + (find-free-fun + #!-alpha 'sb!vm::ash-left-constant-mod32 + #!+alpha 'sb!vm::ash-left-constant-mod64 + "in a strange place")) + (setf (combination-kind node) :full) + (cut-lvar (first (basic-combination-args node))) + (reoptimize-node node 'ash)))))) (cut-lvar (lvar &aux did-something) (do-uses (node lvar) (when (cut-node node) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index af7da99..2da36e3 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -687,7 +687,7 @@ ((< amount -31) (inst xor result result)) (t (inst shr result (- amount)))))))) -(define-vop (fast-ash-left/signed) +(define-vop (fast-ash-left/signed=>signed) (:translate ash) (:args (number :scs (signed-reg) :target result :load-if (not (and (sc-is number signed-stack) @@ -708,7 +708,7 @@ (move ecx amount) (inst shl result :cl))) -(define-vop (fast-ash-left/unsigned) +(define-vop (fast-ash-left/unsigned=>unsigned) (:translate ash) (:args (number :scs (unsigned-reg) :target result :load-if (not (and (sc-is number unsigned-stack) @@ -1142,6 +1142,17 @@ (:translate +-mod32)) (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned) (:translate +-mod32)) +(define-modular-fun --mod32 (x y) - 32) +(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned) + (:translate --mod32)) +(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned) + (:translate --mod32)) + +(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) + (foldable flushable movable)) +(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned + fast-ash-c/unsigned=>unsigned) + (:translate ash-left-constant-mod32)) ;;; logical operations (define-modular-fun lognot-mod32 (x) lognot 32) @@ -1577,7 +1588,7 @@ (0 (let ((tmp (min 3 (aref condensed 1)))) (decf (aref condensed 1) tmp) - `(truly-the (unsigned-byte 32) + `(logand #xffffffff (%lea ,arg ,(decompose-multiplication arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1)) @@ -1585,14 +1596,14 @@ ((1 2 3) (let ((r0 (aref condensed 0))) (incf (aref condensed 1) r0) - `(truly-the (unsigned-byte 32) + `(logand #xffffffff (%lea ,(decompose-multiplication arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1)) ,arg ,(ash 1 r0) 0)))) (t (let ((r0 (aref condensed 0))) (setf (aref condensed 0) 0) - `(truly-the (unsigned-byte 32) + `(logand #xffffffff (ash ,(decompose-multiplication arg (ash num (- r0)) n-bits condensed) ,r0)))))) @@ -1602,7 +1613,7 @@ ((= n-bits 0) 0) ((= num 1) arg) ((= n-bits 1) - `(truly-the (unsigned-byte 32) (ash ,arg ,(1- (integer-length num))))) + `(logand #xffffffff (ash ,arg ,(1- (integer-length num))))) ((let ((max 0) (end 0)) (loop for i from 2 to (length condensed) for j = (reduce #'+ (subseq condensed 0 i)) @@ -1618,14 +1629,14 @@ (let ((n2 (+ (ash 1 (1+ j)) (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num) (1+ j)))) (n1 (1+ (ldb (byte (1+ j) 0) (lognot num))))) - `(truly-the (unsigned-byte 32) + `(logand #xffffffff (- ,(optimize-multiply arg n2) ,(optimize-multiply arg n1)))))))) ((dolist (i '(9 5 3)) (when (integerp (/ num i)) (when (< (logcount (/ num i)) (logcount num)) (let ((x (gensym))) (return `(let ((,x ,(optimize-multiply arg (/ num i)))) - (truly-the (unsigned-byte 32) + (logand #xffffffff (%lea ,x ,x (1- ,i) 0))))))))) (t (basic-decompose-multiplication arg num n-bits condensed)))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 9525cca..ad1853d 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -675,3 +675,18 @@ (wum #'bbfn "hc3" (list))) r3533))) (compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil))) + +;;; the strength reduction of constant multiplication used (before +;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under +;;; certain circumstances, the compiler would derive that a perfectly +;;; reasonable multiplication never returned, causing chaos. Fixed by +;;; explicitly doing modular arithmetic, and relying on the backends +;;; being smart. +(assert (= (funcall + (compile nil + '(lambda (x) + (declare (type (integer 178956970 178956970) x) + (optimize speed)) + (* x 24))) + 178956970) + 4294967280)) diff --git a/version.lisp-expr b/version.lisp-expr index 0e72f46..cfce20d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.4.11" +"0.8.4.12" -- 1.7.10.4