/* --- Copyright University of Sussex 1998. All rights reserved. ----------
 * File:            C.power/src/aprolog.s
 * Purpose:
 * Author:          John Gibson, Mar  2 1998
 */

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

;;;	***********************************************
;;;	****         NOTE ASSEMBLER BUG:          *****
;;;	****  (___reg) DOES NOT ASSEMBLE AS 0(___reg)   *****
;;;	***********************************************

#_<

#_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_barrier)(rsvb)
	ldW	rt4, _SVB_OFFS(_plog_trail_sp)(rsvb)	;;; also used later for check
	ldW	rt5, _SVB_OFFS(_plog_next_var)(rsvb)
	subfc	rt0, rt3, rt4			;;; make trail sp relative

	stW	rt1, _SVB_OFFS(_plog_save_contn_sp)(rsvb)	;;; save contn sp
	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	rt1, _SVB_OFFS(_call_stack_lim)(rsvb)
	ldW	rt2, _SVB_OFFS(_userlim)(rsvb)
	cmplW	CR1, rsp, rt1		;;; CR1-lt set if callstack overflow
	ldW	rt3, _SVB_OFFS(_trap)(rsvb)
	cmplW	CR2, rusp, rt2		;;; CR2-lt set if user overflow
	ldW	rt5, _SVB_OFFS(_plog_trail_lim)(rsvb)
	cmplWi	CR3, rt3, 0		;;; CR3-eq set if no trap pending
	cmplW	CR4, rt4, rt5		;;; CR4-lt set if no trail overflow
	cror	CR5*4+Clt, CR1*4+Clt, CR2*4+Clt ;;; CR5-lt set if stack overflow
	crandc	CR6*4+Ceq, CR3*4+Ceq, CR5*4+Clt ;;; CR6-eq set if no trap/overflow
	crand	CR7*4+Ceq, CR6*4+Ceq, CR4*4+Clt ;;; CR7-eq set if that or no trail overflow
	btlr+	CR7*4+Ceq		;;; return if so
	b	C_LAB(_checkplogall)	;;; else 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
	add	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
	subfc.	rt1, rt0, rt1			;;; word offset added to trail
	bzlr					;;; return if none
	srwi	rt1, rt1, _:WORD_SHIFT		;;; as number of words ...
	mtctr	rt1				;;; ... into count reg
	stW	rt0, _SVB_OFFS(_plog_trail_sp)(rsvb)	;;; set new end
	ldW	rt2, 0(rt0)			;;; get first plogvar
	bdz	La2				;;; branch if only one

ASM_ALIGN_QUAD
La1:	stW	rt2, _PGV_CONT(rt2)		;;; put var in its own PGV_CONT
	ldWu	rt2, _WOFFS(rt0)		;;; get next plogvar/step ptr
	bdnz+	La1				;;; loop if more
	;;; last one
La2:	stW	rt2, _PGV_CONT(rt2)		;;; put var in its own PGV_CONT
	blr



	;;; unify against atom. arg in rt0, atom in rt1
	;;; returns "eq" set if unifies, clear if not

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

Lb1:	andi.	R0, rt0, 1
	bnz	Lb2			;;; finished loop if simple
	ldW	rt2, _KEY(rt0)		;;; key of object
	ldW	rt3, _PGV_CONT(rt0)	;;; assume plogvar and get cont
	cmplW	CR0, rt2, rt5		;;; prologvar?
	bne	Lb2			;;; finished loop if not
	cmplW	CR0, rt3, rt0		;;; undefvar (cont equals var)?
	mr	rt0, rt3		;;; replace var with cont
	bne	Lb1			;;; 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
	la	rt2, _WOFFS(rt2)
	stW	rt2, _SVB_OFFS(_plog_trail_sp)(rsvb) ;;; store updated trail ptr
	blr				;;; return (CR0-eq already set)
	;;; dereffed arg, compare with atom
Lb2:	cmplW	CR0, rt0, rt1		;;; return compare result in CR0
	blr


	;;; prolog pair switch -- arg is in rt0
	;;; Returns CR0 set for switch result: "gt" set if undef var, "eq"
	;;; set if pair, both clear otherwise (dereffed arg in rt0 for pair
	;;; case)

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

Lc1:	andi.	R0, rt0, 1
	bne	Lc3			;;; finished loop if simple
	ldW	rt4, _KEY(rt0)		;;; key of object
	ldW	rt3, _PGV_CONT(rt0)	;;; assume plogvar and get cont
	cmplW	CR0, rt4, rt5		;;; prologvar?
	bne	Lc2			;;; finished loop if not
	cmplW	CR0, rt3, rt0		;;; undefvar (cont equals var)?
	mr	rt0, rt3		;;; replace var with cont
	bne	Lc1			;;; loop if not undef for dereffed obj
	;;; undef var -- push it and return CR0-gt set
	stWu	rt0, -_WOFFS(rusp)
	crset	CR0*4+Cgt
	blr
	;;; compound item (key in rt4) -- return "eq" set if a pair,
	;;; clear if not
Lc2:	ldW	rt5, _SVB_OFFS(pair_key)(rsvb)	;;; get pair key
	cmplW	CR0, rt4, rt5		;;; CR0-eq set if a pair ...
	crclr	CR0*4+Cgt		;;; ... with CR0-gt clear
	blr
	;;; not suitable -- return with "gt" and "eq" clear ("eq" already is)
Lc3:	crclr	CR0*4+Cgt		;;; return CR0-gt clear
	blr


	;;; Just like pair_switch but checks functor and length (== arity + 1)
	;;; arg in rt0, functor in rt1, popint length in rt2.
	;;; Returns CR0 set for switch result: "gt" set if undef var, "eq"
	;;; set if matching term, both clear otherwise (dereffed arg in rt0
	;;; for matching term case)

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

Ld1:	andi.	R0, rt0, 1
	bne	Ld3			;;; finished loop if simple
	ldW	rt4, _KEY(rt0)		;;; key of object
	ldW	rt3, _PGV_CONT(rt0)	;;; assume plogvar and get cont
	cmplW	CR0, rt4, rt5		;;; prologvar?
	bne	Ld2			;;; finished loop if not
	cmplW	CR0, rt3, rt0		;;; undefvar (cont equals var)?
	mr	rt0, rt3		;;; replace var with cont
	bne	Ld1			;;; loop if not undef for dereffed obj
	;;; undef var -- push it and return "gt" set
	stWu	rt0, -_WOFFS(rusp)
	crset	CR0*4+Cgt
	blr
	;;; compound item (key in rt4) -- return "eq" set if a suitable term,
	;;; clear if not
Ld2:	ldW	rt5, _SVB_OFFS(prologterm_key)(rsvb) ;;; get prologterm key
	srawi	rt2, rt2, _:WORD_SHIFT	;;; make required length a sysint
	cmplW	CR0, rt4, rt5		;;; prologterm?
	bne	Ld3			;;; branch if not
	;;; (CR0-gt clear at this point)
	ldW	rt3, _PGT_LENGTH(rt0)	;;; get term length
	ldW	rt4, _PGT_FUNCTOR(rt0)	;;; and functor
	cmplW	CR1, rt3, rt2		;;; (required len) cmp len
	cmplW	CR2, rt4, rt1		;;; (required functor) cmp functor
	crand	CR0*4+Ceq, CR1*4+Ceq, CR2*4+Ceq	;;; CR0-eq set if both match
	blr
	;;; not suitable -- return with "gt" and "eq" clear ("eq" already is)
Ld3:	crclr	CR0*4+Cgt		;;; return CR0-gt clear
	blr


	;;; _prolog_assign(_________prologvar, ____item)
ASM_ALIGN_QUAD
DEF_C_LAB (_prolog_assign)
	ldW	rt0, 0(rusp)		;;; ____item into rt0
	la	rusp, _WOFFS(rusp)
	b	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
	andi.	R0, rt0, 1
	bnz	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
	la	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
	la	rt2, _WOFFS(rt2)	;;; step trail sp
	la	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
	blr

	;;; no pairs left, chain this for more
nopair:	ldW	rpb, _SVB_OFFS(Sys$-Plog$-Assign_pair)(rsvb)
	b	XC_LAB(Sys$-Plog$-Assign_pair)


;;; --- 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

Le1:	andi.	R0, rt0, 1
	bnz	Le2			;;; finished if simple
	ldW	rt2, _KEY(rt0)		;;; key of object
	ldW	rt3, _PGV_CONT(rt0)	;;; assume plogvar and get cont
	cmplW	CR0, rt2, rt5		;;; prologvar?
	bne	Le2			;;; finished if not
	cmplW	CR0, rt3, rt0		;;; undefvar (cont equals var)?
	mr	rt0, rt3		;;; replace var with cont
	bne	Le1			;;; loop if not undef for dereffed obj

Le2:	stW	rt0, 0(rusp)		;;; return item
	blr

	;;; _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
	cmplW	CR0, rt2, rt1		;;; end-of-block reference?
	beq	Lf1			;;; branch if so
	stW	rt0, _PGV_CONT(rt0)	;;; make var undef
	stWu	rt0, -_WOFFS(rusp)	;;; return it
	la	rt1, _PGV_SIZE(rt0)	;;; addr of next var in block
	stW	rt1, _SVB_OFFS(_plog_next_var)(rsvb) ;;; update ptr
	blr

	;;; no prologvars left, chain this instead
Lf1:	ldW	rpb, _SVB_OFFS(Sys$-Plog$-New_var)(rsvb)
	b	XC_LAB(Sys$-Plog$-New_var)



ASM_END_FILE
