1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.34 2002/04/13 05:28:04 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)
23 #define WAIT_EXT_THREAD(tso,ret) waitThread_(tso,ret,rtsTrue)
25 #define WAIT_MAIN_THREAD(tso,ret) waitThread(tso,ret)
26 #define WAIT_EXT_THREAD(tso,ret) waitThread(tso,ret)
29 #if defined(RTS_SUPPORTS_THREADS)
30 /* Cheesy locking scheme while waiting for the
33 static Mutex alloc_mutex = INIT_MUTEX_VAR;
34 static Condition alloc_cond = INIT_COND_VAR;
35 #define INVALID_THREAD_ID ((OSThreadId)(-1))
37 /* Thread currently owning the allocator */
38 static OSThreadId c_id = INVALID_THREAD_ID;
40 static StgPtr alloc(nat n)
42 OSThreadId tid = osThreadId();
43 ACQUIRE_LOCK(&alloc_mutex);
45 /* I've got the lock, just allocate() */
47 } else if (c_id == INVALID_THREAD_ID) {
50 waitCondition(&alloc_cond, &alloc_mutex);
53 RELEASE_LOCK(&alloc_mutex);
57 static void releaseAllocLock(void)
59 ACQUIRE_LOCK(&alloc_mutex);
60 /* Reset the allocator owner */
61 c_id = INVALID_THREAD_ID;
62 RELEASE_LOCK(&alloc_mutex);
64 /* Free up an OS thread waiting to get in */
65 signalCondition(&alloc_cond);
68 # define alloc(n) allocate(n)
69 # define releaseAllocLock() /* nothing */
73 /* ----------------------------------------------------------------------------
74 Building Haskell objects from C datatypes.
75 ------------------------------------------------------------------------- */
79 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
80 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
81 p->payload[0] = (StgClosure *)(StgChar)c;
88 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
89 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
90 p->payload[0] = (StgClosure *)(StgInt)i;
97 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
98 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
99 /* Make sure we mask out the bits above the lowest 8 */
100 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
105 rts_mkInt16 (HsInt16 i)
107 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
108 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
109 /* Make sure we mask out the relevant bits */
110 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
115 rts_mkInt32 (HsInt32 i)
117 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
118 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
119 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
124 rts_mkInt64 (HsInt64 i)
127 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
128 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
129 tmp = (long long*)&(p->payload[0]);
135 rts_mkWord (HsWord i)
137 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
138 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
139 p->payload[0] = (StgClosure *)(StgWord)i;
144 rts_mkWord8 (HsWord8 w)
146 /* see rts_mkInt* comments */
147 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
148 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
149 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
154 rts_mkWord16 (HsWord16 w)
156 /* see rts_mkInt* comments */
157 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
158 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
159 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
164 rts_mkWord32 (HsWord32 w)
166 /* see rts_mkInt* comments */
167 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
168 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
169 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
174 rts_mkWord64 (HsWord64 w)
176 unsigned long long *tmp;
178 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
179 /* see mk_Int8 comment */
180 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
181 tmp = (unsigned long long*)&(p->payload[0]);
187 rts_mkFloat (HsFloat f)
189 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
190 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
191 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
196 rts_mkDouble (HsDouble d)
198 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,sizeofW(StgDouble)));
199 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
200 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
205 rts_mkStablePtr (HsStablePtr s)
207 StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
208 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
209 p->payload[0] = (StgClosure *)s;
216 StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
217 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
218 p->payload[0] = (StgClosure *)a;
222 #ifdef COMPILER /* GHC has em, Hugs doesn't */
224 rts_mkBool (HsBool b)
227 return (StgClosure *)True_closure;
229 return (StgClosure *)False_closure;
234 rts_mkString (char *s)
236 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
238 #endif /* COMPILER */
241 rts_apply (HaskellObj f, HaskellObj arg)
243 StgAP_UPD *ap = (StgAP_UPD *)alloc(AP_sizeW(1));
244 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM);
247 ap->payload[0] = arg;
248 return (StgClosure *)ap;
251 /* ----------------------------------------------------------------------------
252 Deconstructing Haskell objects
253 ------------------------------------------------------------------------- */
256 rts_getChar (HaskellObj p)
258 if ( p->header.info == Czh_con_info ||
259 p->header.info == Czh_static_info) {
260 return (StgChar)(StgWord)(p->payload[0]);
262 barf("rts_getChar: not a Char");
267 rts_getInt (HaskellObj p)
270 p->header.info == Izh_con_info ||
271 p->header.info == Izh_static_info ) {
272 return (HsInt)(p->payload[0]);
274 barf("rts_getInt: not an Int");
279 rts_getInt8 (HaskellObj p)
282 p->header.info == I8zh_con_info ||
283 p->header.info == I8zh_static_info ) {
284 return (HsInt8)(HsInt)(p->payload[0]);
286 barf("rts_getInt8: not an Int8");
291 rts_getInt16 (HaskellObj p)
294 p->header.info == I16zh_con_info ||
295 p->header.info == I16zh_static_info ) {
296 return (HsInt16)(HsInt)(p->payload[0]);
298 barf("rts_getInt16: not an Int16");
303 rts_getInt32 (HaskellObj p)
306 p->header.info == I32zh_con_info ||
307 p->header.info == I32zh_static_info ) {
308 return (HsInt32)(p->payload[0]);
310 barf("rts_getInt32: not an Int32");
315 rts_getInt64 (HaskellObj p)
319 p->header.info == I64zh_con_info ||
320 p->header.info == I64zh_static_info ) {
321 tmp = (HsInt64*)&(p->payload[0]);
324 barf("rts_getInt64: not an Int64");
328 rts_getWord (HaskellObj p)
330 if ( 1 || /* see above comment */
331 p->header.info == Wzh_con_info ||
332 p->header.info == Wzh_static_info ) {
333 return (HsWord)(p->payload[0]);
335 barf("rts_getWord: not a Word");
340 rts_getWord8 (HaskellObj p)
342 if ( 1 || /* see above comment */
343 p->header.info == W8zh_con_info ||
344 p->header.info == W8zh_static_info ) {
345 return (HsWord8)(HsWord)(p->payload[0]);
347 barf("rts_getWord8: not a Word8");
352 rts_getWord16 (HaskellObj p)
354 if ( 1 || /* see above comment */
355 p->header.info == W16zh_con_info ||
356 p->header.info == W16zh_static_info ) {
357 return (HsWord16)(HsWord)(p->payload[0]);
359 barf("rts_getWord16: not a Word16");
364 rts_getWord32 (HaskellObj p)
366 if ( 1 || /* see above comment */
367 p->header.info == W32zh_con_info ||
368 p->header.info == W32zh_static_info ) {
369 return (unsigned int)(p->payload[0]);
371 barf("rts_getWord: not a Word");
377 rts_getWord64 (HaskellObj p)
380 if ( 1 || /* see above comment */
381 p->header.info == W64zh_con_info ||
382 p->header.info == W64zh_static_info ) {
383 tmp = (HsWord64*)&(p->payload[0]);
386 barf("rts_getWord64: not a Word64");
391 rts_getFloat (HaskellObj p)
393 if ( p->header.info == Fzh_con_info ||
394 p->header.info == Fzh_static_info ) {
395 return (float)(PK_FLT((P_)p->payload));
397 barf("rts_getFloat: not a Float");
402 rts_getDouble (HaskellObj p)
404 if ( p->header.info == Dzh_con_info ||
405 p->header.info == Dzh_static_info ) {
406 return (double)(PK_DBL((P_)p->payload));
408 barf("rts_getDouble: not a Double");
413 rts_getStablePtr (HaskellObj p)
415 if ( p->header.info == StablePtr_con_info ||
416 p->header.info == StablePtr_static_info ) {
417 return (StgStablePtr)(p->payload[0]);
419 barf("rts_getStablePtr: not a StablePtr");
424 rts_getPtr (HaskellObj p)
426 if ( p->header.info == Ptr_con_info ||
427 p->header.info == Ptr_static_info ) {
428 return (void *)(p->payload[0]);
430 barf("rts_getPtr: not an Ptr");
434 #ifdef COMPILER /* GHC has em, Hugs doesn't */
436 rts_getBool (HaskellObj p)
438 if (p == True_closure) {
440 } else if (p == False_closure) {
443 barf("rts_getBool: not a Bool");
446 #endif /* COMPILER */
448 /* ----------------------------------------------------------------------------
449 Evaluating Haskell expressions
450 ------------------------------------------------------------------------- */
452 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
456 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
458 scheduleExtThread(tso);
459 return WAIT_EXT_THREAD(tso, ret);
463 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
467 tso = createGenThread(stack_size, p);
469 scheduleExtThread(tso);
470 return WAIT_EXT_THREAD(tso, ret);
474 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
475 * result to WHNF before returning.
478 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
482 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
484 scheduleExtThread(tso);
485 return WAIT_EXT_THREAD(tso, ret);
489 * Identical to rts_evalIO(), but won't create a new task/OS thread
490 * to evaluate the Haskell thread. Used by main() only. Hack.
493 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
497 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
500 return WAIT_MAIN_THREAD(tso, ret);
504 * rts_evalStableIO() is suitable for calling from Haskell. It
505 * evaluates a value of the form (StablePtr (IO a)), forcing the
506 * action's result to WHNF before returning. The result is returned
510 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
514 SchedulerStatus stat;
516 p = (StgClosure *)deRefStablePtr(s);
517 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
519 scheduleExtThread(tso);
520 stat = WAIT_EXT_THREAD(tso, &r);
522 if (stat == Success) {
524 *ret = getStablePtr((StgPtr)r);
531 * Like rts_evalIO(), but doesn't force the action's result.
534 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
538 tso = createIOThread(stack_size, p);
540 scheduleExtThread(tso);
541 return WAIT_EXT_THREAD(tso, ret);
544 /* Convenience function for decoding the returned status. */
547 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
553 barf("%s: uncaught exception",site);
555 barf("%s: interrupted", site);
557 barf("%s: Return code (%d) not ok",(site),(rc));