1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.6 1999/05/04 10:19:18 sof Exp $
4 * (c) The GHC Team, 1998-1999
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
16 /* This is a temporary fudge until the scheduler guarantees
17 that the result returned from an evalIO() is fully evaluated.
19 #define CHASE_OUT_INDIRECTIONS(p) \
20 while ((p)->header.info == &IND_info || (p)->header.info == &IND_STATIC_info || (p)->header.info == &IND_OLDGEN_info || (p)->header.info == &IND_PERM_info || (p)->header.info == &IND_OLDGEN_PERM_info) { p=((StgInd*)p)->indirectee; }
22 /* ----------------------------------------------------------------------------
23 Building Haskell objects from C datatypes.
24 ------------------------------------------------------------------------- */
28 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
29 p->header.info = (const StgInfoTable*)&Czh_con_info;
30 p->payload[0] = (StgClosure *)((StgInt)c);
37 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
38 p->header.info = (const StgInfoTable*)&Izh_con_info;
39 p->payload[0] = (StgClosure *)(StgInt)i;
46 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
47 /* This is a 'cheat', using the static info table for Ints,
48 instead of the one for Int8, but the types have identical
51 p->header.info = (const StgInfoTable*)&Izh_con_info;
52 /* Make sure we mask out the bits above the lowest 8 */
53 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
60 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
61 /* This is a 'cheat', using the static info table for Ints,
62 instead of the one for Int8, but the types have identical
65 p->header.info = (const StgInfoTable*)&Izh_con_info;
66 /* Make sure we mask out the relevant bits */
67 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
74 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
75 /* see mk_Int8 comment */
76 p->header.info = (const StgInfoTable*)&Izh_con_info;
77 p->payload[0] = (StgClosure *)(StgInt)i;
82 rts_mkInt64 (long long int i)
85 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
86 /* see mk_Int8 comment */
87 p->header.info = (const StgInfoTable*)&I64zh_con_info;
88 tmp = (long long*)&(p->payload[0]);
94 rts_mkWord (unsigned int i)
96 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
97 p->header.info = (const StgInfoTable*)&Wzh_con_info;
98 p->payload[0] = (StgClosure *)(StgWord)i;
103 rts_mkWord8 (unsigned int w)
105 /* see rts_mkInt* comments */
106 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
107 p->header.info = (const StgInfoTable*)&Wzh_con_info;
108 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
113 rts_mkWord16 (unsigned int w)
115 /* see rts_mkInt* comments */
116 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
117 p->header.info = (const StgInfoTable*)&Wzh_con_info;
118 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
123 rts_mkWord32 (unsigned int w)
125 /* see rts_mkInt* comments */
126 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
127 p->header.info = (const StgInfoTable*)&Wzh_con_info;
128 p->payload[0] = (StgClosure *)(StgWord)w;
133 rts_mkWord64 (unsigned long long w)
135 unsigned long long *tmp;
137 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
138 /* see mk_Int8 comment */
139 p->header.info = (const StgInfoTable*)&W64zh_con_info;
140 tmp = (unsigned long long*)&(p->payload[0]);
146 rts_mkFloat (float f)
148 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
149 p->header.info = (const StgInfoTable*)&Fzh_con_info;
150 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
155 rts_mkDouble (double d)
157 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
158 p->header.info = (const StgInfoTable*)&Dzh_con_info;
159 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
164 rts_mkStablePtr (StgStablePtr s)
166 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
167 p->header.info = (const StgInfoTable*)&StablePtr_con_info;
168 p->payload[0] = (StgClosure *)s;
175 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
176 p->header.info = (const StgInfoTable*)&Azh_con_info;
177 p->payload[0] = (StgClosure *)a;
181 #ifdef COMPILER /* GHC has em, Hugs doesn't */
186 return (StgClosure *)&True_closure;
188 return (StgClosure *)&False_closure;
193 rts_mkString (char *s)
195 return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s));
199 rts_apply (HaskellObj f, HaskellObj arg)
201 StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
202 ap->header.info = &AP_UPD_info;
205 ap->payload[0] = (P_)arg;
206 return (StgClosure *)ap;
208 #endif /* COMPILER */
210 /* ----------------------------------------------------------------------------
211 Deconstructing Haskell objects
212 ------------------------------------------------------------------------- */
215 rts_getChar (HaskellObj p)
217 CHASE_OUT_INDIRECTIONS(p);
219 if ( p->header.info == (const StgInfoTable*)&Czh_con_info ||
220 p->header.info == (const StgInfoTable*)&Czh_static_info) {
221 return (char)(StgWord)(p->payload[0]);
223 barf("getChar: not a Char");
228 rts_getInt (HaskellObj p)
230 CHASE_OUT_INDIRECTIONS(p);
233 p->header.info == (const StgInfoTable*)&Izh_con_info ||
234 p->header.info == (const StgInfoTable*)&Izh_static_info ) {
235 return (int)(p->payload[0]);
237 barf("getInt: not an Int");
242 rts_getInt32 (HaskellObj p)
244 CHASE_OUT_INDIRECTIONS(p);
247 p->header.info == (const StgInfoTable*)&Izh_con_info ||
248 p->header.info == (const StgInfoTable*)&Izh_static_info ) {
249 return (int)(p->payload[0]);
251 barf("getInt: not an Int");
256 rts_getWord (HaskellObj p)
258 CHASE_OUT_INDIRECTIONS(p);
260 if ( 1 || /* see above comment */
261 p->header.info == (const StgInfoTable*)&Wzh_con_info ||
262 p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
263 return (unsigned int)(p->payload[0]);
265 barf("getWord: not a Word");
270 rts_getWord32 (HaskellObj p)
272 CHASE_OUT_INDIRECTIONS(p);
274 if ( 1 || /* see above comment */
275 p->header.info == (const StgInfoTable*)&Wzh_con_info ||
276 p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
277 return (unsigned int)(p->payload[0]);
279 barf("getWord: not a Word");
284 rts_getFloat (HaskellObj p)
286 CHASE_OUT_INDIRECTIONS(p);
288 if ( p->header.info == (const StgInfoTable*)&Fzh_con_info ||
289 p->header.info == (const StgInfoTable*)&Fzh_static_info ) {
290 return (float)(PK_FLT((P_)p->payload));
292 barf("getFloat: not a Float");
297 rts_getDouble (HaskellObj p)
299 CHASE_OUT_INDIRECTIONS(p);
301 if ( p->header.info == (const StgInfoTable*)&Dzh_con_info ||
302 p->header.info == (const StgInfoTable*)&Dzh_static_info ) {
303 return (double)(PK_DBL((P_)p->payload));
305 barf("getDouble: not a Double");
310 rts_getStablePtr (HaskellObj p)
312 CHASE_OUT_INDIRECTIONS(p);
314 if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info ||
315 p->header.info == (const StgInfoTable*)&StablePtr_static_info ) {
316 return (StgStablePtr)(p->payload[0]);
318 barf("getStablePtr: not a StablePtr");
323 rts_getAddr (HaskellObj p)
325 CHASE_OUT_INDIRECTIONS(p);
327 if ( p->header.info == (const StgInfoTable*)&Azh_con_info ||
328 p->header.info == (const StgInfoTable*)&Azh_static_info ) {
330 return (void *)(p->payload[0]);
332 barf("getAddr: not an Addr");
336 #ifdef COMPILER /* GHC has em, Hugs doesn't */
338 rts_getBool (HaskellObj p)
340 CHASE_OUT_INDIRECTIONS(p);
342 if (p == &True_closure) {
344 } else if (p == &False_closure) {
347 barf("getBool: not a Bool");
350 #endif /* COMPILER */
352 /* ----------------------------------------------------------------------------
353 Evaluating Haskell expressions
354 ------------------------------------------------------------------------- */
356 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
358 StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
359 return schedule(tso, ret);
363 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
365 StgTSO *tso = createGenThread(stack_size, p);
366 return schedule(tso, ret);
370 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
372 StgTSO *tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
373 return schedule(tso, ret);
377 rts_evalIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
379 StgTSO *tso = createIOThread(stack_size, p);
380 return schedule(tso, ret);
383 /* Convenience function for decoding the returned status. */
385 void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
387 if ( rc == Success ) {
390 barf("%s: Return code (%d) not ok",(site),(rc));