/* --- Copyright University of Sussex 1989. All rights reserved. ----------
 * File:            C.alpha/src/aprolog.s
 * Purpose:
 * Author:          John Gibson, Sep 20 1994
 */

;;;------------------ ROUTINES FOR PROLOG --------------------------------

#_<

#_INCLUDE 'asm.ph'

constant
	procedure (Sys$-Plog$-Assign_pair, Sys$-Plog$-New_var),
	_checkplogall
	;

vars
	_plog_trail_sp, _plog_next_var, _plog_contn_sp, _plog_contn_top,
	_plog_save_contn_sp, _plog_trail_barrier, _plog_trail_lim,
	_call_stack_lim
	;

lconstant macro (
	_PGV_CONT		= @@PGV_CONT,
	_PGV_SIZE		= @@(struct PLOGVAR)++,
	_PGT_FUNCTOR		= @@PGT_FUNCTOR,
	_PGT_LENGTH		= @@PGT_LENGTH,
	_SF_PLGSV_CONTN_TOP	= @@SF_PLGSV_CONTN_TOP,
	_SF_PLGSV_NEXT_VAR	= @@SF_PLGSV_NEXT_VAR,
	_SF_PLGSV_TRAIL_SP	= @@SF_PLGSV_TRAIL_SP,
	);

>_#


ASM_START_FILE


ASM_CODE_PSECT


;;; --- PROLOG SAVE AND RESTORE -----------------------------------------

	;;; Save the prolog continuation stack, trail and next free var
	;;; in the corresponding saved locations. Then do stack overflow and
	;;; interrupt checks.
ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_save_check)

	;;; save trail end pointer (relative to trail barrier), and
	;;; save continuation stack top and pointer
	;;; _plog_save_contn_sp is a dynamic local (see plogcore.p)

	ldW	rt1, _SVB_OFFS(_plog_contn_sp)(rsvb)
	ldW	rt2, _SVB_OFFS(_plog_contn_top)(rsvb)
	ldW	rt3, _SVB_OFFS(_plog_trail_sp)(rsvb)	;;; also used later for check
	ldW	rt4, _SVB_OFFS(_plog_trail_barrier)(rsvb)
	ldW	rt5, _SVB_OFFS(_plog_next_var)(rsvb)

	stW	rt1, _SVB_OFFS(_plog_save_contn_sp)(rsvb)	;;; save contn sp
	subq	rt3, rt4, rt0			;;; make trail sp relative
	stW	rt2, _SF_PLGSV_CONTN_TOP(rsp)	;;; save contn top
	stW	rt5, _SF_PLGSV_NEXT_VAR(rsp)	;;; save next var
	stW	rt0, _SF_PLGSV_TRAIL_SP(rsp)	;;; save trail sp

	;;; now do trail/stack/interrupt checks
	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:	ldW	rt0, _SVB_OFFS(_checkplogall)(rsvb)
	jmp	rzero, (rt0)			;;; redo checks


	;;; restore the contn stack and next free var from the current
	;;; saved values, and unwind the trail back to the saved position,
	;;; resetting vars to undef
ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_restore)
	;;; restore next var, contn top and pointer
	ldW	rt1, _SVB_OFFS(_plog_save_contn_sp)(rsvb)	;;; saved contn sp
	ldW	rt2, _SF_PLGSV_CONTN_TOP(rsp)	;;; saved contn top
	ldW	rt5, _SF_PLGSV_NEXT_VAR(rsp)	;;; saved next var
	ldW	rt0, _SF_PLGSV_TRAIL_SP(rsp)	;;; saved relative trail sp
	ldW	rt4, _SVB_OFFS(_plog_trail_barrier)(rsvb)

	stW	rt1, _SVB_OFFS(_plog_contn_sp)(rsvb)	;;; restore contn sp
	stW	rt2, _SVB_OFFS(_plog_contn_top)(rsvb)	;;; restore contn top
	ldW	rt1, _SVB_OFFS(_plog_trail_sp)(rsvb)	;;; get current trail sp
	addq	rt0, rt4, rt0			;;; make saved trail sp abs
	stW	rt5, _SVB_OFFS(_plog_next_var)(rsvb)	;;; restore next var

	;;; restore trail end pointer, setting plogvars back to undef
	cmpult	rt0, rt1, rt3			;;; reached end?
	blbc	rt3, !$2f			;;; done if so
	stW	rt0, _SVB_OFFS(_plog_trail_sp)(rsvb)	;;; set new end
	lda	rt0, _WOFFS(rt0)		;;; step ptr initially

ASM_ALIGN_QUAD
!$1:	ldW	rt2, -_WOFFS(rt0)		;;; get next plogvar
	cmpult	rt0, rt1, rt3			;;; reached end?
	lda	rt0, _WOFFS(rt0)		;;; step ptr
	stW	rt2, _PGV_CONT(rt2)		;;; put var into its own PGV_CONT
	blbs	rt3, !$1b			;;; loop if not
!$2:	ret	rzero, (rret)


	;;; unify against atom. arg in rt0, atom in rt1
	;;; returns rt1 set to compare result (1 if unifies, 0 if not)

ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_unify_atom)
	ldW	rt5, _SVB_OFFS(prologvar_key)(rsvb)	;;; get plogvar key

!$1:	blbs	rt0, !$2f		;;; finished loop if simple
	ldW	rt2, _KEY(rt0)		;;; key of object
	ldW	rt3, _PGV_CONT(rt0)	;;; assume plogvar and get cont
	cmpeq	rt2, rt5, rt4		;;; prologvar?
	blbc	rt4, !$2f		;;; finished loop if not
	cmpeq	rt3, rt0, rt2		;;; undefvar (cont equals var)?
	mov	rt3, rt0		;;; replace var with cont
	blbc	rt2, !$1b		;;; loop if not undef for dereffed obj
	;;; undefvar
	ldW	rt2, _SVB_OFFS(_plog_trail_sp)(rsvb) ;;; get trail ptr
	stW	rt1, _PGV_CONT(rt0)	;;; move atom to cont of var
	stW	rt0, 0(rt2)		;;; push var to trail
	lda	rt2, _WOFFS(rt2)
	mov	1, rt1		;;; return bit0 set (i.e. unifies)
	stW	rt2, _SVB_OFFS(_plog_trail_sp)(rsvb) ;;; store updated trail ptr
	ret	rzero, (rret)
	;;; dereffed arg, compare with atom
!$2:	cmpeq	rt0, rt1, rt1		;;; return compare result in bit0
	ret	rzero, (rret)


	;;; prolog pair switch -- arg is in rt0
	;;; returns rt1 set to switch result: -1 if undef var, 0 if not
	;;; pair, 1 if pair (dereffed arg in rt0 for last case)

ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_pair_switch)
	ldW	rt5, _SVB_OFFS(prologvar_key)(rsvb)	;;; get plogvar key

!$1:	blbs	rt0, !$3f		;;; finished loop if simple
	ldW	rt4, _KEY(rt0)		;;; key of object
	ldW	rt3, _PGV_CONT(rt0)	;;; assume plogvar and get cont
	cmpeq	rt4, rt5, rt6		;;; prologvar?
	blbc	rt6, !$2f		;;; finished loop if not
	cmpeq	rt3, rt0, rt4		;;; undefvar (cont equals var)?
	mov	rt3, rt0		;;; replace var with cont
	blbc	rt4, !$1b		;;; loop if not undef for dereffed obj
	;;; undef var -- push it and return -1 result
	stW	rt0, -_WOFFS(rusp)
	lda	rusp, -_WOFFS(rusp)
	lda	rt1, -1(rzero)		;;; return result < 0
	ret	rzero, (rret)
	;;; compound item (key in rt4) -- return 1 if a pair, else 0
!$2:	ldW	rt5, _SVB_OFFS(pair_key)(rsvb)	;;; get pair key
	cmpeq	rt4, rt5, rt1		;;; result 1 if a pair, 0 if not
	ret	rzero, (rret)
	;;; not suitable -- return 0
!$3:	clr	rt1
	ret	rzero, (rret)


	;;; just like pair_switch but checks functor and length (== arity + 1)
	;;; arg in rt0, functor in rt1, popint length in rt2
	;;; returns rt1 set to switch result: -1 if undef var, 0 if not
	;;; matching term, 1 if matching term (dereffed arg in rt0 for last
	;;; case)

ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_term_switch)
	ldW	rt5, _SVB_OFFS(prologvar_key)(rsvb)	;;; get plogvar key

!$1:	blbs	rt0, !$3f		;;; finished loop if simple
	ldW	rt4, _KEY(rt0)		;;; key of object
	ldW	rt3, _PGV_CONT(rt0)	;;; assume plogvar and get cont
	cmpeq	rt4, rt5, rt6		;;; prologvar?
	blbc	rt6, !$2f		;;; finished loop if not
	cmpeq	rt3, rt0, rt4		;;; undefvar (cont equals var)?
	mov	rt3, rt0		;;; replace var with cont
	blbc	rt4, !$1b		;;; loop if not undef for dereffed obj
	;;; undef var -- push it and return -1 result
	stW	rt0, -_WOFFS(rusp)
	lda	rusp, -_WOFFS(rusp)
	lda	rt1, -1(rzero)		;;; return result < 0
	ret	rzero, (rret)
	;;; compound item (key in rt4) -- return 1 if a suitable term, else 0
!$2:	ldW	rt5, _SVB_OFFS(prologterm_key)(rsvb) ;;; get prologterm key
	sra	rt2, _:WORD_SHIFT, rt2 ;;; make required length a sysint
	cmpeq	rt4, rt5, rt6		;;; prologterm?
	blbc	rt6, !$3f		;;; br if not
	ldW	rt3, _PGT_LENGTH(rt0)	;;; get term length
	ldW	rt4, _PGT_FUNCTOR(rt0)	;;; and functor
	cmpeq	rt3, rt2, rt2		;;; (required len) cmp len
	cmpeq	rt4, rt1, rt1		;;; (required functor) cmp functor
	and	rt1, rt2, rt1		;;; 1 if both equal, 0 if not
	ret	rzero, (rret)
	;;; not suitable -- return 0
!$3:	clr	rt1
	ret	rzero, (rret)


	;;; _prolog_assign(_________prologvar, ____item)
ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_assign)
	ldW	rt0, 0(rusp)		;;; ____item into rt0
	lda	rusp, _WOFFS(rusp)
	br	plog_assign

	;;; _prolog_assign_pair(_________prologvar, _________frontitem, ________backitem)
ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_assign_pair)
	ldW	rt0, _SVB_OFFS(Sys$- _free_pairs)(rsvb) ;;; get free pair list
	ldW	rt2, 0(rusp)		;;; ________backitem
	blbs	rt0, nopair		;;; none left if simple
	ldW	rt1, _P_BACK(rt0)
	ldW	rt3, _WOFFS(rusp)	;;; _________frontitem
	stW	rt1, _SVB_OFFS(Sys$- _free_pairs)(rsvb) ;;; remove pair from _free_pairs
	lda	rusp, _WOFFS*2(rusp)	;;; pop stack
	stW	rt2, _P_BACK(rt0)	;;; assign items into pair
	stW	rt3, _P_FRONT(rt0)

	;;; assign item in rt0 to _________prologvar from stack and push on trail
ASM_ALIGN_QUAD
plog_assign:
	ldW	rt2, _SVB_OFFS(_plog_trail_sp)(rsvb) ;;; get trail sp
	ldW	rt1, 0(rusp)		;;; _________prologvar
	lda	rt2, _WOFFS(rt2)	;;; step trail sp
	lda	rusp, _WOFFS(rusp)	;;; pop stack
	stW	rt0, _PGV_CONT(rt1)	;;; assign item to var cont
	stW	rt1, -_WOFFS(rt2)	;;; push on trail
	stW	rt2, _SVB_OFFS(_plog_trail_sp)(rsvb) ;;; update trail sp
	ret	rzero, (rret)

	;;; no pairs left, chain this for more
nopair:	ldW	rpb, _SVB_OFFS(Sys$-Plog$-Assign_pair)(rsvb)
	ldW	rt0, _PD_EXECUTE(rpb)
	jmp	rzero, (rt0)


;;; --- OPTIONAL ASSEMBLER CODE ----------------------------------------------
;;; optional assembler optimised stuff, for code normally in pop.
;;; see bottom of syscomp/sysdefs.p for when these are used
;;; and plogcore.p, plogterms.p for equivalent pop code

	;;; _prolog_deref(____item) -> _____________dereffed_item
	;;; dereference a chain of prolog variables
ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_deref)
	ldW	rt0, 0(rusp)		;;; ____item
	ldW	rt5, _SVB_OFFS(prologvar_key)(rsvb)	;;; get plogvar key

!$1:	blbs	rt0, !$2f		;;; finished if simple
	ldW	rt2, _KEY(rt0)		;;; key of object
	ldW	rt3, _PGV_CONT(rt0)	;;; assume plogvar and get cont
	cmpeq	rt2, rt5, rt4		;;; prologvar?
	blbc	rt4, !$2f		;;; finished if not
	cmpeq	rt3, rt0, rt2		;;; undefvar (cont equals var)?
	mov	rt3, rt0		;;; replace var with cont
	blbc	rt2, !$1b		;;; loop if not undef for dereffed obj
!$2:	stW	rt0, 0(rusp)		;;; return item
	ret	rzero, (rret)

	;;; _prolog_newvar() -> _________prologvar
ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_newvar)
	ldW	rt0, _SVB_OFFS(_plog_next_var)(rsvb) ;;; next var in block
	ldW	rt1, _SVB_OFFS(ref_key)(rsvb)	;;; get ref key
	ldW	rt2, _KEY(rt0)		;;; key from var
	cmpeq	rt2, rt1, rt3		;;; end-of-block reference?
	blbs	rt3, !$1f		;;; br if so
	stW	rt0, _PGV_CONT(rt0)	;;; make var undef
	stW	rt0, -_WOFFS(rusp)	;;; return it
	lda	rt1, _PGV_SIZE(rt0)	;;; addr of next var in block
	lda	rusp, -_WOFFS(rusp)	;;; correct stack
	stW	rt1, _SVB_OFFS(_plog_next_var)(rsvb) ;;; update ptr
	ret	rzero, (rret)

	;;; no prologvars left, chain this instead
!$1:	ldW	rpb, _SVB_OFFS(Sys$-Plog$-New_var)(rsvb)
	ldW	rt0, _PD_EXECUTE(rpb)
	jmp	rzero, (rt0)



ASM_END_FILE
