1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.29 2001/08/29 11:20:40 simonmar Exp $
4 * (c) The GHC Team, 1998-2001
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
10 #include "PosixSource.h"
19 /* ----------------------------------------------------------------------------
20 Building Haskell objects from C datatypes.
21 ------------------------------------------------------------------------- */
25 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
26 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
27 p->payload[0] = (StgClosure *)(StgChar)c;
34 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
35 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
36 p->payload[0] = (StgClosure *)(StgInt)i;
43 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
44 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
45 /* Make sure we mask out the bits above the lowest 8 */
46 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
51 rts_mkInt16 (HsInt16 i)
53 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
54 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
55 /* Make sure we mask out the relevant bits */
56 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
61 rts_mkInt32 (HsInt32 i)
63 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
64 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
65 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
70 rts_mkInt64 (HsInt64 i)
73 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
74 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
75 tmp = (long long*)&(p->payload[0]);
83 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
84 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
85 p->payload[0] = (StgClosure *)(StgWord)i;
90 rts_mkWord8 (HsWord8 w)
92 /* see rts_mkInt* comments */
93 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
94 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
95 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
100 rts_mkWord16 (HsWord16 w)
102 /* see rts_mkInt* comments */
103 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
104 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
105 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
110 rts_mkWord32 (HsWord32 w)
112 /* see rts_mkInt* comments */
113 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
114 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
115 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
120 rts_mkWord64 (HsWord64 w)
122 unsigned long long *tmp;
124 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
125 /* see mk_Int8 comment */
126 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
127 tmp = (unsigned long long*)&(p->payload[0]);
133 rts_mkFloat (HsFloat f)
135 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
136 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
137 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
142 rts_mkDouble (HsDouble d)
144 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
145 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
146 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
151 rts_mkStablePtr (HsStablePtr s)
153 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
154 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
155 p->payload[0] = (StgClosure *)s;
162 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
163 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
164 p->payload[0] = (StgClosure *)a;
168 #ifdef COMPILER /* GHC has em, Hugs doesn't */
170 rts_mkBool (HsBool b)
173 return (StgClosure *)True_closure;
175 return (StgClosure *)False_closure;
180 rts_mkString (char *s)
182 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
184 #endif /* COMPILER */
187 rts_apply (HaskellObj f, HaskellObj arg)
189 StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
190 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM);
193 ap->payload[0] = arg;
194 return (StgClosure *)ap;
197 /* ----------------------------------------------------------------------------
198 Deconstructing Haskell objects
199 ------------------------------------------------------------------------- */
202 rts_getChar (HaskellObj p)
204 if ( p->header.info == Czh_con_info ||
205 p->header.info == Czh_static_info) {
206 return (StgChar)(StgWord)(p->payload[0]);
208 barf("rts_getChar: not a Char");
213 rts_getInt (HaskellObj p)
216 p->header.info == Izh_con_info ||
217 p->header.info == Izh_static_info ) {
218 return (HsInt)(p->payload[0]);
220 barf("rts_getInt: not an Int");
225 rts_getInt8 (HaskellObj p)
228 p->header.info == I8zh_con_info ||
229 p->header.info == I8zh_static_info ) {
230 return (HsInt8)(HsInt)(p->payload[0]);
232 barf("rts_getInt8: not an Int8");
237 rts_getInt16 (HaskellObj p)
240 p->header.info == I16zh_con_info ||
241 p->header.info == I16zh_static_info ) {
242 return (HsInt16)(HsInt)(p->payload[0]);
244 barf("rts_getInt16: not an Int16");
249 rts_getInt32 (HaskellObj p)
252 p->header.info == I32zh_con_info ||
253 p->header.info == I32zh_static_info ) {
254 return (HsInt32)(p->payload[0]);
256 barf("rts_getInt32: not an Int32");
261 rts_getInt64 (HaskellObj p)
265 p->header.info == I64zh_con_info ||
266 p->header.info == I64zh_static_info ) {
267 tmp = (HsInt64*)&(p->payload[0]);
270 barf("rts_getInt64: not an Int64");
274 rts_getWord (HaskellObj p)
276 if ( 1 || /* see above comment */
277 p->header.info == Wzh_con_info ||
278 p->header.info == Wzh_static_info ) {
279 return (HsWord)(p->payload[0]);
281 barf("rts_getWord: not a Word");
286 rts_getWord8 (HaskellObj p)
288 if ( 1 || /* see above comment */
289 p->header.info == W8zh_con_info ||
290 p->header.info == W8zh_static_info ) {
291 return (HsWord8)(HsWord)(p->payload[0]);
293 barf("rts_getWord8: not a Word8");
298 rts_getWord16 (HaskellObj p)
300 if ( 1 || /* see above comment */
301 p->header.info == W16zh_con_info ||
302 p->header.info == W16zh_static_info ) {
303 return (HsWord16)(HsWord)(p->payload[0]);
305 barf("rts_getWord16: not a Word16");
310 rts_getWord32 (HaskellObj p)
312 if ( 1 || /* see above comment */
313 p->header.info == W32zh_con_info ||
314 p->header.info == W32zh_static_info ) {
315 return (unsigned int)(p->payload[0]);
317 barf("rts_getWord: not a Word");
323 rts_getWord64 (HaskellObj p)
326 if ( 1 || /* see above comment */
327 p->header.info == W64zh_con_info ||
328 p->header.info == W64zh_static_info ) {
329 tmp = (HsWord64*)&(p->payload[0]);
332 barf("rts_getWord64: not a Word64");
337 rts_getFloat (HaskellObj p)
339 if ( p->header.info == Fzh_con_info ||
340 p->header.info == Fzh_static_info ) {
341 return (float)(PK_FLT((P_)p->payload));
343 barf("rts_getFloat: not a Float");
348 rts_getDouble (HaskellObj p)
350 if ( p->header.info == Dzh_con_info ||
351 p->header.info == Dzh_static_info ) {
352 return (double)(PK_DBL((P_)p->payload));
354 barf("rts_getDouble: not a Double");
359 rts_getStablePtr (HaskellObj p)
361 if ( p->header.info == StablePtr_con_info ||
362 p->header.info == StablePtr_static_info ) {
363 return (StgStablePtr)(p->payload[0]);
365 barf("rts_getStablePtr: not a StablePtr");
370 rts_getPtr (HaskellObj p)
372 if ( p->header.info == Ptr_con_info ||
373 p->header.info == Ptr_static_info ) {
374 return (void *)(p->payload[0]);
376 barf("rts_getPtr: not an Ptr");
380 #ifdef COMPILER /* GHC has em, Hugs doesn't */
382 rts_getBool (HaskellObj p)
384 if (p == True_closure) {
386 } else if (p == False_closure) {
389 barf("rts_getBool: not a Bool");
392 #endif /* COMPILER */
394 /* ----------------------------------------------------------------------------
395 Evaluating Haskell expressions
396 ------------------------------------------------------------------------- */
398 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
400 StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
402 return waitThread(tso, ret);
406 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
408 StgTSO *tso = createGenThread(stack_size, p);
410 return waitThread(tso, ret);
414 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
415 * result to WHNF before returning.
418 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
420 StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
422 return waitThread(tso, ret);
426 * Like rts_evalIO(), but doesn't force the action's result.
429 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
431 StgTSO *tso = createIOThread(stack_size, p);
433 return waitThread(tso, ret);
436 /* Convenience function for decoding the returned status. */
439 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
445 barf("%s: uncaught exception",site);
447 barf("%s: interrupted", site);
449 barf("%s: no threads to run: infinite loop or deadlock?", site);
451 barf("%s: Return code (%d) not ok",(site),(rc));