X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Farith.lisp;h=b190cbaa2e975148f2300a223430e006f1cd1931;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=1166c02cc3738587c2fcb1cc8c3be7559df0d47e;hpb=cc56ee05b7ef035da9116a2117280087f58c8e94;p=sbcl.git diff --git a/src/compiler/sparc/arith.lisp b/src/compiler/sparc/arith.lisp index 1166c02..b190cba 100644 --- a/src/compiler/sparc/arith.lisp +++ b/src/compiler/sparc/arith.lisp @@ -44,12 +44,12 @@ (define-vop (fast-lognot/fixnum fixnum-unop) (:translate lognot) - (:generator 2 + (:generator 1 (inst xor res x (fixnumize -1)))) (define-vop (fast-lognot/signed signed-unop) (:translate lognot) - (:generator 1 + (:generator 2 (inst not res x))) ;;;; Binary fixnum operations. @@ -58,7 +58,7 @@ (define-vop (fast-fixnum-binop fast-safe-arith-op) (:args (x :target r :scs (any-reg zero)) - (y :target r :scs (any-reg zero))) + (y :target r :scs (any-reg zero))) (:arg-types tagged-num tagged-num) (:results (r :scs (any-reg))) (:result-types tagged-num) @@ -66,7 +66,7 @@ (define-vop (fast-unsigned-binop fast-safe-arith-op) (:args (x :target r :scs (unsigned-reg zero)) - (y :target r :scs (unsigned-reg zero))) + (y :target r :scs (unsigned-reg zero))) (:arg-types unsigned-num unsigned-num) (:results (r :scs (unsigned-reg))) (:result-types unsigned-num) @@ -74,7 +74,7 @@ (define-vop (fast-signed-binop fast-safe-arith-op) (:args (x :target r :scs (signed-reg zero)) - (y :target r :scs (signed-reg zero))) + (y :target r :scs (signed-reg zero))) (:arg-types signed-num signed-num) (:results (r :scs (signed-reg))) (:result-types signed-num) @@ -85,7 +85,7 @@ (:args (x :target r :scs (any-reg zero))) (:info y) (:arg-types tagged-num - (:constant (and (signed-byte 11) (not (integer 0 0))))) + (:constant (and (signed-byte 11) (not (integer 0 0))))) (:results (r :scs (any-reg))) (:result-types tagged-num) (:note "inline fixnum arithmetic")) @@ -94,7 +94,7 @@ (:args (x :target r :scs (unsigned-reg zero))) (:info y) (:arg-types unsigned-num - (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:constant (and (signed-byte 13) (not (integer 0 0))))) (:results (r :scs (unsigned-reg))) (:result-types unsigned-num) (:note "inline (unsigned-byte 32) arithmetic")) @@ -103,7 +103,7 @@ (:args (x :target r :scs (signed-reg zero))) (:info y) (:arg-types signed-num - (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:constant (and (signed-byte 13) (not (integer 0 0))))) (:results (r :scs (signed-reg))) (:result-types signed-num) (:note "inline (signed-byte 32) arithmetic")) @@ -112,55 +112,55 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro define-binop (translate untagged-penalty op - &optional arg-swap restore-fixnum-mask) + &optional arg-swap restore-fixnum-mask) `(progn (define-vop (,(symbolicate 'fast translate '/fixnum=>fixnum) - fast-fixnum-binop) + fast-fixnum-binop) ,@(when restore-fixnum-mask - `((:temporary (:sc non-descriptor-reg) temp))) + `((: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)) - ,@(when restore-fixnum-mask - `((inst andn r temp fixnum-tag-mask))))) + ,(if arg-swap + `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x) + `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y)) + ,@(when restore-fixnum-mask + `((inst andn r temp fixnum-tag-mask))))) ,@(unless arg-swap - `((define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) - fast-fixnum-binop-c) - ,@(when restore-fixnum-mask - `((:temporary (:sc non-descriptor-reg) temp))) - (:translate ,translate) - (:generator 1 - (inst ,op ,(if restore-fixnum-mask 'temp 'r) x (fixnumize y)) - ,@(when restore-fixnum-mask - `((inst andn r temp fixnum-tag-mask))))))) + `((define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) + fast-fixnum-binop-c) + ,@(when restore-fixnum-mask + `((:temporary (:sc non-descriptor-reg) temp))) + (:translate ,translate) + (:generator 1 + (inst ,op ,(if restore-fixnum-mask 'temp 'r) x (fixnumize y)) + ,@(when restore-fixnum-mask + `((inst andn r temp fixnum-tag-mask))))))) (define-vop (,(symbolicate 'fast- translate '/signed=>signed) - fast-signed-binop) + fast-signed-binop) (:translate ,translate) (:generator ,(1+ untagged-penalty) - ,(if arg-swap - `(inst ,op r y x) - `(inst ,op r x y)))) + ,(if arg-swap + `(inst ,op r y x) + `(inst ,op r x y)))) ,@(unless arg-swap - `((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/signed=>signed) + fast-signed-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (inst ,op r x y))))) (define-vop (,(symbolicate 'fast- translate '/unsigned=>unsigned) - fast-unsigned-binop) + fast-unsigned-binop) (:translate ,translate) (:generator ,(1+ untagged-penalty) - ,(if arg-swap - `(inst ,op r y x) - `(inst ,op r x y)))) + ,(if arg-swap + `(inst ,op r y x) + `(inst ,op r x y)))) ,@(unless arg-swap - `((define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned) - fast-unsigned-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))))))) ); eval-when @@ -175,6 +175,12 @@ (define-binop logxor 2 xor) (define-binop logeqv 2 xnor nil t) +(define-vop (fast-logand/signed-unsigned=>unsigned fast-logand/unsigned=>unsigned) + (:args (x :scs (signed-reg) :target r) + (y :scs (unsigned-reg) :target r)) + (:arg-types signed-num unsigned-num) + (:translate logand)) + ;;; Special case fixnum + and - that trap on overflow. Useful when we ;;; don't know that the output type is a fixnum. @@ -223,10 +229,10 @@ (define-vop (fast-v8-truncate/fixnum=>fixnum fast-safe-arith-op) (:translate truncate) (:args (x :scs (any-reg)) - (y :scs (any-reg))) + (y :scs (any-reg))) (:arg-types tagged-num tagged-num) (:results (quo :scs (any-reg)) - (rem :scs (any-reg))) + (rem :scs (any-reg))) (:result-types tagged-num tagged-num) (:note "inline fixnum arithmetic") (:temporary (:scs (any-reg) :target quo) q) @@ -235,8 +241,8 @@ (:vop-var vop) (:save-p :compute-only) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 12 (let ((zero (generate-error-code vop division-by-zero-error x y))) (inst cmp y zero-tn) @@ -249,20 +255,20 @@ (inst nop) (inst nop) - (inst sdiv q x y-int) ; Q is tagged. + (inst sdiv q x y-int) ; Q is tagged. ;; We have the quotient so we need to compute the remainder - (inst smul r q y-int) ; R is tagged + (inst smul r q y-int) ; R is tagged (inst sub rem x r) (unless (location= quo q) - (move quo q))))) + (move quo q))))) (define-vop (fast-v8-truncate/signed=>signed fast-safe-arith-op) (:translate truncate) (:args (x :scs (signed-reg)) - (y :scs (signed-reg))) + (y :scs (signed-reg))) (:arg-types signed-num signed-num) (:results (quo :scs (signed-reg)) - (rem :scs (signed-reg))) + (rem :scs (signed-reg))) (:result-types signed-num signed-num) (:note "inline (signed-byte 32) arithmetic") (:temporary (:scs (signed-reg) :target quo) q) @@ -270,14 +276,14 @@ (:vop-var vop) (:save-p :compute-only) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 12 (let ((zero (generate-error-code vop division-by-zero-error x y))) (inst cmp y zero-tn) (if (member :sparc-v9 *backend-subfeatures*) - (inst b :eq zero :pn) - (inst b :eq zero)) + (inst b :eq zero :pn) + (inst b :eq zero)) ;; Extend the sign of X into the Y register (inst sra r x 31) (inst wry r) @@ -287,18 +293,18 @@ (inst sdiv q x y) ;; We have the quotient so we need to compue the remainder - (inst smul r q y) ; rem + (inst smul r q y) ; rem (inst sub rem x r) (unless (location= quo q) - (move quo q))))) + (move quo q))))) (define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op) (:translate truncate) (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) + (y :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num) (:results (quo :scs (unsigned-reg)) - (rem :scs (unsigned-reg))) + (rem :scs (unsigned-reg))) (:result-types unsigned-num unsigned-num) (:note "inline (unsigned-byte 32) arithmetic") (:temporary (:scs (unsigned-reg) :target quo) q) @@ -306,33 +312,33 @@ (:vop-var vop) (:save-p :compute-only) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 8 (let ((zero (generate-error-code vop division-by-zero-error x y))) (inst cmp y zero-tn) (if (member :sparc-v9 *backend-subfeatures*) - (inst b :eq zero :pn) - (inst b :eq zero)) - (inst wry zero-tn) ; Clear out high part + (inst b :eq zero :pn) + (inst b :eq zero)) + (inst wry zero-tn) ; Clear out high part (inst nop) (inst nop) (inst nop) - + (inst udiv q x y) ;; Compute remainder (inst umul r q y) (inst sub rem x r) (unless (location= quo q) - (inst move quo q))))) + (inst move quo q))))) (define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op) (:translate truncate) (:args (x :scs (signed-reg)) - (y :scs (signed-reg))) + (y :scs (signed-reg))) (:arg-types signed-num signed-num) (:results (quo :scs (signed-reg)) - (rem :scs (signed-reg))) + (rem :scs (signed-reg))) (:result-types signed-num signed-num) (:note "inline (signed-byte 32) arithmetic") (:temporary (:scs (signed-reg) :target quo) q) @@ -352,15 +358,15 @@ (inst mulx r q y) (inst sub rem x r) (unless (location= quo q) - (inst move quo q))))) + (inst move quo q))))) (define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op) (:translate truncate) (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) + (y :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num) (:results (quo :scs (unsigned-reg)) - (rem :scs (unsigned-reg))) + (rem :scs (unsigned-reg))) (:result-types unsigned-num unsigned-num) (:note "inline (unsigned-byte 32) arithmetic") (:temporary (:scs (unsigned-reg) :target quo) q) @@ -380,14 +386,14 @@ (inst mulx r q y) (inst sub rem x r) (unless (location= quo q) - (inst move quo q))))) + (inst move quo q))))) ;;; Shifting (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) @@ -395,32 +401,43 @@ (: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) @@ -428,113 +445,67 @@ (: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. (macrolet - ((frob (name sc-type type result-type cost) + ((def (name sc-type type result-type cost) `(define-vop (,name) - (:note "inline ASH") - (:translate ash) - (:args (number :scs (,sc-type)) - (amount :scs (signed-reg unsigned-reg immediate))) - (:arg-types ,type positive-fixnum) - (:results (result :scs (,result-type))) - (:result-types ,type) - (:policy :fast-safe) - (:generator ,cost - ;; The result-type assures us that this shift will not - ;; overflow. And for fixnums, the zero bits that get - ;; shifted in are just fine for the fixnum tag. - (sc-case amount - ((signed-reg unsigned-reg) - (inst sll result number amount)) - (immediate - (let ((amount (tn-value amount))) - (assert (>= 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))) - - + (:note "inline ASH") + (:translate ash) + (:args (number :scs (,sc-type)) + (amount :scs (signed-reg unsigned-reg immediate))) + (:arg-types ,type positive-fixnum) + (:results (result :scs (,result-type))) + (:result-types ,type) + (:policy :fast-safe) + (:generator ,cost + ;; The result-type assures us that this shift will not + ;; overflow. And for fixnums, the zero bits that get + ;; shifted in are just fine for the fixnum tag. + (sc-case amount + ((signed-reg unsigned-reg) + (inst sll result number amount)) + (immediate + (let ((amount (tn-value amount))) + (aver (>= amount 0)) + (inst sll result number amount)))))))) + (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3) + (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2) + (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3)) (define-vop (signed-byte-32-len) @@ -548,7 +519,7 @@ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) (:generator 30 (let ((loop (gen-label)) - (test (gen-label))) + (test (gen-label))) (inst addcc shift zero-tn arg) (inst b :ge test) (move res zero-tn) @@ -557,7 +528,7 @@ (emit-label loop) (inst add res (fixnumize 1)) - + (emit-label test) (inst cmp shift) (inst b :ne loop) @@ -576,17 +547,17 @@ (move res arg) (dolist (stuff '((1 #x55555555) (2 #x33333333) (4 #x0f0f0f0f) - (8 #x00ff00ff) (16 #x0000ffff))) - (destructuring-bind (shift bit-mask) - stuff - ;; Set mask - (inst sethi mask (ldb (byte 22 10) bit-mask)) - (inst add mask (ldb (byte 10 0) bit-mask)) + (8 #x00ff00ff) (16 #x0000ffff))) + (destructuring-bind (shift bit-mask) + stuff + ;; Set mask + (inst sethi mask (ldb (byte 22 10) bit-mask)) + (inst add mask (ldb (byte 10 0) bit-mask)) - (inst and temp res mask) - (inst srl res shift) - (inst and res mask) - (inst add res temp))))) + (inst and temp res mask) + (inst srl res shift) + (inst and res mask) + (inst add res temp))))) ;;; Multiply and Divide. @@ -595,8 +566,8 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:translate *) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 2 ;; The cost here should be less than the cost for ;; */signed=>signed. Why? A fixnum product using signed=>signed @@ -609,46 +580,46 @@ (:args (x :target r :scs (any-reg zero))) (:info y) (:arg-types tagged-num - (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:constant (and (signed-byte 13) (not (integer 0 0))))) (:results (r :scs (any-reg))) (:result-types tagged-num) (:note "inline fixnum arithmetic") (:translate *) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 1 (inst smul r x y))) (define-vop (fast-v8-*/signed=>signed fast-signed-binop) (:translate *) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 3 (inst smul r x y))) (define-vop (fast-v8-*-c/signed=>signed fast-signed-binop-c) (:translate *) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 2 (inst smul r x y))) - + (define-vop (fast-v8-*/unsigned=>unsigned fast-unsigned-binop) (:translate *) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 3 (inst umul r x y))) (define-vop (fast-v8-*-c/unsigned=>unsigned fast-unsigned-binop-c) (:translate *) (:guard (or (member :sparc-v8 *backend-subfeatures*) - (and (member :sparc-v9 *backend-subfeatures*) - (not (member :sparc-64 *backend-subfeatures*))))) + (and (member :sparc-v9 *backend-subfeatures*) + (not (member :sparc-64 *backend-subfeatures*))))) (:generator 2 (inst umul r x y))) @@ -676,7 +647,7 @@ ;;;; Modular functions: -(define-modular-fun lognot-mod32 (x) lognot 32) +(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32) (define-vop (lognot-mod32/unsigned=>unsigned) (:translate lognot-mod32) (:args (x :scs (unsigned-reg))) @@ -691,18 +662,18 @@ ((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-modular-fun ,mfun-name (x y) ,fun 32) + (define-modular-fun ,mfun-name (x y) ,fun :untagged nil 32) (define-vop (,modvop ,vop) (:translate ,mfun-name)) - ,@(when constantp - `((define-vop (,modcvop ,cvop) - (:translate ,mfun-name)))))))) + ,@(when constantp + `((define-vop (,modcvop ,cvop) + (:translate ,mfun-name)))))))) (define-modular-backend + t) - (define-modular-backend logxor t) + (define-modular-backend - t) (define-modular-backend logeqv t) (define-modular-backend logandc1) (define-modular-backend logandc2 t) @@ -713,6 +684,18 @@ `(lognot (logand ,x ,y))) (define-source-transform lognor (x y) `(lognot (logior ,x ,y))) + +(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)) ;;;; Binary conditional VOPs: @@ -725,7 +708,7 @@ (define-vop (fast-conditional/fixnum fast-conditional) (:args (x :scs (any-reg zero)) - (y :scs (any-reg zero))) + (y :scs (any-reg zero))) (:arg-types tagged-num tagged-num) (:note "inline fixnum comparison")) @@ -736,7 +719,7 @@ (define-vop (fast-conditional/signed fast-conditional) (:args (x :scs (signed-reg zero)) - (y :scs (signed-reg zero))) + (y :scs (signed-reg zero))) (:arg-types signed-num signed-num) (:note "inline (signed-byte 32) comparison")) @@ -747,7 +730,7 @@ (define-vop (fast-conditional/unsigned fast-conditional) (:args (x :scs (unsigned-reg zero)) - (y :scs (unsigned-reg zero))) + (y :scs (unsigned-reg zero))) (:arg-types unsigned-num unsigned-num) (:note "inline (unsigned-byte 32) comparison")) @@ -760,25 +743,25 @@ (defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned) `(progn ,@(mapcar (lambda (suffix cost signed) - (unless (and (member suffix '(/fixnum -c/fixnum)) - (eq tran 'eql)) - `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" - tran suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,tran) - (:generator ,cost - (inst cmp x - ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y)) - (inst b (if not-p - ,(if signed not-cond not-unsigned) - ,(if signed cond unsigned)) - target) - (inst nop))))) - '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - '(4 3 6 5 6 5) - '(t t t t nil nil)))) + (unless (and (member suffix '(/fixnum -c/fixnum)) + (eq tran 'eql)) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + tran suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,tran) + (:generator ,cost + (inst cmp x + ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y)) + (inst b (if not-p + ,(if signed not-cond not-unsigned) + ,(if signed cond unsigned)) + target) + (inst nop))))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(4 3 6 5 6 5) + '(t t t t nil nil)))) (define-conditional-vop < :lt :ltu :ge :geu) @@ -797,8 +780,8 @@ ;;; (define-vop (fast-eql/fixnum fast-conditional) - (:args (x :scs (any-reg descriptor-reg zero)) - (y :scs (any-reg zero))) + (:args (x :scs (any-reg zero)) + (y :scs (any-reg zero))) (:arg-types tagged-num tagged-num) (:note "inline fixnum comparison") (:translate eql) @@ -808,11 +791,13 @@ (inst nop))) ;;; (define-vop (generic-eql/fixnum fast-eql/fixnum) + (:args (x :scs (any-reg descriptor-reg)) + (y :scs (any-reg))) (:arg-types * tagged-num) (:variant-cost 7)) (define-vop (fast-eql-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg descriptor-reg zero))) + (:args (x :scs (any-reg zero))) (:arg-types tagged-num (:constant (signed-byte 11))) (:info target not-p y) (:translate eql) @@ -822,71 +807,17 @@ (inst nop))) ;;; (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) + (:args (x :scs (any-reg descriptor-reg))) (:arg-types * (:constant (signed-byte 11))) (:variant-cost 6)) ;;;; 32-bit logical operations -(define-vop (merge-bits) - (:translate merge-bits) - (:args (shift :scs (signed-reg unsigned-reg)) - (prev :scs (unsigned-reg)) - (next :scs (unsigned-reg))) - (:arg-types tagged-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe) - (:generator 4 - (let ((done (gen-label))) - (inst cmp shift) - (inst b :eq done) - (inst srl res next shift) - (inst sub temp zero-tn shift) - (inst sll temp prev temp) - (inst or res temp) - (emit-label done) - (move result res)))) - -(define-source-transform 32bit-logical-not (x) - `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32)))) - -(deftransform 32bit-logical-and ((x y)) - '(logand x y)) - -(deftransform 32bit-logical-nand ((x y)) - '(logand (lognand x y) #.(1- (ash 1 32)))) - -(deftransform 32bit-logical-or ((x y)) - '(logior x y)) - -(deftransform 32bit-logical-nor ((x y)) - '(logand (lognor x y) #.(1- (ash 1 32)))) - -(deftransform 32bit-logical-xor ((x y)) - '(logxor x y)) - -(deftransform 32bit-logical-eqv ((x y)) - '(logand (logeqv x y) #.(1- (ash 1 32)))) - -(deftransform 32bit-logical-orc1 ((x y)) - '(logand (logorc1 x y) #.(1- (ash 1 32)))) - -(deftransform 32bit-logical-orc2 ((x y)) - '(logand (logorc2 x y) #.(1- (ash 1 32)))) - -(deftransform 32bit-logical-andc1 ((x y)) - '(logand (logandc1 x y) #.(1- (ash 1 32)))) - -(deftransform 32bit-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)) - (amount :scs (signed-reg))) + (amount :scs (signed-reg))) (:arg-types unsigned-num tagged-num) (:results (r :scs (unsigned-reg))) (:result-types unsigned-num)) @@ -904,33 +835,32 @@ (inst srl r num amount))) ;;;; Bignum stuff. - (define-vop (bignum-length get-header-data) - (:translate sb!bignum::%bignum-length) + (:translate sb!bignum:%bignum-length) (:policy :fast-safe)) (define-vop (bignum-set-length set-header-data) - (:translate sb!bignum::%bignum-set-length) + (:translate sb!bignum:%bignum-set-length) (:policy :fast-safe)) (define-vop (bignum-ref word-index-ref) (:variant bignum-digits-offset other-pointer-lowtag) - (:translate sb!bignum::%bignum-ref) + (:translate sb!bignum:%bignum-ref) (:results (value :scs (unsigned-reg))) (:result-types unsigned-num)) (define-vop (bignum-set word-index-set) (:variant bignum-digits-offset other-pointer-lowtag) - (:translate sb!bignum::%bignum-set) + (:translate sb!bignum:%bignum-set) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg immediate zero)) - (value :scs (unsigned-reg))) + (index :scs (any-reg immediate zero)) + (value :scs (unsigned-reg))) (:arg-types t positive-fixnum unsigned-num) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num)) (define-vop (digit-0-or-plus) - (:translate sb!bignum::%digit-0-or-plusp) + (:translate sb!bignum:%digit-0-or-plusp) (:policy :fast-safe) (:args (digit :scs (unsigned-reg))) (:arg-types unsigned-num) @@ -945,7 +875,7 @@ (emit-label done)))) (define-vop (v9-digit-0-or-plus-cmove) - (:translate sb!bignum::%digit-0-or-plusp) + (:translate sb!bignum:%digit-0-or-plusp) (:policy :fast-safe) (:args (digit :scs (unsigned-reg))) (:arg-types unsigned-num) @@ -959,7 +889,7 @@ ;; This doesn't work? #+nil (define-vop (v9-digit-0-or-plus-movr) - (:translate sb!bignum::%digit-0-or-plusp) + (:translate sb!bignum:%digit-0-or-plusp) (:policy :fast-safe) (:args (digit :scs (unsigned-reg))) (:arg-types unsigned-num) @@ -971,16 +901,15 @@ (inst movr result null-tn digit :lz) (inst movr result temp digit :gez))) - (define-vop (add-w/carry) - (:translate sb!bignum::%add-with-carry) + (:translate sb!bignum:%add-with-carry) (:policy :fast-safe) (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (any-reg))) + (b :scs (unsigned-reg)) + (c :scs (any-reg))) (:arg-types unsigned-num unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg)) - (carry :scs (unsigned-reg))) + (carry :scs (unsigned-reg))) (:result-types unsigned-num positive-fixnum) (:generator 3 (inst addcc zero-tn c -1) @@ -988,14 +917,14 @@ (inst addx carry zero-tn zero-tn))) (define-vop (sub-w/borrow) - (:translate sb!bignum::%subtract-with-borrow) + (:translate sb!bignum:%subtract-with-borrow) (:policy :fast-safe) (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (any-reg))) + (b :scs (unsigned-reg)) + (c :scs (any-reg))) (:arg-types unsigned-num unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg)) - (borrow :scs (unsigned-reg))) + (borrow :scs (unsigned-reg))) (:result-types unsigned-num positive-fixnum) (:generator 4 (inst subcc zero-tn c 1) @@ -1005,13 +934,13 @@ ;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly ;;; routines. -;;; +;;; (defun emit-multiply (multiplier multiplicand result-high result-low) "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result in RESULT-HIGH and RESULT-LOW. KIND is either :signed or :unsigned. Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap." (declare (type tn multiplier result-high result-low) - (type (or tn (signed-byte 13)) multiplicand)) + (type (or tn (signed-byte 13)) multiplicand)) ;; It seems that emit-multiply is only used to do an unsigned ;; multiply, so the code only does an unsigned multiply. (cond @@ -1022,7 +951,7 @@ ;; unsigned 64-bit numbers. (inst srl multiplier 0) (inst srl multiplicand 0) - + ;; Multiply the two numbers and put the result in ;; result-high. Copy the low 32-bits to result-low. Then ;; shift result-high so the high 32-bits end up in the low @@ -1031,7 +960,7 @@ (inst move result-low result-high) (inst srax result-high 32)) ((or (member :sparc-v8 *backend-subfeatures*) - (member :sparc-v9 *backend-subfeatures*)) + (member :sparc-v9 *backend-subfeatures*)) ;; V8 has a multiply instruction. This should also work for ;; the V9, but umul and the Y register is deprecated on the ;; V9. @@ -1046,7 +975,7 @@ (inst nop) (inst nop) (dotimes (i 32) - (inst mulscc result-high multiplicand)) + (inst mulscc result-high multiplicand)) (inst mulscc result-high zero-tn) (inst cmp multiplicand) (inst b :ge label) @@ -1056,14 +985,14 @@ (inst rdy result-low))))) (define-vop (bignum-mult-and-add-3-arg) - (:translate sb!bignum::%multiply-and-add) + (:translate sb!bignum:%multiply-and-add) (:policy :fast-safe) (:args (x :scs (unsigned-reg) :to (:eval 1)) - (y :scs (unsigned-reg) :to (:eval 1)) - (carry-in :scs (unsigned-reg) :to (:eval 2))) + (y :scs (unsigned-reg) :to (:eval 1)) + (carry-in :scs (unsigned-reg) :to (:eval 2))) (:arg-types unsigned-num unsigned-num unsigned-num) (:results (hi :scs (unsigned-reg) :from (:eval 0)) - (lo :scs (unsigned-reg) :from (:eval 1))) + (lo :scs (unsigned-reg) :from (:eval 1))) (:result-types unsigned-num unsigned-num) (:generator 40 (emit-multiply x y hi lo) @@ -1071,15 +1000,15 @@ (inst addx hi zero-tn))) (define-vop (bignum-mult-and-add-4-arg) - (:translate sb!bignum::%multiply-and-add) + (:translate sb!bignum:%multiply-and-add) (:policy :fast-safe) (:args (x :scs (unsigned-reg) :to (:eval 1)) - (y :scs (unsigned-reg) :to (:eval 1)) - (prev :scs (unsigned-reg) :to (:eval 2)) - (carry-in :scs (unsigned-reg) :to (:eval 2))) + (y :scs (unsigned-reg) :to (:eval 1)) + (prev :scs (unsigned-reg) :to (:eval 2)) + (carry-in :scs (unsigned-reg) :to (:eval 2))) (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) (:results (hi :scs (unsigned-reg) :from (:eval 0)) - (lo :scs (unsigned-reg) :from (:eval 1))) + (lo :scs (unsigned-reg) :from (:eval 1))) (:result-types unsigned-num unsigned-num) (:generator 40 (emit-multiply x y hi lo) @@ -1089,22 +1018,22 @@ (inst addx hi zero-tn))) (define-vop (bignum-mult) - (:translate sb!bignum::%multiply) + (:translate sb!bignum:%multiply) (:policy :fast-safe) (:args (x :scs (unsigned-reg) :to (:result 1)) - (y :scs (unsigned-reg) :to (:result 1))) + (y :scs (unsigned-reg) :to (:result 1))) (:arg-types unsigned-num unsigned-num) (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) + (lo :scs (unsigned-reg))) (:result-types unsigned-num unsigned-num) (:generator 40 (emit-multiply x y hi lo))) (define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned) - (:translate sb!bignum::%lognot)) + (:translate sb!bignum:%lognot)) (define-vop (fixnum-to-digit) - (:translate sb!bignum::%fixnum-to-digit) + (:translate sb!bignum:%fixnum-to-digit) (:policy :fast-safe) (:args (fixnum :scs (any-reg))) (:arg-types tagged-num) @@ -1114,44 +1043,44 @@ (inst sra digit fixnum n-fixnum-tag-bits))) (define-vop (bignum-floor) - (:translate sb!bignum::%floor) + (:translate sb!bignum:%bigfloor) (:policy :fast-safe) (:args (div-high :scs (unsigned-reg) :target rem) - (div-low :scs (unsigned-reg) :target quo) - (divisor :scs (unsigned-reg))) + (div-low :scs (unsigned-reg) :target quo) + (divisor :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num unsigned-num) (:results (quo :scs (unsigned-reg) :from (:argument 1)) - (rem :scs (unsigned-reg) :from (:argument 0))) + (rem :scs (unsigned-reg) :from (:argument 0))) (:result-types unsigned-num unsigned-num) (:generator 300 (move rem div-high) (move quo div-low) (dotimes (i 33) (let ((label (gen-label))) - (inst cmp rem divisor) - (inst b :ltu label) - (inst addxcc quo quo) - (inst sub rem divisor) - (emit-label label) - (unless (= i 32) - (inst addx rem rem)))) + (inst cmp rem divisor) + (inst b :ltu label) + (inst addxcc quo quo) + (inst sub rem divisor) + (emit-label label) + (unless (= i 32) + (inst addx rem rem)))) (inst not quo))) (define-vop (bignum-floor-v8) - (:translate sb!bignum::%floor) + (:translate sb!bignum:%bigfloor) (:policy :fast-safe) (:args (div-high :scs (unsigned-reg) :target rem) - (div-low :scs (unsigned-reg) :target quo) - (divisor :scs (unsigned-reg))) + (div-low :scs (unsigned-reg) :target quo) + (divisor :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num unsigned-num) (:results (quo :scs (unsigned-reg) :from (:argument 1)) - (rem :scs (unsigned-reg) :from (:argument 0))) + (rem :scs (unsigned-reg) :from (:argument 0))) (:result-types unsigned-num unsigned-num) (:temporary (:scs (unsigned-reg) :target quo) q) ;; This vop is for a v8 or v9, provided we're also not using ;; sparc-64, for which there a special sparc-64 vop. (:guard (or (member :sparc-v8 *backend-subfeatures*) - (member :sparc-v9 *backend-subfeatures*))) + (member :sparc-v9 *backend-subfeatures*))) (:generator 15 (inst wry div-high) (inst nop) @@ -1167,19 +1096,19 @@ (move quo q)))) (define-vop (bignum-floor-v9) - (:translate sb!bignum::%floor) + (:translate sb!bignum:%bigfloor) (:policy :fast-safe) (:args (div-high :scs (unsigned-reg)) - (div-low :scs (unsigned-reg)) - (divisor :scs (unsigned-reg) :to (:result 1))) + (div-low :scs (unsigned-reg)) + (divisor :scs (unsigned-reg) :to (:result 1))) (:arg-types unsigned-num unsigned-num unsigned-num) (:temporary (:sc unsigned-reg :from (:argument 0)) dividend) (:results (quo :scs (unsigned-reg)) - (rem :scs (unsigned-reg))) + (rem :scs (unsigned-reg))) (:result-types unsigned-num unsigned-num) (:guard (member :sparc-64 *backend-subfeatures*)) (:generator 5 - ;; Set dividend to be div-high and div-low + ;; Set dividend to be div-high and div-low (inst sllx dividend div-high 32) (inst add dividend div-low) ;; Compute quotient @@ -1189,7 +1118,7 @@ (inst sub rem dividend rem))) (define-vop (signify-digit) - (:translate sb!bignum::%fixnum-digit-with-correct-sign) + (:translate sb!bignum:%fixnum-digit-with-correct-sign) (:policy :fast-safe) (:args (digit :scs (unsigned-reg) :target res)) (:arg-types unsigned-num) @@ -1202,12 +1131,11 @@ (signed-reg (move res digit))))) - (define-vop (digit-ashr) - (:translate sb!bignum::%ashr) + (:translate sb!bignum:%ashr) (:policy :fast-safe) (:args (digit :scs (unsigned-reg)) - (count :scs (unsigned-reg))) + (count :scs (unsigned-reg))) (:arg-types unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) @@ -1215,12 +1143,12 @@ (inst sra result digit count))) (define-vop (digit-lshr digit-ashr) - (:translate sb!bignum::%digit-logical-shift-right) + (:translate sb!bignum:%digit-logical-shift-right) (:generator 1 (inst srl result digit count))) (define-vop (digit-ashl digit-ashr) - (:translate sb!bignum::%ashl) + (:translate sb!bignum:%ashl) (:generator 1 (inst sll result digit count))) @@ -1250,67 +1178,23 @@ (define-static-fun two-arg-eqv (x y) :translate logeqv) -;; 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) - ((unsigned-byte 32) (constant-arg (unsigned-byte 32))) - (unsigned-byte 32)) + ((unsigned-byte 32) (constant-arg (unsigned-byte 32))) + (unsigned-byte 32)) "recode as shifts and adds" - (let ((y (continuation-value y))) + (let ((y (lvar-value y))) (multiple-value-bind (result adds shifts) - (ub32-strength-reduce-constant-multiply 'x y) + (ub32-strength-reduce-constant-multiply 'x y) (cond ;; we assume, perhaps foolishly, that good SPARCs don't have an ;; issue with multiplications. (Remember that there's a ;; different transform for converting x*2^k to a shift). ((member :sparc-64 *backend-subfeatures*) (give-up-ir1-transform)) ((or (member :sparc-v9 *backend-subfeatures*) - (member :sparc-v8 *backend-subfeatures*)) - ;; breakeven point as measured by Raymond Toy - (when (> (+ adds shifts) 9) - (give-up-ir1-transform)))) + (member :sparc-v8 *backend-subfeatures*)) + ;; breakeven point as measured by Raymond Toy + (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 (continuation-type num)) - (shift-type (continuation-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))))) -