1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.27 2001/08/03 16:30:13 sof Exp $
4 * (c) The GHC Team, 1998-2001
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
18 /* ----------------------------------------------------------------------------
19 Building Haskell objects from C datatypes.
20 ------------------------------------------------------------------------- */
24 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
25 p->header.info = Czh_con_info;
26 p->payload[0] = (StgClosure *)(StgChar)c;
33 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
34 p->header.info = Izh_con_info;
35 p->payload[0] = (StgClosure *)(StgInt)i;
42 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
43 p->header.info = I8zh_con_info;
44 /* Make sure we mask out the bits above the lowest 8 */
45 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
50 rts_mkInt16 (HsInt16 i)
52 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
53 p->header.info = I16zh_con_info;
54 /* Make sure we mask out the relevant bits */
55 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
60 rts_mkInt32 (HsInt32 i)
62 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
63 p->header.info = I32zh_con_info;
64 p->payload[0] = (StgClosure *)(StgInt)i;
69 rts_mkInt64 (HsInt64 i)
72 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
73 p->header.info = I64zh_con_info;
74 tmp = (long long*)&(p->payload[0]);
82 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
83 p->header.info = Wzh_con_info;
84 p->payload[0] = (StgClosure *)(StgWord)i;
89 rts_mkWord8 (HsWord8 w)
91 /* see rts_mkInt* comments */
92 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
93 p->header.info = W8zh_con_info;
94 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
99 rts_mkWord16 (HsWord16 w)
101 /* see rts_mkInt* comments */
102 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
103 p->header.info = W16zh_con_info;
104 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
109 rts_mkWord32 (HsWord32 w)
111 /* see rts_mkInt* comments */
112 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
113 p->header.info = W32zh_con_info;
114 p->payload[0] = (StgClosure *)(StgWord)w;
119 rts_mkWord64 (HsWord64 w)
121 unsigned long long *tmp;
123 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
124 /* see mk_Int8 comment */
125 p->header.info = W64zh_con_info;
126 tmp = (unsigned long long*)&(p->payload[0]);
132 rts_mkFloat (HsFloat f)
134 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
135 p->header.info = Fzh_con_info;
136 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
141 rts_mkDouble (HsDouble d)
143 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
144 p->header.info = Dzh_con_info;
145 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
150 rts_mkStablePtr (HsStablePtr s)
152 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
153 p->header.info = StablePtr_con_info;
154 p->payload[0] = (StgClosure *)s;
161 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
162 p->header.info = Ptr_con_info;
163 p->payload[0] = (StgClosure *)a;
167 #ifdef COMPILER /* GHC has em, Hugs doesn't */
169 rts_mkBool (HsBool b)
172 return (StgClosure *)True_closure;
174 return (StgClosure *)False_closure;
179 rts_mkString (char *s)
181 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
183 #endif /* COMPILER */
186 rts_apply (HaskellObj f, HaskellObj arg)
188 StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
189 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM);
192 ap->payload[0] = arg;
193 return (StgClosure *)ap;
196 /* ----------------------------------------------------------------------------
197 Deconstructing Haskell objects
198 ------------------------------------------------------------------------- */
201 rts_getChar (HaskellObj p)
203 if ( p->header.info == Czh_con_info ||
204 p->header.info == Czh_static_info) {
205 return (StgChar)(StgWord)(p->payload[0]);
207 barf("rts_getChar: not a Char");
212 rts_getInt (HaskellObj p)
215 p->header.info == Izh_con_info ||
216 p->header.info == Izh_static_info ) {
217 return (HsInt)(p->payload[0]);
219 barf("rts_getInt: not an Int");
224 rts_getInt8 (HaskellObj p)
227 p->header.info == I8zh_con_info ||
228 p->header.info == I8zh_static_info ) {
229 return (HsInt8)(HsInt)(p->payload[0]);
231 barf("rts_getInt8: not an Int8");
236 rts_getInt16 (HaskellObj p)
239 p->header.info == I16zh_con_info ||
240 p->header.info == I16zh_static_info ) {
241 return (HsInt16)(HsInt)(p->payload[0]);
243 barf("rts_getInt16: not an Int16");
248 rts_getInt32 (HaskellObj p)
251 p->header.info == I32zh_con_info ||
252 p->header.info == I32zh_static_info ) {
253 return (HsInt32)(p->payload[0]);
255 barf("rts_getInt32: not an Int32");
260 rts_getInt64 (HaskellObj p)
264 p->header.info == I64zh_con_info ||
265 p->header.info == I64zh_static_info ) {
266 tmp = (HsInt64*)&(p->payload[0]);
269 barf("rts_getInt64: not an Int64");
273 rts_getWord (HaskellObj p)
275 if ( 1 || /* see above comment */
276 p->header.info == Wzh_con_info ||
277 p->header.info == Wzh_static_info ) {
278 return (HsWord)(p->payload[0]);
280 barf("rts_getWord: not a Word");
285 rts_getWord8 (HaskellObj p)
287 if ( 1 || /* see above comment */
288 p->header.info == W8zh_con_info ||
289 p->header.info == W8zh_static_info ) {
290 return (HsWord8)(HsWord)(p->payload[0]);
292 barf("rts_getWord8: not a Word8");
297 rts_getWord16 (HaskellObj p)
299 if ( 1 || /* see above comment */
300 p->header.info == W16zh_con_info ||
301 p->header.info == W16zh_static_info ) {
302 return (HsWord16)(HsWord)(p->payload[0]);
304 barf("rts_getWord16: not a Word16");
309 rts_getWord32 (HaskellObj p)
311 if ( 1 || /* see above comment */
312 p->header.info == W32zh_con_info ||
313 p->header.info == W32zh_static_info ) {
314 return (unsigned int)(p->payload[0]);
316 barf("rts_getWord: not a Word");
322 rts_getWord64 (HaskellObj p)
325 if ( 1 || /* see above comment */
326 p->header.info == W64zh_con_info ||
327 p->header.info == W64zh_static_info ) {
328 tmp = (HsWord64*)&(p->payload[0]);
331 barf("rts_getWord64: not a Word64");
336 rts_getFloat (HaskellObj p)
338 if ( p->header.info == Fzh_con_info ||
339 p->header.info == Fzh_static_info ) {
340 return (float)(PK_FLT((P_)p->payload));
342 barf("rts_getFloat: not a Float");
347 rts_getDouble (HaskellObj p)
349 if ( p->header.info == Dzh_con_info ||
350 p->header.info == Dzh_static_info ) {
351 return (double)(PK_DBL((P_)p->payload));
353 barf("rts_getDouble: not a Double");
358 rts_getStablePtr (HaskellObj p)
360 if ( p->header.info == StablePtr_con_info ||
361 p->header.info == StablePtr_static_info ) {
362 return (StgStablePtr)(p->payload[0]);
364 barf("rts_getStablePtr: not a StablePtr");
369 rts_getPtr (HaskellObj p)
371 if ( p->header.info == Ptr_con_info ||
372 p->header.info == Ptr_static_info ) {
373 return (void *)(p->payload[0]);
375 barf("rts_getPtr: not an Ptr");
379 #ifdef COMPILER /* GHC has em, Hugs doesn't */
381 rts_getBool (HaskellObj p)
383 if (p == True_closure) {
385 } else if (p == False_closure) {
388 barf("rts_getBool: not a Bool");
391 #endif /* COMPILER */
393 /* ----------------------------------------------------------------------------
394 Evaluating Haskell expressions
395 ------------------------------------------------------------------------- */
397 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
399 StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
401 return waitThread(tso, ret);
405 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
407 StgTSO *tso = createGenThread(stack_size, p);
409 return waitThread(tso, ret);
413 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
414 * result to WHNF before returning.
417 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
419 StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
421 return waitThread(tso, ret);
425 * Like rts_evalIO(), but doesn't force the action's result.
428 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
430 StgTSO *tso = createIOThread(stack_size, p);
432 return waitThread(tso, ret);
435 /* Convenience function for decoding the returned status. */
438 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
444 barf("%s: uncaught exception",site);
446 barf("%s: interrupted", site);
448 barf("%s: no threads to run: infinite loop or deadlock?", site);
450 barf("%s: Return code (%d) not ok",(site),(rc));