From 1e11e12bd37c6d59153c62c4b56ea59ad6ab9b9b Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Sun, 28 Oct 1990 06:01:50 +0000 Subject: [PATCH] Initial revision --- assembly/mips/arith.lisp | 161 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 161 insertions(+) create mode 100644 assembly/mips/arith.lisp diff --git a/assembly/mips/arith.lisp b/assembly/mips/arith.lisp new file mode 100644 index 000000000..9d2d85543 --- /dev/null +++ b/assembly/mips/arith.lisp @@ -0,0 +1,161 @@ +;;; -*- Log: code.log; Package: C -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/arith.lisp,v 1.1 1990/10/28 06:01:50 wlott Exp $ +;;; +;;; Stuff to handle simple cases for generic arithmetic. +;;; +;;; Written by William Lott. +;;; + +(in-package "C") + + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x descriptor-reg a0-offset) + (:arg y descriptor-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 cname descriptor-reg cname-offset) + (:temp ocfp any-reg old-fp-offset)) + (inst and temp x 3) + (inst bne temp DO-STATIC-FUN) + (inst and temp y 3) + (inst bne temp DO-STATIC-FUN) + (inst nop) + (inst add res x y) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (load-symbol cname 'two-arg-+) + (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)) + + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x descriptor-reg a0-offset) + (:arg y descriptor-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 cname descriptor-reg cname-offset) + (:temp ocfp any-reg old-fp-offset)) + (inst and temp x 3) + (inst bne temp DO-STATIC-FUN) + (inst and temp y 3) + (inst bne temp DO-STATIC-FUN) + (inst nop) + (inst sub res x y) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (load-symbol cname 'two-arg--) + (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)) + + +(define-assembly-routine (generic-* + (:cost 25) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x descriptor-reg a0-offset) + (:arg y descriptor-reg a1-offset) + + (:res res descriptor-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 lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cname descriptor-reg cname-offset) + (:temp ocfp any-reg old-fp-offset)) + ;; If either arg is not a fixnum, call the static function. + (inst and temp x 3) + (inst bne temp DO-STATIC-FUN) + (inst and temp y 3) + (inst bne temp DO-STATIC-FUN) + (inst nop) + + ;; Remove the tag from one arg so that the result will have the correct + ;; fixnum tag. + (inst sra temp x 2) + (inst mult temp y) + (inst mflo res) + (inst mfhi hi) + ;; 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 temp res 31) + (inst xor temp hi) + (inst beq temp DONE) + ;; Shift the double word hi:res down two bits into hi:low to get rid of the + ;; fixnum tag. + (inst srl lo res 2) + (inst sll temp hi 30) + (inst or lo temp) + (inst sra hi 2) + ;; Allocate a BIGNUM for the result. + (pseudo-atomic (temp) + (let ((one-word (gen-label))) + (inst addu res alloc-tn vm:other-pointer-type) + ;; Assume we need one word. + (inst addu alloc-tn (vm:pad-data-block (1+ vm:bignum-digits-offset))) + ;; Is that correct? + (inst sra temp lo 31) + (inst xor temp hi) + (inst beq temp one-word) + (inst li temp (logior (ash 1 vm:type-bits) vm:bignum-type)) + ;; Nope, we need two, so allocate the addition space. + (inst addu alloc-tn (- (vm:pad-data-block (+ 2 vm:bignum-digits-offset)) + (vm:pad-data-block (1+ vm:bignum-digits-offset)))) + (inst li temp (logior (ash 2 vm:type-bits) vm:bignum-type)) + (storew hi res (1+ vm:bignum-digits-offset) vm:other-pointer-type) + (emit-label one-word) + (storew temp res 0 vm:other-pointer-type) + (storew lo res vm:bignum-digits-offset vm:other-pointer-type))) + ;; Out of here + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (load-symbol cname 'two-arg-*) + (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) + + DONE) -- GitLab