X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fassembly%2Falpha%2Farith.lisp;h=52f02652206270364b30a9c4c4a4e80f4baa2f0c;hb=dfc9c3a9dde3ae21498ac1a184a6e56fd4e79eb0;hp=32890fc24affc03d7308d8a2a7e8f88262656c76;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/assembly/alpha/arith.lisp b/src/assembly/alpha/arith.lisp index 32890fc..52f0265 100644 --- a/src/assembly/alpha/arith.lisp +++ b/src/assembly/alpha/arith.lisp @@ -1,71 +1,67 @@ -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle simple cases for generic arithmetic. -;;; -;;; Written by William Lott. -;;; Conversion by Sean Hallgren -;;; - -(in-package "SB!VM") +;;;; stuff to handle simple cases for generic arithmetic +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. +(in-package "SB!VM") (define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp temp3 non-descriptor-reg nl2-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp temp3 non-descriptor-reg nl2-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) (inst and y 3 temp) (inst bne temp DO-STATIC-FUN) (inst addq x y res) - - ; Check to see if we need a bignum + + ; Check whether we need a bignum. (inst sra res 31 temp) (inst beq temp DONE) (inst not temp temp) (inst beq temp DONE) (inst sra res 2 temp3) - - ; From move-from-signed + + ; from move-from-signed (inst li 2 temp2) (inst sra temp3 31 temp) (inst cmoveq temp 1 temp2) (inst not temp temp) (inst cmoveq temp 1 temp2) - (inst sll temp2 type-bits temp2) - (inst bis temp2 bignum-type temp2) - + (inst sll temp2 n-widetag-bits temp2) + (inst bis temp2 bignum-widetag temp2) + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) - (inst bis alloc-tn other-pointer-type res) - (storew temp2 res 0 other-pointer-type) - (storew temp3 res bignum-digits-offset other-pointer-type) + (inst bis alloc-tn other-pointer-lowtag res) + (storew temp2 res 0 other-pointer-lowtag) + (storew temp3 res bignum-digits-offset other-pointer-lowtag) (inst srl temp3 32 temp) - (storew temp res (1+ bignum-digits-offset) other-pointer-type)) + (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag)) DONE (lisp-return lra lip :offset 2) DO-STATIC-FUN - (inst ldl lip (static-function-offset 'two-arg-+) null-tn) + (inst ldl lip (static-fun-offset 'two-arg-+) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) @@ -73,56 +69,56 @@ (define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp temp3 non-descriptor-reg nl2-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp temp3 non-descriptor-reg nl2-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) (inst and y 3 temp) (inst bne temp DO-STATIC-FUN) (inst subq x y res) - - ; Check to see if we need a bignum + + ; Check whether we need a bignum. (inst sra res 31 temp) (inst beq temp DONE) (inst not temp temp) (inst beq temp DONE) (inst sra res 2 temp3) - - ; From move-from-signed + + ; from move-from-signed (inst li 2 temp2) (inst sra temp3 31 temp) (inst cmoveq temp 1 temp2) (inst not temp temp) (inst cmoveq temp 1 temp2) - (inst sll temp2 type-bits temp2) - (inst bis temp2 bignum-type temp2) - + (inst sll temp2 n-widetag-bits temp2) + (inst bis temp2 bignum-widetag temp2) + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) - (inst bis alloc-tn other-pointer-type res) - (storew temp2 res 0 other-pointer-type) - (storew temp3 res bignum-digits-offset other-pointer-type) + (inst bis alloc-tn other-pointer-lowtag res) + (storew temp2 res 0 other-pointer-lowtag) + (storew temp3 res bignum-digits-offset other-pointer-lowtag) (inst srl temp3 32 temp) - (storew temp res (1+ bignum-digits-offset) other-pointer-type)) + (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag)) DONE (lisp-return lra lip :offset 2) DO-STATIC-FUN - (inst ldl lip (static-function-offset 'two-arg--) null-tn) + (inst ldl lip (static-fun-offset 'two-arg--) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) @@ -130,77 +126,77 @@ (define-assembly-routine (generic-* - (:cost 25) - (:return-style :full-call) - (:translate *) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lo non-descriptor-reg nl1-offset) - (:temp hi non-descriptor-reg nl2-offset) - (:temp temp2 non-descriptor-reg nl3-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 25) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp temp2 non-descriptor-reg nl3-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) (inst and y 3 temp) (inst bne temp DO-STATIC-FUN) - ;; Remove the tag from one arg so that the result will have the correct - ;; fixnum tag. + ;; Remove the tag from one arg so that the result will have the + ;; correct fixnum tag. (inst sra x 2 temp) (inst mulq temp y lo) (inst sra lo 32 hi) (inst sll lo 32 res) (inst sra res 32 res) - ;; Check to see if the result will fit in a fixnum. (I.e. the high word - ;; is just 32 copies of the sign bit of the low word). + ;; Check to see if the result will fit in a fixnum. (I.e. the high + ;; word is just 32 copies of the sign bit of the low word). (inst sra res 31 temp) (inst xor hi temp temp) (inst beq temp DONE) - ;; Shift the double word hi:res down two bits into hi:low to get rid of the - ;; fixnum tag. + ;; Shift the double word hi:res down two bits into hi:low to get rid + ;; of the fixnum tag. (inst sra lo 2 lo) (inst sra lo 32 hi) ;; Do we need one word or two? Assume two. - (inst li (logior (ash 2 type-bits) bignum-type) temp2) + (inst li (logior (ash 2 n-widetag-bits) bignum-widetag) temp2) (inst sra lo 31 temp) (inst xor temp hi temp) (inst bne temp two-words) ;; Only need one word, fix the header. - (inst li (logior (ash 1 type-bits) bignum-type) temp2) + (inst li (logior (ash 1 n-widetag-bits) bignum-widetag) temp2) ;; Allocate one word. (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) - (inst bis alloc-tn other-pointer-type res) - (storew temp2 res 0 other-pointer-type)) + (inst bis alloc-tn other-pointer-lowtag res) + (storew temp2 res 0 other-pointer-lowtag)) ;; Store one word - (storew lo res bignum-digits-offset other-pointer-type) + (storew lo res bignum-digits-offset other-pointer-lowtag) ;; Out of here (lisp-return lra lip :offset 2) TWO-WORDS ;; Allocate two words. (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset))) - (inst bis alloc-tn other-pointer-type res) - (storew temp2 res 0 other-pointer-type)) + (inst bis alloc-tn other-pointer-lowtag res) + (storew temp2 res 0 other-pointer-lowtag)) ;; Store two words. - (storew lo res bignum-digits-offset other-pointer-type) - (storew hi res (1+ bignum-digits-offset) other-pointer-type) - ;; Out of here + (storew lo res bignum-digits-offset other-pointer-lowtag) + (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) + ;; out of here (lisp-return lra lip :offset 2) DO-STATIC-FUN - (inst ldl lip (static-function-offset 'two-arg-*) null-tn) + (inst ldl lip (static-fun-offset 'two-arg-*) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) @@ -209,28 +205,28 @@ DONE) -;;;; Division. +;;;; division (define-assembly-routine (signed-truncate - (:note "(signed-byte 32) truncate") - (:cost 60) - (:policy :fast-safe) - (:translate truncate) - (:arg-types signed-num signed-num) - (:result-types signed-num signed-num)) - - ((:arg dividend signed-reg nl0-offset) - (:arg divisor signed-reg nl1-offset) - - (:res quo signed-reg nl2-offset) - (:res rem signed-reg nl3-offset) - - (:temp quo-sign signed-reg nl5-offset) - (:temp rem-sign signed-reg nargs-offset) - (:temp temp1 non-descriptor-reg nl4-offset)) - + (:note "(signed-byte 64) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl3-offset) + + (:temp quo-sign signed-reg nl5-offset) + (:temp rem-sign signed-reg nargs-offset) + (:temp temp1 non-descriptor-reg nl4-offset)) + (let ((error (generate-error-code nil division-by-zero-error - dividend divisor))) + dividend divisor))) (inst beq divisor error)) (inst xor dividend divisor quo-sign) @@ -245,9 +241,8 @@ (emit-label label)) (inst move zero-tn rem) (inst move zero-tn quo) - (inst sll dividend 32 dividend) - (dotimes (i 32) + (dotimes (i 64) (inst srl dividend 63 temp1) (inst sll rem 1 rem) (inst bis temp1 rem rem) @@ -271,64 +266,64 @@ (emit-label label))) -;;;; Comparison routines. +;;;; comparison routines (macrolet ((define-cond-assem-rtn (name translate static-fn cmp not-p) `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and x 3 temp) - (inst bne temp DO-STATIC-FN) - (inst and y 3 temp) - (inst beq temp DO-COMPARE) - - DO-STATIC-FN - (inst ldl lip (static-function-offset ',static-fn) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip) - - DO-COMPARE - ,cmp - (inst move null-tn res) - (inst ,(if not-p 'bne 'beq) temp done) - (load-symbol res t) - DONE))) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FN) + (inst and y 3 temp) + (inst beq temp DO-COMPARE) + + DO-STATIC-FN + (inst ldl lip (static-fun-offset ',static-fn) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + DO-COMPARE + ,cmp + (inst move null-tn res) + (inst ,(if not-p 'bne 'beq) temp done) + (load-symbol res t) + DONE))) (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil) (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil)) (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst cmpeq x y temp) (inst bne temp RETURN-T) (inst and x 3 temp) @@ -341,7 +336,7 @@ (lisp-return lra lip :offset 2) DO-STATIC-FN - (inst ldl lip (static-function-offset 'eql) null-tn) + (inst ldl lip (static-fun-offset 'eql) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) @@ -351,21 +346,21 @@ (load-symbol res t)) (define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FN) (inst and y 3 temp) @@ -377,7 +372,7 @@ (lisp-return lra lip :offset 2) DO-STATIC-FN - (inst ldl lip (static-function-offset 'two-arg-=) null-tn) + (inst ldl lip (static-fun-offset 'two-arg-=) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) @@ -387,21 +382,21 @@ (load-symbol res t)) (define-assembly-routine (generic-/= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate /=) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FN) (inst and y 3 temp) @@ -413,7 +408,7 @@ (lisp-return lra lip :offset 2) DO-STATIC-FN - (inst ldl lip (static-function-offset 'two-arg-=) null-tn) + (inst ldl lip (static-fun-offset 'two-arg-/=) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn)