Oops. Undo modular fixnum arithmetic changes from 0.8.17.24.
;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more
;;; discussion of this hack. -- CSR, 2003-10-09
#!-alpha
-(progn
(defun sb!vm::ash-left-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)))))
-(defun sb!vm::ash-left-mod29 (integer amount)
- (etypecase integer
- (fixnum (ldb (byte 29 0) (ash (logand integer #x1fffffff) amount)))
- (bignum (ldb (byte 29 0) (ash (logand integer #x1fffffff) amount)))))
-) ; PROGN
#!+alpha
(defun sb!vm::ash-left-mod64 (integer amount)
(etypecase integer
(sb!c::give-up-ir1-transform))
'(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
-(macrolet ((define-modular-backend (fun &optional constantp)
- (collect ((forms))
- (dolist (info '((29 fixnum) (32 unsigned)))
- (destructuring-bind (width regtype) info
- (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
- (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
- fun width regtype regtype)))
- (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
- fun width regtype regtype)))
- (vop (intern (format nil "FAST-~A/~A=>~A"
- fun regtype regtype)))
- (cvop (intern (format nil "FAST-~A-C/~A=>~A"
- fun regtype regtype))))
- (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
- (forms `(define-vop (,mvop ,vop)
- (:translate ,mfun-name)))
- (when constantp
- (forms `(define-vop (,mcvop ,cvop)
- (:translate ,mfun-name)))))))
- `(progn ,@(forms)))))
+(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))
+ (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
+ (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
+ `(progn
+ (define-modular-fun ,mfun-name (x y) ,fun 64)
+ (define-vop (,modvop ,vop)
+ (:translate ,mfun-name))
+ ,@(when constantp
+ `((define-vop (,modcvop ,cvop)
+ (:translate ,mfun-name))))))))
(define-modular-backend + t)
(define-modular-backend - t)
(define-modular-backend logxor t)
;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
;; don't have a true Alpha64 port yet, we'll have to stick to
;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
- ;;
- ;; FIXME: I think we only want a single optimizer for ASH; this code
- ;; currently defines two (the second one, AFAICS, overrides the first),
- ;; but everything "works"--ASH with results of 29 bits or fewer use
- ;; fixnum arithmetic. -- njf, 2004-12-08
- #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
- (def sb!vm::ash-left-mod29 29)
#!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
(def sb!vm::ash-left-mod32 32)
#!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
\f
;;;; modular functions
-
-(macrolet ((define-modular-backend (fun &optional constantp)
- (collect ((forms))
- (dolist (info '((29 fixnum) (32 unsigned)))
- (destructuring-bind (width regtype) info
- (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
- (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
- fun width regtype regtype)))
- (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
- fun width regtype regtype)))
- (vop (intern (format nil "FAST-~A/~A=>~A"
- fun regtype regtype)))
- (cvop (intern (format nil "FAST-~A-C/~A=>~A"
- fun regtype regtype))))
- (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
- (forms `(define-vop (,mvop ,vop)
- (:translate ,mfun-name)))
- (when constantp
- (forms `(define-vop (,mcvop ,cvop)
- (:translate ,mfun-name)))))))
- `(progn ,@(forms)))))
- (define-modular-backend + t)
- (define-modular-backend - t)
- ;; FIXME: constant versions of these could be defined if anybody
- ;; cared enough to implement them. -- CSR/NJF
- (define-modular-backend logxor)
- (define-modular-backend logandc1)
- (define-modular-backend logandc2))
+(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))
+(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))
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
(:generator 1
(inst uaddcm zero-tn x res)))
+(macrolet
+ ((define-modular-backend (fun)
+ (let ((mfun-name (symbolicate fun '-mod32))
+ ;; FIXME: if anyone cares, add constant-arg vops. --
+ ;; CSR, 2003-09-16
+ (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
+ (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
+ `(progn
+ (define-modular-fun ,mfun-name (x y) ,fun 32)
+ (define-vop (,modvop ,vop)
+ (:translate ,mfun-name))))))
+ (define-modular-backend logxor)
+ (define-modular-backend logandc1)
+ (define-modular-backend logandc2))
+
(define-source-transform logeqv (&rest args)
(if (oddp (length args))
`(logxor ,@args)
(inst sll r num amount)))))
\f
;;;; Modular arithmetic
-
-(macrolet ((define-modular-backend (fun &optional constantp)
- (collect ((forms))
- (dolist (info '((29 fixnum) (32 unsigned)))
- (destructuring-bind (width regtype) info
- (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
- (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
- fun width regtype regtype)))
- (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
- fun width regtype regtype)))
- (vop (intern (format nil "FAST-~A/~A=>~A"
- fun regtype regtype)))
- (cvop (intern (format nil "FAST-~A-C/~A=>~A"
- fun regtype regtype))))
- (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
- (forms `(define-vop (,mvop ,vop)
- (:translate ,mfun-name)))
- (when constantp
- (forms `(define-vop (,mcvop ,cvop)
- (:translate ,mfun-name)))))))
- `(progn ,@(forms)))))
- (define-modular-backend + t)
- (define-modular-backend - t)
- (define-modular-backend logxor t))
+(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))
+(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))
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
(:generator 1
(inst nor r x zero-tn)))
+(define-modular-fun logxor-mod32 (x y) logxor 32)
+(define-vop (fast-logxor-mod32/unsigned=>unsigned
+ fast-logxor/unsigned=>unsigned)
+ (:translate logxor-mod32))
+(define-vop (fast-logxor-mod32-c/unsigned=>unsigned
+ fast-logxor-c/unsigned=>unsigned)
+ (:translate logxor-mod32))
+
(define-modular-fun lognor-mod32 (x y) lognor 32)
(define-vop (fast-lognor-mod32/unsigned=>unsigned
fast-lognor/unsigned=>unsigned)
(:note "inline (signed-byte 32) arithmetic"))
-(macrolet ((define-var-binop (translate untagged-penalty op
- &optional arg-swap restore-fixnum-mask)
- `(progn
- (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
- fast-fixnum-binop)
- ,@(when restore-fixnum-mask
- `((:temporary (:sc non-descriptor-reg) temp)))
- (:translate ,translate)
- (:generator 2
- ,(if arg-swap
- `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
- `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
- ;; FIXME: remind me what convention we used for 64bitizing
- ;; stuff? -- CSR, 2003-08-27
- ,@(when restore-fixnum-mask
- `((inst clrrwi r temp (1- n-lowtag-bits))))))
- (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
- fast-signed-binop)
- (:translate ,translate)
- (:generator ,(1+ untagged-penalty)
- ,(if arg-swap
- `(inst ,op r y x)
- `(inst ,op r x y))))
- (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
- fast-unsigned-binop)
- (:translate ,translate)
- (:generator ,(1+ untagged-penalty)
- ,(if arg-swap
- `(inst ,op r y x)
- `(inst ,op r x y))))))
- (define-const-binop (translate untagged-penalty op)
- `(progn
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defmacro define-var-binop (translate untagged-penalty op
+ &optional arg-swap restore-fixnum-mask)
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ ,@(when restore-fixnum-mask
+ `((:temporary (:sc non-descriptor-reg) temp)))
+ (:translate ,translate)
+ (:generator 2
+ ,(if arg-swap
+ `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
+ `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
+ ;; FIXME: remind me what convention we used for 64bitizing
+ ;; stuff? -- CSR, 2003-08-27
+ ,@(when restore-fixnum-mask
+ `((inst clrrwi r temp (1- n-lowtag-bits))))))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ ,(if arg-swap
+ `(inst ,op r y x)
+ `(inst ,op r x y))))
+ (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+ fast-unsigned-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ ,(if arg-swap
+ `(inst ,op r y x)
+ `(inst ,op r x y))))))
+
+
+(defmacro define-const-binop (translate untagged-penalty op)
+ `(progn
- (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
- fast-fixnum-binop-c)
- (:translate ,translate)
- (:generator 1
- (inst ,op r x (fixnumize y))))
- (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
- fast-signed-binop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (inst ,op r x y)))
- (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
- fast-unsigned-binop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (inst ,op r x y)))))
- (defmacro define-const-logop (translate untagged-penalty op)
- `(progn
+ (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+ fast-fixnum-binop-c)
+ (:translate ,translate)
+ (:generator 1
+ (inst ,op r x (fixnumize y))))
+ (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+ fast-signed-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+ fast-unsigned-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (inst ,op r x y)))))
+
+(defmacro define-const-logop (translate untagged-penalty op)
+ `(progn
- (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
- fast-fixnum-logop-c)
- (:translate ,translate)
- (:generator 1
- (inst ,op r x (fixnumize y))))
- (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
- fast-signed-logop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (inst ,op r x y)))
- (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
- fast-unsigned-logop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (inst ,op r x y))))))
- (define-var-binop + 4 add)
- (define-var-binop - 4 sub)
- (define-var-binop logand 2 and)
- (define-var-binop logandc1 2 andc t)
- (define-var-binop logandc2 2 andc)
- (define-var-binop logior 2 or)
- (define-var-binop logorc1 2 orc t t)
- (define-var-binop logorc2 2 orc nil t)
- (define-var-binop logxor 2 xor)
- (define-var-binop logeqv 2 eqv nil t)
- (define-var-binop lognand 2 nand nil t)
- (define-var-binop lognor 2 nor nil t)
-
- (define-const-binop + 4 addi)
- (define-const-binop - 4 subi)
- (define-const-logop logand 2 andi.)
- (define-const-logop logior 2 ori)
- (define-const-logop logxor 2 xori))
+ (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+ fast-fixnum-logop-c)
+ (:translate ,translate)
+ (:generator 1
+ (inst ,op r x (fixnumize y))))
+ (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+ fast-signed-logop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+ fast-unsigned-logop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (inst ,op r x y)))))
+
+); eval-when
+
+(define-var-binop + 4 add)
+(define-var-binop - 4 sub)
+(define-var-binop logand 2 and)
+(define-var-binop logandc1 2 andc t)
+(define-var-binop logandc2 2 andc)
+(define-var-binop logior 2 or)
+(define-var-binop logorc1 2 orc t t)
+(define-var-binop logorc2 2 orc nil t)
+(define-var-binop logxor 2 xor)
+(define-var-binop logeqv 2 eqv nil t)
+(define-var-binop lognand 2 nand nil t)
+(define-var-binop lognor 2 nor nil t)
+
+(define-const-binop + 4 addi)
+(define-const-binop - 4 subi)
+(define-const-logop logand 2 andi.)
+(define-const-logop logior 2 ori)
+(define-const-logop logxor 2 xori)
+
;;; Special case fixnum + and - that trap on overflow. Useful when we
;;; don't know that the output type is a fixnum.
(sb!c::give-up-ir1-transform))
'(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
-(macrolet ((define-modular-backend (fun &optional constantp)
- (collect ((forms))
- (dolist (info '((29 fixnum) (32 unsigned)))
- (destructuring-bind (width regtype) info
- (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
- (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
- fun width regtype regtype)))
- (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
- fun width regtype regtype)))
- (vop (intern (format nil "FAST-~A/~A=>~A"
- fun regtype regtype)))
- (cvop (intern (format nil "FAST-~A-C/~A=>~A"
- fun regtype regtype))))
- (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
- (forms `(define-vop (,mvop ,vop)
- (:translate ,mfun-name)))
- (when constantp
- (forms `(define-vop (,mcvop ,cvop)
- (:translate ,mfun-name)))))))
- `(progn ,@(forms)))))
+(macrolet
+ ((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))
+ (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
+ (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
+ `(progn
+ (define-modular-fun ,mfun-name (x y) ,fun 32)
+ (define-vop (,modvop ,vop)
+ (:translate ,mfun-name))
+ ,@(when constantp
+ `((define-vop (,modcvop ,cvop)
+ (:translate ,mfun-name))))))))
(define-modular-backend + t)
(define-modular-backend - t)
(define-modular-backend * t)
(:generator 1
(inst not res x)))
-(macrolet ((define-modular-backend (fun &optional constantp)
- (collect ((forms))
- (dolist (info '((29 fixnum) (32 unsigned)))
- (destructuring-bind (width regtype) info
- (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
- (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
- fun width regtype regtype)))
- (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
- fun width regtype regtype)))
- (vop (intern (format nil "FAST-~A/~A=>~A"
- fun regtype regtype)))
- (cvop (intern (format nil "FAST-~A-C/~A=>~A"
- fun regtype regtype))))
- (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
- (forms `(define-vop (,mvop ,vop)
- (:translate ,mfun-name)))
- (when constantp
- (forms `(define-vop (,mcvop ,cvop)
- (:translate ,mfun-name)))))))
- `(progn ,@(forms)))))
+(macrolet
+ ((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))
+ (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
+ (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
+ `(progn
+ (define-modular-fun ,mfun-name (x y) ,fun 32)
+ (define-vop (,modvop ,vop)
+ (:translate ,mfun-name))
+ ,@(when constantp
+ `((define-vop (,modcvop ,cvop)
+ (:translate ,mfun-name))))))))
(define-modular-backend + t)
(define-modular-backend - t)
(define-modular-backend logxor t)
\f
;;;; Modular functions
-(macrolet ((define-modular-backend (fun &optional constantp)
- (collect ((forms))
- (dolist (info '((60 fixnum) (64 unsigned)))
- (destructuring-bind (width regtype) info
- (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
- (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
- fun width regtype regtype)))
- (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
- fun width regtype regtype)))
- (vop (intern (format nil "FAST-~A/~A=>~A"
- fun regtype regtype)))
- (cvop (intern (format nil "FAST-~A-C/~A=>~A"
- fun regtype regtype))))
- (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
- (forms `(define-vop (,mvop ,vop)
- (:translate ,mfun-name)))
- (when constantp
- (forms `(define-vop (,mcvop ,cvop)
- (:translate ,mfun-name)))))))
- `(progn ,@(forms)))))
- (define-modular-backend + t)
- (define-modular-backend - t)
- (define-modular-backend *) ; FIXME: there exists a
- ; FAST-*-C/FIXNUM=>FIXNUM VOP which
- ; should be used for the MOD60 case,
- ; but the MOD64 case cannot accept
- ; immediate arguments.
- (define-modular-backend logxor t))
+(define-modular-fun +-mod64 (x y) + 64)
+(define-vop (fast-+-mod64/unsigned=>unsigned fast-+/unsigned=>unsigned)
+ (:translate +-mod64))
+(define-vop (fast-+-mod64-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
+ (:translate +-mod64))
+(define-modular-fun --mod64 (x y) - 64)
+(define-vop (fast---mod64/unsigned=>unsigned fast--/unsigned=>unsigned)
+ (:translate --mod64))
+(define-vop (fast---mod64-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
+ (:translate --mod64))
+
+(define-modular-fun *-mod64 (x y) * 64)
+(define-vop (fast-*-mod64/unsigned=>unsigned fast-*/unsigned=>unsigned)
+ (:translate *-mod64))
+;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
(move r x)
(inst not r)))
+(define-modular-fun logxor-mod64 (x y) logxor 64)
+(define-vop (fast-logxor-mod64/unsigned=>unsigned
+ fast-logxor/unsigned=>unsigned)
+ (:translate logxor-mod64))
+(define-vop (fast-logxor-mod64-c/unsigned=>unsigned
+ fast-logxor-c/unsigned=>unsigned)
+ (:translate logxor-mod64))
+
(define-source-transform logeqv (&rest args)
(if (oddp (length args))
`(logxor ,@args)
\f
;;;; Modular functions
-(macrolet ((define-modular-backend (fun &optional constantp)
- (collect ((forms))
- (dolist (info '((29 fixnum) (32 unsigned)))
- (destructuring-bind (width regtype) info
- (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
- (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
- fun width regtype regtype)))
- (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
- fun width regtype regtype)))
- (vop (intern (format nil "FAST-~A/~A=>~A"
- fun regtype regtype)))
- (cvop (intern (format nil "FAST-~A-C/~A=>~A"
- fun regtype regtype))))
- (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
- (forms `(define-vop (,mvop ,vop)
- (:translate ,mfun-name)))
- (when constantp
- (forms `(define-vop (,mcvop ,cvop)
- (:translate ,mfun-name)))))))
- `(progn ,@(forms)))))
- (define-modular-backend + t)
- (define-modular-backend - t)
- (define-modular-backend *) ; FIXME: there exists a
- ; FAST-*-C/FIXNUM=>FIXNUM VOP which
- ; should be used for the MOD29 case,
- ; but the MOD32 case cannot accept
- ; immediate arguments.
- (define-modular-backend logxor t))
-
-(macrolet ((define-modular-ash (width regtype)
- (let ((mfun-name (intern (format nil "ASH-LEFT-MOD~A" width)))
- (modvop (intern (format nil "FAST-ASH-LEFT-MOD~A/~A=>~A"
- width regtype regtype)))
- (modcvop (intern (format nil "FAST-ASH-LEFT-MOD~A-C/~A=>~A"
- width regtype regtype)))
- (vop (intern (format nil "FAST-ASH-LEFT/~A=>~A"
- regtype regtype)))
- (cvop (intern (format nil "FAST-ASH-C/~A=>~A"
- regtype regtype))))
- `(progn
- (define-vop (,modcvop ,cvop)
- (:translate ,mfun-name))
- (define-vop (,modvop ,vop))
- (deftransform ,mfun-name ((integer count)
- ((unsigned-byte ,width) (unsigned-byte 5)))
- (when (sb!c::constant-lvar-p count)
- (sb!c::give-up-ir1-transform))
- '(%primitive ,modvop integer count))))))
- (define-modular-ash 29 fixnum)
- (define-modular-ash 32 unsigned))
+(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))
+(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))
+
+(define-modular-fun *-mod32 (x y) * 32)
+(define-vop (fast-*-mod32/unsigned=>unsigned fast-*/unsigned=>unsigned)
+ (:translate *-mod32))
+;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
+
+(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
+ fast-ash-c/unsigned=>unsigned)
+ (:translate ash-left-mod32))
+
+(define-vop (fast-ash-left-mod32/unsigned=>unsigned
+ fast-ash-left/unsigned=>unsigned))
+(deftransform ash-left-mod32 ((integer count)
+ ((unsigned-byte 32) (unsigned-byte 5)))
+ (when (sb!c::constant-lvar-p count)
+ (sb!c::give-up-ir1-transform))
+ '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
(in-package "SB!C")
(defknown sb!vm::%lea-mod32 (integer integer (member 1 2 4 8) (signed-byte 32))
(unsigned-byte 32)
(foldable flushable movable))
-(defknown sb!vm::%lea-mod29 (integer integer (member 1 2 4 8) (signed-byte 29))
- (unsigned-byte 29)
- (foldable flushable movable))
+
(define-modular-fun-optimizer %lea ((base index scale disp) :width width)
(when (and (<= width 32)
(constant-lvar-p scale)
(constant-lvar-p disp))
(cut-to-width base width)
(cut-to-width index width)
- (if (<= width 29)
- 'sb!vm::%lea-mod29
- 'sb!vm::%lea-mod32)))
+ 'sb!vm::%lea-mod32))
#+sb-xc-host
-(progn
-(defun sb!vm::%lea-mod29 (base index scale disp)
- (ldb (byte 29 0) (%lea base index scale disp)))
(defun sb!vm::%lea-mod32 (base index scale disp)
- (ldb (byte 32 0) (%lea base index scale disp))))
+ (ldb (byte 32 0) (%lea base index scale disp)))
#-sb-xc-host
-(progn
-(defun sb!vm::%lea-mod29 (base index scale disp)
- (let ((base (logand base #x1fffffff))
- (index (logand index #x1fffffff)))
- ;; can't use modular version of %LEA, as we only have VOPs for
- ;; constant SCALE and DISP.
- (ldb (byte 29 0) (+ base (* index scale) disp))))
(defun sb!vm::%lea-mod32 (base index scale disp)
(let ((base (logand base #xffffffff))
(index (logand index #xffffffff)))
;; can't use modular version of %LEA, as we only have VOPs for
;; constant SCALE and DISP.
- (ldb (byte 32 0) (+ base (* index scale) disp)))))
+ (ldb (byte 32 0) (+ base (* index scale) disp))))
(in-package "SB!VM")
(define-vop (%lea-mod32/unsigned=>unsigned
%lea/unsigned=>unsigned)
(:translate %lea-mod32))
-(define-vop (%lea-mod29/fixnum=>fixnum
- %lea/fixnum=>fixnum)
- (:translate %lea-mod29))
;;; logical operations
(define-modular-fun lognot-mod32 (x) lognot 32)
(move r x)
(inst not r)))
+(define-modular-fun logxor-mod32 (x y) logxor 32)
+(define-vop (fast-logxor-mod32/unsigned=>unsigned
+ fast-logxor/unsigned=>unsigned)
+ (:translate logxor-mod32))
+(define-vop (fast-logxor-mod32-c/unsigned=>unsigned
+ fast-logxor-c/unsigned=>unsigned)
+ (:translate logxor-mod32))
+
(define-source-transform logeqv (&rest args)
(if (oddp (length args))
`(logxor ,@args)
;;; This is essentially a straight implementation of the algorithm in
;;; "Strength Reduction of Multiplications by Integer Constants",
;;; Youfeng Wu, ACM SIGPLAN Notices, Vol. 30, No.2, February 1995.
-(defun basic-decompose-multiplication (arg num n-bits condensed mask)
+(defun basic-decompose-multiplication (arg num n-bits condensed)
(case (aref condensed 0)
(0
(let ((tmp (min 3 (aref condensed 1))))
(decf (aref condensed 1) tmp)
- `(logand ,mask (%lea ,arg
- ,(decompose-multiplication
- arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1)
- mask)
- ,(ash 1 tmp) 0))))
+ `(logand #xffffffff
+ (%lea ,arg
+ ,(decompose-multiplication
+ arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1))
+ ,(ash 1 tmp) 0))))
((1 2 3)
(let ((r0 (aref condensed 0)))
(incf (aref condensed 1) r0)
- `(logand ,mask (%lea ,(decompose-multiplication
- arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1)
- mask)
- ,arg
- ,(ash 1 r0) 0))))
+ `(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)
- `(logand ,mask (ash ,(decompose-multiplication
- arg (ash num (- r0)) n-bits condensed mask)
- ,r0))))))
+ `(logand #xffffffff
+ (ash ,(decompose-multiplication
+ arg (ash num (- r0)) n-bits condensed)
+ ,r0))))))
-(defun decompose-multiplication (arg num n-bits condensed mask)
-
+(defun decompose-multiplication (arg num n-bits condensed)
(cond
((= n-bits 0) 0)
((= num 1) arg)
((= n-bits 1)
- `(logand ,mask (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))
(ash (ldb (byte (- 32 (1+ j)) (1+ j)) num)
(1+ j)))
(ash 1 32)))
- do (setq max (- (* 2 i) 3 j)
- end i))
+ do (setq max (- (* 2 i) 3 j)
+ end i))
(when (> max 0)
(let ((j (reduce #'+ (subseq condensed 0 end))))
(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)))))
- `(logand ,mask (- ,(optimize-multiply arg n2 mask)
- ,(optimize-multiply arg n1 mask))))))))
+ `(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) mask)))
- (logand ,mask (%lea ,x ,x (1- ,i) 0)))))))))
- (t (basic-decompose-multiplication arg num n-bits condensed mask))))
+ (return `(let ((,x ,(optimize-multiply arg (/ num i))))
+ (logand #xffffffff
+ (%lea ,x ,x (1- ,i) 0)))))))))
+ (t (basic-decompose-multiplication arg num n-bits condensed))))
-(defun optimize-multiply (arg x mask)
+(defun optimize-multiply (arg x)
(let* ((n-bits (logcount x))
(condensed (make-array n-bits)))
(let ((count 0) (bit 0))
(setf count 1)
(incf bit))
(t (incf count)))))
- (decompose-multiplication arg x n-bits condensed mask)))
+ (decompose-multiplication arg x n-bits condensed)))
-(defun *-transformer (y mask)
+(defun *-transformer (y)
(cond
((= y (ash 1 (integer-length y)))
;; there's a generic transform for y = 2^k
;; FIXME: should make this more fine-grained. If nothing else,
;; there should probably be a cutoff of about 9 instructions on
;; pentium-class machines.
- (t (optimize-multiply 'x y mask))))
-
-;;; KLUDGE: due to the manner in which DEFTRANSFORM is implemented, it
-;;; is vitally important that the transform for (UNSIGNED-BYTE 29)
-;;; multiply come after the transform for (UNSIGNED-BYTE 32) multiply.
-;;; When attempting to transform a function application, the compiler
-;;; examines the relevant transforms for the function in the reverse
-;;; order in which they were defined and takes the first one which
-;;; succeeds. If the (UNSIGNED-BYTE 32) transform were to come after
-;;; the (UNSIGNED-BYTE 29) transform, the (UNSIGNED-BYTE 32) transform
-;;; would be attempted first. Since (UNSIGNED-BYTE 29) is subsumed by
-;;; (UNSIGNED-BYTE 32), and assuming the arguments and result are
-;;; (UNSIGNED-BYTE 29)s, the (UNSIGNED-BYTE 32) transform would succeed
-;;; and force (UNSIGNED-BYTE 32) arithmetic where (UNSIGNED-BYTE 29)
-;;; arithmetic would work perfectly well--introducing unnecessary
-;;; shifting and causing efficiency notes where the user might not
-;;; expect them to occur. So we define the (UNSIGNED-BYTE 29) transform
-;;; *after* the (UNSIGNED-BYTE 32) transform in order to attempt the
-;;; (UNSIGNED-BYTE 29) transform *before* the (UNSIGNED-BYTE 32)
-;;; transform. Yuck. -- njf, 2004-12-07
+ (t (optimize-multiply 'x y))))
+
(deftransform * ((x y)
((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
(unsigned-byte 32))
"recode as leas, shifts and adds"
(let ((y (lvar-value y)))
- (*-transformer y #xffffffff)))
-
-(deftransform * ((x y)
- ((unsigned-byte 29) (constant-arg (unsigned-byte 29)))
- (unsigned-byte 29))
- "recode as leas, shifts, and adds"
- (let ((y (lvar-value y)))
- (*-transformer y #x1fffffff)))
+ (*-transformer y)))
(deftransform sb!vm::*-mod32
((x y) ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
(unsigned-byte 32))
"recode as leas, shifts and adds"
(let ((y (lvar-value y)))
- (*-transformer y #xffffffff)))
-
-(deftransform sb!vm::*-mod29
- ((x y) ((unsigned-byte 29) (constant-arg (unsigned-byte 29)))
- (unsigned-byte 29))
- "recode as leas, shifts and adds"
- (let ((y (lvar-value y)))
- (*-transformer y #x1fffffff)))
+ (*-transformer y)))
;;; FIXME: we should also be able to write an optimizer or two to
;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA.
;;; 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.17.27"
+"0.8.17.28"
projects / sbcl.git / commitdiff