From 6c4e759d697fed4c67935a8e86b1d3dc3d5bbf8b Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 23 Nov 1990 08:43:43 +0000 Subject: [PATCH] Added generic comparison assembly routines. --- assembly/mips/arith.lisp | 174 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 173 insertions(+), 1 deletion(-) diff --git a/assembly/mips/arith.lisp b/assembly/mips/arith.lisp index 6fb44db14..06c2d1c60 100644 --- a/assembly/mips/arith.lisp +++ b/assembly/mips/arith.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/arith.lisp,v 1.4 1990/11/03 17:22:51 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/arith.lisp,v 1.5 1990/11/23 08:43:43 wlott Exp $ ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; @@ -165,3 +165,175 @@ (inst move fp-tn csp-tn) DONE) + + + +;;;; 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) + (:return-style :full-call)) + ((: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 cname descriptor-reg cname-offset) + (:temp ocfp any-reg old-fp-offset)) + (inst and temp x 3) + (inst bne temp DO-STATIC-FN) + (inst and temp y 3) + (inst beq temp DO-COMPARE) + ,cmp + + DO-STATIC-FN + (load-symbol cname ',static-fn) + (inst li nargs (fixnum 2)) + (inst lw lip cname + (- (ash vm:symbol-raw-function-addr-slot vm:word-shift) + vm:other-pointer-type)) + (inst move ocfp fp-tn) + (inst j lip) + (inst move fp-tn csp-tn) + + DO-COMPARE + (inst ,(if not-p 'bne 'beq) done) + (inst move res null-tn) + (load-symbol res t) + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil) + (define-cond-assem-rtn generic-<= <= two-arg-<= (inst slt temp y x) t) + (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil) + (define-cond-assem-rtn generic->= >= two-arg->= (inst slt temp x y) t)) + + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:return-style :full-call)) + ((: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 cname descriptor-reg cname-offset) + (:temp ocfp any-reg old-fp-offset)) + (inst beq x y RETURN-T) + (inst and temp x 3) + (inst beq temp RETURN-NIL) + (inst and temp y 3) + (inst bne temp DO-STATIC-FN) + (inst nop) + + RETURN-NIL + (inst move res null-tn) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (load-symbol cname 'eql) + (inst li nargs (fixnum 2)) + (inst lw lip cname + (- (ash vm:symbol-raw-function-addr-slot vm:word-shift) + vm:other-pointer-type)) + (inst move ocfp fp-tn) + (inst j lip) + (inst move fp-tn csp-tn) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:return-style :full-call)) + ((: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 cname descriptor-reg cname-offset) + (:temp ocfp any-reg old-fp-offset)) + (inst beq x y RETURN-T) + (inst and temp x 3) + (inst bne temp DO-STATIC-FN) + (inst and temp y 3) + (inst bne temp DO-STATIC-FN) + (inst nop) + + (inst move res null-tn) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (load-symbol cname 'two-arg-=) + (inst li nargs (fixnum 2)) + (inst lw lip cname + (- (ash vm:symbol-raw-function-addr-slot vm:word-shift) + vm:other-pointer-type)) + (inst move ocfp fp-tn) + (inst j lip) + (inst move fp-tn csp-tn) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-/= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:return-style :full-call)) + ((: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 cname descriptor-reg cname-offset) + (:temp ocfp any-reg old-fp-offset)) + (inst beq x y RETURN-NIL) + (inst and temp x 3) + (inst bne temp DO-STATIC-FN) + (inst and temp y 3) + (inst bne temp DO-STATIC-FN) + (inst nop) + + (load-symbol res t) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (load-symbol cname 'two-arg-=) + (inst li nargs (fixnum 2)) + (inst lw lip cname + (- (ash vm:symbol-raw-function-addr-slot vm:word-shift) + vm:other-pointer-type)) + (inst move ocfp fp-tn) + (inst j lip) + (inst move fp-tn csp-tn) + + RETURN-NIL + (inst move res null-tn)) -- GitLab