;;; 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)
- (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))))))))
+(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)
;; 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
-(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))
+
+(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-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
-(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))
+
+(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-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"))
-(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
+(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
- (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)))))
-
-); 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)
-
+ (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))
;;; 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)
- (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))))))))
+(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 * t)
(:generator 1
(inst not res x)))
-(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))))))))
+(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)
\f
;;;; Modular functions
-(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)
+(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-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
-(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))
+(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))
(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)
- 'sb!vm::%lea-mod32))
+ (if (<= width 29)
+ 'sb!vm::%lea-mod29
+ '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)
+(defun basic-decompose-multiplication (arg num n-bits condensed mask)
(case (aref condensed 0)
(0
(let ((tmp (min 3 (aref condensed 1))))
(decf (aref condensed 1) tmp)
- `(logand #xffffffff
- (%lea ,arg
- ,(decompose-multiplication
- arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1))
- ,(ash 1 tmp) 0))))
+ `(logand ,mask (%lea ,arg
+ ,(decompose-multiplication
+ arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1)
+ mask)
+ ,(ash 1 tmp) 0))))
((1 2 3)
(let ((r0 (aref condensed 0)))
(incf (aref condensed 1) r0)
- `(logand #xffffffff
- (%lea ,(decompose-multiplication
- arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1))
- ,arg
- ,(ash 1 r0) 0))))
+ `(logand ,mask (%lea ,(decompose-multiplication
+ arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1)
+ mask)
+ ,arg
+ ,(ash 1 r0) 0))))
(t (let ((r0 (aref condensed 0)))
(setf (aref condensed 0) 0)
- `(logand #xffffffff
- (ash ,(decompose-multiplication
- arg (ash num (- r0)) n-bits condensed)
- ,r0))))))
+ `(logand ,mask (ash ,(decompose-multiplication
+ arg (ash num (- r0)) n-bits condensed mask)
+ ,r0))))))
-(defun decompose-multiplication (arg num n-bits condensed)
+(defun decompose-multiplication (arg num n-bits condensed mask)
+
(cond
((= n-bits 0) 0)
((= num 1) arg)
((= n-bits 1)
- `(logand #xffffffff (ash ,arg ,(1- (integer-length num)))))
+ `(logand ,mask (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 #xffffffff
- (- ,(optimize-multiply arg n2) ,(optimize-multiply arg n1))))))))
+ `(logand ,mask (- ,(optimize-multiply arg n2 mask)
+ ,(optimize-multiply arg n1 mask))))))))
((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))))
- (logand #xffffffff
- (%lea ,x ,x (1- ,i) 0)))))))))
- (t (basic-decompose-multiplication arg num n-bits condensed))))
+ (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))))
-(defun optimize-multiply (arg x)
+(defun optimize-multiply (arg x mask)
(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)))
+ (decompose-multiplication arg x n-bits condensed mask)))
-(defun *-transformer (y)
+(defun *-transformer (y mask)
(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))))
-
+ (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
(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)))
+ (*-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)))
(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)))
+ (*-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)))
;;; 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.23"
+"0.8.17.24"
projects / sbcl.git / commitdiff