1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.26 2001/03/22 03:51:10 hwloidl 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("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 (int)(p->payload[0]);
219 barf("getInt: not an Int");
224 rts_getInt32 (HaskellObj p)
227 p->header.info == I32zh_con_info ||
228 p->header.info == I32zh_static_info ) {
229 return (int)(p->payload[0]);
231 barf("getInt: not an Int");
236 rts_getWord (HaskellObj p)
238 if ( 1 || /* see above comment */
239 p->header.info == Wzh_con_info ||
240 p->header.info == Wzh_static_info ) {
241 return (unsigned int)(p->payload[0]);
243 barf("getWord: not a Word");
248 rts_getWord32 (HaskellObj p)
250 if ( 1 || /* see above comment */
251 p->header.info == W32zh_con_info ||
252 p->header.info == W32zh_static_info ) {
253 return (unsigned int)(p->payload[0]);
255 barf("getWord: not a Word");
260 rts_getFloat (HaskellObj p)
262 if ( p->header.info == Fzh_con_info ||
263 p->header.info == Fzh_static_info ) {
264 return (float)(PK_FLT((P_)p->payload));
266 barf("getFloat: not a Float");
271 rts_getDouble (HaskellObj p)
273 if ( p->header.info == Dzh_con_info ||
274 p->header.info == Dzh_static_info ) {
275 return (double)(PK_DBL((P_)p->payload));
277 barf("getDouble: not a Double");
282 rts_getStablePtr (HaskellObj p)
284 if ( p->header.info == StablePtr_con_info ||
285 p->header.info == StablePtr_static_info ) {
286 return (StgStablePtr)(p->payload[0]);
288 barf("getStablePtr: not a StablePtr");
293 rts_getPtr (HaskellObj p)
295 if ( p->header.info == Ptr_con_info ||
296 p->header.info == Ptr_static_info ) {
297 return (void *)(p->payload[0]);
299 barf("getPtr: not an Ptr");
303 #ifdef COMPILER /* GHC has em, Hugs doesn't */
305 rts_getBool (HaskellObj p)
307 if (p == True_closure) {
309 } else if (p == False_closure) {
312 barf("getBool: not a Bool");
315 #endif /* COMPILER */
317 /* ----------------------------------------------------------------------------
318 Evaluating Haskell expressions
319 ------------------------------------------------------------------------- */
321 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
323 StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
325 return waitThread(tso, ret);
329 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
331 StgTSO *tso = createGenThread(stack_size, p);
333 return waitThread(tso, ret);
337 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
338 * result to WHNF before returning.
341 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
343 StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
345 return waitThread(tso, ret);
349 * Like rts_evalIO(), but doesn't force the action's result.
352 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
354 StgTSO *tso = createIOThread(stack_size, p);
356 return waitThread(tso, ret);
359 /* Convenience function for decoding the returned status. */
362 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
368 barf("%s: uncaught exception",site);
370 barf("%s: interrupted", site);
372 barf("%s: no threads to run: infinite loop or deadlock?", site);
374 barf("%s: Return code (%d) not ok",(site),(rc));