/* --- Copyright University of Sussex 1994. All rights reserved. ----------
 * File:            S.axpvms/src/aextern.s
 * Purpose:
 * Author:          John Gibson, Oct 14 1994
 */

	.title	"aextern.o"	;;; must be the object file name

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

#_<

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

lconstant macro (
	_XP_PTR  	= @@XP_PTR,
	_DD_1		= @@DD_1,
	_DD_2		= @@DD_2,
	_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_l, _K_EXTERN_TYPE_b) = FIELD_lb(@@K_EXTERN_TYPE),

	;;; Used by _call_external
	rSAVSP	= rpl6,
	rROUT	= rpl5,
	rARGC	= rpl4,
	rSTKA	= rpl3,
	rFBIT	= rfalse,
	);

>_#


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).

	.align quad
DEF_C_LAB (_call_external)
	stl	sp, _svb_SAVED_SP	;;; save pop caller's stack frame
	lda	sp, -20(sp)		;;; and push return address
	stl	rret, 16(sp)		;;; in normal SF_RETURN_ADDR position
	mov	sp, rSAVSP		;;; save sp to restore after call
	bic	sp, #15, sp		;;; then octaword-align sp

	;;; use pop local regs to save things across the call
	mov	rsvb,   rpl10		;;; save special var block
	mov	rnpl0,  rpl9		;;; save 'unoffical' local (r20)
	mov	rnpl1,  rpl8		;;;  "        "        "   (r21)
	mov	rfalse, rpl7		;;; save rfalse

	ldl	rARGC, 8(rusp)		;;; arg count ___N in rARGC
	ldl	rpb, 4(rusp)		;;; _________routine descriptor
	ldl	rFBIT, (rusp)		;;; ___________fltsingle
	lda	rusp, 12(rusp)
	mov	rARGC, r25		;;; arg count ___N in AI reg r25
	s4addl	rARGC, rusp, rusp	;;; address of after last arg on stack
	mov	sp, rSTKA		;;; place to store floats
	stl	rusp, _svb_SAVED_USP	;;; save usp for after call/callback
	ldq	rret, 8(rpb)		;;; exec address of _________routine

	beq	rARGC, do_call		;;; br if no args
	ldl	rt0, -4(rusp)		;;; else get first arg into rt0

	.begin_exact
	br	rROUT, first_arg	;;; get addr of first routine in rROUT

	;;; Routines to store args in r/f16 - r/f21 and then successive stack
	;;; locations. Next integer routine address is (rROUT), single float
	;;; is 4*4(rROUT), double float is 8*4(rROUT)

	mov	rt0, r16		;;; 4 instructions for int arg
	beq	rARGC, do_call		;;; br if no args
	br	arg_loop
	nop

	fmov	f0, f16			;;; 4 instructions for single float
	lda	r25, ^X100(r25)		;;; 1<<8 (1 = AI$K_ARG_FF, F float in reg)
	beq	rARGC, do_call
	br	arg_loop

	fmov	f0, f16			;;; 5 instructions for double float
	lda	r25, ^X300(r25)		;;; 3<<8 (3 = AI$K_ARG_FG, G float in reg)
	beq	rARGC, do_call
	br	arg_loop
	nop
;;;
	mov	rt0, r17
	beq	rARGC, do_call
	br	arg_loop
	nop

	fmov	f0, f17
	lda	r25, ^X800(r25)		;;; 1<<11
	beq	rARGC, do_call
	br	arg_loop

	fmov	f0, f17
	lda	r25, ^X1800(r25)	;;; 3<<11
	beq	rARGC, do_call
	br	arg_loop
	nop
;;;
	mov	rt0, r18
	beq	rARGC, do_call
	br	arg_loop
	nop

	fmov	f0, f18
	lda	r25, ^X4000(r25)	;;; 1<<14
	beq	rARGC, do_call
	br	arg_loop

	fmov	f0, f18
	lda	r25, -^X4000(r25)	;;; 3<<14 + -1<<16
	ldah	r25, 1(r25)		;;; cancel out -1<<16 on last
	beq	rARGC, do_call
	br	arg_loop
;;;
	mov	rt0, r19
	beq	rARGC, do_call
	br	arg_loop
	nop

	fmov	f0, f19
	ldah	r25, ^X2(r25)		;;; 1<<17
	beq	rARGC, do_call
	br	arg_loop

	fmov	f0, f19
	ldah	r25, ^X6(r25)		;;; 3<<17
	beq	rARGC, do_call
	br	arg_loop
	nop
;;;
	mov	rt0, r20
	beq	rARGC, do_call
	br	arg_loop
	nop

	fmov	f0, f20
	ldah	r25, ^X10(r25)		;;; 1<<20
	beq	rARGC, do_call
	br	arg_loop

	fmov	f0, f20
	ldah	r25, ^X30(r25)		;;; 3<<20
	beq	rARGC, do_call
	br	arg_loop
	nop
;;;
	mov	rt0, r21
	beq	rARGC, do_call
	br	setup_stack
	nop

	fmov	f0, f21
	ldah	r25, ^X80(r25)		;;; 1<<23
	beq	rARGC, do_call
	br	setup_stack

	fmov	f0, f21
	ldah	r25, ^X180(r25)		;;; 3<<23
	beq	rARGC, do_call
	br	setup_stack
	nop
;;;
	stq	rt0, (rSTKA)
	beq	rARGC, do_call
	lda	rSTKA, 8(rSTKA)
	br	arg_loop_stack

	stf	f0, (rSTKA)
	beq	rARGC, do_call
	lda	rSTKA, 8(rSTKA)
	br	arg_loop_stack

	stg	f0, (rSTKA)
	beq	rARGC, do_call
	lda	rSTKA, 8(rSTKA)
	br	arg_loop_stack

	.end_exact



	;;; set up stack args -- alloc octa-aligned space on stack
	;;; (enough for 2 args already there)
setup_stack:
	bic	rARGC, #1, rt1		;;; round remaining number down to even
	sll	rt1, #3, rt1		;;; make quad offset
	subl	sp, rt1, sp		;;; alloc stack space
	mov	sp, rSTKA		;;; work up stack using rSTKA

	;;; loops for 2nd and subsequent args
arg_loop:
	lda	rROUT, 13*4(rROUT)	;;; next store routine
arg_loop_stack:
	ldl	rt0, -4(rusp)		;;; get next arg
	sra	rFBIT, #1, rFBIT	;;; shift down next _________fltsingle bit

first_arg:
	subl	rARGC, #1, rARGC	;;; decrement arg count

	;;; deal with arg in rt0

	blbc	rt0, 2$			;;; br if structure

	;;; simple
	and	rt0, #2, rt1		;;; test integer bit
	lda	rusp, -4(rusp)		;;; step arg ptr
	beq	rt1, 1$			;;; br if decimal
	;;; integer
	sra	rt0, #2, rt0		;;; convert to m/c int
	jmp	(rROUT)			;;; store non-float arg in rt0

	;;; decimal -- pass as double float unless _________fltsingle bit set
1$:	bic	rt0, #1, rt0		;;; clear tag bit on decimal
	extwl	rt0, #2, rt1		;;; hi 16-bits -> lo
	lda	rt2, 4*4(rROUT)		;;; address to store single float arg
	inswl	rt0, #2, rt0		;;; lo 16-bits -> hi
	or	rt0, rt1, rt0		;;; or to make F float
	lda	rt1, 8*4(rROUT)		;;; address to store double float arg
	cmovlbs	rFBIT, rt2, rt1		;;; 4*4(rROUT) if _________fltsingle bit
	stl	rt0, (rSTKA)		;;; store in mem
	ldf	f0, (rSTKA)		;;; reload as float
	jmp	(rt1)			;;; store float arg in f0

	;;; structure
2$:	ldl	rt1, _KEY(rt0)		;;; get key
	lda	rusp, -4(rusp)		;;; step arg ptr
	ldl	rt1, _K_EXTERN_TYPE_l(rt1)	;;; word with type
	extbl	rt1, #_K_EXTERN_TYPE_b, rt1	;;; extern type
	bne	rt1, 3$			;;; br if not EXTERN_TYPE_NORMAL (0)
	;;; ordinary structure -- just pass pointer
	jmp	(rROUT)			;;; store non-float arg in rt0

3$:	cmpeq	rt1, #_:EXTERN_TYPE_DEREF, rt2
	blbc	rt2, 4$			;;; br if not EXTERN_TYPE_DEREF
	;;; pass word field at pointer (e.g. external pointer)
	ldl	rt0, (rt0)		;;; dereference it
	jmp	(rROUT)			;;; store non-float arg in rt0

4$:	cmpeq	rt1, #_:EXTERN_TYPE_DDEC, rt2
	blbc	rt2, 6$			;;; br if not EXTERN_TYPE_DDEC
	;;; decimal -- pass as double float unless _________fltsingle bit set
	ldl	rt1, _DD_1(rt0)
	ldl	rt0, _DD_2(rt0)
	stl	rt1,  (rSTKA)
	stl	rt0, 4(rSTKA)
	ldg	f0, (rSTKA)		;;; load to float reg
	lda	rt1, 8*4(rROUT)		;;; address to store double float arg
	blbc	rFBIT, 5$		;;; br if _________fltsingle bit clear
	;;; convert double to single
	lda	rt1, 4*4(rROUT)		;;; routine to store single float arg
	cvtgf	f0, f0			;;; checks G float okay as F float
5$:	jmp	(rt1)			;;; store it

	;;; else must be biginteger (EXTERN_TYPE_BIGINT)
	;;; pass least significant 32 bits
6$:	ldl	rt1, _BGI_LENGTH(rt0)	;;; number of slices
	ldl	rt2, _BGI_SLICES(rt0)	;;; get ls slice
	cmpeq	rt1, #1, rt1		;;; only 1 slice?
	blbs	rt1, 7$			;;; just ls slice if so
	ldl	rt1, _BGI_SLICES+4(rt0)	;;; else get next slice
	sll	rt1, #31, rt1		;;; shift up
	addl	rt1, rt2, rt2		;;; add ls bits
7$:	mov	rt2, rt0
	jmp	(rROUT)			;;; store non-float arg in rt0


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

	jsr	rret, (rret)		;;; the call

call_extern_unwind_return:
	mov	rpl10, rsvb		;;; restore special var block
	;;; NEXT INSTRUCTION DISABLES ASYNC CALLBACK
	stl	rzero, _svb_IN_USER_EXTERN

	;;; restore regs
	ldl	rret, 16(rSAVSP)	;;; restore return address
	lda	sp, 20(rSAVSP)		;;; restore caller's frame

	mov	rpl9,  rnpl0		;;; restore 'unoffical' local (r20)
	mov	rpl8,  rnpl1		;;;     "        "        "   (r21)
	mov	rpl7,  rfalse		;;; restore rfalse

	;;; set _result_struct with possible float result from
	;;; f0 in first 2 words and possible word result from r0 in last
	ldl	rt1, _SVB_OFFS(Sys$-Extern$- _result_struct)(rsvb)
	ldl	rusp, _svb_SAVED_USP	;;; usp with args removed
	stg	f0, (rt1)		;;; float result
	stl	rt0, 8(rt1)		;;; word result

	ldl	rpb, _SF_OWNER(sp)	;;; restore caller's pb
	stl	rzero, _svb_SAVED_SP	;;; says no longer in extern calls
	ret	(rret)


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

	;;; passed procedure descriptor (= exfunc_closure) in rpb
	;;; (with args in r16-r21, r25 and on stack)
	;;; assign EFC_ARG to EFC_ARG_DEST and chain EFC_FUNC

	.align quad
DEF_C_LAB(Sys$- _exfunc_clos_action)
	ldl	rt0, _EFC_FUNC(rpb)	;;; exptr to base procedure desc
	ldl	rt1, _EFC_ARG(rpb)	;;; get arg
	ldl	rt2, _EFC_ARG_DEST(rpb)	;;; get destination address
	ldl	rpb, _XP_PTR(rt0)	;;; replace rpb with base desc
	stl	rt1, (rt2)		;;; store arg at destination
	ldq     rt0, 8(rpb)		;;; get entry point
	jmp	(rt0)			;;; chain to it


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

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

$ROUTINE _pop_external_callback, -
	KIND = stack, -
	SAVED_REGS = <r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13,r14,r15,fp>, -
	HANDLER = _pop_errsig_handler

	$LINKAGE_SECTION
pifadr:	.long	__pop_invocation_fp
svbadr: .long	C_LAB(_special_var_block)
ecbadr:	.long	C_LAB(Sys$-Extern$-Callback)
uwradr:	.long	call_extern_unwind_return
guwadr:	.long	sys$goto_unwind

	$CODE_SECTION
	.base	rpb, $LS

	ldl	rsvb, svbadr		;;; recover rusp

	;;; 4 word dummy stack frame to hold SF_NEXT_SEG_SP and SF_NEXT_SEG_HI
	lda	sp, -4*4(sp)

	ldl	rnpl0, _svb_IN_USER_EXTERN  ;;; save this and restore at end
	;;; NEXT INSTRUCTION DISABLES ASYNC CALLBACK
	stl	rzero, _svb_IN_USER_EXTERN

	ldl	rnpl1, pifadr		;;; address of __pop_invocation_fp
	ldl	rfalse, _svb_FALSE
	ldl	rusp, _svb_SAVED_USP	;;; regain saved user sp
	ldl	rpb, ecbadr		;;; get Callback (clobbers .base)

	INIT_POP_REGISTERS		;;; set pop lvar registers to false

	ldl	r0, _PD_EXECUTE(rpb)	;;; exec addr of Callback
	stl	r16, -4(rusp)		;;; push ____argp
	stl	rzero, -8(rusp)		;;; push dummy break diff
	lda	rusp, -8(rusp)

	ldl	rnpl2, (rnpl1)		;;; save current __pop_invocation_fp
	stl	fp, (rnpl1)		;;; then make my fp current

	jsr	rret, (r0)		;;; call Callback

	stl	rnpl2, (rnpl1)		;;; reset previous __pop_invocation_fp

	ldl	r0, (rusp)		;;; return status
	lda	rusp, 4(rusp)
	stl	rusp, _svb_SAVED_USP	;;; resave user sp for _call_external

	bge	r0, 1$			;;; normal return if status >= 0

	;;; negative return means unwind the external calls and return to
	;;; _call_external (whose return is frigged to continue the
	;;; abnormal exit)
	ldl	rpb, (fp)		;;; restore my .base
	sll	rnpl2, #1, r16		;;; create handle for __pop_invocation_fp
	bis	r16, #^X1F, r16
	stl	r16, (sp)
	mov	sp, r16			;;; pointer to handle
	lda	r17, uwradr		;;; new PC = call_extern_unwind_return
	clr	r18			;;; zero 3rd and 4th args
	clr	r19
	mov	#4, r25			;;; = 4 args
	ldl	rpb, guwadr		;;; sys$goto_unwind pdr desc
	ldq	r0, 8(rpb)		;;; exec addr
	jsr	rret, (r0)		;;; unwind

	;;; NEXT INSTRUCTION ENABLES ASYNC CALLBACK
1$:	stl	rnpl0, _svb_IN_USER_EXTERN  ;;; set back to value on entry

	$RETURN				;;; return into external code
$END_ROUTINE


	;;; for indirect weak reference
SET_C_LAB(Sys$- _external_callback_func) = _pop_external_callback


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

	.psect pop$nosrdata,noshr,noexe,wrt,quad

	;;; 3 word struct for result from _call_external
	.align quad
DEF_C_LAB(Sys$-Extern$- _result_struct)
	.blkl	3




	.end