1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.35 2002/06/19 20:45:14 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(RTS_SUPPORTS_THREADS)
22 /* Cheesy locking scheme while waiting for the
25 static Mutex alloc_mutex = INIT_MUTEX_VAR;
26 static Condition alloc_cond = INIT_COND_VAR;
27 #define INVALID_THREAD_ID ((OSThreadId)(-1))
29 /* Thread currently owning the allocator */
30 static OSThreadId c_id = INVALID_THREAD_ID;
32 static StgPtr alloc(nat n)
34 OSThreadId tid = osThreadId();
35 ACQUIRE_LOCK(&alloc_mutex);
37 /* I've got the lock, just allocate() */
39 } else if (c_id == INVALID_THREAD_ID) {
42 waitCondition(&alloc_cond, &alloc_mutex);
45 RELEASE_LOCK(&alloc_mutex);
49 static void releaseAllocLock(void)
51 ACQUIRE_LOCK(&alloc_mutex);
52 /* Reset the allocator owner */
53 c_id = INVALID_THREAD_ID;
54 RELEASE_LOCK(&alloc_mutex);
56 /* Free up an OS thread waiting to get in */
57 signalCondition(&alloc_cond);
60 # define alloc(n) allocate(n)
61 # define releaseAllocLock() /* nothing */
65 /* ----------------------------------------------------------------------------
66 Building Haskell objects from C datatypes.
67 ------------------------------------------------------------------------- */
71 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
72 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
73 p->payload[0] = (StgClosure *)(StgChar)c;
80 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
81 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
82 p->payload[0] = (StgClosure *)(StgInt)i;
89 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
90 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
91 /* Make sure we mask out the bits above the lowest 8 */
92 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
97 rts_mkInt16 (HsInt16 i)
99 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
100 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
101 /* Make sure we mask out the relevant bits */
102 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
107 rts_mkInt32 (HsInt32 i)
109 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
110 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
111 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
116 rts_mkInt64 (HsInt64 i)
119 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
120 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
121 tmp = (long long*)&(p->payload[0]);
127 rts_mkWord (HsWord i)
129 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
130 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
131 p->payload[0] = (StgClosure *)(StgWord)i;
136 rts_mkWord8 (HsWord8 w)
138 /* see rts_mkInt* comments */
139 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
140 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
141 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
146 rts_mkWord16 (HsWord16 w)
148 /* see rts_mkInt* comments */
149 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
150 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
151 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
156 rts_mkWord32 (HsWord32 w)
158 /* see rts_mkInt* comments */
159 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
160 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
161 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
166 rts_mkWord64 (HsWord64 w)
168 unsigned long long *tmp;
170 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
171 /* see mk_Int8 comment */
172 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
173 tmp = (unsigned long long*)&(p->payload[0]);
179 rts_mkFloat (HsFloat f)
181 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
182 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
183 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
188 rts_mkDouble (HsDouble d)
190 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,sizeofW(StgDouble)));
191 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
192 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
197 rts_mkStablePtr (HsStablePtr s)
199 StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
200 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
201 p->payload[0] = (StgClosure *)s;
208 StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
209 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
210 p->payload[0] = (StgClosure *)a;
214 #ifdef COMPILER /* GHC has em, Hugs doesn't */
216 rts_mkBool (HsBool b)
219 return (StgClosure *)True_closure;
221 return (StgClosure *)False_closure;
226 rts_mkString (char *s)
228 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
230 #endif /* COMPILER */
233 rts_apply (HaskellObj f, HaskellObj arg)
235 StgAP_UPD *ap = (StgAP_UPD *)alloc(AP_sizeW(1));
236 SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM);
239 ap->payload[0] = arg;
240 return (StgClosure *)ap;
243 /* ----------------------------------------------------------------------------
244 Deconstructing Haskell objects
245 ------------------------------------------------------------------------- */
248 rts_getChar (HaskellObj p)
250 if ( p->header.info == Czh_con_info ||
251 p->header.info == Czh_static_info) {
252 return (StgChar)(StgWord)(p->payload[0]);
254 barf("rts_getChar: not a Char");
259 rts_getInt (HaskellObj p)
262 p->header.info == Izh_con_info ||
263 p->header.info == Izh_static_info ) {
264 return (HsInt)(p->payload[0]);
266 barf("rts_getInt: not an Int");
271 rts_getInt8 (HaskellObj p)
274 p->header.info == I8zh_con_info ||
275 p->header.info == I8zh_static_info ) {
276 return (HsInt8)(HsInt)(p->payload[0]);
278 barf("rts_getInt8: not an Int8");
283 rts_getInt16 (HaskellObj p)
286 p->header.info == I16zh_con_info ||
287 p->header.info == I16zh_static_info ) {
288 return (HsInt16)(HsInt)(p->payload[0]);
290 barf("rts_getInt16: not an Int16");
295 rts_getInt32 (HaskellObj p)
298 p->header.info == I32zh_con_info ||
299 p->header.info == I32zh_static_info ) {
300 return (HsInt32)(p->payload[0]);
302 barf("rts_getInt32: not an Int32");
307 rts_getInt64 (HaskellObj p)
311 p->header.info == I64zh_con_info ||
312 p->header.info == I64zh_static_info ) {
313 tmp = (HsInt64*)&(p->payload[0]);
316 barf("rts_getInt64: not an Int64");
320 rts_getWord (HaskellObj p)
322 if ( 1 || /* see above comment */
323 p->header.info == Wzh_con_info ||
324 p->header.info == Wzh_static_info ) {
325 return (HsWord)(p->payload[0]);
327 barf("rts_getWord: not a Word");
332 rts_getWord8 (HaskellObj p)
334 if ( 1 || /* see above comment */
335 p->header.info == W8zh_con_info ||
336 p->header.info == W8zh_static_info ) {
337 return (HsWord8)(HsWord)(p->payload[0]);
339 barf("rts_getWord8: not a Word8");
344 rts_getWord16 (HaskellObj p)
346 if ( 1 || /* see above comment */
347 p->header.info == W16zh_con_info ||
348 p->header.info == W16zh_static_info ) {
349 return (HsWord16)(HsWord)(p->payload[0]);
351 barf("rts_getWord16: not a Word16");
356 rts_getWord32 (HaskellObj p)
358 if ( 1 || /* see above comment */
359 p->header.info == W32zh_con_info ||
360 p->header.info == W32zh_static_info ) {
361 return (unsigned int)(p->payload[0]);
363 barf("rts_getWord: not a Word");
369 rts_getWord64 (HaskellObj p)
372 if ( 1 || /* see above comment */
373 p->header.info == W64zh_con_info ||
374 p->header.info == W64zh_static_info ) {
375 tmp = (HsWord64*)&(p->payload[0]);
378 barf("rts_getWord64: not a Word64");
383 rts_getFloat (HaskellObj p)
385 if ( p->header.info == Fzh_con_info ||
386 p->header.info == Fzh_static_info ) {
387 return (float)(PK_FLT((P_)p->payload));
389 barf("rts_getFloat: not a Float");
394 rts_getDouble (HaskellObj p)
396 if ( p->header.info == Dzh_con_info ||
397 p->header.info == Dzh_static_info ) {
398 return (double)(PK_DBL((P_)p->payload));
400 barf("rts_getDouble: not a Double");
405 rts_getStablePtr (HaskellObj p)
407 if ( p->header.info == StablePtr_con_info ||
408 p->header.info == StablePtr_static_info ) {
409 return (StgStablePtr)(p->payload[0]);
411 barf("rts_getStablePtr: not a StablePtr");
416 rts_getPtr (HaskellObj p)
418 if ( p->header.info == Ptr_con_info ||
419 p->header.info == Ptr_static_info ) {
420 return (void *)(p->payload[0]);
422 barf("rts_getPtr: not an Ptr");
426 #ifdef COMPILER /* GHC has em, Hugs doesn't */
428 rts_getBool (HaskellObj p)
430 if (p == True_closure) {
432 } else if (p == False_closure) {
435 barf("rts_getBool: not a Bool");
438 #endif /* COMPILER */
440 /* ----------------------------------------------------------------------------
441 Evaluating Haskell expressions
442 ------------------------------------------------------------------------- */
444 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
448 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
450 return scheduleWaitThread(tso,ret);
454 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
458 tso = createGenThread(stack_size, p);
460 return scheduleWaitThread(tso,ret);
464 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
465 * result to WHNF before returning.
468 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
472 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
474 return scheduleWaitThread(tso,ret);
478 * Identical to rts_evalIO(), but won't create a new task/OS thread
479 * to evaluate the Haskell thread. Used by main() only. Hack.
482 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
486 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
489 return waitThread(tso, ret);
493 * rts_evalStableIO() is suitable for calling from Haskell. It
494 * evaluates a value of the form (StablePtr (IO a)), forcing the
495 * action's result to WHNF before returning. The result is returned
499 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
503 SchedulerStatus stat;
505 p = (StgClosure *)deRefStablePtr(s);
506 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
508 stat = scheduleWaitThread(tso,&r);
510 if (stat == Success) {
512 *ret = getStablePtr((StgPtr)r);
519 * Like rts_evalIO(), but doesn't force the action's result.
522 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
526 tso = createIOThread(stack_size, p);
528 return scheduleWaitThread(tso,ret);
531 /* Convenience function for decoding the returned status. */
534 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
540 barf("%s: uncaught exception",site);
542 barf("%s: interrupted", site);
544 barf("%s: Return code (%d) not ok",(site),(rc));