ghc/runtime/c-as-asm/PerformIO.lhc

   1 %/****************************************************************
   2 %*                                                              *
   3 \section[adr-performIO]{PerformIO --- part of the Foreign Language Extension}
   4 %*                                                              *
   5 %****************************************************************/
   6
   7 The following is heavily based on code in
   8 @runtime/main/StgStartup.lhc@.
   9
  10 \begin{code}
  11 #ifndef PAR
  12
  13 #define MAIN_REG_MAP        /* STG world */
  14 #include "rtsdefs.h"
  15 \end{code}
  16
  17 \begin{code}
  18 STGFUN(stopPerformIODirectReturn)
  19 {
  20     FUNBEGIN;
  21     /* The final exit.
  22
  23        The top-top-level closures (e.g., "main") are of type "PrimIO ()".
  24        When entered, they perform an IO action and return a () --
  25        essentially, TagReg is set to 1.  Here, we don't need to do
  26        anything with that.
  27
  28        We just tidy up the register stuff (real regs in *_SAVE, then
  29        *_SAVE -> smInfo locs).
  30     */
  31
  32 #if defined(__STG_GCC_REGS__)
  33     SaveAllStgRegs();   /* inline! */
  34 #else
  35     SAVE_Hp    = Hp;
  36     SAVE_HpLim = HpLim;
  37 #endif
  38
  39     JMP_(miniInterpretEnd);
  40     FUNEND;
  41 }
  42
  43 /*
  44    NB: For direct returns to work properly, the name of the routine must be
  45    the same as the name of the vector table with vtbl_ removed and DirectReturn
  46    appended.  This is all the mangler understands.
  47 */
  48
  49 const W_ vtbl_stopPerformIO[] = {
  50   /* at least "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
  51   (W_) stopPerformIODirectReturn,
  52   (W_) stopPerformIODirectReturn,
  53   (W_) stopPerformIODirectReturn,
  54   (W_) stopPerformIODirectReturn,
  55   (W_) stopPerformIODirectReturn,
  56   (W_) stopPerformIODirectReturn,
  57   (W_) stopPerformIODirectReturn,
  58   (W_) stopPerformIODirectReturn
  59 };
  60
  61 /* ptr to a closure (should be of type @IO_Int#@) which the C-world
  62    has gotten hold of (hopefully via @MakeStablePtr#@).
  63 */
  64 P_ unstable_Closure;
  65 ED_RO_(WorldStateToken_closure);
  66
  67 STGFUN(startPerformIO)
  68 {
  69     FUNBEGIN;
  70
  71     /* At this point we are in the threaded-code world.
  72
  73        io points to a closure of type IO (), which should be
  74        performed (by applying it to the state of the world).
  75
  76        The main stg register dump is assumed to be up to date, and is
  77        used to load the STG registers.
  78     */
  79
  80     /* Load up the real registers from the *_SAVE locns. */
  81     RestoreAllStgRegs();        /* inline! */
  82
  83     /* ------- STG registers are now valid! -------------------------*/
  84
  85     /* NB: To work properly with concurrent threads (on a uniprocessor,
  86        where stable pointers still make some sense), there must be a
  87        stack overflow check here!  --JSM
  88      */
  89
  90     /* Put a suitable return address on the B stack */
  91     RetReg = (StgRetAddr) UNVEC(stopPerformIODirectReturn,vtbl_stopPerformIO);
  92
  93     /* Put a World State Token on the A stack */
  94     /* This is necessary because we've not unboxed it (to reveal a void) yet */
  95     SpA -= AREL(1);
  96     *SpA = (P_) WorldStateToken_closure;
  97
  98     Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
  99     ENT_VIA_NODE();
 100     InfoPtr=(D_)(INFO_PTR(Node));
 101     JMP_(ENTRY_CODE(InfoPtr));
 102     FUNEND;
 103 }
 104 \end{code}
 105
 106 \begin{code}
 107 StgInt enterInt_Result;
 108
 109 STGFUN(stopEnterIntDirectReturn)
 110 {
 111     FUNBEGIN;
 112     enterInt_Result = R1.i;
 113
 114 #if defined(__STG_GCC_REGS__)
 115     SaveAllStgRegs();   /* inline! */
 116 #else
 117     SAVE_Hp    = Hp;
 118     SAVE_HpLim = HpLim;
 119 #endif
 120
 121     JMP_(miniInterpretEnd);
 122     FUNEND;
 123 }
 124
 125 /*
 126    NB: For direct returns to work properly, the name of the routine must be
 127    the same as the name of the vector table with vtbl_ removed and DirectReturn
 128    appended.  This is all the mangler understands.
 129 */
 130
 131 const W_ vtbl_stopEnterInt[] = {
 132   (W_) stopEnterIntDirectReturn,
 133   (W_) stopEnterIntDirectReturn,
 134   (W_) stopEnterIntDirectReturn,
 135   (W_) stopEnterIntDirectReturn,
 136   (W_) stopEnterIntDirectReturn,
 137   (W_) stopEnterIntDirectReturn,
 138   (W_) stopEnterIntDirectReturn,
 139   (W_) stopEnterIntDirectReturn
 140 };
 141
 142 STGFUN(startEnterInt)
 143 {
 144     FUNBEGIN;
 145
 146     /* Load up the real registers from the *_SAVE locns. */
 147 #if defined(__STG_GCC_REGS__)
 148     RestoreAllStgRegs();        /* inline! */
 149 #else
 150     Hp    = SAVE_Hp;
 151     HpLim = SAVE_HpLim;
 152 #endif
 153
 154     /* ------- STG registers are now valid! -------------------------*/
 155
 156     /* Put a suitable return address on the B stack */
 157     SpB  -= BREL(1);    /* Allocate a word for the return address */
 158     *SpB = (W_) UNVEC(stopEnterIntDirectReturn,vtbl_stopEnterInt); /* Push return vector */
 159
 160     Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
 161     ENT_VIA_NODE();
 162     InfoPtr=(D_)(INFO_PTR(Node));
 163     JMP_(ENTRY_CODE(InfoPtr));
 164     FUNEND;
 165 }
 166 \end{code}
 167
 168
 169 \begin{code}
 170 StgInt enterFloat_Result;
 171
 172 STGFUN(stopEnterFloatDirectReturn)
 173 {
 174     FUNBEGIN;
 175     enterFloat_Result = R1.f;
 176
 177 #if defined(__STG_GCC_REGS__)
 178     SaveAllStgRegs();   /* inline! */
 179 #else
 180     SAVE_Hp    = Hp;
 181     SAVE_HpLim = HpLim;
 182 #endif
 183
 184     JMP_(miniInterpretEnd);
 185     FUNEND;
 186 }
 187
 188 /* usual comment about the mangler (hack...) */
 189
 190 const W_ vtbl_stopEnterFloat[] = {
 191   (W_) stopEnterFloatDirectReturn,
 192   (W_) stopEnterFloatDirectReturn,
 193   (W_) stopEnterFloatDirectReturn,
 194   (W_) stopEnterFloatDirectReturn,
 195   (W_) stopEnterFloatDirectReturn,
 196   (W_) stopEnterFloatDirectReturn,
 197   (W_) stopEnterFloatDirectReturn,
 198   (W_) stopEnterFloatDirectReturn
 199 };
 200
 201 STGFUN(startEnterFloat)
 202 {
 203     FUNBEGIN;
 204
 205     /* Load up the real registers from the *_SAVE locns. */
 206 #if defined(__STG_GCC_REGS__)
 207     RestoreAllStgRegs();        /* inline! */
 208 #else
 209     Hp    = SAVE_Hp;
 210     HpLim = SAVE_HpLim;
 211 #endif
 212
 213     /* ------- STG registers are now valid! -------------------------*/
 214
 215     /* Put a suitable return address on the B stack */
 216     SpB  -= BREL(1);    /* Allocate a word for the return address */
 217     *SpB = (W_) UNVEC(stopEnterFloatDirectReturn,vtbl_stopEnterFloat); /* Push return vector */
 218
 219     Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
 220     ENT_VIA_NODE();
 221     InfoPtr=(D_)(INFO_PTR(Node));
 222     JMP_(ENTRY_CODE(InfoPtr));
 223     FUNEND;
 224 }
 225 \end{code}
 226
 227
 228 \begin{code}
 229 #endif /* ! PAR */
 230 \end{code}
 231