%/****************************************************************
%*								*
\section[adr-performIO]{PerformIO --- part of the Foreign Language Extension}
%*								*
%****************************************************************/

The following is heavily based on code in
@runtime/main/StgStartup.lhc@.

\begin{code}
#ifndef PAR

#define MAIN_REG_MAP	    /* STG world */
#include "rtsdefs.h"
\end{code}

\begin{code}
#if 0
I_ CStackDelta;
#endif
W_ SAVE_esp;

STGFUN(stopPerformIODirectReturn)
{
    FUNBEGIN;

    /* The final exit.

       The top-top-level closures (e.g., "main") are of type "PrimIO ()".
       When entered, they perform an IO action and return a () --
       essentially, TagReg is set to 1.  Here, we don't need to do
       anything with that.

       We just tidy up the register stuff (real regs in *_SAVE, then 
       *_SAVE -> smInfo locs).

    */

    /* Pop off saved C stack pointer */
#if defined(CONCURRENT) && defined(i386_TARGET_ARCH)
    SAVE_esp = (W_)*SpB;
    SpB = SpB - 1;
#endif

#if defined(__STG_GCC_REGS__)
    SaveAllStgRegs();	/* inline! */
#else
    SAVE_Hp    = Hp;
    SAVE_HpLim = HpLim;
#endif

    /* Grimily restore C stack pointer */
#if defined(CONCURRENT) && defined(i386_TARGET_ARCH)
    __asm__ volatile ("mov %0,%%esp" : "m=" (SAVE_esp));
#endif

    RESUME_(miniInterpretEnd);
    FUNEND;
}

/*
   NB: For direct returns to work properly, the name of the routine must be
   the same as the name of the vector table with vtbl_ removed and DirectReturn
   appended.  This is all the mangler understands.
*/

const W_ vtbl_stopPerformIO[] = {
  /* at least "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
  (W_) stopPerformIODirectReturn,
  (W_) stopPerformIODirectReturn,
  (W_) stopPerformIODirectReturn,
  (W_) stopPerformIODirectReturn,
  (W_) stopPerformIODirectReturn,
  (W_) stopPerformIODirectReturn,
  (W_) stopPerformIODirectReturn,
  (W_) stopPerformIODirectReturn
};

/* ptr to a closure (should be of type @IO_Int#@) which the C-world
   has gotten hold of (hopefully via @MakeStablePtr#@).
*/
P_ unstable_Closure;
ED_RO_(WorldStateToken_closure);

STGFUN(startPerformIO)
{
    FUNBEGIN;

    /* At this point we are in the threaded-code world.

       unstable_Closure points to a closure of type PrimIO (),
       which should be performed (by applying it to the
       state of the world).

       The main stg register dump is assumed to be up to date,
       and is used to load the STG registers.
    */
    
#if defined(CONCURRENT) && defined(i386_TARGET_ARCH)
    __asm__ volatile ("mov %%esp,%0" : "=m" (SAVE_esp));
#endif

    /* Load up the real registers from the *_SAVE locns. */
    RestoreAllStgRegs();    	/* inline! */

    /* ------- STG registers are now valid! -------------------------*/
    
    /* first off, check for stk space.. */
#if defined(CONCURRENT) || !defined(STACK_CHECK_BY_PAGE_FAULT) 
    STK_CHK(LivenessReg,1/*A*/,1/*B*/, 0, 0, 0/*prim*/, 0/*re-enter*/);
#else
    STK_CHK(LivenessReg,1/*A*/,0, 0, 0, 0/*prim*/, 0/*re-enter*/);
#endif

    /* Put a suitable return address on the B stack */
    RetReg = (StgRetAddr) UNVEC(stopPerformIODirectReturn,vtbl_stopPerformIO);

    /* Put a World State Token on the A stack */
    /* This is necessary because we've not unboxed it (to reveal a void) yet */
    SpA -= AREL(1);
    *SpA = (P_) WorldStateToken_closure;

    /* Save away C stack pointer so that we can restore it when we leave
       the Haskell world.
    */
    SpB[1] = (W_)SAVE_esp;
    SpB    = SpB + 1;

    Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
    ENT_VIA_NODE();
    InfoPtr=(D_)(INFO_PTR(Node));
    JMP_(ENTRY_CODE(InfoPtr));
    FUNEND;
}
\end{code}

\begin{code}
StgInt enterInt_Result;

STGFUN(stopEnterIntDirectReturn)
{
    FUNBEGIN;
    enterInt_Result = R1.i;

#if defined(__STG_GCC_REGS__)
    SaveAllStgRegs();	/* inline! */
#else
    SAVE_Hp    = Hp;
    SAVE_HpLim = HpLim;
#endif

    JMP_(miniInterpretEnd);
    FUNEND;
}

/*
   NB: For direct returns to work properly, the name of the routine must be
   the same as the name of the vector table with vtbl_ removed and DirectReturn
   appended.  This is all the mangler understands.
*/

const W_ vtbl_stopEnterInt[] = {
  (W_) stopEnterIntDirectReturn,
  (W_) stopEnterIntDirectReturn,
  (W_) stopEnterIntDirectReturn,
  (W_) stopEnterIntDirectReturn,
  (W_) stopEnterIntDirectReturn,
  (W_) stopEnterIntDirectReturn,
  (W_) stopEnterIntDirectReturn,
  (W_) stopEnterIntDirectReturn
};

STGFUN(startEnterInt)
{
    FUNBEGIN;

    /* Load up the real registers from the *_SAVE locns. */
#if defined(__STG_GCC_REGS__)
    RestoreAllStgRegs();    	/* inline! */
#else
    Hp	  = SAVE_Hp;
    HpLim = SAVE_HpLim;
#endif

    /* ------- STG registers are now valid! -------------------------*/

    /* Put a suitable return address on the B stack */
    SpB  -= BREL(1);	/* Allocate a word for the return address */
    *SpB = (W_) UNVEC(stopEnterIntDirectReturn,vtbl_stopEnterInt); /* Push return vector */

    Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
    ENT_VIA_NODE();
    InfoPtr=(D_)(INFO_PTR(Node));
    JMP_(ENTRY_CODE(InfoPtr));
    FUNEND;
}
\end{code}


\begin{code}
StgInt enterFloat_Result;

STGFUN(stopEnterFloatDirectReturn)
{
    FUNBEGIN;
    enterFloat_Result = R1.f;

#if defined(__STG_GCC_REGS__)
    SaveAllStgRegs();	/* inline! */
#else
    SAVE_Hp    = Hp;
    SAVE_HpLim = HpLim;
#endif

    JMP_(miniInterpretEnd);
    FUNEND;
}

/* usual comment about the mangler (hack...) */

const W_ vtbl_stopEnterFloat[] = {
  (W_) stopEnterFloatDirectReturn,
  (W_) stopEnterFloatDirectReturn,
  (W_) stopEnterFloatDirectReturn,
  (W_) stopEnterFloatDirectReturn,
  (W_) stopEnterFloatDirectReturn,
  (W_) stopEnterFloatDirectReturn,
  (W_) stopEnterFloatDirectReturn,
  (W_) stopEnterFloatDirectReturn
};

STGFUN(startEnterFloat)
{
    FUNBEGIN;

    /* Load up the real registers from the *_SAVE locns. */
#if defined(__STG_GCC_REGS__)
    RestoreAllStgRegs();    	/* inline! */
#else
    Hp	  = SAVE_Hp;
    HpLim = SAVE_HpLim;
#endif

    /* ------- STG registers are now valid! -------------------------*/

    /* Put a suitable return address on the B stack */
    SpB  -= BREL(1);	/* Allocate a word for the return address */
    *SpB = (W_) UNVEC(stopEnterFloatDirectReturn,vtbl_stopEnterFloat); /* Push return vector */

    Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
    ENT_VIA_NODE();
    InfoPtr=(D_)(INFO_PTR(Node));
    JMP_(ENTRY_CODE(InfoPtr));
    FUNEND;
}
\end{code}


\begin{code}
#endif /* ! PAR */
\end{code}