1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.5 1999/03/03 19:20:15 sof Exp $
4 * (c) The GHC Team, 1998-1999
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
16 #define CHASE_OUT_INDIRECTIONS(p) \
17 while ((p)->header.info == &IND_info) { p=((StgInd*)p)->indirectee; }
19 /* ----------------------------------------------------------------------------
20 Building Haskell objects from C datatypes.
21 ------------------------------------------------------------------------- */
25 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
26 p->header.info = (const StgInfoTable*)&Czh_con_info;
27 p->payload[0] = (StgClosure *)((StgInt)c);
34 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
35 p->header.info = (const StgInfoTable*)&Izh_con_info;
36 p->payload[0] = (StgClosure *)(StgInt)i;
43 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
44 /* This is a 'cheat', using the static info table for Ints,
45 instead of the one for Int8, but the types have identical
48 p->header.info = (const StgInfoTable*)&Izh_con_info;
49 /* Make sure we mask out the bits above the lowest 8 */
50 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
57 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
58 /* This is a 'cheat', using the static info table for Ints,
59 instead of the one for Int8, but the types have identical
62 p->header.info = (const StgInfoTable*)&Izh_con_info;
63 /* Make sure we mask out the relevant bits */
64 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
71 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
72 /* see mk_Int8 comment */
73 p->header.info = (const StgInfoTable*)&Izh_con_info;
74 p->payload[0] = (StgClosure *)(StgInt)i;
79 rts_mkInt64 (long long int i)
82 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
83 /* see mk_Int8 comment */
84 p->header.info = (const StgInfoTable*)&I64zh_con_info;
85 tmp = (long long*)&(p->payload[0]);
91 rts_mkWord (unsigned int i)
93 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
94 p->header.info = (const StgInfoTable*)&Wzh_con_info;
95 p->payload[0] = (StgClosure *)(StgWord)i;
100 rts_mkWord8 (unsigned int w)
102 /* see rts_mkInt* comments */
103 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
104 p->header.info = (const StgInfoTable*)&Wzh_con_info;
105 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
110 rts_mkWord16 (unsigned int w)
112 /* see rts_mkInt* comments */
113 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
114 p->header.info = (const StgInfoTable*)&Wzh_con_info;
115 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
120 rts_mkWord32 (unsigned int w)
122 /* see rts_mkInt* comments */
123 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
124 p->header.info = (const StgInfoTable*)&Wzh_con_info;
125 p->payload[0] = (StgClosure *)(StgWord)w;
130 rts_mkWord64 (unsigned long long w)
132 unsigned long long *tmp;
134 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
135 /* see mk_Int8 comment */
136 p->header.info = (const StgInfoTable*)&W64zh_con_info;
137 tmp = (unsigned long long*)&(p->payload[0]);
143 rts_mkFloat (float f)
145 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
146 p->header.info = (const StgInfoTable*)&Fzh_con_info;
147 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
152 rts_mkDouble (double d)
154 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
155 p->header.info = (const StgInfoTable*)&Dzh_con_info;
156 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
161 rts_mkStablePtr (StgStablePtr s)
163 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
164 p->header.info = (const StgInfoTable*)&StablePtr_con_info;
165 p->payload[0] = (StgClosure *)s;
172 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
173 p->header.info = (const StgInfoTable*)&Azh_con_info;
174 p->payload[0] = (StgClosure *)a;
178 #ifdef COMPILER /* GHC has em, Hugs doesn't */
183 return (StgClosure *)&True_closure;
185 return (StgClosure *)&False_closure;
190 rts_mkString (char *s)
192 return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s));
196 rts_apply (HaskellObj f, HaskellObj arg)
198 StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
199 ap->header.info = &AP_UPD_info;
202 ap->payload[0] = (P_)arg;
203 return (StgClosure *)ap;
205 #endif /* COMPILER */
207 /* ----------------------------------------------------------------------------
208 Deconstructing Haskell objects
209 ------------------------------------------------------------------------- */
212 rts_getChar (HaskellObj p)
214 CHASE_OUT_INDIRECTIONS(p);
216 if ( p->header.info == (const StgInfoTable*)&Czh_con_info ||
217 p->header.info == (const StgInfoTable*)&Czh_static_info) {
218 return (char)(StgWord)(p->payload[0]);
220 barf("getChar: not a Char");
225 rts_getInt (HaskellObj p)
227 CHASE_OUT_INDIRECTIONS(p);
229 if ( 1 || /* ToDo: accommodate I32's here as well */
230 p->header.info == (const StgInfoTable*)&Izh_con_info ||
231 p->header.info == (const StgInfoTable*)&Izh_static_info ) {
232 return (int)(p->payload[0]);
234 barf("getInt: not an Int");
239 rts_getWord (HaskellObj p)
241 CHASE_OUT_INDIRECTIONS(p);
243 if ( 1 || /* see above comment */
244 p->header.info == (const StgInfoTable*)&Wzh_con_info ||
245 p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
246 return (unsigned int)(p->payload[0]);
248 barf("getWord: not a Word");
253 rts_getFloat (HaskellObj p)
255 CHASE_OUT_INDIRECTIONS(p);
257 if ( p->header.info == (const StgInfoTable*)&Fzh_con_info ||
258 p->header.info == (const StgInfoTable*)&Fzh_static_info ) {
259 return (float)(PK_FLT((P_)p->payload));
261 barf("getFloat: not a Float");
266 rts_getDouble (HaskellObj p)
268 CHASE_OUT_INDIRECTIONS(p);
270 if ( p->header.info == (const StgInfoTable*)&Dzh_con_info ||
271 p->header.info == (const StgInfoTable*)&Dzh_static_info ) {
272 return (double)(PK_DBL((P_)p->payload));
274 barf("getDouble: not a Double");
279 rts_getStablePtr (HaskellObj p)
281 CHASE_OUT_INDIRECTIONS(p);
283 if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info ||
284 p->header.info == (const StgInfoTable*)&StablePtr_static_info ) {
285 return (StgStablePtr)(p->payload[0]);
287 barf("getStablePtr: not a StablePtr");
292 rts_getAddr (HaskellObj p)
294 CHASE_OUT_INDIRECTIONS(p);
296 if ( p->header.info == (const StgInfoTable*)&Azh_con_info ||
297 p->header.info == (const StgInfoTable*)&Azh_static_info ) {
299 return (void *)(p->payload[0]);
301 barf("getAddr: not an Addr");
305 #ifdef COMPILER /* GHC has em, Hugs doesn't */
307 rts_getBool (HaskellObj p)
309 CHASE_OUT_INDIRECTIONS(p);
311 if (p == &True_closure) {
313 } else if (p == &False_closure) {
316 barf("getBool: not a Bool");
319 #endif /* COMPILER */
321 /* ----------------------------------------------------------------------------
322 Evaluating Haskell expressions
323 ------------------------------------------------------------------------- */
325 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
327 StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
328 return schedule(tso, ret);
332 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
334 StgTSO *tso = createGenThread(stack_size, p);
335 return schedule(tso, ret);
339 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
341 StgTSO *tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
342 return schedule(tso, ret);
346 rts_evalIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
348 StgTSO *tso = createIOThread(stack_size, p);
349 return schedule(tso, ret);
352 /* Convenience function for decoding the returned status. */
354 void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
356 if ( rc == Success ) {
359 barf("%s: Return code (%d) not ok",(site),(rc));