1 %/****************************************************************
3 \section[adr-performIO]{PerformIO --- part of the Foreign Language Extension}
5 %****************************************************************/
7 The following is heavily based on code in
8 @runtime/main/StgStartup.lhc@.
13 #define MAIN_REG_MAP /* STG world */
18 STGFUN(stopPerformIODirectReturn)
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
28 We just tidy up the register stuff (real regs in *_SAVE, then
29 *_SAVE -> smInfo locs).
32 #if defined(__STG_GCC_REGS__)
33 SaveAllStgRegs(); /* inline! */
39 JMP_(miniInterpretEnd);
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.
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
61 /* ptr to a closure (should be of type @IO_Int#@) which the C-world
62 has gotten hold of (hopefully via @MakeStablePtr#@).
65 ED_RO_(WorldStateToken_closure);
67 STGFUN(startPerformIO)
71 /* At this point we are in the threaded-code world.
73 io points to a closure of type IO (), which should be
74 performed (by applying it to the state of the world).
76 The main stg register dump is assumed to be up to date, and is
77 used to load the STG registers.
80 /* Load up the real registers from the *_SAVE locns. */
81 RestoreAllStgRegs(); /* inline! */
83 /* ------- STG registers are now valid! -------------------------*/
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
90 /* Put a suitable return address on the B stack */
91 RetReg = (StgRetAddr) UNVEC(stopPerformIODirectReturn,vtbl_stopPerformIO);
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 */
96 *SpA = (P_) WorldStateToken_closure;
98 Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
100 InfoPtr=(D_)(INFO_PTR(Node));
101 JMP_(ENTRY_CODE(InfoPtr));
107 StgInt enterInt_Result;
109 STGFUN(stopEnterIntDirectReturn)
112 enterInt_Result = R1.i;
114 #if defined(__STG_GCC_REGS__)
115 SaveAllStgRegs(); /* inline! */
121 JMP_(miniInterpretEnd);
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.
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
142 STGFUN(startEnterInt)
146 /* Load up the real registers from the *_SAVE locns. */
147 #if defined(__STG_GCC_REGS__)
148 RestoreAllStgRegs(); /* inline! */
154 /* ------- STG registers are now valid! -------------------------*/
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 */
160 Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
162 InfoPtr=(D_)(INFO_PTR(Node));
163 JMP_(ENTRY_CODE(InfoPtr));
170 StgInt enterFloat_Result;
172 STGFUN(stopEnterFloatDirectReturn)
175 enterFloat_Result = R1.f;
177 #if defined(__STG_GCC_REGS__)
178 SaveAllStgRegs(); /* inline! */
184 JMP_(miniInterpretEnd);
188 /* usual comment about the mangler (hack...) */
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
201 STGFUN(startEnterFloat)
205 /* Load up the real registers from the *_SAVE locns. */
206 #if defined(__STG_GCC_REGS__)
207 RestoreAllStgRegs(); /* inline! */
213 /* ------- STG registers are now valid! -------------------------*/
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 */
219 Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
221 InfoPtr=(D_)(INFO_PTR(Node));
222 JMP_(ENTRY_CODE(InfoPtr));