1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.7 1999/05/21 14:46:19 sof Exp $
4 * (c) The GHC Team, 1998-1999
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
16 /* ----------------------------------------------------------------------------
17 Building Haskell objects from C datatypes.
18 ------------------------------------------------------------------------- */
22 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
23 p->header.info = (const StgInfoTable*)&Czh_con_info;
24 p->payload[0] = (StgClosure *)((StgInt)c);
31 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
32 p->header.info = (const StgInfoTable*)&Izh_con_info;
33 p->payload[0] = (StgClosure *)(StgInt)i;
40 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
41 /* This is a 'cheat', using the static info table for Ints,
42 instead of the one for Int8, but the types have identical
45 p->header.info = (const StgInfoTable*)&Izh_con_info;
46 /* Make sure we mask out the bits above the lowest 8 */
47 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
54 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
55 /* This is a 'cheat', using the static info table for Ints,
56 instead of the one for Int8, but the types have identical
59 p->header.info = (const StgInfoTable*)&Izh_con_info;
60 /* Make sure we mask out the relevant bits */
61 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
68 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
69 /* see mk_Int8 comment */
70 p->header.info = (const StgInfoTable*)&Izh_con_info;
71 p->payload[0] = (StgClosure *)(StgInt)i;
76 rts_mkInt64 (long long int i)
79 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
80 /* see mk_Int8 comment */
81 p->header.info = (const StgInfoTable*)&I64zh_con_info;
82 tmp = (long long*)&(p->payload[0]);
88 rts_mkWord (unsigned int i)
90 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
91 p->header.info = (const StgInfoTable*)&Wzh_con_info;
92 p->payload[0] = (StgClosure *)(StgWord)i;
97 rts_mkWord8 (unsigned int w)
99 /* see rts_mkInt* comments */
100 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
101 p->header.info = (const StgInfoTable*)&Wzh_con_info;
102 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
107 rts_mkWord16 (unsigned int w)
109 /* see rts_mkInt* comments */
110 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
111 p->header.info = (const StgInfoTable*)&Wzh_con_info;
112 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
117 rts_mkWord32 (unsigned int w)
119 /* see rts_mkInt* comments */
120 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
121 p->header.info = (const StgInfoTable*)&Wzh_con_info;
122 p->payload[0] = (StgClosure *)(StgWord)w;
127 rts_mkWord64 (unsigned long long w)
129 unsigned long long *tmp;
131 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
132 /* see mk_Int8 comment */
133 p->header.info = (const StgInfoTable*)&W64zh_con_info;
134 tmp = (unsigned long long*)&(p->payload[0]);
140 rts_mkFloat (float f)
142 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
143 p->header.info = (const StgInfoTable*)&Fzh_con_info;
144 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
149 rts_mkDouble (double d)
151 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
152 p->header.info = (const StgInfoTable*)&Dzh_con_info;
153 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
158 rts_mkStablePtr (StgStablePtr s)
160 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
161 p->header.info = (const StgInfoTable*)&StablePtr_con_info;
162 p->payload[0] = (StgClosure *)s;
169 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
170 p->header.info = (const StgInfoTable*)&Azh_con_info;
171 p->payload[0] = (StgClosure *)a;
175 #ifdef COMPILER /* GHC has em, Hugs doesn't */
180 return (StgClosure *)&True_closure;
182 return (StgClosure *)&False_closure;
187 rts_mkString (char *s)
189 return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s));
193 rts_apply (HaskellObj f, HaskellObj arg)
195 StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
196 ap->header.info = &AP_UPD_info;
199 ap->payload[0] = (P_)arg;
200 return (StgClosure *)ap;
202 #endif /* COMPILER */
204 /* ----------------------------------------------------------------------------
205 Deconstructing Haskell objects
206 ------------------------------------------------------------------------- */
209 rts_getChar (HaskellObj p)
211 if ( p->header.info == (const StgInfoTable*)&Czh_con_info ||
212 p->header.info == (const StgInfoTable*)&Czh_static_info) {
213 return (char)(StgWord)(p->payload[0]);
215 barf("getChar: not a Char");
220 rts_getInt (HaskellObj p)
223 p->header.info == (const StgInfoTable*)&Izh_con_info ||
224 p->header.info == (const StgInfoTable*)&Izh_static_info ) {
225 return (int)(p->payload[0]);
227 barf("getInt: not an Int");
232 rts_getInt32 (HaskellObj p)
235 p->header.info == (const StgInfoTable*)&Izh_con_info ||
236 p->header.info == (const StgInfoTable*)&Izh_static_info ) {
237 return (int)(p->payload[0]);
239 barf("getInt: not an Int");
244 rts_getWord (HaskellObj p)
246 if ( 1 || /* see above comment */
247 p->header.info == (const StgInfoTable*)&Wzh_con_info ||
248 p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
249 return (unsigned int)(p->payload[0]);
251 barf("getWord: not a Word");
256 rts_getWord32 (HaskellObj p)
258 if ( 1 || /* see above comment */
259 p->header.info == (const StgInfoTable*)&Wzh_con_info ||
260 p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
261 return (unsigned int)(p->payload[0]);
263 barf("getWord: not a Word");
268 rts_getFloat (HaskellObj p)
270 if ( p->header.info == (const StgInfoTable*)&Fzh_con_info ||
271 p->header.info == (const StgInfoTable*)&Fzh_static_info ) {
272 return (float)(PK_FLT((P_)p->payload));
274 barf("getFloat: not a Float");
279 rts_getDouble (HaskellObj p)
281 if ( p->header.info == (const StgInfoTable*)&Dzh_con_info ||
282 p->header.info == (const StgInfoTable*)&Dzh_static_info ) {
283 return (double)(PK_DBL((P_)p->payload));
285 barf("getDouble: not a Double");
290 rts_getStablePtr (HaskellObj p)
292 if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info ||
293 p->header.info == (const StgInfoTable*)&StablePtr_static_info ) {
294 return (StgStablePtr)(p->payload[0]);
296 barf("getStablePtr: not a StablePtr");
301 rts_getAddr (HaskellObj p)
303 if ( p->header.info == (const StgInfoTable*)&Azh_con_info ||
304 p->header.info == (const StgInfoTable*)&Azh_static_info ) {
306 return (void *)(p->payload[0]);
308 barf("getAddr: not an Addr");
312 #ifdef COMPILER /* GHC has em, Hugs doesn't */
314 rts_getBool (HaskellObj p)
316 if (p == &True_closure) {
318 } else if (p == &False_closure) {
321 barf("getBool: not a Bool");
324 #endif /* COMPILER */
326 /* ----------------------------------------------------------------------------
327 Evaluating Haskell expressions
328 ------------------------------------------------------------------------- */
330 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
332 StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
333 return schedule(tso, ret);
337 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
339 StgTSO *tso = createGenThread(stack_size, p);
340 return schedule(tso, ret);
344 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
345 * result to WHNF before returning.
348 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
350 StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
351 return schedule(tso, ret);
355 * Like rts_evalIO(), but doesn't force the action's result.
358 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
360 StgTSO *tso = createIOThread(stack_size, p);
361 return schedule(tso, ret);
364 /* Convenience function for decoding the returned status. */
366 void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
368 if ( rc == Success ) {
371 barf("%s: Return code (%d) not ok",(site),(rc));