From: Christophe R. <cr...@us...> - 2003-09-16 12:07:45
|
Update of /cvsroot/sbcl/sbcl/src/compiler/alpha In directory sc8-pr-cvs1:/tmp/cvs-serv7388/src/compiler/alpha Modified Files: arith.lisp parms.lisp Log Message: 0.8.3.72: Merge modular_arithmetic_branch ... include untested modular arithmetic implementation for hppa ... unkludge sb-md5: now implemented using natural, high-level lisp. (and as a bonus, compiles to shorter code on x86 at least). ... passes self-tests and pfdietz-tests on x86 at least. More exhaustive testing on other platforms is probably needed, maybe with the torturer Index: arith.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/alpha/arith.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- arith.lisp 15 Sep 2003 11:31:56 -0000 1.9 +++ arith.lisp 16 Sep 2003 12:07:40 -0000 1.10 @@ -101,58 +101,88 @@ (:info y) (:arg-types tagged-num (:constant integer))) -(defmacro define-binop (translate cost untagged-cost op - tagged-type untagged-type) +(defmacro define-binop (translate cost untagged-cost op + tagged-type untagged-type + &optional arg-swap restore-fixnum-mask) `(progn (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") fast-fixnum-binop) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) + ,@(when restore-fixnum-mask + `((:temporary (:sc non-descriptor-reg) temp))) + (:args (x ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg)) + (y ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg))) (:translate ,translate) (:generator ,(1+ cost) - (inst ,op x y r))) + ,(if arg-swap + `(inst ,op y x ,(if restore-fixnum-mask 'temp 'r)) + `(inst ,op x y ,(if restore-fixnum-mask 'temp 'r))) + ,@(when restore-fixnum-mask + `((inst bic temp #.(ash lowtag-mask -1) r))))) (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") fast-signed-binop) (:args (x :target r :scs (signed-reg)) (y :target r :scs (signed-reg))) (:translate ,translate) (:generator ,(1+ untagged-cost) - (inst ,op x y r))) + ,(if arg-swap + `(inst ,op y x r) + `(inst ,op x y r)))) (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") fast-unsigned-binop) (:args (x :target r :scs (unsigned-reg)) (y :target r :scs (unsigned-reg))) (:translate ,translate) (:generator ,(1+ untagged-cost) - (inst ,op x y r))) - ,@(when tagged-type + ,(if arg-swap + `(inst ,op y x r) + `(inst ,op x y r)))) + ,@(when (and tagged-type (not arg-swap)) `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") fast-fixnum-c-binop) - (:arg-types tagged-num (:constant ,tagged-type)) + (:arg-types tagged-num (:constant ,tagged-type)) + ,@(when restore-fixnum-mask + `((:temporary (:sc non-descriptor-reg) temp))) (:translate ,translate) (:generator ,cost - (inst ,op x (fixnumize y) r))))) - ,@(when untagged-type + (inst ,op x (fixnumize y) ,(if restore-fixnum-mask 'temp 'r)) + ,@(when restore-fixnum-mask + `((inst bic temp #.(ash lowtag-mask -1) r))))))) + ,@(when (and untagged-type (not arg-swap)) `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") fast-signed-c-binop) - (:arg-types signed-num (:constant ,untagged-type)) + (:arg-types signed-num (:constant ,untagged-type)) (:translate ,translate) (:generator ,untagged-cost - (inst ,op x y r))) + (inst ,op x y r))) (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED") fast-unsigned-c-binop) - (:arg-types unsigned-num (:constant ,untagged-type)) + (:arg-types unsigned-num (:constant ,untagged-type)) (:translate ,translate) (:generator ,untagged-cost - (inst ,op x y r))))))) + (inst ,op x y r))))))) (define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8)) (define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8)) -(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8)) -(define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8)) (define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8)) +(define-binop logandc1 1 3 bic (unsigned-byte 6) (unsigned-byte 8) t) +(define-binop logandc2 1 3 bic (unsigned-byte 6) (unsigned-byte 8)) +(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8)) +(define-binop logorc1 1 3 ornot (unsigned-byte 6) (unsigned-byte 8) t t) +(define-binop logorc2 1 3 ornot (unsigned-byte 6) (unsigned-byte 8) nil t) (define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8)) +(define-binop logeqv 1 3 eqv (unsigned-byte 6) (unsigned-byte 8) nil t) + +;;; special cases for LOGAND where we can use a mask operation +(define-vop (fast-logand-c-mask/unsigned=>unsigned fast-unsigned-c-binop) + (:translate logand) + (:arg-types unsigned-num + (:constant (or (integer #xffffffff #xffffffff) + (integer #xffffffff00000000 #xffffffff00000000)))) + (:generator 1 + (ecase y + (#xffffffff (inst mskll x 4 r)) + (#xffffffff00000000 (inst mskll x 0 r))))) ;;;; shifting @@ -322,6 +352,45 @@ (:generator 3 (inst mulq x y r))) +;;;; Modular functions: +(define-modular-fun lognot-mod64 (x) lognot 64) +(define-vop (lognot-mod64/unsigned=>unsigned) + (:translate lognot-mod64) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (inst not x res))) + +(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 logxor t) + (define-modular-backend logeqv t) + (define-modular-backend logandc1) + (define-modular-backend logandc2 t) + (define-modular-backend logorc1) + (define-modular-backend logorc2 t)) + +(define-source-transform lognand (x y) + `(lognot (logand ,x ,y))) +(define-source-transform lognor (x y) + `(lognot (logior ,x ,y))) + ;;;; binary conditional VOPs (define-vop (fast-conditional) @@ -507,62 +576,42 @@ (emit-label done) (move res result)))) +(define-source-transform 32bit-logical-not (x) + `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32)))) -(define-vop (32bit-logical) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe)) - -(define-vop (32bit-logical-not 32bit-logical) - (:translate 32bit-logical-not) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:generator 2 - (inst not x r) - (inst mskll r 4 r))) - -(define-vop (32bit-logical-and 32bit-logical) - (:translate 32bit-logical-and) - (:generator 1 - (inst and x y r))) - -(deftransform 32bit-logical-nand ((x y) (* *)) - '(32bit-logical-not (32bit-logical-and x y))) +(deftransform 32bit-logical-and ((x y)) + '(logand x y)) -(define-vop (32bit-logical-or 32bit-logical) - (:translate 32bit-logical-or) - (:generator 1 - (inst bis x y r))) +(define-source-transform 32bit-logical-nand (x y) + `(32bit-logical-not (32bit-logical-and ,x ,y))) -(define-vop (32bit-logical-nor 32bit-logical) - (:translate 32bit-logical-nor) - (:generator 2 - (inst ornot x y r) - (inst mskll r 4 r))) +(deftransform 32bit-logical-or ((x y)) + '(logior x y)) -(define-vop (32bit-logical-xor 32bit-logical) - (:translate 32bit-logical-xor) - (:generator 1 - (inst xor x y r))) +(define-source-transform 32bit-logical-nor (x y) + `(logand (lognor (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y)) + #.(1- (ash 1 32)))) -(deftransform 32bit-logical-eqv ((x y) (* *)) - '(32bit-logical-not (32bit-logical-xor x y))) +(deftransform 32bit-logical-xor ((x y)) + '(logxor x y)) -(deftransform 32bit-logical-andc1 ((x y) (* *)) - '(32bit-logical-and (32bit-logical-not x) y)) +(define-source-transform 32bit-logical-eqv (x y) + `(logand (logeqv (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y)) + #.(1- (ash 1 32)))) -(deftransform 32bit-logical-andc2 ((x y) (* *)) - '(32bit-logical-and x (32bit-logical-not y))) +(define-source-transform 32bit-logical-orc1 (x y) + `(logand (logorc1 (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y)) + #.(1- (ash 1 32)))) -(deftransform 32bit-logical-orc1 ((x y) (* *)) - '(32bit-logical-or (32bit-logical-not x) y)) +(define-source-transform 32bit-logical-orc2 (x y) + `(logand (logorc2 (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y)) + #.(1- (ash 1 32)))) -(deftransform 32bit-logical-orc2 ((x y) (* *)) - '(32bit-logical-or x (32bit-logical-not y))) +(define-source-transform 32bit-logical-andc1 (x y) + `(logandc1 (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y))) +(define-source-transform 32bit-logical-andc2 (x y) + `(logandc2 (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y))) (define-vop (shift-towards-someplace) (:policy :fast-safe) @@ -814,3 +863,4 @@ (define-static-fun two-arg-and (x y) :translate logand) (define-static-fun two-arg-ior (x y) :translate logior) (define-static-fun two-arg-xor (x y) :translate logxor) +(define-static-fun two-arg-eqv (x y) :translate logeqv) Index: parms.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/alpha/parms.lisp,v retrieving revision 1.19 retrieving revision 1.20 diff -u -d -r1.19 -r1.20 --- parms.lisp 21 Jul 2003 00:57:06 -0000 1.19 +++ parms.lisp 16 Sep 2003 12:07:40 -0000 1.20 @@ -234,5 +234,6 @@ sb!kernel:two-arg-and sb!kernel:two-arg-ior sb!kernel:two-arg-xor + sb!kernel:two-arg-eqv sb!kernel:two-arg-gcd sb!kernel:two-arg-lcm)) |