1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.33 2002/02/15 07:40:10 sof 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"
21 #if defined(THREADED_RTS)
22 #define WAIT_MAIN_THREAD(tso,ret) waitThread_(tso,ret,rtsFalse)
24 #define WAIT_MAIN_THREAD(tso,ret) waitThread(tso,ret)
27 #if defined(RTS_SUPPORTS_THREADS)
28 /* Cheesy locking scheme while waiting for the
31 static Mutex alloc_mutex = INIT_MUTEX_VAR;
32 static Condition alloc_cond = INIT_COND_VAR;
33 #define INVALID_THREAD_ID ((OSThreadId)(-1))
35 /* Thread currently owning the allocator */
36 static OSThreadId c_id = INVALID_THREAD_ID;
38 static StgPtr alloc(nat n)
40 OSThreadId tid = osThreadId();
41 ACQUIRE_LOCK(&alloc_mutex);
43 /* I've got the lock, just allocate() */
45 } else if (c_id == INVALID_THREAD_ID) {
48 waitCondition(&alloc_cond, &alloc_mutex);
51 RELEASE_LOCK(&alloc_mutex);
55 static void releaseAllocLock(void)
57 ACQUIRE_LOCK(&alloc_mutex);
58 /* Reset the allocator owner */
59 c_id = INVALID_THREAD_ID;
60 RELEASE_LOCK(&alloc_mutex);
62 /* Free up an OS thread waiting to get in */
63 signalCondition(&alloc_cond);
66 # define alloc(n) allocate(n)
67 # define releaseAllocLock() /* nothing */
71 /* ----------------------------------------------------------------------------
72 Building Haskell objects from C datatypes.
73 ------------------------------------------------------------------------- */
77 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
78 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
79 p->payload[0] = (StgClosure *)(StgChar)c;
86 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
87 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
88 p->payload[0] = (StgClosure *)(StgInt)i;
95 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
96 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
97 /* Make sure we mask out the bits above the lowest 8 */
98 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
103 rts_mkInt16 (HsInt16 i)
105 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
106 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
107 /* Make sure we mask out the relevant bits */
108 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
113 rts_mkInt32 (HsInt32 i)
115 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
116 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
117 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
122 rts_mkInt64 (HsInt64 i)
125 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
126 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
127 tmp = (long long*)&(p->payload[0]);
133 rts_mkWord (HsWord i)
135 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
136 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
137 p->payload[0] = (StgClosure *)(StgWord)i;
142 rts_mkWord8 (HsWord8 w)
144 /* see rts_mkInt* comments */
145 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
146 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
147 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
152 rts_mkWord16 (HsWord16 w)
154 /* see rts_mkInt* comments */
155 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
156 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
157 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
162 rts_mkWord32 (HsWord32 w)
164 /* see rts_mkInt* comments */
165 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
166 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
167 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
172 rts_mkWord64 (HsWord64 w)
174 unsigned long long *tmp;
176 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
177 /* see mk_Int8 comment */
178 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
179 tmp = (unsigned long long*)&(p->payload[0]);
185 rts_mkFloat (HsFloat f)
187 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
188 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
189 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
194 rts_mkDouble (HsDouble d)
196 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,sizeofW(StgDouble)));
197 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
198 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
203 rts_mkStablePtr (HsStablePtr s)
205 StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
206 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
207 p->payload[0] = (StgClosure *)s;
214 StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
215 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
216 p->payload[0] = (StgClosure *)a;
220 #ifdef COMPILER /* GHC has em, Hugs doesn't */
222 rts_mkBool (HsBool b)
225 return (StgClosure *)True_closure;
227 return (StgClosure *)False_closure;
232 rts_mkString (char *s)
234 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
236 #endif /* COMPILER */
239 rts_apply (HaskellObj f, HaskellObj arg)
241 StgAP_UPD *ap = (StgAP_UPD *)alloc(AP_sizeW(1));
242 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM);
245 ap->payload[0] = arg;
246 return (StgClosure *)ap;
249 /* ----------------------------------------------------------------------------
250 Deconstructing Haskell objects
251 ------------------------------------------------------------------------- */
254 rts_getChar (HaskellObj p)
256 if ( p->header.info == Czh_con_info ||
257 p->header.info == Czh_static_info) {
258 return (StgChar)(StgWord)(p->payload[0]);
260 barf("rts_getChar: not a Char");
265 rts_getInt (HaskellObj p)
268 p->header.info == Izh_con_info ||
269 p->header.info == Izh_static_info ) {
270 return (HsInt)(p->payload[0]);
272 barf("rts_getInt: not an Int");
277 rts_getInt8 (HaskellObj p)
280 p->header.info == I8zh_con_info ||
281 p->header.info == I8zh_static_info ) {
282 return (HsInt8)(HsInt)(p->payload[0]);
284 barf("rts_getInt8: not an Int8");
289 rts_getInt16 (HaskellObj p)
292 p->header.info == I16zh_con_info ||
293 p->header.info == I16zh_static_info ) {
294 return (HsInt16)(HsInt)(p->payload[0]);
296 barf("rts_getInt16: not an Int16");
301 rts_getInt32 (HaskellObj p)
304 p->header.info == I32zh_con_info ||
305 p->header.info == I32zh_static_info ) {
306 return (HsInt32)(p->payload[0]);
308 barf("rts_getInt32: not an Int32");
313 rts_getInt64 (HaskellObj p)
317 p->header.info == I64zh_con_info ||
318 p->header.info == I64zh_static_info ) {
319 tmp = (HsInt64*)&(p->payload[0]);
322 barf("rts_getInt64: not an Int64");
326 rts_getWord (HaskellObj p)
328 if ( 1 || /* see above comment */
329 p->header.info == Wzh_con_info ||
330 p->header.info == Wzh_static_info ) {
331 return (HsWord)(p->payload[0]);
333 barf("rts_getWord: not a Word");
338 rts_getWord8 (HaskellObj p)
340 if ( 1 || /* see above comment */
341 p->header.info == W8zh_con_info ||
342 p->header.info == W8zh_static_info ) {
343 return (HsWord8)(HsWord)(p->payload[0]);
345 barf("rts_getWord8: not a Word8");
350 rts_getWord16 (HaskellObj p)
352 if ( 1 || /* see above comment */
353 p->header.info == W16zh_con_info ||
354 p->header.info == W16zh_static_info ) {
355 return (HsWord16)(HsWord)(p->payload[0]);
357 barf("rts_getWord16: not a Word16");
362 rts_getWord32 (HaskellObj p)
364 if ( 1 || /* see above comment */
365 p->header.info == W32zh_con_info ||
366 p->header.info == W32zh_static_info ) {
367 return (unsigned int)(p->payload[0]);
369 barf("rts_getWord: not a Word");
375 rts_getWord64 (HaskellObj p)
378 if ( 1 || /* see above comment */
379 p->header.info == W64zh_con_info ||
380 p->header.info == W64zh_static_info ) {
381 tmp = (HsWord64*)&(p->payload[0]);
384 barf("rts_getWord64: not a Word64");
389 rts_getFloat (HaskellObj p)
391 if ( p->header.info == Fzh_con_info ||
392 p->header.info == Fzh_static_info ) {
393 return (float)(PK_FLT((P_)p->payload));
395 barf("rts_getFloat: not a Float");
400 rts_getDouble (HaskellObj p)
402 if ( p->header.info == Dzh_con_info ||
403 p->header.info == Dzh_static_info ) {
404 return (double)(PK_DBL((P_)p->payload));
406 barf("rts_getDouble: not a Double");
411 rts_getStablePtr (HaskellObj p)
413 if ( p->header.info == StablePtr_con_info ||
414 p->header.info == StablePtr_static_info ) {
415 return (StgStablePtr)(p->payload[0]);
417 barf("rts_getStablePtr: not a StablePtr");
422 rts_getPtr (HaskellObj p)
424 if ( p->header.info == Ptr_con_info ||
425 p->header.info == Ptr_static_info ) {
426 return (void *)(p->payload[0]);
428 barf("rts_getPtr: not an Ptr");
432 #ifdef COMPILER /* GHC has em, Hugs doesn't */
434 rts_getBool (HaskellObj p)
436 if (p == True_closure) {
438 } else if (p == False_closure) {
441 barf("rts_getBool: not a Bool");
444 #endif /* COMPILER */
446 /* ----------------------------------------------------------------------------
447 Evaluating Haskell expressions
448 ------------------------------------------------------------------------- */
450 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
454 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
456 scheduleExtThread(tso);
457 return waitThread(tso, ret);
461 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
465 tso = createGenThread(stack_size, p);
467 scheduleExtThread(tso);
468 return waitThread(tso, ret);
472 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
473 * result to WHNF before returning.
476 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
480 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
482 scheduleExtThread(tso);
483 return waitThread(tso, ret);
487 * Identical to rts_evalIO(), but won't create a new task/OS thread
488 * to evaluate the Haskell thread. Used by main() only. Hack.
491 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
495 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
498 return WAIT_MAIN_THREAD(tso, ret);
502 * rts_evalStableIO() is suitable for calling from Haskell. It
503 * evaluates a value of the form (StablePtr (IO a)), forcing the
504 * action's result to WHNF before returning. The result is returned
508 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
512 SchedulerStatus stat;
514 p = (StgClosure *)deRefStablePtr(s);
515 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
517 scheduleExtThread(tso);
518 stat = waitThread(tso, &r);
520 if (stat == Success) {
522 *ret = getStablePtr((StgPtr)r);
529 * Like rts_evalIO(), but doesn't force the action's result.
532 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
536 tso = createIOThread(stack_size, p);
538 scheduleExtThread(tso);
539 return waitThread(tso, ret);
542 /* Convenience function for decoding the returned status. */
545 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
551 barf("%s: uncaught exception",site);
553 barf("%s: interrupted", site);
555 barf("%s: Return code (%d) not ok",(site),(rc));