1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.37 2002/12/02 14:33:10 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
247 We would like to assert that we have the right kind of object in
248 each case, but this is problematic because in GHCi the info table
249 for the D# constructor (say) might be dynamically loaded. Hence we
250 omit these assertions for now.
251 ------------------------------------------------------------------------- */
254 rts_getChar (HaskellObj p)
256 // See comment above:
257 // ASSERT(p->header.info == Czh_con_info ||
258 // p->header.info == Czh_static_info);
259 return (StgChar)(StgWord)(p->payload[0]);
263 rts_getInt (HaskellObj p)
265 // See comment above:
266 // ASSERT(p->header.info == Izh_con_info ||
267 // p->header.info == Izh_static_info);
268 return (HsInt)(p->payload[0]);
272 rts_getInt8 (HaskellObj p)
274 // See comment above:
275 // ASSERT(p->header.info == I8zh_con_info ||
276 // p->header.info == I8zh_static_info);
277 return (HsInt8)(HsInt)(p->payload[0]);
281 rts_getInt16 (HaskellObj p)
283 // See comment above:
284 // ASSERT(p->header.info == I16zh_con_info ||
285 // p->header.info == I16zh_static_info);
286 return (HsInt16)(HsInt)(p->payload[0]);
290 rts_getInt32 (HaskellObj p)
292 // See comment above:
293 // ASSERT(p->header.info == I32zh_con_info ||
294 // p->header.info == I32zh_static_info);
295 return (HsInt32)(p->payload[0]);
299 rts_getInt64 (HaskellObj p)
302 // See comment above:
303 // ASSERT(p->header.info == I64zh_con_info ||
304 // p->header.info == I64zh_static_info);
305 tmp = (HsInt64*)&(p->payload[0]);
309 rts_getWord (HaskellObj p)
311 // See comment above:
312 // ASSERT(p->header.info == Wzh_con_info ||
313 // p->header.info == Wzh_static_info);
314 return (HsWord)(p->payload[0]);
318 rts_getWord8 (HaskellObj p)
320 // See comment above:
321 // ASSERT(p->header.info == W8zh_con_info ||
322 // p->header.info == W8zh_static_info);
323 return (HsWord8)(HsWord)(p->payload[0]);
327 rts_getWord16 (HaskellObj p)
329 // See comment above:
330 // ASSERT(p->header.info == W16zh_con_info ||
331 // p->header.info == W16zh_static_info);
332 return (HsWord16)(HsWord)(p->payload[0]);
336 rts_getWord32 (HaskellObj p)
338 // See comment above:
339 // ASSERT(p->header.info == W32zh_con_info ||
340 // p->header.info == W32zh_static_info);
341 return (HsWord32)(p->payload[0]);
346 rts_getWord64 (HaskellObj p)
349 // See comment above:
350 // ASSERT(p->header.info == W64zh_con_info ||
351 // p->header.info == W64zh_static_info);
352 tmp = (HsWord64*)&(p->payload[0]);
357 rts_getFloat (HaskellObj p)
359 // See comment above:
360 // ASSERT(p->header.info == Fzh_con_info ||
361 // p->header.info == Fzh_static_info);
362 return (float)(PK_FLT((P_)p->payload));
366 rts_getDouble (HaskellObj p)
368 // See comment above:
369 // ASSERT(p->header.info == Dzh_con_info ||
370 // p->header.info == Dzh_static_info);
371 return (double)(PK_DBL((P_)p->payload));
375 rts_getStablePtr (HaskellObj p)
377 // See comment above:
378 // ASSERT(p->header.info == StablePtr_con_info ||
379 // p->header.info == StablePtr_static_info);
380 return (StgStablePtr)(p->payload[0]);
384 rts_getPtr (HaskellObj p)
386 // See comment above:
387 // ASSERT(p->header.info == Ptr_con_info ||
388 // p->header.info == Ptr_static_info);
389 return (void *)(p->payload[0]);
392 #ifdef COMPILER /* GHC has em, Hugs doesn't */
394 rts_getBool (HaskellObj p)
396 if (p == True_closure) {
398 } else if (p == False_closure) {
401 barf("rts_getBool: not a Bool");
404 #endif /* COMPILER */
406 /* ----------------------------------------------------------------------------
407 Evaluating Haskell expressions
408 ------------------------------------------------------------------------- */
410 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
414 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
416 return scheduleWaitThread(tso,ret);
420 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
424 tso = createGenThread(stack_size, p);
426 return scheduleWaitThread(tso,ret);
430 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
431 * result to WHNF before returning.
434 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
438 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
440 return scheduleWaitThread(tso,ret);
444 * Identical to rts_evalIO(), but won't create a new task/OS thread
445 * to evaluate the Haskell thread. Used by main() only. Hack.
448 rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
452 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
455 return waitThread(tso, ret);
459 * rts_evalStableIO() is suitable for calling from Haskell. It
460 * evaluates a value of the form (StablePtr (IO a)), forcing the
461 * action's result to WHNF before returning. The result is returned
465 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
469 SchedulerStatus stat;
471 p = (StgClosure *)deRefStablePtr(s);
472 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
474 stat = scheduleWaitThread(tso,&r);
476 if (stat == Success) {
478 *ret = getStablePtr((StgPtr)r);
485 * Like rts_evalIO(), but doesn't force the action's result.
488 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
492 tso = createIOThread(stack_size, p);
494 return scheduleWaitThread(tso,ret);
497 /* Convenience function for decoding the returned status. */
500 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
506 barf("%s: uncaught exception",site);
508 barf("%s: interrupted", site);
510 barf("%s: Return code (%d) not ok",(site),(rc));