1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.18 2000/08/07 23:37:23 qrczak Exp $
4 * (c) The GHC Team, 1998-2000
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
18 /* ----------------------------------------------------------------------------
19 Building Haskell objects from C datatypes.
20 ------------------------------------------------------------------------- */
22 rts_mkChar (unsigned int c)
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 /* This is a 'cheat', using the static info table for Ints,
44 instead of the one for Int8, but the types have identical
47 p->header.info = Izh_con_info;
48 /* Make sure we mask out the bits above the lowest 8 */
49 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
56 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
57 /* This is a 'cheat', using the static info table for Ints,
58 instead of the one for Int8, but the types have identical
61 p->header.info = Izh_con_info;
62 /* Make sure we mask out the relevant bits */
63 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
70 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
71 /* see mk_Int8 comment */
72 p->header.info = Izh_con_info;
73 p->payload[0] = (StgClosure *)(StgInt)i;
78 rts_mkInt64 (long long int i)
81 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
82 /* see mk_Int8 comment */
83 p->header.info = I64zh_con_info;
84 tmp = (long long*)&(p->payload[0]);
90 rts_mkWord (unsigned int i)
92 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
93 p->header.info = Wzh_con_info;
94 p->payload[0] = (StgClosure *)(StgWord)i;
99 rts_mkWord8 (unsigned int w)
101 /* see rts_mkInt* comments */
102 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
103 p->header.info = Wzh_con_info;
104 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
109 rts_mkWord16 (unsigned int w)
111 /* see rts_mkInt* comments */
112 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
113 p->header.info = Wzh_con_info;
114 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
119 rts_mkWord32 (unsigned int w)
121 /* see rts_mkInt* comments */
122 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
123 p->header.info = Wzh_con_info;
124 p->payload[0] = (StgClosure *)(StgWord)w;
129 rts_mkWord64 (unsigned long long w)
131 unsigned long long *tmp;
133 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
134 /* see mk_Int8 comment */
135 p->header.info = W64zh_con_info;
136 tmp = (unsigned long long*)&(p->payload[0]);
142 rts_mkFloat (float f)
144 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
145 p->header.info = Fzh_con_info;
146 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
151 rts_mkDouble (double d)
153 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
154 p->header.info = Dzh_con_info;
155 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
160 rts_mkStablePtr (StgStablePtr s)
162 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
163 p->header.info = StablePtr_con_info;
164 p->payload[0] = (StgClosure *)s;
171 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
172 p->header.info = Azh_con_info;
173 p->payload[0] = (StgClosure *)a;
177 #ifdef COMPILER /* GHC has em, Hugs doesn't */
179 rts_mkBool (StgBool b)
182 return (StgClosure *)True_closure;
184 return (StgClosure *)False_closure;
189 rts_mkString (char *s)
191 return rts_apply((StgClosure *)unpackCString_closure, rts_mkAddr(s));
193 #endif /* COMPILER */
196 rts_apply (HaskellObj f, HaskellObj arg)
198 StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
199 SET_HDR(ap, &AP_UPD_info, CCS_SYSTEM);
202 ap->payload[0] = (P_)arg;
203 return (StgClosure *)ap;
206 /* ----------------------------------------------------------------------------
207 Deconstructing Haskell objects
208 ------------------------------------------------------------------------- */
211 rts_getChar (HaskellObj p)
213 if ( p->header.info == Czh_con_info ||
214 p->header.info == Czh_static_info) {
215 return (StgChar)(StgWord)(p->payload[0]);
217 barf("getChar: not a Char");
222 rts_getInt (HaskellObj p)
225 p->header.info == Izh_con_info ||
226 p->header.info == Izh_static_info ) {
227 return (int)(p->payload[0]);
229 barf("getInt: not an Int");
234 rts_getInt32 (HaskellObj p)
237 p->header.info == Izh_con_info ||
238 p->header.info == Izh_static_info ) {
239 return (int)(p->payload[0]);
241 barf("getInt: not an Int");
246 rts_getWord (HaskellObj p)
248 if ( 1 || /* see above comment */
249 p->header.info == Wzh_con_info ||
250 p->header.info == Wzh_static_info ) {
251 return (unsigned int)(p->payload[0]);
253 barf("getWord: not a Word");
258 rts_getWord32 (HaskellObj p)
260 if ( 1 || /* see above comment */
261 p->header.info == Wzh_con_info ||
262 p->header.info == Wzh_static_info ) {
263 return (unsigned int)(p->payload[0]);
265 barf("getWord: not a Word");
270 rts_getFloat (HaskellObj p)
272 if ( p->header.info == Fzh_con_info ||
273 p->header.info == Fzh_static_info ) {
274 return (float)(PK_FLT((P_)p->payload));
276 barf("getFloat: not a Float");
281 rts_getDouble (HaskellObj p)
283 if ( p->header.info == Dzh_con_info ||
284 p->header.info == Dzh_static_info ) {
285 return (double)(PK_DBL((P_)p->payload));
287 barf("getDouble: not a Double");
292 rts_getStablePtr (HaskellObj p)
294 if ( p->header.info == StablePtr_con_info ||
295 p->header.info == StablePtr_static_info ) {
296 return (StgStablePtr)(p->payload[0]);
298 barf("getStablePtr: not a StablePtr");
303 rts_getAddr (HaskellObj p)
305 if ( p->header.info == Azh_con_info ||
306 p->header.info == Azh_static_info ) {
308 return (void *)(p->payload[0]);
310 barf("getAddr: not an Addr");
314 #ifdef COMPILER /* GHC has em, Hugs doesn't */
316 rts_getBool (HaskellObj p)
318 if (p == True_closure) {
320 } else if (p == False_closure) {
323 barf("getBool: not a Bool");
326 #endif /* COMPILER */
328 /* ----------------------------------------------------------------------------
329 Evaluating Haskell expressions
330 ------------------------------------------------------------------------- */
332 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
334 StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
336 return waitThread(tso, ret);
340 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
342 StgTSO *tso = createGenThread(stack_size, p);
344 return waitThread(tso, ret);
348 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
349 * result to WHNF before returning.
352 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
354 StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
356 return waitThread(tso, ret);
360 * Like rts_evalIO(), but doesn't force the action's result.
363 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
365 StgTSO *tso = createIOThread(stack_size, p);
367 return waitThread(tso, ret);
370 #if defined(PAR) || defined(SMP)
372 Needed in the parallel world for non-Main PEs, which do not get a piece
373 of work to start with --- they have to humbly ask for it
377 rts_evalNothing(unsigned int stack_size)
379 /* ToDo: propagate real SchedulerStatus back to caller */
380 scheduleThread(END_TSO_QUEUE);
385 /* Convenience function for decoding the returned status. */
388 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
394 barf("%s: uncaught exception",site);
396 barf("%s: interrupted", site);
398 barf("%s: no threads to run: infinite loop or deadlock?", site);
400 barf("%s: Return code (%d) not ok",(site),(rc));