1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.38 2002/12/11 15:36:47 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"
23 #if defined(RTS_SUPPORTS_THREADS)
24 /* Cheesy locking scheme while waiting for the
27 static Mutex alloc_mutex = INIT_MUTEX_VAR;
28 static Condition alloc_cond = INIT_COND_VAR;
29 #define INVALID_THREAD_ID ((OSThreadId)(-1))
31 /* Thread currently owning the allocator */
32 static OSThreadId c_id = INVALID_THREAD_ID;
34 static StgPtr alloc(nat n)
36 OSThreadId tid = osThreadId();
37 ACQUIRE_LOCK(&alloc_mutex);
39 /* I've got the lock, just allocate() */
41 } else if (c_id == INVALID_THREAD_ID) {
44 waitCondition(&alloc_cond, &alloc_mutex);
47 RELEASE_LOCK(&alloc_mutex);
51 static void releaseAllocLock(void)
53 ACQUIRE_LOCK(&alloc_mutex);
54 /* Reset the allocator owner */
55 c_id = INVALID_THREAD_ID;
56 RELEASE_LOCK(&alloc_mutex);
58 /* Free up an OS thread waiting to get in */
59 signalCondition(&alloc_cond);
62 # define alloc(n) allocate(n)
63 # define releaseAllocLock() /* nothing */
67 /* ----------------------------------------------------------------------------
68 Building Haskell objects from C datatypes.
69 ------------------------------------------------------------------------- */
73 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
74 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
75 p->payload[0] = (StgClosure *)(StgChar)c;
82 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
83 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
84 p->payload[0] = (StgClosure *)(StgInt)i;
91 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
92 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
93 /* Make sure we mask out the bits above the lowest 8 */
94 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
99 rts_mkInt16 (HsInt16 i)
101 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
102 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
103 /* Make sure we mask out the relevant bits */
104 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
109 rts_mkInt32 (HsInt32 i)
111 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
112 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
113 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
118 rts_mkInt64 (HsInt64 i)
121 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
122 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
123 tmp = (long long*)&(p->payload[0]);
129 rts_mkWord (HsWord i)
131 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
132 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
133 p->payload[0] = (StgClosure *)(StgWord)i;
138 rts_mkWord8 (HsWord8 w)
140 /* see rts_mkInt* comments */
141 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
142 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
143 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
148 rts_mkWord16 (HsWord16 w)
150 /* see rts_mkInt* comments */
151 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
152 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
153 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
158 rts_mkWord32 (HsWord32 w)
160 /* see rts_mkInt* comments */
161 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
162 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
163 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
168 rts_mkWord64 (HsWord64 w)
170 unsigned long long *tmp;
172 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2));
173 /* see mk_Int8 comment */
174 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
175 tmp = (unsigned long long*)&(p->payload[0]);
181 rts_mkFloat (HsFloat f)
183 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1));
184 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
185 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
190 rts_mkDouble (HsDouble d)
192 StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,sizeofW(StgDouble)));
193 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
194 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
199 rts_mkStablePtr (HsStablePtr s)
201 StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
202 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
203 p->payload[0] = (StgClosure *)s;
210 StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1);
211 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
212 p->payload[0] = (StgClosure *)a;
216 #ifdef COMPILER /* GHC has em, Hugs doesn't */
218 rts_mkBool (HsBool b)
221 return (StgClosure *)True_closure;
223 return (StgClosure *)False_closure;
228 rts_mkString (char *s)
230 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
232 #endif /* COMPILER */
235 rts_apply (HaskellObj f, HaskellObj arg)
239 ap = (StgClosure *)alloc(sizeofW(StgClosure) + 2);
240 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
242 ap->payload[1] = arg;
243 return (StgClosure *)ap;
246 /* ----------------------------------------------------------------------------
247 Deconstructing Haskell objects
249 We would like to assert that we have the right kind of object in
250 each case, but this is problematic because in GHCi the info table
251 for the D# constructor (say) might be dynamically loaded. Hence we
252 omit these assertions for now.
253 ------------------------------------------------------------------------- */
256 rts_getChar (HaskellObj p)
258 // See comment above:
259 // ASSERT(p->header.info == Czh_con_info ||
260 // p->header.info == Czh_static_info);
261 return (StgChar)(StgWord)(p->payload[0]);
265 rts_getInt (HaskellObj p)
267 // See comment above:
268 // ASSERT(p->header.info == Izh_con_info ||
269 // p->header.info == Izh_static_info);
270 return (HsInt)(p->payload[0]);
274 rts_getInt8 (HaskellObj p)
276 // See comment above:
277 // ASSERT(p->header.info == I8zh_con_info ||
278 // p->header.info == I8zh_static_info);
279 return (HsInt8)(HsInt)(p->payload[0]);
283 rts_getInt16 (HaskellObj p)
285 // See comment above:
286 // ASSERT(p->header.info == I16zh_con_info ||
287 // p->header.info == I16zh_static_info);
288 return (HsInt16)(HsInt)(p->payload[0]);
292 rts_getInt32 (HaskellObj p)
294 // See comment above:
295 // ASSERT(p->header.info == I32zh_con_info ||
296 // p->header.info == I32zh_static_info);
297 return (HsInt32)(p->payload[0]);
301 rts_getInt64 (HaskellObj p)
304 // See comment above:
305 // ASSERT(p->header.info == I64zh_con_info ||
306 // p->header.info == I64zh_static_info);
307 tmp = (HsInt64*)&(p->payload[0]);
311 rts_getWord (HaskellObj p)
313 // See comment above:
314 // ASSERT(p->header.info == Wzh_con_info ||
315 // p->header.info == Wzh_static_info);
316 return (HsWord)(p->payload[0]);
320 rts_getWord8 (HaskellObj p)
322 // See comment above:
323 // ASSERT(p->header.info == W8zh_con_info ||
324 // p->header.info == W8zh_static_info);
325 return (HsWord8)(HsWord)(p->payload[0]);
329 rts_getWord16 (HaskellObj p)
331 // See comment above:
332 // ASSERT(p->header.info == W16zh_con_info ||
333 // p->header.info == W16zh_static_info);
334 return (HsWord16)(HsWord)(p->payload[0]);
338 rts_getWord32 (HaskellObj p)
340 // See comment above:
341 // ASSERT(p->header.info == W32zh_con_info ||
342 // p->header.info == W32zh_static_info);
343 return (HsWord32)(p->payload[0]);
348 rts_getWord64 (HaskellObj p)
351 // See comment above:
352 // ASSERT(p->header.info == W64zh_con_info ||
353 // p->header.info == W64zh_static_info);
354 tmp = (HsWord64*)&(p->payload[0]);
359 rts_getFloat (HaskellObj p)
361 // See comment above:
362 // ASSERT(p->header.info == Fzh_con_info ||
363 // p->header.info == Fzh_static_info);
364 return (float)(PK_FLT((P_)p->payload));
368 rts_getDouble (HaskellObj p)
370 // See comment above:
371 // ASSERT(p->header.info == Dzh_con_info ||
372 // p->header.info == Dzh_static_info);
373 return (double)(PK_DBL((P_)p->payload));
377 rts_getStablePtr (HaskellObj p)
379 // See comment above:
380 // ASSERT(p->header.info == StablePtr_con_info ||
381 // p->header.info == StablePtr_static_info);
382 return (StgStablePtr)(p->payload[0]);
386 rts_getPtr (HaskellObj p)
388 // See comment above:
389 // ASSERT(p->header.info == Ptr_con_info ||
390 // p->header.info == Ptr_static_info);
391 return (void *)(p->payload[0]);
394 #ifdef COMPILER /* GHC has em, Hugs doesn't */
396 rts_getBool (HaskellObj p)
398 if (p == True_closure) {
400 } else if (p == False_closure) {
403 barf("rts_getBool: not a Bool");
406 #endif /* COMPILER */
408 /* ----------------------------------------------------------------------------
409 Evaluating Haskell expressions
410 ------------------------------------------------------------------------- */
412 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
416 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
418 return scheduleWaitThread(tso,ret);
422 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
426 tso = createGenThread(stack_size, p);
428 return scheduleWaitThread(tso,ret);
432 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
433 * result to WHNF before returning.
436 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
440 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
442 return scheduleWaitThread(tso,ret);
446 * Identical to rts_evalIO(), but won't create a new task/OS thread
447 * to evaluate the Haskell thread. Used by main() only. Hack.
450 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
454 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
457 return waitThread(tso, ret);
461 * rts_evalStableIO() is suitable for calling from Haskell. It
462 * evaluates a value of the form (StablePtr (IO a)), forcing the
463 * action's result to WHNF before returning. The result is returned
467 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
471 SchedulerStatus stat;
473 p = (StgClosure *)deRefStablePtr(s);
474 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
476 stat = scheduleWaitThread(tso,&r);
478 if (stat == Success) {
480 *ret = getStablePtr((StgPtr)r);
487 * Like rts_evalIO(), but doesn't force the action's result.
490 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
494 tso = createIOThread(stack_size, p);
496 return scheduleWaitThread(tso,ret);
499 /* Convenience function for decoding the returned status. */
502 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
508 prog_belch("%s: uncaught exception",site);
509 stg_exit(EXIT_FAILURE);
511 prog_belch("%s: interrupted", site);
512 stg_exit(EXIT_FAILURE);
514 prog_belch("%s: Return code (%d) not ok",(site),(rc));
515 stg_exit(EXIT_FAILURE);