1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.42 2003/02/06 10:04:57 simonmar Exp $
4 * (c) The GHC Team, 1998-2001
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
10 #include "PosixSource.h"
18 #include "OSThreads.h"
20 #include "Capability.h"
24 /* ----------------------------------------------------------------------------
25 Building Haskell objects from C datatypes.
26 ------------------------------------------------------------------------- */
30 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
31 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
32 p->payload[0] = (StgClosure *)(StgChar)c;
39 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
40 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
41 p->payload[0] = (StgClosure *)(StgInt)i;
48 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
49 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
50 /* Make sure we mask out the bits above the lowest 8 */
51 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
56 rts_mkInt16 (HsInt16 i)
58 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
59 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
60 /* Make sure we mask out the relevant bits */
61 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
66 rts_mkInt32 (HsInt32 i)
68 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
69 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
70 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
75 rts_mkInt64 (HsInt64 i)
78 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
79 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
80 tmp = (long long*)&(p->payload[0]);
88 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
89 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
90 p->payload[0] = (StgClosure *)(StgWord)i;
95 rts_mkWord8 (HsWord8 w)
97 /* see rts_mkInt* comments */
98 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
99 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
100 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
105 rts_mkWord16 (HsWord16 w)
107 /* see rts_mkInt* comments */
108 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
109 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
110 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
115 rts_mkWord32 (HsWord32 w)
117 /* see rts_mkInt* comments */
118 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
119 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
120 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
125 rts_mkWord64 (HsWord64 w)
127 unsigned long long *tmp;
129 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
130 /* see mk_Int8 comment */
131 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
132 tmp = (unsigned long long*)&(p->payload[0]);
138 rts_mkFloat (HsFloat f)
140 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
141 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
142 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
147 rts_mkDouble (HsDouble d)
149 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
150 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
151 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
156 rts_mkStablePtr (HsStablePtr s)
158 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
159 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
160 p->payload[0] = (StgClosure *)s;
167 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
168 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
169 p->payload[0] = (StgClosure *)a;
174 rts_mkFunPtr (HsFunPtr a)
176 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
177 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
178 p->payload[0] = (StgClosure *)a;
182 #ifdef COMPILER /* GHC has em, Hugs doesn't */
184 rts_mkBool (HsBool b)
187 return (StgClosure *)True_closure;
189 return (StgClosure *)False_closure;
194 rts_mkString (char *s)
196 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
198 #endif /* COMPILER */
201 rts_apply (HaskellObj f, HaskellObj arg)
205 ap = (StgClosure *)allocate(sizeofW(StgClosure) + 2);
206 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
208 ap->payload[1] = arg;
209 return (StgClosure *)ap;
212 /* ----------------------------------------------------------------------------
213 Deconstructing Haskell objects
215 We would like to assert that we have the right kind of object in
216 each case, but this is problematic because in GHCi the info table
217 for the D# constructor (say) might be dynamically loaded. Hence we
218 omit these assertions for now.
219 ------------------------------------------------------------------------- */
222 rts_getChar (HaskellObj p)
224 // See comment above:
225 // ASSERT(p->header.info == Czh_con_info ||
226 // p->header.info == Czh_static_info);
227 return (StgChar)(StgWord)(p->payload[0]);
231 rts_getInt (HaskellObj p)
233 // See comment above:
234 // ASSERT(p->header.info == Izh_con_info ||
235 // p->header.info == Izh_static_info);
236 return (HsInt)(p->payload[0]);
240 rts_getInt8 (HaskellObj p)
242 // See comment above:
243 // ASSERT(p->header.info == I8zh_con_info ||
244 // p->header.info == I8zh_static_info);
245 return (HsInt8)(HsInt)(p->payload[0]);
249 rts_getInt16 (HaskellObj p)
251 // See comment above:
252 // ASSERT(p->header.info == I16zh_con_info ||
253 // p->header.info == I16zh_static_info);
254 return (HsInt16)(HsInt)(p->payload[0]);
258 rts_getInt32 (HaskellObj p)
260 // See comment above:
261 // ASSERT(p->header.info == I32zh_con_info ||
262 // p->header.info == I32zh_static_info);
263 return (HsInt32)(p->payload[0]);
267 rts_getInt64 (HaskellObj p)
270 // See comment above:
271 // ASSERT(p->header.info == I64zh_con_info ||
272 // p->header.info == I64zh_static_info);
273 tmp = (HsInt64*)&(p->payload[0]);
277 rts_getWord (HaskellObj p)
279 // See comment above:
280 // ASSERT(p->header.info == Wzh_con_info ||
281 // p->header.info == Wzh_static_info);
282 return (HsWord)(p->payload[0]);
286 rts_getWord8 (HaskellObj p)
288 // See comment above:
289 // ASSERT(p->header.info == W8zh_con_info ||
290 // p->header.info == W8zh_static_info);
291 return (HsWord8)(HsWord)(p->payload[0]);
295 rts_getWord16 (HaskellObj p)
297 // See comment above:
298 // ASSERT(p->header.info == W16zh_con_info ||
299 // p->header.info == W16zh_static_info);
300 return (HsWord16)(HsWord)(p->payload[0]);
304 rts_getWord32 (HaskellObj p)
306 // See comment above:
307 // ASSERT(p->header.info == W32zh_con_info ||
308 // p->header.info == W32zh_static_info);
309 return (HsWord32)(p->payload[0]);
314 rts_getWord64 (HaskellObj p)
317 // See comment above:
318 // ASSERT(p->header.info == W64zh_con_info ||
319 // p->header.info == W64zh_static_info);
320 tmp = (HsWord64*)&(p->payload[0]);
325 rts_getFloat (HaskellObj p)
327 // See comment above:
328 // ASSERT(p->header.info == Fzh_con_info ||
329 // p->header.info == Fzh_static_info);
330 return (float)(PK_FLT((P_)p->payload));
334 rts_getDouble (HaskellObj p)
336 // See comment above:
337 // ASSERT(p->header.info == Dzh_con_info ||
338 // p->header.info == Dzh_static_info);
339 return (double)(PK_DBL((P_)p->payload));
343 rts_getStablePtr (HaskellObj p)
345 // See comment above:
346 // ASSERT(p->header.info == StablePtr_con_info ||
347 // p->header.info == StablePtr_static_info);
348 return (StgStablePtr)(p->payload[0]);
352 rts_getPtr (HaskellObj p)
354 // See comment above:
355 // ASSERT(p->header.info == Ptr_con_info ||
356 // p->header.info == Ptr_static_info);
357 return (void *)(p->payload[0]);
361 rts_getFunPtr (HaskellObj p)
363 // See comment above:
364 // ASSERT(p->header.info == FunPtr_con_info ||
365 // p->header.info == FunPtr_static_info);
366 return (void *)(p->payload[0]);
369 #ifdef COMPILER /* GHC has em, Hugs doesn't */
371 rts_getBool (HaskellObj p)
373 if (p == True_closure) {
375 } else if (p == False_closure) {
378 barf("rts_getBool: not a Bool");
381 #endif /* COMPILER */
383 /* ----------------------------------------------------------------------------
384 Evaluating Haskell expressions
385 ------------------------------------------------------------------------- */
387 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
391 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
392 return scheduleWaitThread(tso,ret);
396 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
400 tso = createGenThread(stack_size, p);
401 return scheduleWaitThread(tso,ret);
405 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
406 * result to WHNF before returning.
409 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
413 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
414 return scheduleWaitThread(tso,ret);
418 * Identical to rts_evalIO(), but won't create a new task/OS thread
419 * to evaluate the Haskell thread. Used by main() only. Hack.
423 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
427 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
429 return waitThread(tso, ret);
433 * rts_evalStableIO() is suitable for calling from Haskell. It
434 * evaluates a value of the form (StablePtr (IO a)), forcing the
435 * action's result to WHNF before returning. The result is returned
439 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
443 SchedulerStatus stat;
445 p = (StgClosure *)deRefStablePtr(s);
446 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
447 stat = scheduleWaitThread(tso,&r);
449 if (stat == Success) {
451 *ret = getStablePtr((StgPtr)r);
458 * Like rts_evalIO(), but doesn't force the action's result.
461 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
465 tso = createIOThread(stack_size, p);
466 return scheduleWaitThread(tso,ret);
469 /* Convenience function for decoding the returned status. */
472 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
478 prog_belch("%s: uncaught exception",site);
479 stg_exit(EXIT_FAILURE);
481 prog_belch("%s: interrupted", site);
482 stg_exit(EXIT_FAILURE);
484 prog_belch("%s: Return code (%d) not ok",(site),(rc));
485 stg_exit(EXIT_FAILURE);
492 #ifdef RTS_SUPPORTS_THREADS
494 ACQUIRE_LOCK(&sched_mutex);
496 // we request to get the capability immediately, in order to
497 // a) stop other threads from using allocate()
498 // b) wake the current worker thread from awaitEvent()
499 // (so that a thread started by rts_eval* will start immediately)
500 grabReturnCapability(&sched_mutex,&cap);
502 // now that we have the capability, we don't need it anymore
503 // (other threads will continue to run as soon as we release the sched_mutex)
504 releaseCapability(cap);
506 // In the RTS hasn't been entered yet,
508 // If there is already a task available (waiting for the work capability),
509 // this will do nothing.
510 startSchedulerTask();
517 #ifdef RTS_SUPPORTS_THREADS
518 RELEASE_LOCK(&sched_mutex);