/* --- Copyright University of Sussex 1994. All rights reserved. ----------
 * File:            C.alpha/src/amisc.s
 * Purpose:         Miscellaneous Assembler routines
 * Author:          John Gibson, Sep 12 1994
 */

#_<

#_INCLUDE 'asm.ph'

vars
	_call_stack_lim, _plog_trail_sp, _plog_trail_lim
	;

section $-Sys;

constant
	procedure (Call_overflow, User_overflow, Callstack_reset,
	Conspair, Plog$-Area_overflow, Async_raise_signal)
	;

endsection;

>_#


ASM_START_FILE


ASM_CODE_PSECT


;;;---------------------------------------------------------------------------

	;;; do checks

ASM_ALIGN_QUAD
DEF_C_LAB (_checkplogall)
	ldW	rt3, _SVB_OFFS(_plog_trail_sp)(rsvb)
	ldW	rt4, _SVB_OFFS(_plog_trail_lim)(rsvb)
	ldW	rt0, _SVB_OFFS(_call_stack_lim)(rsvb)
	cmpule	rt4, rt3, rt4		;;; rt4=1 if trail overflow
	ldW	rt1, _SVB_OFFS(_userlim)(rsvb)
	cmpult	rsp, rt0, rt0		;;; rt0=1 if callstack overflow
	ldW	rt2, _SVB_OFFS(_trap)(rsvb)		;;; rt2 = 1 if trap
	cmpult	rusp, rt1, rt1		;;; rt1=1 if userstack overflow
	or	rt2, rt4, rt3		;;; rt3=1 if trap or trail overflow
	or	rt0, rt1, rt1		;;; rt1=1 if call/user overflow
	or	rt1, rt3, rt3		;;; rt3=1 if any
	blbs	rt3, !$1f		;;; br if so
	ret	rzero, (rret)			;;; else return

!$1:	blbc	rt4, checkall_failed	;;; br if no trail overflow
	ldW	rpb, _SVB_OFFS(weakref[prologvar_key] Sys$-Plog$-Area_overflow)(rsvb)
	ldW	rt0, _PD_EXECUTE(rpb)
	jmp	rzero, (rt0)			;;; chain Area_overflow


ASM_ALIGN_QUAD
DEF_C_LAB (_checkall)
	ldW	rt0, _SVB_OFFS(_call_stack_lim)(rsvb)
	ldW	rt1, _SVB_OFFS(_userlim)(rsvb)
	cmpult	rsp, rt0, rt0		;;; rt0=1 if callstack overflow
	cmpult	rusp, rt1, rt1		;;; rt1=1 if userstack overflow
	ldW	rt2, _SVB_OFFS(_trap)(rsvb)		;;; rt2 = 1 if trap
	or	rt0, rt1, rt1		;;; rt1=1 if call/user overflow
	or	rt1, rt2, rt3		;;; rt3=1 if stack overflow or trap
	blbs	rt3, checkall_failed	;;; br if so
	ret	rzero, (rret)			;;; else return

	;;; one or more checks failed
ASM_ALIGN_QUAD
checkall_failed:
	ldW	rt3, _SVB_OFFS(_disable)(rsvb)
	blbc	rt1, !$2f		;;; br if stack checks okay
	;;; stack check failed
	and	rt3, 2, rt1		;;; stack checks disabled?
	bne	rt1, !$1f		;;; br if so to check trap
	ldW	rt2, _SVB_OFFS(Sys$-User_overflow)(rsvb)
	ldW	rpb, _SVB_OFFS(Sys$-Call_overflow)(rsvb)
	cmovlbc	rt0, rt2, rpb		;;; set User_overflow if not call over
	ldW	rt0, _PD_EXECUTE(rpb)
	jmp	rzero, (rt0)			;;; chain overflow procedure
	;;; check for trap when stack checks disabled
!$1:	blbc	rt2, !$3f		;;; return if no trap

	;;; trap pending
!$2:	blbs	rt3, !$3f		;;; return if disabled
	ldW	rpb, _SVB_OFFS(Sys$-Async_raise_signal)(rsvb)
	ldW	rt0, _PD_EXECUTE(rpb)
	jmp	rzero, (rt0)			;;; chain Async_raise_signal
!$3:	ret	rzero, (rret)


ASM_ALIGN_QUAD
DEF_C_LAB (_checkinterrupt)
	ldW	rt0, _SVB_OFFS(_trap)(rsvb)
	blbs	rt0, C_LAB(_checkall)	;;; br if trap pending
	ret	rzero, (rret)			;;; else return


;;; --- CALLING ARBITRARY OBJECTS ----------------------------------------

	;;; applying a poplog object in ARG_REG_0 = rt0
	;;; normal checking entry
ASM_ALIGN_QUAD
DEF_C_LAB (_popenter)
	ldW	rt2, _SVB_OFFS(procedure_key)(rsvb)
	blbs	rt0, !$1f		;;; br if object simple
	ldW	rt1, _KEY(rt0)		;;; key in rt1
	ldW	rt3, _PD_EXECUTE(rt0)
	cmpeq	rt1, rt2, rt2
	blbc	rt2, !$2f		;;; br if non-procedure structure
	mov	rt0, rpb
	jmp	rzero, (rt3)			;;; execute procedure

	;;; applying a simple object. set appropriate key in rt1
ASM_ALIGN_QUAD
!$1:	and	rt0, 2, rt2		;;; test integer tag
	ldW	rt1, _SVB_OFFS(integer_key)(rsvb)	;;; assume integer
	bne	rt2, !$2f		;;; br if so
	ldW	rt1, _SVB_OFFS(weakref decimal_key)(rsvb) ;;; else decimal

	;;; applying a structure -- run key apply procedure
ASM_ALIGN_QUAD
!$2:	ldW	rt1, _K_APPLY(rt1)	;;; K_APPLY ref from key
	lda	rusp, -_WOFFS(rusp)
	ldW	rpb, _RF_CONT(rt1)	;;; apply procedure in ref cont
	stW	rt0, 0(rusp)		;;; stack object
	ldW	rt1, _PD_EXECUTE(rpb)	;;; execute address
	jmp	rzero, (rt1)			;;; run it


	;;; applying an object in ARG_REG_0 = rt0 in update mode
ASM_ALIGN_QUAD
DEF_C_LAB (_popuenter)
	ldW	rt2, _SVB_OFFS(procedure_key)(rsvb)
	blbs	rt0, !$2f		;;; br if object simple
	ldW	rt1, _KEY(rt0)		;;; key in rt1
	ldW	rpb, _PD_UPDATER(rt0)	;;; assume can load updater in pb
	cmpeq	rt1, rt2, rt2		;;; has procedure key?
	blbs	rt2, up_ex_pb		;;; br if so to execute updater

	;;; applying non procedure as updater
	;;; -- run key apply procedure updater (key in rt1)
!$1:	ldW	rt1, _K_APPLY(rt1)	;;; K_APPLY ref from key
	lda	rusp, -_WOFFS(rusp)
	ldW	rt1, _RF_CONT(rt1)	;;; apply procedure in ref cont
	stW	rt0, 0(rusp)		;;; stack object
	ldW	rpb, _PD_UPDATER(rt1)	;;; get updater
	cmpeq	rpb, rfalse, rt1	;;; false?
	blbs	rt1, up_err		;;; br if so
	ldW	rt1, _PD_EXECUTE(rpb)	;;; get updater's execute address
	jmp	rzero, (rt1)			;;; run it

	;;; applying a simple object as updater. set appropriate key in rt1
!$2:	and	rt0, 2, rt2		;;; test integer tag
	ldW	rt1, _SVB_OFFS(integer_key)(rsvb)	;;; assume integer
	bne	rt2, !$1b		;;; br if so
	ldW	rt1, _SVB_OFFS(weakref decimal_key)(rsvb) ;;; else decimal
	br	!$1b

	;;; updater was false
up_err_stack:
	lda	rusp, -_WOFFS(rusp)
	stW	rt0, 0(rusp)		;;; stack object
up_err:
	ldW	rt1, _SVB_OFFS(Sys$-Exec_nonpd)(rsvb)
	ldW	rpb, _PD_UPDATER(rt1)
	ldW	rt1, _PD_EXECUTE(rpb)
	jmp	rzero, (rt1)			;;; run Exec_nonpd updater


	;;; call updater of object in rt0 -- no-checking entry
ASM_ALIGN_QUAD
DEF_C_LAB (_popuncenter)
	ldW	rpb, _PD_UPDATER(rt0)	;;; get updater
up_ex_pb:
	cmpeq	rpb, rfalse, rt1	;;; false?
	blbs	rt1, up_err_stack	;;; br if so
	ldW	rt1, _PD_EXECUTE(rpb)	;;; get updater's execute address
	jmp	rzero, (rt1)			;;; run it


;;; --- CHAINING ROUTINES ---------------------------------------------------

	;;; Unwind the current stack frame, by jumping into the procedure's
	;;; exit code. This subroutine is called immediately after executing
	;;; an M_UNWIND_SF operation, so that the (unwanted) return address
	;;; into the procedure being unwound has been replaced in rret by this
	;;; subroutine's return address.
	;;;	The procedure's exit code finishes with 'ret (rret)', and we
	;;; replace the return address into the NEXT caller with the return
	;;; from this subroutine, but saving the former in rchain, from
	;;; whence it can be restored with an M_CALL_WITH_RETURN operation.
	;;;	Alpha version also saves PB on stack (UNWIND_FRAME_SAVES_PB
	;;; set true by genproc.p)

ASM_ALIGN_QUAD
DEF_C_LAB (_unwind_frame)
	stW	rpb, -_WOFFS(rusp)	     ;;; save rpb on stack
	ldW	rpb, _SF_OWNER(rsp)	     ;;; ensure pb set for current pdr
	lda	rusp, -_WOFFS(rusp)
	ldl	rt1, _PD_FRAME_LEN_l(rpb)    ;;; get longword with frame len
	ldW	rt0, _PD_EXIT(rpb)	     ;;; address of pdr's exit code
	extbl	rt1, _PD_FRAME_LEN_b, rt1  ;;; frame length in words
	sWaddq	rt1, rsp, rt1		     ;;; sp for next caller
	ldW	rchain, _SF_RETURN_ADDR(rt1) ;;; save its return in chain reg
	stW	rret, _SF_RETURN_ADDR(rt1)   ;;; and replace with my return
	jmp	rzero, (rt0)			     ;;; go to current's exit code



	;;; Routines to chain a procedure, either directly or out of the
	;;; current caller. These are executed as a result of displacing a
	;;; stack frame return address with their address and then returning.
	;;; In the case of _syschain and _sysncchain, the displaced return is
	;;; saved in rchain.

ASM_ALIGN_QUAD
DEF_C_LAB (_syschain_caller)
	bsr	rret, C_LAB(_unwind_frame)	;;; pop frame for caller
	lda	rusp, _WOFFS(rusp)		;;; erase saved rpb
DEF_C_LAB (_syschain)
	mov	rchain, rret	;;; reinstate return address from chain reg
	ldW	rt0, 0(rusp)	;;; object to chain on user stack
	lda	rusp, _WOFFS(rusp)
	br	C_LAB(_popenter) ;;; check and run it


	;;; The same, but with no check for procedure

ASM_ALIGN_QUAD
DEF_C_LAB (_sysncchain_caller)
	bsr	rret, C_LAB(_unwind_frame)	;;; pop frame for caller
	lda	rusp, _WOFFS(rusp)		;;; erase saved rpb
DEF_C_LAB (_sysncchain)
	mov	rchain, rret	;;; reinstate return address from chain reg
	ldW	rpb, 0(rusp)	;;; procedure to chain on user stack
	lda	rusp, _WOFFS(rusp)
	ldW	rt0, _PD_EXECUTE(rpb)
	jmp	rzero, (rt0)		;;; run it


;;;---------------------------------------------------------------------------

	;;; erase 1 word from the call stack and chain Callstack_reset
	;;; (used by Callstack_reset in cleaning up)

DEF_C_LAB (_erase_sp_1)
	lda	rsp, _WOFFS(rsp)		;;; chop off a word
	ldW	rpb, _SVB_OFFS(Sys$-Callstack_reset)(rsvb)
	ldW	rt0, _PD_EXECUTE(rpb)
	jmp	rzero, (rt0)				;;; try again


;;;---------------------------------------------------------------------------

	;;;  _nextframe(________sframe) -> ___________nextframe
	;;; get next stack frame from ________sframe

ASM_ALIGN_QUAD
DEF_C_LAB (_nextframe)
	ldW	rt0, 0(rusp)		    ;;; ________sframe
	ldW	rt1, _SF_OWNER(rt0)	    ;;; owner procedure
	ldl	rt1, _PD_FRAME_LEN_l(rt1)   ;;; get word with frame len
	extbl	rt1, _PD_FRAME_LEN_b, rt1 ;;; frame length in words
	sWaddq	rt1, rt0, rt1		    ;;; ________sframe + frame offs = ___________nextframe
	stW	rt1, 0(rusp)		    ;;; return it
	ret	rzero, (rret)


;;;---------------------------------------------------------------------------

	;;; fast routines for subscrs and its updater

	;;; _subss(_________subscript, ______string) -> ____byte

ASM_ALIGN_QUAD
DEF_C_LAB (_subss)
	ldW	rt1, _WOFFS(rusp)	;;; _________subscript
	ldW	rt0, 0(rusp)		;;; ______string
	sra	rt1, _:WORD_SHIFT, rt1 ;;; _________subscript -> sysint
	lda	rt0, _V_BYTES-1(rt0)	;;; adjust addr for base 1 subscript
	addq	rt0, rt1, rt0		;;; ptr to byte
	ldq_u	rt1, 0(rt0)		;;; quadword containing it
	lda	rusp, _WOFFS(rusp)
	extbl	rt1, rt0, rt1		;;; get the byte
	sWaddW	rt1, 3, rt1		;;; convert to popint
	stW	rt1, 0(rusp)		;;; return it
	ret	rzero, (rret)


	;;; ____byte -> _subss(_________subscript, ______string)
	;;; _u_subss(____byte, _________subscript, ______string)

ASM_ALIGN_QUAD
DEF_C_LAB (-> _subss)
DEF_C_LAB (_u_subss)
	ldW	rt1, _WOFFS(rusp)	;;; _________subscript
	ldW	rt0, 0(rusp)		;;; ______string
	sra	rt1, _:WORD_SHIFT, rt1 ;;; _________subscript -> sysint
	lda	rt0, _V_BYTES-1(rt0)	;;; adjust addr for base 1 subscript
	addq	rt0, rt1, rt0		;;; ptr to byte
	ldq_u	rt1, 0(rt0)		;;; quadword containing it
	ldW	rt2, _WOFFS*2(rusp)	;;; ____byte
	lda	rusp, _WOFFS*3(rusp)	;;; remove args
	sra	rt2, _:WORD_SHIFT, rt2 ;;; ____byte -> sysint
	mskbl	rt1, rt0, rt1		;;; clear byte position in quadword
	insbl	rt2, rt0, rt2		;;; shift new byte to position
	or	rt1, rt2, rt1		;;; or in new byte
	stq_u	rt1, 0(rt0)		;;; store the updated quadword
	ret	rzero, (rret)


;;; --- PREDICATES ----------------------------------------------------------

	;;; _not(____item) -> ____bool
ASM_ALIGN_QUAD
DEF_C_LAB (_not)
	ldW	rt0, 0(rusp)
	lda	rt1, _TRUEOFFS(rfalse)
	cmpeq	rt0, rfalse, rt0
	cmovlbc	rt0, rfalse, rt1
	stW	rt1, 0(rusp)
	ret	rzero, (rret)

	;;; _isinteger(____item) -> ____bool
ASM_ALIGN_QUAD
DEF_C_LAB (_isinteger)
	ldW	rt0, 0(rusp)
	lda	rt1, _TRUEOFFS(rfalse)
	and	rt0, 2, rt0
	cmoveq	rt0, rfalse, rt1
	stW	rt1, 0(rusp)
	ret	rzero, (rret)


#_<
define lconstant macro TST_ROUTINE S cmov_op;
lvars cmov_op, S;
[
	ldW \t	  rt0, _0(rusp)		\n
\t	lda \t	  rt1, _TRUEOFFS(rfalse) \n
\t	^cmov_op \t  rt0, rfalse, rt1	\n
\t	stW \t	  rt1, _0(rusp)		\n
\t	ret \t 	  rzero, (rret)		\n
].dl
enddefine;
>_#

	;;; _iscompound(____item) -> ____bool
ASM_ALIGN_QUAD
DEF_C_LAB (_iscompound)
	TST_ROUTINE cmovlbs

	;;; _issimple(____item) -> ____bool
ASM_ALIGN_QUAD
DEF_C_LAB (_issimple)
	TST_ROUTINE cmovlbc

	;;; _zero(_____int) -> ____bool
ASM_ALIGN_QUAD
DEF_C_LAB (_zero)
	TST_ROUTINE cmovne

	;;; _neg(_____int) -> ____bool
ASM_ALIGN_QUAD
DEF_C_LAB (_neg)
	TST_ROUTINE cmovge


#_<
define lconstant macro CMP_ROUTINE S cmp_op S cmov_op;
lvars cmp_op, cmov_op, S;
[
	ldW \t	  rt0, _WOFFS(rusp)	\n
\t	ldW \t	  rt1, _0(rusp)		\n
\t	lda \t	  rusp, _WOFFS(rusp)	\n
\t	lda \t	  rt2, _TRUEOFFS(rfalse) \n
\t	^cmp_op  \t  rt0, rt1, rt0	\n
\t	^cmov_op \t  rt0, rfalse, rt2	\n
\t	stW \t	  rt2, _0(rusp)		\n
\t	ret \t	  rzero, (rret)		\n
].dl
enddefine;
>_#

	;;; ______int1 _bitst ______int2 -> ____bool   (bit test)
ASM_ALIGN_QUAD
DEF_C_LAB 4 (_bitst)
	CMP_ROUTINE and cmoveq

	;;; ______int1 _gr ______int2 -> ____bool   (unsigned greater than)
ASM_ALIGN_QUAD
DEF_C_LAB 6 (_gr)
	CMP_ROUTINE cmpule cmovlbs

	;;; ______int1 _greq ______int2 -> ____bool   (unsigned greater than or equal)
ASM_ALIGN_QUAD
DEF_C_LAB 6 (_greq)
	CMP_ROUTINE cmpult cmovlbs

	;;; ______int1 _lt ______int2 -> ____bool   (unsigned less than)
ASM_ALIGN_QUAD
DEF_C_LAB 6 (_lt)
	CMP_ROUTINE cmpult cmovlbc

	;;; ______int1 _lteq ______int2 -> ____bool   (unsigned less than or equal)
ASM_ALIGN_QUAD
DEF_C_LAB 6 (_lteq)
	CMP_ROUTINE cmpule cmovlbc

	;;; ______int1 _sgr ______int2 -> ____bool   (signed greater than)
ASM_ALIGN_QUAD
DEF_C_LAB 6 (_sgr)
	CMP_ROUTINE cmple cmovlbs

	;;; ______int1 _sgreq ______int2 -> ____bool   (signed greater than or equal)
ASM_ALIGN_QUAD
DEF_C_LAB 6 (_sgreq)
	CMP_ROUTINE cmplt cmovlbs

	;;; ______int1 _slt ______int2 -> ____bool   (signed less than)
ASM_ALIGN_QUAD
DEF_C_LAB 6 (_slt)
	CMP_ROUTINE cmplt cmovlbc

	;;; ______int1 _slteq ______int2 -> ____bool   (signed less than or equal)
ASM_ALIGN_QUAD
DEF_C_LAB 6 (_slteq)
	CMP_ROUTINE cmple cmovlbc

	;;; _____item1 _eq _____item2 -> ____bool
ASM_ALIGN_QUAD
DEF_C_LAB 7 (_eq)
	CMP_ROUTINE cmpeq cmovlbc

	;;; _____item1 _neq _____item2 -> ____bool
ASM_ALIGN_QUAD
DEF_C_LAB 7 (_neq)
	CMP_ROUTINE cmpeq cmovlbs


;;;---------------------------------------------------------------------------

	;;; _haskey(____item, ___key) -> ____bool

ASM_ALIGN_QUAD
DEF_C_LAB (_haskey)
	ldW	rt0, _WOFFS(rusp)	;;; ____item
	ldW	rt1, 0(rusp)		;;; ___key
	lda	rusp, _WOFFS(rusp)
	blbs	rt0, !$1f		;;; false if simple
	ldW	rt2, _KEY(rt0)		;;; else get key
	lda	rt3, _TRUEOFFS(rfalse)
	xor	rt2, rt1, rt0		;;; zero if keys equal
!$1:	cmovne	rt0, rfalse, rt3
	stW	rt3, 0(rusp)
	ret	rzero, (rret)

	;;; _datakey(____item) -> ___key
	;;; get the key of any pop object

ASM_ALIGN_QUAD
DEF_C_LAB (_datakey)
	ldW	rt0, 0(rusp)		;;; ____item
	blbs	rt0, !$1f		;;; br if simple
	ldW	rt0, _KEY(rt0)		;;; else get key
	stW	rt0, 0(rusp)
	ret	rzero, (rret)
!$1:	and	rt0, 2, rt0		;;; integer?
	beq	rt0, !$2f		;;; br if not
	ldW	rt0, _SVB_OFFS(integer_key)(rsvb)
	stW	rt0, 0(rusp)
	ret	rzero, (rret)
!$2:	ldW	rt0, _SVB_OFFS(weakref decimal_key)(rsvb)
	stW	rt0, 0(rusp)
	ret	rzero, (rret)


;;;---------------------------------------------------------------------------

	;;; _conspair(_________frontitem, ________backitem) -> ____pair
	;;; optimise subroutine for "conspair"

ASM_ALIGN_QUAD
DEF_C_LAB (_conspair)
	ldW	rt0, _SVB_OFFS(Sys$- _free_pairs)(rsvb)  ;;; get free pair list
	ldW	rt2, 0(rusp)		    ;;; ________backitem
	blbs	rt0, !$1f		    ;;; none left if simple
	ldW	rt1, _P_BACK(rt0)
	ldW	rt3, _WOFFS(rusp)	    ;;; _________frontitem
	lda	rusp, _WOFFS(rusp)	    ;;; pop stack
	stW	rt1, _SVB_OFFS(Sys$- _free_pairs)(rsvb)  ;;; remove pair from _free_pairs
	stW	rt2, _P_BACK(rt0)	    ;;; assign items into pair
	stW	rt3, _P_FRONT(rt0)
	stW	rt0, 0(rusp)		    ;;; return ____pair
	ret	rzero, (rret)
	;;; no pairs left, chain Conspair
!$1:	ldW	rpb, _SVB_OFFS(Sys$-Conspair)(rsvb)
	ldW	rt0, _PD_EXECUTE(rpb)
	jmp	rzero, (rt0)



ASM_END_FILE
