1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.8 1999/07/06 09:42:38 sof Exp $
4 * (c) The GHC Team, 1998-1999
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
17 /* ----------------------------------------------------------------------------
18 Building Haskell objects from C datatypes.
19 ------------------------------------------------------------------------- */
23 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
24 p->header.info = (const StgInfoTable*)&Czh_con_info;
25 p->payload[0] = (StgClosure *)((StgInt)c);
32 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
33 p->header.info = (const StgInfoTable*)&Izh_con_info;
34 p->payload[0] = (StgClosure *)(StgInt)i;
41 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
42 /* This is a 'cheat', using the static info table for Ints,
43 instead of the one for Int8, but the types have identical
46 p->header.info = (const StgInfoTable*)&Izh_con_info;
47 /* Make sure we mask out the bits above the lowest 8 */
48 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
55 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
56 /* This is a 'cheat', using the static info table for Ints,
57 instead of the one for Int8, but the types have identical
60 p->header.info = (const StgInfoTable*)&Izh_con_info;
61 /* Make sure we mask out the relevant bits */
62 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
69 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
70 /* see mk_Int8 comment */
71 p->header.info = (const StgInfoTable*)&Izh_con_info;
72 p->payload[0] = (StgClosure *)(StgInt)i;
77 rts_mkInt64 (long long int i)
80 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
81 /* see mk_Int8 comment */
82 p->header.info = (const StgInfoTable*)&I64zh_con_info;
83 tmp = (long long*)&(p->payload[0]);
89 rts_mkWord (unsigned int i)
91 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
92 p->header.info = (const StgInfoTable*)&Wzh_con_info;
93 p->payload[0] = (StgClosure *)(StgWord)i;
98 rts_mkWord8 (unsigned int w)
100 /* see rts_mkInt* comments */
101 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
102 p->header.info = (const StgInfoTable*)&Wzh_con_info;
103 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
108 rts_mkWord16 (unsigned int w)
110 /* see rts_mkInt* comments */
111 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
112 p->header.info = (const StgInfoTable*)&Wzh_con_info;
113 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
118 rts_mkWord32 (unsigned int w)
120 /* see rts_mkInt* comments */
121 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
122 p->header.info = (const StgInfoTable*)&Wzh_con_info;
123 p->payload[0] = (StgClosure *)(StgWord)w;
128 rts_mkWord64 (unsigned long long w)
130 unsigned long long *tmp;
132 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
133 /* see mk_Int8 comment */
134 p->header.info = (const StgInfoTable*)&W64zh_con_info;
135 tmp = (unsigned long long*)&(p->payload[0]);
141 rts_mkFloat (float f)
143 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
144 p->header.info = (const StgInfoTable*)&Fzh_con_info;
145 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
150 rts_mkDouble (double d)
152 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
153 p->header.info = (const StgInfoTable*)&Dzh_con_info;
154 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
159 rts_mkStablePtr (StgStablePtr s)
161 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
162 p->header.info = (const StgInfoTable*)&StablePtr_con_info;
163 p->payload[0] = (StgClosure *)s;
170 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
171 p->header.info = (const StgInfoTable*)&Azh_con_info;
172 p->payload[0] = (StgClosure *)a;
176 #ifdef COMPILER /* GHC has em, Hugs doesn't */
181 return (StgClosure *)&True_closure;
183 return (StgClosure *)&False_closure;
188 rts_mkString (char *s)
190 return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s));
194 rts_apply (HaskellObj f, HaskellObj arg)
196 StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
197 ap->header.info = &AP_UPD_info;
200 ap->payload[0] = (P_)arg;
201 return (StgClosure *)ap;
203 #endif /* COMPILER */
205 /* ----------------------------------------------------------------------------
206 Deconstructing Haskell objects
207 ------------------------------------------------------------------------- */
210 rts_getChar (HaskellObj p)
212 if ( p->header.info == (const StgInfoTable*)&Czh_con_info ||
213 p->header.info == (const StgInfoTable*)&Czh_static_info) {
214 return (char)(StgWord)(p->payload[0]);
216 barf("getChar: not a Char");
221 rts_getInt (HaskellObj p)
224 p->header.info == (const StgInfoTable*)&Izh_con_info ||
225 p->header.info == (const StgInfoTable*)&Izh_static_info ) {
226 return (int)(p->payload[0]);
228 barf("getInt: not an Int");
233 rts_getInt32 (HaskellObj p)
236 p->header.info == (const StgInfoTable*)&Izh_con_info ||
237 p->header.info == (const StgInfoTable*)&Izh_static_info ) {
238 return (int)(p->payload[0]);
240 barf("getInt: not an Int");
245 rts_getWord (HaskellObj p)
247 if ( 1 || /* see above comment */
248 p->header.info == (const StgInfoTable*)&Wzh_con_info ||
249 p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
250 return (unsigned int)(p->payload[0]);
252 barf("getWord: not a Word");
257 rts_getWord32 (HaskellObj p)
259 if ( 1 || /* see above comment */
260 p->header.info == (const StgInfoTable*)&Wzh_con_info ||
261 p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
262 return (unsigned int)(p->payload[0]);
264 barf("getWord: not a Word");
269 rts_getFloat (HaskellObj p)
271 if ( p->header.info == (const StgInfoTable*)&Fzh_con_info ||
272 p->header.info == (const StgInfoTable*)&Fzh_static_info ) {
273 return (float)(PK_FLT((P_)p->payload));
275 barf("getFloat: not a Float");
280 rts_getDouble (HaskellObj p)
282 if ( p->header.info == (const StgInfoTable*)&Dzh_con_info ||
283 p->header.info == (const StgInfoTable*)&Dzh_static_info ) {
284 return (double)(PK_DBL((P_)p->payload));
286 barf("getDouble: not a Double");
291 rts_getStablePtr (HaskellObj p)
293 if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info ||
294 p->header.info == (const StgInfoTable*)&StablePtr_static_info ) {
295 return (StgStablePtr)(p->payload[0]);
297 barf("getStablePtr: not a StablePtr");
302 rts_getAddr (HaskellObj p)
304 if ( p->header.info == (const StgInfoTable*)&Azh_con_info ||
305 p->header.info == (const StgInfoTable*)&Azh_static_info ) {
307 return (void *)(p->payload[0]);
309 barf("getAddr: not an Addr");
313 #ifdef COMPILER /* GHC has em, Hugs doesn't */
315 rts_getBool (HaskellObj p)
317 if (p == &True_closure) {
319 } else if (p == &False_closure) {
322 barf("getBool: not a Bool");
325 #endif /* COMPILER */
327 /* ----------------------------------------------------------------------------
328 Evaluating Haskell expressions
329 ------------------------------------------------------------------------- */
331 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
333 StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
334 return schedule(tso, ret);
338 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
340 StgTSO *tso = createGenThread(stack_size, p);
341 return schedule(tso, ret);
345 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
346 * result to WHNF before returning.
349 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
351 StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
352 return schedule(tso, ret);
356 * Like rts_evalIO(), but doesn't force the action's result.
359 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
361 StgTSO *tso = createIOThread(stack_size, p);
362 return schedule(tso, ret);
365 /* Convenience function for decoding the returned status. */
367 void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
369 if ( rc == Success ) {
372 barf("%s: Return code (%d) not ok",(site),(rc));