%/****************************************************************
%*								*
\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}
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).
    */

#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_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.

       io points to a closure of type IO (), 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.
    */

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

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

    /* NB: To work properly with concurrent threads (on a uniprocessor,
       where stable pointers still make some sense), there must be a 
       stack overflow check here!  --JSM
     */

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

    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}