#define LANGUAGE_ASSEMBLY

#include "sbcl.h"
#include "lispregs.h"
#include "genesis/closure.h"
#include "genesis/fdefn.h"
#include "genesis/simple-fun.h"
#include "genesis/return-pc.h"
#include "genesis/static-symbols.h"
#include "genesis/funcallable-instance.h"

        .level  2.0
        .text

	.import $global$,data
        .import $$dyncall,MILLICODE
	.import foreign_function_call_active,data
	.import current_control_stack_pointer,data
	.import current_control_frame_pointer,data
	.import current_binding_stack_pointer,data
	.import dynamic_space_free_pointer,data
/*	.import return_from_lisp_function,data */


/*
 * Call-into-lisp
 */

	.export call_into_lisp
call_into_lisp:
	.proc
	.callinfo entry_gr=18,save_rp
	.entry
	/* %arg0=function, %arg1=cfp, %arg2=nargs */

        stw     %rp,-0x14(%sr0,%sp)
        stwm    %r3,0x40(%sr0,%sp)
        stw     %r4,-0x3c(%sr0,%sp)
        stw     %r5,-0x38(%sr0,%sp)
        stw     %r6,-0x34(%sr0,%sp)
        stw     %r7,-0x30(%sr0,%sp)
        stw     %r8,-0x2c(%sr0,%sp)
        stw     %r9,-0x28(%sr0,%sp)
        stw     %r10,-0x24(%sr0,%sp)
        stw     %r11,-0x20(%sr0,%sp)
        stw     %r12,-0x1c(%sr0,%sp)
        stw     %r13,-0x18(%sr0,%sp)
        stw     %r14,-0x14(%sr0,%sp)
        stw     %r15,-0x10(%sr0,%sp)
        stw     %r16,-0xc(%sr0,%sp)
        stw     %r17,-0x8(%sr0,%sp)
        stw     %r18,-0x4(%sr0,%sp)

	/* Clear the descriptor regs, moving in args as approporate. */
	copy	%r0,reg_CODE
	copy	%r0,reg_FDEFN
	copy	%arg0,reg_LEXENV
	zdep	%arg2,29,30,reg_NARGS
	copy	%r0,reg_OCFP
	copy	%r0,reg_LRA
	copy	%r0,reg_A0
	copy	%r0,reg_A1
	copy	%r0,reg_A2
	copy	%r0,reg_A3
	copy	%r0,reg_A4
	copy	%r0,reg_A5
	copy	%r0,reg_L0
	copy	%r0,reg_L1
	copy	%r0,reg_L2

	/* Establish NIL. */
	ldil	L%NIL,reg_NULL
	ldo	R%NIL(reg_NULL),reg_NULL

	/* Turn on pseudo-atomic. */
	ldo	4(%r0),reg_ALLOC

	/* No longer in foreign function call land. */
	addil	L%foreign_function_call_active-$global$,%dp
	stw	%r0,R%foreign_function_call_active-$global$(0,%r1)

	/* Load lisp state. */
	addil	L%dynamic_space_free_pointer-$global$,%dp
	ldw	R%dynamic_space_free_pointer-$global$(0,%r1),%r1
	add	reg_ALLOC,%r1,reg_ALLOC
	addil	L%current_binding_stack_pointer-$global$,%dp
	ldw	R%current_binding_stack_pointer-$global$(0,%r1),reg_BSP
	addil	L%current_control_stack_pointer-$global$,%dp
	ldw	R%current_control_stack_pointer-$global$(0,%r1),reg_CSP
	addil	L%current_control_frame_pointer-$global$,%dp
	ldw	R%current_control_frame_pointer-$global$(0,%r1),reg_OCFP
	copy	%arg1,reg_CFP

	/* End of pseudo-atomic. */
	addit,od	-4,reg_ALLOC,reg_ALLOC

	/* Establish lisp arguments. */
	ldw	0(reg_CFP),reg_A0
	ldw	4(reg_CFP),reg_A1
	ldw	8(reg_CFP),reg_A2
	ldw	12(reg_CFP),reg_A3
	ldw	16(reg_CFP),reg_A4
	ldw	20(reg_CFP),reg_A5

	/* Calculate the LRA. */
  ldil  L%lra-RETURN_PC_RETURN_POINT_OFFSET,reg_LRA
  ldo R%lra-RETURN_PC_RETURN_POINT_OFFSET(reg_LRA),reg_LRA

	/* Indirect the closure */
	ldw	CLOSURE_FUN_OFFSET(0,reg_LEXENV),reg_CODE
  addi  SIMPLE_FUN_CODE_OFFSET,reg_CODE,reg_LIP

#ifdef LISP_FEATURE_HPUX
  /*  Get the stub address, ie assembly-routine return-from-lisp */
  addil   L%return_from_lisp_stub-$global$,%dp
  ldw     R%return_from_lisp_stub-$global$(0,%r1),reg_NL0
  be,n  0(%sr5,reg_NL0)
#else
  be,n  0(%sr5,reg_LIP)
#endif

	break	0,0

	.align	8
lra:
  nop /* a few nops because we dont know where we land */
  nop /* the return convention would govern this */
  nop
  nop

	/* Copy CFP (%r4) into someplace else and restore r4. */
	copy	reg_CFP,reg_NL1
  ldw -0x3c(0,%sp),%r4

	/* Copy the return value. */
	copy	reg_A0,%ret0

	/* Turn on pseudo-atomic. */
	addi	4,reg_ALLOC,reg_ALLOC

	/* Store the lisp state. */
	copy	reg_ALLOC,reg_NL0
	depi	0,31,3,reg_NL0
	addil	L%dynamic_space_free_pointer-$global$,%dp
	stw	reg_NL0,R%dynamic_space_free_pointer-$global$(0,%r1)
	addil	L%current_binding_stack_pointer-$global$,%dp
	stw	reg_BSP,R%current_binding_stack_pointer-$global$(0,%r1)
	addil	L%current_control_stack_pointer-$global$,%dp
	stw	reg_CSP,R%current_control_stack_pointer-$global$(0,%r1)
	addil	L%current_control_frame_pointer-$global$,%dp
	stw	reg_NL1,R%current_control_frame_pointer-$global$(0,%r1)

	/* Back in C land.  [CSP is just a handy non-zero value.] */
	addil	L%foreign_function_call_active-$global$,%dp
	stw	reg_CSP,R%foreign_function_call_active-$global$(0,%r1)

	/* Turn off pseudo-atomic and check for traps. */
	addit,od	-4,reg_ALLOC,reg_ALLOC

        ldw     -0x54(%sr0,%sp),%rp
        ldw     -0x4(%sr0,%sp),%r18
        ldw     -0x8(%sr0,%sp),%r17
        ldw     -0xc(%sr0,%sp),%r16
        ldw     -0x10(%sr0,%sp),%r15
        ldw     -0x14(%sr0,%sp),%r14
        ldw     -0x18(%sr0,%sp),%r13
        ldw     -0x1c(%sr0,%sp),%r12
        ldw     -0x20(%sr0,%sp),%r11
        ldw     -0x24(%sr0,%sp),%r10
        ldw     -0x28(%sr0,%sp),%r9
        ldw     -0x2c(%sr0,%sp),%r8
        ldw     -0x30(%sr0,%sp),%r7
        ldw     -0x34(%sr0,%sp),%r6
        ldw     -0x38(%sr0,%sp),%r5
        ldw     -0x3c(%sr0,%sp),%r4
        bv      %r0(%rp)
        ldwm    -0x40(%sr0,%sp),%r3

	/* And thats all. */
	.exit
	.procend


/*
 * Call-into-C
 */

	.export call_into_c
call_into_c:
	/* Set up a lisp stack frame. */
	copy	reg_CFP, reg_OCFP
	copy	reg_CSP, reg_CFP
	addi	32, reg_CSP, reg_CSP
	stw	reg_OCFP, 0(0,reg_CFP) ; save old cfp
	stw	reg_CFP, 4(0,reg_CFP)  ; save old csp
        /* convert raw return PC into a fixnum PC-offset, because we dont
           have ahold of an lra object */
	sub	reg_LIP, reg_CODE, reg_NL5
	addi	3-OTHER_POINTER_LOWTAG, reg_NL5, reg_NL5
	stw	reg_NL5, 8(0,reg_CFP)
	stw	reg_CODE, 0xc(0,reg_CFP)

	/* set pseudo-atomic flag */
	addi	4, reg_ALLOC, reg_ALLOC

	/* Store the lisp state. */
	copy	reg_ALLOC,reg_NL5
	depi	0,31,3,reg_NL5
	addil	L%dynamic_space_free_pointer-$global$,%dp
	stw	reg_NL5,R%dynamic_space_free_pointer-$global$(0,%r1)
	addil	L%current_binding_stack_pointer-$global$,%dp
	stw	reg_BSP,R%current_binding_stack_pointer-$global$(0,%r1)
	addil	L%current_control_stack_pointer-$global$,%dp
	stw	reg_CSP,R%current_control_stack_pointer-$global$(0,%r1)
	addil	L%current_control_frame_pointer-$global$,%dp
	stw	reg_CFP,R%current_control_frame_pointer-$global$(0,%r1)

	/* Back in C land.  [CSP is just a handy non-zero value.] */
	addil	L%foreign_function_call_active-$global$,%dp
	stw	reg_CSP,R%foreign_function_call_active-$global$(0,%r1)

	/* Turn off pseudo-atomic and check for traps. */
	addit,od	-4,reg_ALLOC,reg_ALLOC

	/* in order to be able to call incrementally linked (ld -A) functions,
	   we have to do some mild trickery here */
        copy reg_CFUNC, %r22
        bl      $$dyncall,%r31
        copy    %r31, %r2
call_into_c_return:
	/* Clear the callee saves descriptor regs. */
	copy	%r0, reg_A5
	copy	%r0, reg_L0
	copy	%r0, reg_L1
	copy	%r0, reg_L2

	/* Turn on pseudo-atomic. */
	ldi	4, reg_ALLOC

	/* Turn off foreign function call. */
	addil	L%foreign_function_call_active-$global$,%dp
	stw	%r0,R%foreign_function_call_active-$global$(0,%r1)

	/* Load ALLOC. */
	addil	L%dynamic_space_free_pointer-$global$,%dp
	ldw	R%dynamic_space_free_pointer-$global$(0,%r1),%r1
	add	reg_ALLOC,%r1,reg_ALLOC

	/* We don't need to load OCFP, CFP, CSP, or BSP because they are
	 * in caller saves registers.
	 */

	/* End of pseudo-atomic. */
	addit,od	-4,reg_ALLOC,reg_ALLOC

	/* Restore CODE.  Even though it is in a callee saves register
	 * it might have been GC'ed.
	 */
	ldw	0xc(0,reg_CFP), reg_CODE

	/* Restore the return pc. */
	ldw	8(0,reg_CFP), reg_NL0
	addi	OTHER_POINTER_LOWTAG-3, reg_NL0, reg_NL0
/*
	addi	-3, reg_NL0, reg_NL0
        ldi OTHER_POINTER_LOWTAG, reg_NL1
	sub	reg_NL0, reg_NL1, reg_NL0
*/
	add	reg_CODE, reg_NL0, reg_LIP

	/* Pop the lisp stack frame, and back we go. */
	ldw	4(0,reg_CFP), reg_CSP
	ldw	0(0,reg_CFP), reg_OCFP
	copy	reg_OCFP, reg_CFP
	be	0(5,reg_LIP)
        nop


/*
 * Stuff to sanctify a block of memory for execution.
 * FIX why does this code work: parisc2.0 guide tells
 * us that we should add an sync after fdc and fic and
 * then let seven nops be executed before executing the
 * sanctified code.
 */


	.EXPORT sanctify_for_execution
sanctify_for_execution:
	.proc
	.callinfo
	.entry
	/* %arg0=start addr, %arg1=length in bytes */
	add	%arg0,%arg1,%arg1
	ldo	-1(%arg1),%arg1
	depi	0,31,5,%arg0
	depi	0,31,5,%arg1
	ldsid	(%arg0),%r1
	mtsp	%r1,%sr1
	ldi	32,%r1			; bytes per cache line
sanctify_loop:
	fdc	0(%sr1,%arg0)
	comb,<	%arg0,%arg1,sanctify_loop
	fic,m	%r1(%sr1,%arg0)

	bv	%r0(%rp)
	nop

	.exit
	.procend


/*
 * Core saving/restoring support
 */

	.export call_on_stack
call_on_stack:
	/* %arg0 = fn to invoke, %arg1 = new stack base */

	/* Compute the new stack pointer. */
	addi	64,%arg1,%sp

	/* Zero out the previous stack pointer. */
	stw	%r0,-4(0,%sp)

	/* Invoke the function. */
	ble	0(4,%arg0)
	copy	%r31, %r2

	/* Flame out. */
	break	0,0

	.export	save_state
save_state:
	.proc
	.callinfo entry_gr=18,entry_fr=21,save_rp,calls
	.entry

	stw	%rp,-0x14(%sr0,%sp)
	fstds,ma	%fr12,8(%sr0,%sp)
	fstds,ma	%fr13,8(%sr0,%sp)
	fstds,ma	%fr14,8(%sr0,%sp)
	fstds,ma	%fr15,8(%sr0,%sp)
	fstds,ma	%fr16,8(%sr0,%sp)
	fstds,ma	%fr17,8(%sr0,%sp)
	fstds,ma	%fr18,8(%sr0,%sp)
	fstds,ma	%fr19,8(%sr0,%sp)
	fstds,ma	%fr20,8(%sr0,%sp)
	fstds,ma	%fr21,8(%sr0,%sp)
	stwm	%r3,0x70(%sr0,%sp)
	stw	%r4,-0x6c(%sr0,%sp)
	stw	%r5,-0x68(%sr0,%sp)
	stw	%r6,-0x64(%sr0,%sp)
	stw	%r7,-0x60(%sr0,%sp)
	stw	%r8,-0x5c(%sr0,%sp)
	stw	%r9,-0x58(%sr0,%sp)
	stw	%r10,-0x54(%sr0,%sp)
	stw	%r11,-0x50(%sr0,%sp)
	stw	%r12,-0x4c(%sr0,%sp)
	stw	%r13,-0x48(%sr0,%sp)
	stw	%r14,-0x44(%sr0,%sp)
	stw	%r15,-0x40(%sr0,%sp)
	stw	%r16,-0x3c(%sr0,%sp)
	stw	%r17,-0x38(%sr0,%sp)
	stw	%r18,-0x34(%sr0,%sp)


	/* Remember the function we want to invoke */
	copy	%arg0,%r19

	/* Pass the new stack pointer in as %arg0 */
	copy	%sp,%arg0

	/* Leave %arg1 as %arg1. */

	/* do the call. */
	ble	0(4,%r19)
	copy	%r31, %r2

	.export _restore_state
_restore_state:

	ldw	-0xd4(%sr0,%sp),%rp
	ldw	-0x34(%sr0,%sp),%r18
	ldw	-0x38(%sr0,%sp),%r17
	ldw	-0x3c(%sr0,%sp),%r16
	ldw	-0x40(%sr0,%sp),%r15
	ldw	-0x44(%sr0,%sp),%r14
	ldw	-0x48(%sr0,%sp),%r13
	ldw	-0x4c(%sr0,%sp),%r12
	ldw	-0x50(%sr0,%sp),%r11
	ldw	-0x54(%sr0,%sp),%r10
	ldw	-0x58(%sr0,%sp),%r9
	ldw	-0x5c(%sr0,%sp),%r8
	ldw	-0x60(%sr0,%sp),%r7
	ldw	-0x64(%sr0,%sp),%r6
	ldw	-0x68(%sr0,%sp),%r5
	ldw	-0x6c(%sr0,%sp),%r4
	ldwm	-0x70(%sr0,%sp),%r3
	fldds,mb	-8(%sr0,%sp),%fr21
	fldds,mb	-8(%sr0,%sp),%fr20
	fldds,mb	-8(%sr0,%sp),%fr19
	fldds,mb	-8(%sr0,%sp),%fr18
	fldds,mb	-8(%sr0,%sp),%fr17
	fldds,mb	-8(%sr0,%sp),%fr16
	fldds,mb	-8(%sr0,%sp),%fr15
	fldds,mb	-8(%sr0,%sp),%fr14
	fldds,mb	-8(%sr0,%sp),%fr13
	bv	%r0(%rp)
	fldds,mb	-8(%sr0,%sp),%fr12


	.exit
	.procend

	.export	restore_state
restore_state:
	.proc
	.callinfo
	copy	%arg0,%sp
	b	_restore_state
	copy	%arg1,%ret0
	.procend



/* FIX, add support for singlestep
	break	trap_SingleStepBreakpoint,0
	break	trap_SingleStepBreakpoint,0
*/
	.export SingleStepTraps
SingleStepTraps:

/* Missing !! NOT
	there's a break 0,0 in the new version here!!!
*/

/*
 * For an explanation of the magic involved in function-end
 * breakpoints, see the implementation in ppc-assem.S.
 */

	.align	8
	.export fun_end_breakpoint_guts
fun_end_breakpoint_guts:
	.word	RETURN_PC_HEADER_WIDETAG + 0x600
	/* multiple value return point -- just jump to trap. */
	b,n	fun_end_breakpoint_trap
	/* single value return point -- convert to multiple w/ n=1 */
	copy	reg_CSP, reg_OCFP
	addi	4, reg_CSP, reg_CSP
	addi	4, %r0, reg_NARGS
	copy	reg_NULL, reg_A1
	copy	reg_NULL, reg_A2
	copy	reg_NULL, reg_A3
	copy	reg_NULL, reg_A4
	copy	reg_NULL, reg_A5

	.export	fun_end_breakpoint_trap
fun_end_breakpoint_trap:
	break	trap_FunEndBreakpoint,0
	b,n	fun_end_breakpoint_trap

	.export	fun_end_breakpoint_end
fun_end_breakpoint_end:

/* FIX-lav: these are found in assem-rtns.lisp too, but
   genesis.lisp has problem referencing them, so we keep
   these old versions too.  Lisp code cant jump to them
   because it is an inter space jump but lisp do intra
   space jumps */

	.align	8
        .EXPORT closure_tramp
closure_tramp:
        /* reg_FDEFN holds the fdefn object. */
        ldw     FDEFN_FUN_OFFSET(0,reg_FDEFN),reg_LEXENV
        ldw     CLOSURE_FUN_OFFSET(0,reg_LEXENV),reg_L0
        addi    SIMPLE_FUN_CODE_OFFSET, reg_L0, reg_LIP
        bv,n    0(reg_LIP)

	.align	8
        .EXPORT undefined_tramp
undefined_tramp:
        break   trap_Error,0
        .byte   4
        .byte   UNDEFINED_FUN_ERROR
        .byte   254
        .byte   (0x20 + sc_DescriptorReg)
        .byte   1
        .align  4

