1 /* ----------------------------------------------------------------------------
3 * (c) The GHC Team, 1998-2001
5 * API for invoking Haskell functions via the RTS
7 * --------------------------------------------------------------------------*/
9 #include "PosixSource.h"
11 #include "OSThreads.h"
19 #include "Capability.h"
23 static Capability *rtsApiCapability = NULL;
25 /* ----------------------------------------------------------------------------
26 Building Haskell objects from C datatypes.
27 ------------------------------------------------------------------------- */
31 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
32 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
33 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
40 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
41 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
42 p->payload[0] = (StgClosure *)(StgInt)i;
49 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
50 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
51 /* Make sure we mask out the bits above the lowest 8 */
52 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
57 rts_mkInt16 (HsInt16 i)
59 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
60 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
61 /* Make sure we mask out the relevant bits */
62 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
67 rts_mkInt32 (HsInt32 i)
69 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
70 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
71 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
76 rts_mkInt64 (HsInt64 i)
79 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
80 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
81 tmp = (llong*)&(p->payload[0]);
89 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
90 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
91 p->payload[0] = (StgClosure *)(StgWord)i;
96 rts_mkWord8 (HsWord8 w)
98 /* see rts_mkInt* comments */
99 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
100 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
101 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
106 rts_mkWord16 (HsWord16 w)
108 /* see rts_mkInt* comments */
109 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
110 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
111 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
116 rts_mkWord32 (HsWord32 w)
118 /* see rts_mkInt* comments */
119 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
120 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
121 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
126 rts_mkWord64 (HsWord64 w)
130 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
131 /* see mk_Int8 comment */
132 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
133 tmp = (ullong*)&(p->payload[0]);
139 rts_mkFloat (HsFloat f)
141 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
142 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
143 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
148 rts_mkDouble (HsDouble d)
150 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
151 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
152 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
157 rts_mkStablePtr (HsStablePtr s)
159 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
160 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
161 p->payload[0] = (StgClosure *)s;
168 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
169 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
170 p->payload[0] = (StgClosure *)a;
175 rts_mkFunPtr (HsFunPtr a)
177 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
178 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
179 p->payload[0] = (StgClosure *)a;
184 rts_mkBool (HsBool b)
187 return (StgClosure *)True_closure;
189 return (StgClosure *)False_closure;
194 rts_mkString (char *s)
196 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
200 rts_apply (HaskellObj f, HaskellObj arg)
204 ap = (StgThunk *)allocate(sizeofW(StgThunk) + 2);
205 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
207 ap->payload[1] = arg;
208 return (StgClosure *)ap;
211 /* ----------------------------------------------------------------------------
212 Deconstructing Haskell objects
214 We would like to assert that we have the right kind of object in
215 each case, but this is problematic because in GHCi the info table
216 for the D# constructor (say) might be dynamically loaded. Hence we
217 omit these assertions for now.
218 ------------------------------------------------------------------------- */
221 rts_getChar (HaskellObj p)
223 // See comment above:
224 // ASSERT(p->header.info == Czh_con_info ||
225 // p->header.info == Czh_static_info);
226 return (StgChar)(StgWord)(p->payload[0]);
230 rts_getInt (HaskellObj p)
232 // See comment above:
233 // ASSERT(p->header.info == Izh_con_info ||
234 // p->header.info == Izh_static_info);
235 return (HsInt)(p->payload[0]);
239 rts_getInt8 (HaskellObj p)
241 // See comment above:
242 // ASSERT(p->header.info == I8zh_con_info ||
243 // p->header.info == I8zh_static_info);
244 return (HsInt8)(HsInt)(p->payload[0]);
248 rts_getInt16 (HaskellObj p)
250 // See comment above:
251 // ASSERT(p->header.info == I16zh_con_info ||
252 // p->header.info == I16zh_static_info);
253 return (HsInt16)(HsInt)(p->payload[0]);
257 rts_getInt32 (HaskellObj p)
259 // See comment above:
260 // ASSERT(p->header.info == I32zh_con_info ||
261 // p->header.info == I32zh_static_info);
262 return (HsInt32)(HsInt)(p->payload[0]);
266 rts_getInt64 (HaskellObj p)
269 // See comment above:
270 // ASSERT(p->header.info == I64zh_con_info ||
271 // p->header.info == I64zh_static_info);
272 tmp = (HsInt64*)&(p->payload[0]);
276 rts_getWord (HaskellObj p)
278 // See comment above:
279 // ASSERT(p->header.info == Wzh_con_info ||
280 // p->header.info == Wzh_static_info);
281 return (HsWord)(p->payload[0]);
285 rts_getWord8 (HaskellObj p)
287 // See comment above:
288 // ASSERT(p->header.info == W8zh_con_info ||
289 // p->header.info == W8zh_static_info);
290 return (HsWord8)(HsWord)(p->payload[0]);
294 rts_getWord16 (HaskellObj p)
296 // See comment above:
297 // ASSERT(p->header.info == W16zh_con_info ||
298 // p->header.info == W16zh_static_info);
299 return (HsWord16)(HsWord)(p->payload[0]);
303 rts_getWord32 (HaskellObj p)
305 // See comment above:
306 // ASSERT(p->header.info == W32zh_con_info ||
307 // p->header.info == W32zh_static_info);
308 return (HsWord32)(HsWord)(p->payload[0]);
313 rts_getWord64 (HaskellObj p)
316 // See comment above:
317 // ASSERT(p->header.info == W64zh_con_info ||
318 // p->header.info == W64zh_static_info);
319 tmp = (HsWord64*)&(p->payload[0]);
324 rts_getFloat (HaskellObj p)
326 // See comment above:
327 // ASSERT(p->header.info == Fzh_con_info ||
328 // p->header.info == Fzh_static_info);
329 return (float)(PK_FLT((P_)p->payload));
333 rts_getDouble (HaskellObj p)
335 // See comment above:
336 // ASSERT(p->header.info == Dzh_con_info ||
337 // p->header.info == Dzh_static_info);
338 return (double)(PK_DBL((P_)p->payload));
342 rts_getStablePtr (HaskellObj p)
344 // See comment above:
345 // ASSERT(p->header.info == StablePtr_con_info ||
346 // p->header.info == StablePtr_static_info);
347 return (StgStablePtr)(p->payload[0]);
351 rts_getPtr (HaskellObj p)
353 // See comment above:
354 // ASSERT(p->header.info == Ptr_con_info ||
355 // p->header.info == Ptr_static_info);
356 return (void *)(p->payload[0]);
360 rts_getFunPtr (HaskellObj p)
362 // See comment above:
363 // ASSERT(p->header.info == FunPtr_con_info ||
364 // p->header.info == FunPtr_static_info);
365 return (void *)(p->payload[0]);
369 rts_getBool (HaskellObj p)
373 info = get_itbl((StgClosure *)p);
374 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
381 /* ----------------------------------------------------------------------------
382 Evaluating Haskell expressions
383 ------------------------------------------------------------------------- */
385 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
388 Capability *cap = rtsApiCapability;
389 rtsApiCapability = NULL;
391 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
392 return scheduleWaitThread(tso,ret,cap);
396 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
399 Capability *cap = rtsApiCapability;
400 rtsApiCapability = NULL;
402 tso = createGenThread(stack_size, p);
403 return scheduleWaitThread(tso,ret,cap);
407 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
408 * result to WHNF before returning.
411 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
414 Capability *cap = rtsApiCapability;
415 rtsApiCapability = NULL;
417 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
418 return scheduleWaitThread(tso,ret,cap);
422 * rts_evalStableIO() is suitable for calling from Haskell. It
423 * evaluates a value of the form (StablePtr (IO a)), forcing the
424 * action's result to WHNF before returning. The result is returned
428 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
432 SchedulerStatus stat;
433 Capability *cap = rtsApiCapability;
434 rtsApiCapability = NULL;
436 p = (StgClosure *)deRefStablePtr(s);
437 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
438 stat = scheduleWaitThread(tso,&r,cap);
440 if (stat == Success && ret != NULL) {
442 *ret = getStablePtr((StgPtr)r);
449 * Like rts_evalIO(), but doesn't force the action's result.
452 rts_evalLazyIO (HaskellObj p, /*out*/HaskellObj *ret)
455 Capability *cap = rtsApiCapability;
456 rtsApiCapability = NULL;
458 tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
459 return scheduleWaitThread(tso,ret,cap);
463 rts_evalLazyIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
466 Capability *cap = rtsApiCapability;
467 rtsApiCapability = NULL;
469 tso = createIOThread(stack_size, p);
470 return scheduleWaitThread(tso,ret,cap);
473 /* Convenience function for decoding the returned status. */
476 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
482 errorBelch("%s: uncaught exception",site);
483 stg_exit(EXIT_FAILURE);
485 errorBelch("%s: interrupted", site);
486 stg_exit(EXIT_FAILURE);
488 errorBelch("%s: Return code (%d) not ok",(site),(rc));
489 stg_exit(EXIT_FAILURE);
496 #ifdef RTS_SUPPORTS_THREADS
497 ACQUIRE_LOCK(&sched_mutex);
499 // we request to get the capability immediately, in order to
500 // a) stop other threads from using allocate()
501 // b) wake the current worker thread from awaitEvent()
502 // (so that a thread started by rts_eval* will start immediately)
503 waitForReturnCapability(&sched_mutex,&rtsApiCapability);
505 grabCapability(&rtsApiCapability);
512 #ifdef RTS_SUPPORTS_THREADS
513 if (rtsApiCapability) {
514 releaseCapability(rtsApiCapability);
516 rtsApiCapability = NULL;
517 RELEASE_LOCK(&sched_mutex);