Skip to content
Snippets Groups Projects
Commit 1e11e12b authored by wlott's avatar wlott
Browse files

Initial revision

parent 57f5ee19
No related branches found
No related tags found
No related merge requests found
;;; -*- 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)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment