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

;;; ---------------- USER EXTERNAL CALLS / CALLBACK ----------------------

#_<

#_INCLUDE 'asm.ph'
#_INCLUDE 'external.ph'
#_INCLUDE 'numbers.ph'

vars Sys$-Extern$- _invocation_fp;

lconstant macro (
	_XP_PTR  	= @@XP_PTR,
	_DD_1		= @@DD_1,
	_BGI_LENGTH	= @@BGI_LENGTH,
	_BGI_SLICES	= @@BGI_SLICES,
	_EFC_FUNC	= @@EFC_FUNC,
	_EFC_ARG	= @@EFC_ARG,
	_EFC_ARG_DEST	= @@EFC_ARG_DEST,
	_K_EXTERN_TYPE	= @@K_EXTERN_TYPE,

	;;; Used by _call_external before calling the routine (hence don't
	;;; need to be OS locals)
	rROUT	= rpl0,
	rFROUT	= rpl1,
	rARG0	= rpl2,
	rARG1	= rpl3,
	rSTKA	= rpl4,
	rFBIT	= rpl5,
	rT1	= rpl6,
	rT2	= rpl7,
	);

#_IF WORD_BITS/==DOUBLE_BITS
lconstant macro _DD_2 = @@DD_2;
#_ENDIF

>_#

ASM_START_FILE


ASM_CODE_PSECT


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


	;;;    _call_external(____arg1, ..., ____argN, ___N, _________routine, ___________fltsingle)
	;;;
	;;; Call an external procedure, moving args from userstack
	;;; to stack and converting -- for users. Must be capable of
	;;; dealing with callback.
	;;;    Bit _N set in the _________fltsingle arg says pass the _Nth arg as a
	;;; single float if it's a (d)decimal (otherwise pass (d)decimals
	;;; as doubles). Note that bit 31 governs all args from 32nd onwards
	;;; (i.e. after each arg, _________fltsingle is shifted right _____________algebraically).

	;;; All pop registers are localised by procedures that call this.

ASM_ALIGN_QUAD
DEF_C_LAB (_call_external)
	mflr	R0			;;; get my return
	stW	rsp, _svb_SAVED_SP	;;; save pop caller's stack frame
	stWu	R0, _SF_RETURN_ADDR(rsp);;; save return in normal position
	ldW	rt0, _WOFFS*2(rusp)	;;; arg count ___N in rt0
	rlwinm	rsp, rsp, 0, ~0xf	;;; quadword-align sp
	ldW	rpb, _WOFFS(rusp)	;;; _________routine descriptor
	la	rsp, -_WOFFS*16(rsp)	;;; enough for quad-aligned tmp frame
	ldW	rFBIT, 0(rusp)		;;; ___________fltsingle
	slwi.	R0, rt0, _:WORD_SHIFT	;;; offset of args/test for zero
	la	rusp, _WOFFS*3(rusp)
	add	rusp, rusp, R0		;;; address of after last arg on stack
	mtctr	rt0			;;; ___N into count reg
	stW	rusp, _svb_SAVED_USP	;;; save usp for after call/callback
	bz-	do_call			;;; branch if no args
	bl	first_arg		;;; get address of rout1 in link reg

	;;; Routines to store arg words in rchain, rt7-rt1 (= R3-R10) and
	;;; then successive stack locations. Next single routine is (rROUT),
	;;; double is 4*4(rROUT).
rout1:
	mr	rchain, rARG0		;;; <- single R3
	bdz-	do_call
	la	rROUT, 9*4(rROUT)
	b	arg_loop
	mr	rchain, rARG0		;;; <- double R3, R4
	mr	rt7, rARG1
	bdz-	do_call
	la	rROUT, 9*2*4(rROUT)
	b	arg_loop

	mr	rt7, rARG0		;;; <- single R4
	bdz-	do_call
	la	rROUT, 9*4(rROUT)
	b	arg_loop
	mr	rt7, rARG0		;;; <- double R4, R5
	mr	rt6, rARG1
	bdz-	do_call
	la	rROUT, 9*2*4(rROUT)
	b	arg_loop

	mr	rt6, rARG0		;;; <- single R5
	bdz-	do_call
	la	rROUT, 9*4(rROUT)
	b	arg_loop
	mr	rt6, rARG0		;;; <- double R5, R6
	mr	rt5, rARG1
	bdz-	do_call
	la	rROUT, 9*2*4(rROUT)
	b	arg_loop

	mr	rt5, rARG0		;;; <- single R6
	bdz-	do_call
	la	rROUT, 9*4(rROUT)
	b	arg_loop
	mr	rt5, rARG0		;;; <- double R6, R7
	mr	rt4, rARG1
	bdz-	do_call
	la	rROUT, 9*2*4(rROUT)
	b	arg_loop

	mr	rt4, rARG0		;;; <- single R7
	bdz+	do_call
	la	rROUT, 9*4(rROUT)
	b	arg_loop
	mr	rt4, rARG0		;;; <- double R7, R8
	mr	rt3, rARG1
	bdz+	do_call
	la	rROUT, 9*2*4(rROUT)
	b	arg_loop

	mr	rt3, rARG0		;;; <- single R8
	bdz+	do_call
	la	rROUT, 9*4(rROUT)
	b	arg_loop
	mr	rt3, rARG0		;;; <- double R8, R9
	mr	rt2, rARG1
	bdz+	do_call
	la	rROUT, 9*2*4(rROUT)
	b	arg_loop

	mr	rt2, rARG0		;;; <- single R9
	bdz+	do_call
	la	rROUT, 9*4(rROUT)
	b	arg_loop
	mr	rt2, rARG0		;;; <- double R9, R10
	mr	rt1, rARG1
	bdz+	do_call
	la	rROUT, 9*2*4(rROUT)
	b	arg_loop

	mr	rt1, rARG0		;;; <- single R10
	bdz+	do_call
	la	rROUT, 10*4(rROUT)
	b	arg_loop
	bl	setup_stack		;;; <- double R10, 56(SP)
	mr	rt1, rARG0
	stwu	rARG1, _WOFFS(rSTKA)
	bdz+	do_call
	la	rROUT, 10*4(rROUT)
	b	arg_loop

	bl	setup_stack		;;; <- single first on stack
	stwu	rARG0, _WOFFS(rSTKA)
	bdz+	do_call
	b	arg_loop
	bl	setup_stack		;;; <- double first on stack
	stwu	rARG0, _WOFFS(rSTKA)
	stwu	rARG1, _WOFFS(rSTKA)
	bdz+	do_call
	b	arg_loop

	stwu	rARG0, _WOFFS(rSTKA)	;;; <- single on stack
	bdz+	do_call
	b	arg_loop
	nop
	stwu	rARG0, _WOFFS(rSTKA)	;;; <- double on stack
	stwu	rARG1, _WOFFS(rSTKA)
	bdz+	do_call
	b	arg_loop

	;;; subroutine to set up for stack args
setup_stack:
	;;; allow 2 words of stack space for each remaining arg
	mfctr	rT1			;;; number of remaining args
	slwi	rT1, rT1, 3 		;;; offset of remaining args
	la	rROUT, 9*4(rROUT)	;;; set for last arg routine
	addi	rT1, rT1, 0xf		;;; round up to quad mult
	rlwinm	rT1, rT1, 0, ~0xf
	subfc	rsp, rT1, rsp		;;; decr sp for extra args
	la	rSTKA, _WOFFS*13(rsp)	;;; position of 8th arg word on stack
	blr


	;;; Routines to store first 13 floats in float arg registers
frout1:	fmr	1, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	2, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	3, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	4, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	5, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	6, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	7, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	8, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	9, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	10, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	11, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	12, ft0
	la	rFROUT, 3*4(rFROUT)
	blr
	fmr	13, ft0
	la	rFROUT, 2*4(rFROUT)	;;; 2*4 so next one is just "blr"
	blr


	;;; 1st argument
first_arg:
	mflr	rROUT			;;; get address of first routine rout1
	ldWu	rARG0, -_WOFFS(rusp)	;;; get first arg into rARG0
	la	rFROUT, frout1-rout1(rROUT) ;;; addr of first float routine
	b	arg_loop_1

	;;; loop for 2nd and subsequent args
arg_loop:
	ldWu	rARG0, -_WOFFS(rusp)	;;; get next arg
	srawi	rFBIT, rFBIT, 1		;;; shift down next _________fltsingle bit
	mtlr	rROUT			;;; set next routine

arg_loop_1:
	;;; deal with arg in rARG0
	andi.	R0, rARG0, 1
	bz	La3			;;; branch if structure

	;;; simple
	andi.	R0, rARG0, 2		;;; test integer bit
	bz	La1			;;; branch if decimal
	;;; integer
	srawi	rARG0, rARG0, _:WORD_SHIFT ;;; convert to m/c int
	blr				;;; store single arg in rARG0

	;;; decimal -- pass as double float unless _________fltsingle bit set
La1:	rlwinm	rARG0, rARG0, 0, ~1	;;; clear tag bit on decimal
	mtlr	rFROUT			;;; float reg routine in link reg
#_IF WORD_BITS==DOUBLE_BITS
#_ELSE
	stw	rARG0, -4(rsp)		;;; store in mem
	lfs	ft0, -4(rsp)		;;; reload as single float
	blrl				;;; store in next float arg reg
	andi.	R0, rFBIT, 1		;;; test _________fltsingle bit
	mtlr	rROUT			;;; set next single routine
	bnzlr-				;;; go to it if bit set
	la	rT1, 4*4(rROUT)		;;; address to store double arg
	stfd	ft0, -8(rsp)		;;; image of double in mem
	lwz	rARG0, -8(rsp)		;;; bring image into rARG0,rARG1
	mtlr	rT1
	lwz	rARG1, -4(rsp)
	blr				;;; store those
#_ENDIF

	;;; structure
La3:	ldW	rT1, _KEY(rARG0)	;;; get key
	lbz	rT1, _K_EXTERN_TYPE(rT1) ;;; extern type
	mr.	rT1, rT1		;;; test it
	bzlr				;;; store if EXTERN_TYPE_NORMAL (0)
	;;; not EXTERN_TYPE_NORMAL
	cmplwi	CR0, rT1, _:EXTERN_TYPE_DEREF
	bne	La5			;;; branch if not EXTERN_TYPE_DEREF
	;;; pass word field at pointer (e.g. external pointer)
	ldW	rARG0, 0(rARG0)		;;; dereference it
	blr				;;; store it

La5:	cmplwi	CR0, rT1, _:EXTERN_TYPE_DDEC
	bne	La7			;;; branch if not EXTERN_TYPE_DDEC
	;;; ddecimal -- pass as double float unless _________fltsingle bit set
#_IF WORD_BITS==DOUBLE_BITS
#_ELSE
	lwz	rARG1, _DD_2(rARG0)
	lwz	rARG0, _DD_1(rARG0)
	mtlr	rFROUT			;;; float reg routine in link reg
	stw	rARG1,  -4(rsp)
	stw	rARG0, -8(rsp)
	andi.	R0, rFBIT, 1		;;; test _________fltsingle bit
	lfd	ft0, -8(rsp)		;;; load dfloat to ft0
	bnz-	La6			;;; branch if single
	la	rT1, 4*4(rROUT)		;;; address to store double arg
	blrl				;;; store in next float arg reg
	mtlr	rT1
	blr				;;; store as double arg
	;;; convert double to single
La6:	frsp	ft0, ft0		;;; round to single precision
	stfs	ft0, -4(rsp)		;;; get single in mem
	blrl				;;; store ft0 in next float arg reg
	mtlr	rROUT
	lwz	rARG0, -4(rsp)		;;; get single in rARG0
	blr				;;; store single arg
#_ENDIF

	;;; else must be biginteger (EXTERN_TYPE_BIGINT)
	;;; pass least significant 32 bits
La7:	ldW	rT1, _BGI_LENGTH(rARG0)	;;; number of slices
	lwz	rT2, _BGI_SLICES(rARG0)	;;; ls slice (31 bits) into rT2
	cmplWi	CR0, rT1, 1		;;; only 1 slice?
	beq	La8			;;; just ls slice if so
	lwz	rT1, _BGI_SLICES+4(rARG0) ;;; else next slice into rT1
	slwi	rT1, rT1, 31 		;;; bottom bit upto top
	add	rT2, rT2, rT1		;;; add to ls 31 bits
La8:	mr	rARG0, rT2		;;; with value in rARG0
	blr				;;; store single arg


	;;; args transferred -- call routine
do_call:
	;;; NEXT INSTRUCTION ENABLES ASYNC CALLBACK
	stW	rsp, _svb_IN_USER_EXTERN	;;; any nonzero value

	ldW	rARG0, _svb_INVOC_FP	;;; frame pointer of pop's invoker
	ldW	R0, 0(rpb)		;;; exec address from descriptor
	stW	rtoc, _WOFFS*5(rsp)	;;; save TOC in standard frame
	stW	rARG0, _WOFFS*0(rsp)	;;; and back chain to invocation frame
	mtctr	R0
	ldW	rtoc, _WOFFS(rpb)	;;; set TOC from descriptor
	ldW	R11, _WOFFS*2(rpb)	;;; = R11 (is this necessary?)
	bctrl				;;; execute _________routine

	li	R0, 0
	ldW	rt0, _SVB_OFFS(Sys$-Extern$-result_struct)(rsvb)
	;;; NEXT INSTRUCTION DISABLES ASYNC CALLBACK
	stW	R0, _svb_IN_USER_EXTERN

	;;; restore regs
	ldW	rtoc, _WOFFS*5(rsp)	;;; restore TOC from stack frame
	ldW	rsp, _svb_SAVED_SP	;;; restore pop's sp
	ldW	rusp, _svb_SAVED_USP	;;; restore usp with args removed
	ldW	rt1, _SF_RETURN_ADDR(rsp) ;;; restore my return (could have changed)

	;;; set result_struct with possible float result from
	;;; F1 in first 2 words and possible word result from R3 in last
	stfd	1, 0(rt0)		;;; dfloat result
	stW	rchain, 8(rt0)		;;; word result (= R3)

	mtlr	rt1			;;; return -> link reg
	ldW	rpb, _SF_OWNER(rsp)	;;; restore caller's pb
	stW	R0, _svb_SAVED_SP	;;; says no longer in extern calls
	blr


;;; --- EXTERNAL FUNCTION CLOSURES --------------------------------------

	;;; passed the exfunc_closure in rtoc
	;;; (with args in r3-r10 and on stack)
	;;; assign EFC_ARG to EFC_ARG_DEST and chain EFC_FUNC

ASM_ALIGN_QUAD
DEF_C_LAB(Sys$- _exfunc_clos_action)
	ldW	R11, _EFC_FUNC(rtoc)	;;; exptr to base procedure desc
	ldW	R0, _EFC_ARG(rtoc)	;;; get arg
	ldW	R12, _EFC_ARG_DEST(rtoc);;; get destination address
	ldW	R11, _XP_PTR(R11)	;;; get base desc/exec
	stW	R0, 0(R12)		;;; store arg at destination
	ldW	R0, 0(R11)		;;; exec address from descriptor
	ldW	rtoc, _WOFFS(R11)	;;; set TOC from descriptor
	mtctr	R0
	ldW	R11, _WOFFS*2(R11)	;;; (is this necessary?)
	bctr				;;; chain to exec address



;;; --- INTERFACE ROUTINE FOR EXTERNAL CALLBACK ------------------------------

	;;; C Synopsis:
	;;;
	;;; 	int _pop_external_callback(____argp)
	;;; 	unsigned ____argp[];
	;;;
	;;; (where ____argp[0] is the function code for Callback)

#_IF DEF AIX


	.csect[PR]

.globl ._pop_external_callback
._pop_external_callback:
	mfcr	R0
	mflr	rt0			;;; (= R11)
	stW	R0, _WOFFS*1(rsp)	;;; save condition reg in caller frame
	stW	rt0, _WOFFS*2(rsp)	;;; save link reg in caller frame
	mr	rt0, rsp		;;; save sp

	;;; save AIX local registers (13-31)
	;;; alloc space to save regs plus 4 word dummy stack frame to hold
	;;; SF_NEXT_SEG_SP and SF_NEXT_SEG_HI
	la	rsp, -_WOFFS*23(rsp)
	stW	13, _WOFFS*4(rsp)
	stW	14, _WOFFS*5(rsp)
	stW	15, _WOFFS*6(rsp)
	stW	16, _WOFFS*7(rsp)
	stW	17, _WOFFS*8(rsp)
	stW	18, _WOFFS*9(rsp)
	stW	19, _WOFFS*10(rsp)
	stW	20, _WOFFS*11(rsp)
	stW	21, _WOFFS*12(rsp)
	stW	22, _WOFFS*13(rsp)
	stW	23, _WOFFS*14(rsp)
	stW	24, _WOFFS*15(rsp)
	stW	25, _WOFFS*16(rsp)
	stW	26, _WOFFS*17(rsp)
	stW	27, _WOFFS*18(rsp)
	stW	28, _WOFFS*19(rsp)
	stW	29, _WOFFS*20(rsp)
	stW	30, _WOFFS*21(rsp)
	stW	31, _WOFFS*22(rsp)

	ldW	rsvb, T.special_var_block(rtoc)	;;; recover rsvb

	li	R0, 0
	ldW	rnpl0, _svb_IN_USER_EXTERN  ;;; save this and restore at end
	;;; NEXT INSTRUCTION DISABLES ASYNC CALLBACK
	stW	R0, _svb_IN_USER_EXTERN

	ldW	rfalse, _svb_FALSE
	ldW	rusp, _svb_SAVED_USP	;;; regain saved user sp
	ldW	rpb, T.Callback(rtoc)	;;; get Callback

	INIT_POP_REGISTERS		;;; set pop lvar registers to false

	stWu	rchain, -_WOFFS(rusp)	;;; push ____argp (= R3)
	ldW	rnpl2, _svb_INVOC_FP	;;; save current _invocation_fp
	stWu	R0, -_WOFFS(rusp)	;;; push dummy break diff
	stW	rt0, _svb_INVOC_FP	;;; then make my fp current

	bl	XC_LAB(Sys$-Extern$-Callback)	;;; call Callback

	stW	rnpl2, _svb_INVOC_FP	;;; reset previous _invocation_fp

	ldW	rchain, 0(rusp)		;;; return status (= R3)
	la	rusp, _WOFFS(rusp)
	stW	rusp, _svb_SAVED_USP	;;; resave user sp for _call_external

	;;; NEXT INSTRUCTION ENABLES ASYNC CALLBACK
	stW	rnpl0, _svb_IN_USER_EXTERN  ;;; set back to value on entry

	;;; restore AIX local registers/erase dummy stack frame
	ldW	13, _WOFFS*4(rsp)
	ldW	14, _WOFFS*5(rsp)
	ldW	15, _WOFFS*6(rsp)
	ldW	16, _WOFFS*7(rsp)
	ldW	17, _WOFFS*8(rsp)
	ldW	18, _WOFFS*9(rsp)
	ldW	19, _WOFFS*10(rsp)
	ldW	20, _WOFFS*11(rsp)
	ldW	21, _WOFFS*12(rsp)
	ldW	22, _WOFFS*13(rsp)
	ldW	23, _WOFFS*14(rsp)
	ldW	24, _WOFFS*15(rsp)
	ldW	25, _WOFFS*16(rsp)
	ldW	26, _WOFFS*17(rsp)
	ldW	27, _WOFFS*18(rsp)
	ldW	28, _WOFFS*19(rsp)
	ldW	29, _WOFFS*20(rsp)
	ldW	30, _WOFFS*21(rsp)
	ldW	31, _WOFFS*22(rsp)
	la	rsp, _WOFFS*23(rsp)

	ldW	R0, _WOFFS*1(rsp)	;;; restore condition reg
	ldW	rt0, _WOFFS*2(rsp)	;;; restore link reg
	mtcrf	0xff, R0
	mtlr	rt0
	li	rchain, 0		;;; normal exit status (= R3)
	blr				;;; return

	.toc

T.special_var_block:
	.tc	a1[TC], C_LAB(_special_var_block)
T.Callback:
	.tc	a2[TC], C_LAB(Sys$-Extern$-Callback)

.globl _pop_external_callback[DS]
	.csect	_pop_external_callback[DS]
DEF_C_LAB(Sys$- _external_callback_func)
	.long	._pop_external_callback
	.long	TOC[TC0]
	.long	0x00000000

#_ENDIF

ASM_END_FILE
