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?)
(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)))
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)))))
+
(: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
`((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)
(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
(: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)
(: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)
(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")
(: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))
`((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)
(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)
(: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)
(: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.
(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)))
-
-
-
\f
(define-vop (signed-byte-32-len)
(:translate integer-length)
((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
`((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)
`(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))
\f
;;;; Binary conditional VOPs:
\f
;;;; 32-bit logical operations
-
(define-vop (merge-bits)
(:translate merge-bits)
(:args (shift :scs (signed-reg unsigned-reg))
(inst srl r num amount)))
\f
;;;; Bignum stuff.
-
(define-vop (bignum-length get-header-data)
(:translate sb!bignum::%bignum-length)
(:policy :fast-safe))
(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)
(signed-reg
(move res digit)))))
-
(define-vop (digit-ashr)
(:translate sb!bignum::%ashr)
(:policy :fast-safe)
(define-static-fun two-arg-eqv (x y) :translate logeqv)
\f
-;; 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)
(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)))))
-
(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)
((< 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)
(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)
(: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)
(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))
((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))))))
((= 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))
(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))))
(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))
;;; 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"
projects / sbcl.git / commitdiff