(;; SCCS   : @(#)ARITH.LSP	3.14 2/4/86
;;; File   : $xerox/arith.lsp
;;; Author : Richard A. O'Keefe
;;; Purpose: Define the arithmetic instructions.
PROGN
;;; ------------------------------------------------------------------------
;;
;;	WARNING: This material is CONFIDENTIAL and proprietary to Quintus
;;	Computer Systems Inc.  This notice is protection against inadvertent
;;	disclosure and does not constitute publication or reflect any intent
;;	to publish.
;;
;;	Copyright (C) 1985, by Quintus Computer Systems, Inc.
;;	All rights reserved.
;;
;;	CAVEAT LECTOR: This software is under development.  No warrantee is
;;	made that it is any use for anything at all.
;;
;;; ------------------------------------------------------------------------


;;; ------------------------------------------------------------------------
;;
;;	The D-machine version of the arithmetic instructions differs from
;;	the VAX and Sun emulators.  Instead of holding unboxed numbers, T0
;;	and T1 hold ordinary Lisp pointers to SMALLPs, FIXPs, FLOATPs, or
;;	whatever.  There are several reasons for this.  One is that it is
;;	easiest to do it this way.  Another important one is that in JAZZ
;;	I am told there will be BIGNUMs, so that the two-fold distinction
;;	which that VAX and Sun emulators assume will not be adequate.  As
;;	a consequence of this change, there is no distinction between the
;;	two modes here as there is in the VAX/Sun versions: we always stay
;;	in whatever mode we happened to be in when we started.
;;
;;	A difference between the Lisp emulator and the existing emulators
;;	is the way that division by zero is handled.  The existing
;;	emulators check for zero and simply fail.  Arithmetic overflow
;;	is handling by taking whatever the hardware gives you for integers,
;;	and infinities for floating point numbers.  Allowing infinities
;;	was a glaringly stupid mistake, we cannot possibly make that work
;;	on the VAX nor on the 1108, and we may change the SUN version to
;;	trap floating point overflows as well.  The Koto version of Lisp
;;	supports bignums, so integer overflow isn't a problem.  But we
;;	want to do something sensible with floating pointer overflow and
;;	all kinds of integer division as well, so we run with

	(OVERFLOW T)

;;	enabled.  Floating overflow is supposed to be caught; for some
;;	reason zero divide is slipping through.


;;  (raw.float)
;;  Takes the floating point number in T0 and turns it into a FIXP
;;  with the same bits.  T0 is first floated, if necessary.

(def.both.mode raw.float (extend)
    (LET ((Ptr (FLOAT (get.nb T0)) ))
	(put.nb T0 (\MAKENUMBER (\GETBASE Ptr 0) (\GETBASE Ptr 1)))
    )
    (continue 0)
)

;;  (float)
;;  ensures that T0 is a floating point number.

(def.both.mode float (extend)
    (if (NOT (FLOATP (get.nb T0))) then
	(put.nb T0 (FLOAT (get.nb T0)) ))
    (continue 0)
)

;;  (fix)
;;  ensures that T0 is a fixed point number.
;;  Note that this can cause an overflow trap.

(def.both.mode fix (extend)
    (if (FLOATP (get.nb T0)) then
	(put.nb T0 (FIX (get.nb T0)) ))
    (continue 0)
)


;;  (minus)
;;  negates a number.
;;  does (IMINUS -2^31) cause an integer overflow trap?  It should.

(def.both.mode minus (extend)
    (put.nb T0 (MINUS (get.nb T0)))
    (continue 0)
)


;;  (boolean.not)
;;  takes the complement of a number.

(def.both.mode boolean.not (extend)
    (put.nb T0 (LOGNOT (get.nb T0)))
    (continue 0)
)


;;  All the two-argument arithmetic operations follow a common pattern.
;;  They just apply a Lisp function to T0 and T1, and put the result in
;;  T0.  So, to save my effort, they are defined via a macro.

(def.macro def.binop (Op Fn)
   `(def.both.mode ,Op (extend)
	(put.nb T0 (,Fn (get.nb T1) (get.nb T0)) )
	(continue 0)
    )
)

(def.binop add			PLUS)
(def.binop subtract		DIFFERENCE)
(def.binop multiply		TIMES)
(def.binop divide		FQUOTIENT)
(def.binop integer.divide	IQUOTIENT)
(def.binop modulus		REMAINDER)

(def.binop boolean.and		LOGAND)
(def.binop boolean.or		LOGOR)
(def.binop boolean.xor		LOGXOR)
(def.binop left.shift		LSH)	; *NOT* LLSH
(def.binop right.shift		RSH)	; *NOT* LRSH


;;  There are two versions of each arithmetic relation.
;;  <foo> succeeds if the relation holds, fails otherwise.
;;  <foo.else L> falls through if the relation holds, or
;;  jumps to L if the relation fails to hold.  For convenience,
;;  the jump instructions are like other jumps, [opcode:8|addr:24]
;;  and the other ones are [extend:8|opcode:8].  As a matter of
;;  fact, these instructions can only appear at the end of a
;;  block of arithmetic instructions, so if we arranged for load
;;  instructions to set read mode, we could double up the other
;;  arithmetic instructions, particularly the jumps and stores.

(def.macro def.relop (Fn Op1 Op2)
   `(PROGN
	(def.both.mode ,Op1 (extend)
	    (if (,Fn (get.nb T1) (get.nb T0)) then
		(continue 0)
	    else
		(fast.fail)
	    )
	)
	(def.both.mode ,Op2 (address)
	    (if (,Fn (get.nb T1) (get.nb T0)) then
		(continue 1)
	    else
		(continue.at (address.operand))
	    )
	)
    )
)

(def.relop	EQP	    equal.to		equal.to.else)
(def.relop	(LAMBDA (X Y) (NOT (EQP X Y)))
			    not.equal.to	not.equal.to.else)
(def.relop	LESSP	    less.than		less.than.else)
(def.relop	GEQ	    not.less.than	not.less.than.else)
(def.relop	GREATERP    greater.than	greater.than.else)
(def.relop	LEQ	    not.greater.than	not.greater.than.else)



;;  (store.variable.Xn n)
;;  stores the number in T0 in the previously uninitialised variable Xn.
;;  We set the tag of T0, but it is safe to continue in arithmetic mode,
;;  because the arithmetic operations ignore that tag.  We have to use
;;  tag.other here rather than tag.number because, thanks to the new
;;  improved choice point code, T0 might be a Prolog choice point handle.

(def.macro store.variable (store)
   `(LET ((Ptr (get.nb T0)))
	(if (AND (NOT (SMALLP Ptr)) (NUMBERP Ptr)) then
	    (QP.ADD.REF Ptr)	; FIXP, BIGNUM, FLOATP
	)
	(,store N (tag.other Ptr))
    )
)

(def.both.mode store.variable.Xn (areg)
    (store.variable put.Aval)
    (continue 0)
)

;;  (store.variable.XnM n)
;;  is for the X registers stored in memory.

(def.both.mode store.variable.XnM (amem)
    (store.variable put.Amem)
    (continue 0)
)

;;  (store.variable.Yn n)
;;  is much the same.

(def.both.mode store.variable.Yn (yreg)
    (store.variable put.Yval)
    (continue 0)
)



;;  (store.value.Xn n) and
;;  (store.value.Yn n)
;;  are really a form of unification.  For the moment, the simplest
;;  thing to do is to set up T0 and T1 and go ahead with a call to
;;  the general unifier.  We could save some time by making a special
;;  case unify.constant routine, but it wouldn't save all that much
;;  effort, as we still have to check for boxed numbers.   Because
;;  maintaining Lisp reference counts is so expensive, we want to
;;  avoid calling QP.ADD.REF if we possibly can.  The same criteria
;;  apply to all flavours of store value, even store.value.Xn, as
;;  Xn might hold an unbound variable.  So the store.value macro
;;  packages up the reference count maintenance and tag repair for
;;  all flavours of store.value.  We use tag.other because gettopval
;;  is sometimes used to load procedure record addresses!

(def.open store.value ()
    (LET ((Ptr (get.nb T0)))
	(if (AND (EQ (tag.of T1) ref.tag.8)	; might store into memory
		 (NOT (SMALLP Ptr))		; might need a ref count
		 (NUMBERP Ptr)) then		; filter out BLOCKDATAPs
	    (QP.ADD.REF Ptr)
	)
	(put.32 T0 (tag.other Ptr))
    )
    (unify.and.continue 0)
)

(def.both.mode store.value.Xn (areg)
    (put.32 T1 (get.Aval N))
    (store.value)
)

(def.both.mode store.value.XnM (amem)
    (put.32 T1 (get.Amem N))
    (store.value)
)

(def.both.mode store.value.Yn (yreg)
    (put.32 T1 (get.Yval N))
    (store.value)
)



;;  (store.integer cell) and
;;  (store.float cell)
;;  could be done the same way, by just going off to the general unifier.
;;  Indeed, the whole of the "store" family could be handled by just the
;;  store.variable.An instruction, followed by unification against that
;;  A register.  store.integer can check immediately for a FIXP, and
;;  store.float can check immediately for a FLOATP; this is no real gain
;;  as these instructions are vanishingly rare.

(def.both.mode store.integer (extend cell)
    (put.32 T1 (cell.operand))
    (if (AND (FIXP (get.nb T0)) (EQP (get.nb T0) (get.nb T1)) ) then
	(continue 2)
    else
	(fast.fail)
    )
)

(def.both.mode store.float (extend cell)
    (put.32 T1 (cell.operand))
    (if (AND (FLOATP (get.nb T0)) (EQP (get.nb T0) (get.nb T1)) ) then
	(continue 2)
    else
	(fast.fail)
    )
)




;;  In an earlier version of this file, the load instructions used to
;;  demand that an integer or float be yielded.  But now that BIGNUMS
;;  are available, this is no longer right, and more importantly, the
;;  pseudo-Prolog code that maintains dynamic clauses expects X =\= 0
;;  to work correctly for any "address" X.  So now we accept any kind
;;  of constant.   If we do arithmetic on a non-numeric value, Inter-
;;  LOSS is perfectly capable of spotting the error and reporting it.
;;  As we don't check, "Y = a, X is Y" will succeed in compiled code,
;;  and it isn't supposed to (and won't in interpreted code).  We can
;;  live with that.  When we find a constant, we leave the tag in T0.
;;  It doesn't matter, nothing is going to look at it.  The final (?)
;;  idea is to reject atoms but accept "others".

(def.subr load.value.error ()			; print an error message
    ;;  Check whether we can change (MKATOM &) -> &
    (QP.PUT.TOKEN.SYMBOL QP.CURRENT.OUTPUT (MKATOM "%
[Warning: Arithmetic predicate has failed - tried to evaluate a non number]%
[         Use the interpreter and debugger to locate this error]%
"   ) 0)
    (fast.fail)
)

(def.open load.value ()
    (PROG (Tag)
	(while (EQ (SETQ Tag (tag.of T0)) ref.tag.8)
	    ;;  variable.  Dereference, see if unbound.
	    (put.24 R  (untag.ref T0))
	    (put.32 T0 (get.cell R 0))
	    (if (EQ (get.nb T0) (get.24 R)) then
		(load.value.error)	; unbound variable, never ok
	    )
	)
	(if (ILESSP Tag immed.tag.8) then
	    (load.value.error)		; not a constant
	)
    )
    ;;  T0 is a smallp, fixp, floatp, or "other"
    (continue 0)
)


(def.both.mode load.value.Xn (areg)
    (put.32 T1 (get.32 T0))		; "push" T0
    (put.32 T0 (get.Aval N))
    (load.value)
)


(def.both.mode load.value.XnM (amem)
    (put.32 T1 (get.32 T0))		; "push" T0
    (put.32 T0 (get.Amem N))		; #TAIL
    (load.value)
)


(def.both.mode load.value.Yn (yreg)
    (put.32 T1 (get.32 T0))		; "push" T0
    (put.32 T0 (get.Yval N))
    (load.value)
)



;;  When it comes to loading a constant, we don't need to have separate
;;  load.integer and load.float instructions.  The Sun/VAX emulators use
;;  them so that (1) they can work out fast what mode they are supposed
;;  to be in, and (2) they can put 32-bit boxed numbers in line in the
;;  code.  We don't use the mode that way, and there isn't any advantage
;;  to having in-line constants.  Indeed, it'd cost us more boxing.
;;  So there is only the
;;  (load.constant cell)
;;  instruction, which copies the pointer part of the cell to T0.  (The
;;  tag is copied too, but nobody cares about that.)

(def.both.mode load.constant (extend cell)
    (put.32 T1 (get.32 T0))		; "push" T0
    (put.32 T0 (cell.operand))
    (continue 2)
)


;;  There are four instructions which take 16-bit integer arguments.
;;  load.{pos/neg}.word are there for compactness; they are one word
;;  shorter than load.cell.  All things considered, I wonder if I am
;;  wise to keep them?

(def.both.mode load.pos.word (extend word)
    (put.32 T1 (get.32 T0))
    (put.nb T0 (get.code P 0))
    (continue 1)
)

(def.both.mode load.neg.word (extend word)
    (put.32 T1 (get.32 T0))
    (put.nb T0 (\VAG2 (CONSTANT (\HILOC -1)) (get.code P 0)))
    (continue 1)
)

;;  add.{pos/neg}.word add a 17-bit integer to T0.  They have to do
;;  this without disturbing T1, so we use R as a scratch register.
;;  This really needs some thought.  add.constant would be one word
;;  longer, and would not be all that much slower.

(def.both.mode add.pos.word (extend word)
    (put.nb T0 (PLUS (get.nb T0) (get.code P 0)))
    (continue 1)
)

(def.both.mode add.neg.word (extend word)
    (put.nb T0 (PLUS (get.nb T0)
	(\VAG2 (CONSTANT (\HILOC -1)) (get.code P 0))))
    (continue 1)
)


) STOP