;;; -*- Package: HPPA -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: src/assembly/hppa/arith.lisp $")
;;;
;;; **********************************************************************
;;;
;;; Stuff to handle simple cases for generic arithmetic.
;;;
;;; Written by William Lott.
;;;

(in-package "HPPA")


;;;; Multiplication and Division helping routines.

#+assembler
(define-assembly-routine
    multiply
    ((:arg x (signed-reg) nl0-offset)
     (:arg y (signed-reg) nl1-offset)

     (:res res (signed-reg) nl2-offset)

     (:temp tmp (unsigned-reg) nl3-offset)
     (:temp sign (unsigned-reg) nl4-offset))

  ;; Determine the sign of the result.
  (inst extrs x 0 1 sign :=)
  (inst sub zero-tn x x)
  (inst extrs y 0 1 tmp :=)
  (inst sub zero-tn y y)
  (inst xor sign tmp sign)

  ;; Make sure X is less then Y.
  (inst comclr x y tmp :<<)
  (inst xor x y tmp)
  (inst xor x tmp x)
  (inst xor y tmp y)
  ;; Blow out of here if the result is zero.
  (inst comb := x zero-tn done)
  (inst li 0 res)

  LOOP
  (inst extru x 31 1 zero-tn :ev)
  (inst add y res res)
  (inst extru x 30 1 zero-tn :ev)
  (inst sh1add y res res)
  (inst extru x 29 1 zero-tn :ev)
  (inst sh2add y res res)
  (inst extru x 28 1 zero-tn :ev)
  (inst sh3add y res res)

  (inst srl x 4 x)
  (inst comb :<> x zero-tn loop)
  (inst sll y 4 y)

  DONE
  (inst xor res sign res)
  (inst add res sign res))


#+assembler
(define-assembly-routine
    (truncate)
    ((:arg dividend signed-reg nl0-offset)
     (:arg divisor signed-reg nl1-offset)

     (:res quo signed-reg nl2-offset)
     (:res rem signed-reg nl3-offset))
  
  ;; Move abs(divident) into quo.
  (inst move dividend quo :>=)
  (inst sub zero-tn quo quo)
  ;; Do one divide-step with -divisor to prime V  (use rem as a temp)
  (inst sub zero-tn divisor rem)
  (inst ds zero-tn rem zero-tn)
  ;; Shift the dividend/quotient one bit, setting the carry flag.
  (inst add quo quo quo)
  ;; The first real divide-step.
  (inst ds zero-tn divisor rem)
  (inst addc quo quo quo)
  ;; And 31 more of them.
  (dotimes (i 31)
    (inst ds rem divisor rem)
    (inst addc quo quo quo))
  ;; If the remainder is negative, we need to add the absolute value of the
  ;; divisor.
  (inst comb :>= rem zero-tn remainder-positive)
  (inst comclr divisor zero-tn zero-tn :<)
  (inst add rem divisor rem :tr)
  (inst sub rem divisor rem)
  REMAINDER-POSITIVE
  ;; Now we have to fix the signs of quo and rem.
  (inst xor divisor dividend zero-tn :>=)
  (inst sub zero-tn quo quo)
  (inst move dividend zero-tn :>=)
  (inst sub zero-tn rem rem))



;;;; Generic arithmetic.

(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 lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst extru x 31 2 zero-tn :=)
  (inst b do-static-fun :nullify t)
  (inst extru y 31 2 zero-tn :=)
  (inst b do-static-fun :nullify t)
  (inst addo x y res)
  (lisp-return lra :offset 1)

  DO-STATIC-FUN
  (inst ldw (static-function-offset 'two-arg-+) null-tn lip)
  (inst li (fixnumize 2) nargs)
  (inst move cfp-tn ocfp)
  (inst bv lip)
  (inst move csp-tn cfp-tn))

(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 lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst extru x 31 2 zero-tn :=)
  (inst b do-static-fun :nullify t)
  (inst extru y 31 2 zero-tn :=)
  (inst b do-static-fun :nullify t)
  (inst subo x y res)
  (lisp-return lra :offset 1)

  DO-STATIC-FUN
  (inst ldw (static-function-offset 'two-arg--) null-tn lip)
  (inst li (fixnumize 2) nargs)
  (inst move cfp-tn ocfp)
  (inst bv lip)
  (inst move csp-tn cfp-tn))



;;;; Comparison routines.

(macrolet
    ((define-cond-assem-rtn (name translate static-fn cond)
       `(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 lip interior-reg lip-offset)
				  (:temp lra descriptor-reg lra-offset)
				  (:temp nargs any-reg nargs-offset)
				  (:temp ocfp any-reg ocfp-offset))
	  (inst extru x 31 2 zero-tn :=)
	  (inst b do-static-fn :nullify t)
	  (inst extru y 31 2 zero-tn :=)
	  (inst b do-static-fn :nullify t)

	  (inst comclr x y zero-tn ,cond)
	  (inst move null-tn res :tr)
	  (load-symbol res t)
	  (lisp-return lra :offset 1)

	  DO-STATIC-FN
	  (inst ldw (static-function-offset ',static-fn) null-tn lip)
	  (inst li (fixnumize 2) nargs)
	  (inst move cfp-tn ocfp)
	  (inst bv lip)
	  (inst move csp-tn cfp-tn))))

  (define-cond-assem-rtn generic-< < two-arg-< :<)
  (define-cond-assem-rtn generic-> > two-arg-> :>))


(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 lip interior-reg lip-offset)
     (:temp lra descriptor-reg lra-offset)
     (:temp nargs any-reg nargs-offset)
     (:temp ocfp any-reg ocfp-offset))

  (inst comb := x y return-t :nullify t)
  (inst extru x 31 2 zero-tn :<>)
  (inst b return-nil :nullify t)
  (inst extru y 31 2 zero-tn :=)
  (inst b do-static-fn :nullify t)

  RETURN-NIL
  (inst move null-tn res)
  (lisp-return lra :offset 1)

  DO-STATIC-FN
  (inst ldw (static-function-offset 'eql) null-tn lip)
  (inst li (fixnumize 2) nargs)
  (inst move cfp-tn ocfp)
  (inst bv lip)
  (inst move csp-tn cfp-tn)

  RETURN-T
  (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 lip interior-reg lip-offset)
     (:temp lra descriptor-reg lra-offset)
     (:temp nargs any-reg nargs-offset)
     (:temp ocfp any-reg ocfp-offset))

  (inst comb := x y return-t :nullify t)
  (inst extru x 31 2 zero-tn :=)
  (inst b do-static-fn :nullify t)
  (inst extru y 31 2 zero-tn :=)
  (inst b do-static-fn :nullify t)

  (inst move null-tn res)
  (lisp-return lra :offset 1)

  DO-STATIC-FN
  (inst ldw (static-function-offset 'two-arg-=) null-tn lip)
  (inst li (fixnumize 2) nargs)
  (inst move cfp-tn ocfp)
  (inst bv lip)
  (inst move csp-tn cfp-tn)

  RETURN-T
  (load-symbol res t))
