1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.36 2002/08/16 14:30:21 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"
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)
237 ap = (StgClosure *)alloc(sizeofW(StgClosure) + 2);
238 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
240 ap->payload[1] = arg;
241 return (StgClosure *)ap;
244 /* ----------------------------------------------------------------------------
245 Deconstructing Haskell objects
246 ------------------------------------------------------------------------- */
249 rts_getChar (HaskellObj p)
251 if ( p->header.info == Czh_con_info ||
252 p->header.info == Czh_static_info) {
253 return (StgChar)(StgWord)(p->payload[0]);
255 barf("rts_getChar: not a Char");
260 rts_getInt (HaskellObj p)
263 p->header.info == Izh_con_info ||
264 p->header.info == Izh_static_info ) {
265 return (HsInt)(p->payload[0]);
267 barf("rts_getInt: not an Int");
272 rts_getInt8 (HaskellObj p)
275 p->header.info == I8zh_con_info ||
276 p->header.info == I8zh_static_info ) {
277 return (HsInt8)(HsInt)(p->payload[0]);
279 barf("rts_getInt8: not an Int8");
284 rts_getInt16 (HaskellObj p)
287 p->header.info == I16zh_con_info ||
288 p->header.info == I16zh_static_info ) {
289 return (HsInt16)(HsInt)(p->payload[0]);
291 barf("rts_getInt16: not an Int16");
296 rts_getInt32 (HaskellObj p)
299 p->header.info == I32zh_con_info ||
300 p->header.info == I32zh_static_info ) {
301 return (HsInt32)(p->payload[0]);
303 barf("rts_getInt32: not an Int32");
308 rts_getInt64 (HaskellObj p)
312 p->header.info == I64zh_con_info ||
313 p->header.info == I64zh_static_info ) {
314 tmp = (HsInt64*)&(p->payload[0]);
317 barf("rts_getInt64: not an Int64");
321 rts_getWord (HaskellObj p)
323 if ( 1 || /* see above comment */
324 p->header.info == Wzh_con_info ||
325 p->header.info == Wzh_static_info ) {
326 return (HsWord)(p->payload[0]);
328 barf("rts_getWord: not a Word");
333 rts_getWord8 (HaskellObj p)
335 if ( 1 || /* see above comment */
336 p->header.info == W8zh_con_info ||
337 p->header.info == W8zh_static_info ) {
338 return (HsWord8)(HsWord)(p->payload[0]);
340 barf("rts_getWord8: not a Word8");
345 rts_getWord16 (HaskellObj p)
347 if ( 1 || /* see above comment */
348 p->header.info == W16zh_con_info ||
349 p->header.info == W16zh_static_info ) {
350 return (HsWord16)(HsWord)(p->payload[0]);
352 barf("rts_getWord16: not a Word16");
357 rts_getWord32 (HaskellObj p)
359 if ( 1 || /* see above comment */
360 p->header.info == W32zh_con_info ||
361 p->header.info == W32zh_static_info ) {
362 return (unsigned int)(p->payload[0]);
364 barf("rts_getWord: not a Word");
370 rts_getWord64 (HaskellObj p)
373 if ( 1 || /* see above comment */
374 p->header.info == W64zh_con_info ||
375 p->header.info == W64zh_static_info ) {
376 tmp = (HsWord64*)&(p->payload[0]);
379 barf("rts_getWord64: not a Word64");
384 rts_getFloat (HaskellObj p)
386 if ( p->header.info == Fzh_con_info ||
387 p->header.info == Fzh_static_info ) {
388 return (float)(PK_FLT((P_)p->payload));
390 barf("rts_getFloat: not a Float");
395 rts_getDouble (HaskellObj p)
397 if ( p->header.info == Dzh_con_info ||
398 p->header.info == Dzh_static_info ) {
399 return (double)(PK_DBL((P_)p->payload));
401 barf("rts_getDouble: not a Double");
406 rts_getStablePtr (HaskellObj p)
408 if ( p->header.info == StablePtr_con_info ||
409 p->header.info == StablePtr_static_info ) {
410 return (StgStablePtr)(p->payload[0]);
412 barf("rts_getStablePtr: not a StablePtr");
417 rts_getPtr (HaskellObj p)
419 if ( p->header.info == Ptr_con_info ||
420 p->header.info == Ptr_static_info ) {
421 return (void *)(p->payload[0]);
423 barf("rts_getPtr: not an Ptr");
427 #ifdef COMPILER /* GHC has em, Hugs doesn't */
429 rts_getBool (HaskellObj p)
431 if (p == True_closure) {
433 } else if (p == False_closure) {
436 barf("rts_getBool: not a Bool");
439 #endif /* COMPILER */
441 /* ----------------------------------------------------------------------------
442 Evaluating Haskell expressions
443 ------------------------------------------------------------------------- */
445 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
449 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
451 return scheduleWaitThread(tso,ret);
455 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
459 tso = createGenThread(stack_size, p);
461 return scheduleWaitThread(tso,ret);
465 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
466 * result to WHNF before returning.
469 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
473 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
475 return scheduleWaitThread(tso,ret);
479 * Identical to rts_evalIO(), but won't create a new task/OS thread
480 * to evaluate the Haskell thread. Used by main() only. Hack.
483 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
487 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
490 return waitThread(tso, ret);
494 * rts_evalStableIO() is suitable for calling from Haskell. It
495 * evaluates a value of the form (StablePtr (IO a)), forcing the
496 * action's result to WHNF before returning. The result is returned
500 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
504 SchedulerStatus stat;
506 p = (StgClosure *)deRefStablePtr(s);
507 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
509 stat = scheduleWaitThread(tso,&r);
511 if (stat == Success) {
513 *ret = getStablePtr((StgPtr)r);
520 * Like rts_evalIO(), but doesn't force the action's result.
523 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
527 tso = createIOThread(stack_size, p);
529 return scheduleWaitThread(tso,ret);
532 /* Convenience function for decoding the returned status. */
535 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
541 barf("%s: uncaught exception",site);
543 barf("%s: interrupted", site);
545 barf("%s: Return code (%d) not ok",(site),(rc));