X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fppc%2Farith.lisp;h=8cb995c1e5f15b699f02ad5ecc7762df206837bb;hb=6a7ffd51f991961a59c4496bd80aaa89698231f9;hp=8141ec4076203778c6737320366ef7dadd388fbb;hpb=ace140856e6b3f92bb06597092a59753f1e59142;p=sbcl.git diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp index 8141ec4..8cb995c 100644 --- a/src/compiler/ppc/arith.lisp +++ b/src/compiler/ppc/arith.lisp @@ -135,99 +135,90 @@ (: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. @@ -475,20 +466,34 @@ fast-ash-c/unsigned=>unsigned) (:translate ash-left-mod32)) -(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-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 * t) @@ -703,39 +708,6 @@ (emit-label done) (move result res)))) -(define-source-transform word-logical-not (x) - `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32)))) - -(deftransform word-logical-and ((x y)) - '(logand x y)) - -(deftransform word-logical-nand ((x y)) - '(logand (lognand x y) #.(1- (ash 1 32)))) - -(deftransform word-logical-or ((x y)) - '(logior x y)) - -(deftransform word-logical-nor ((x y)) - '(logand (lognor x y) #.(1- (ash 1 32)))) - -(deftransform word-logical-xor ((x y)) - '(logxor x y)) - -(deftransform word-logical-eqv ((x y)) - '(logand (logeqv x y) #.(1- (ash 1 32)))) - -(deftransform word-logical-orc1 ((x y)) - '(logand (logorc1 x y) #.(1- (ash 1 32)))) - -(deftransform word-logical-orc2 ((x y)) - '(logand (logorc2 x y) #.(1- (ash 1 32)))) - -(deftransform word-logical-andc1 ((x y)) - '(logand (logandc1 x y) #.(1- (ash 1 32)))) - -(deftransform word-logical-andc2 ((x y)) - '(logand (logandc2 x y) #.(1- (ash 1 32)))) - (define-vop (shift-towards-someplace) (:policy :fast-safe) (:args (num :scs (unsigned-reg))