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"
18 #include "Capability.h"
23 /* ----------------------------------------------------------------------------
24 Building Haskell objects from C datatypes.
25 ------------------------------------------------------------------------- */
27 rts_mkChar (Capability *cap, HsChar c)
29 StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
30 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
31 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
36 rts_mkInt (Capability *cap, HsInt i)
38 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
39 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
40 p->payload[0] = (StgClosure *)(StgInt)i;
45 rts_mkInt8 (Capability *cap, HsInt8 i)
47 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
48 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
49 /* Make sure we mask out the bits above the lowest 8 */
50 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
55 rts_mkInt16 (Capability *cap, HsInt16 i)
57 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
58 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
59 /* Make sure we mask out the relevant bits */
60 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
65 rts_mkInt32 (Capability *cap, HsInt32 i)
67 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
68 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
69 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
74 rts_mkInt64 (Capability *cap, HsInt64 i)
77 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
78 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
79 tmp = (llong*)&(p->payload[0]);
85 rts_mkWord (Capability *cap, HsWord i)
87 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
88 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
89 p->payload[0] = (StgClosure *)(StgWord)i;
94 rts_mkWord8 (Capability *cap, HsWord8 w)
96 /* see rts_mkInt* comments */
97 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
98 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
99 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
104 rts_mkWord16 (Capability *cap, HsWord16 w)
106 /* see rts_mkInt* comments */
107 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
108 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
109 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
114 rts_mkWord32 (Capability *cap, HsWord32 w)
116 /* see rts_mkInt* comments */
117 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
118 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
119 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
124 rts_mkWord64 (Capability *cap, HsWord64 w)
128 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
129 /* see mk_Int8 comment */
130 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
131 tmp = (ullong*)&(p->payload[0]);
137 rts_mkFloat (Capability *cap, HsFloat f)
139 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
140 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
141 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
146 rts_mkDouble (Capability *cap, HsDouble d)
148 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
149 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
150 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
155 rts_mkStablePtr (Capability *cap, HsStablePtr s)
157 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
158 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
159 p->payload[0] = (StgClosure *)s;
164 rts_mkPtr (Capability *cap, HsPtr a)
166 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
167 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
168 p->payload[0] = (StgClosure *)a;
173 rts_mkFunPtr (Capability *cap, HsFunPtr a)
175 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
176 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
177 p->payload[0] = (StgClosure *)a;
182 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
185 return (StgClosure *)True_closure;
187 return (StgClosure *)False_closure;
192 rts_mkString (Capability *cap, char *s)
194 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
198 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
202 ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
203 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
205 ap->payload[1] = arg;
206 return (StgClosure *)ap;
209 /* ----------------------------------------------------------------------------
210 Deconstructing Haskell objects
212 We would like to assert that we have the right kind of object in
213 each case, but this is problematic because in GHCi the info table
214 for the D# constructor (say) might be dynamically loaded. Hence we
215 omit these assertions for now.
216 ------------------------------------------------------------------------- */
219 rts_getChar (HaskellObj p)
221 // See comment above:
222 // ASSERT(p->header.info == Czh_con_info ||
223 // p->header.info == Czh_static_info);
224 return (StgChar)(StgWord)(p->payload[0]);
228 rts_getInt (HaskellObj p)
230 // See comment above:
231 // ASSERT(p->header.info == Izh_con_info ||
232 // p->header.info == Izh_static_info);
233 return (HsInt)(p->payload[0]);
237 rts_getInt8 (HaskellObj p)
239 // See comment above:
240 // ASSERT(p->header.info == I8zh_con_info ||
241 // p->header.info == I8zh_static_info);
242 return (HsInt8)(HsInt)(p->payload[0]);
246 rts_getInt16 (HaskellObj p)
248 // See comment above:
249 // ASSERT(p->header.info == I16zh_con_info ||
250 // p->header.info == I16zh_static_info);
251 return (HsInt16)(HsInt)(p->payload[0]);
255 rts_getInt32 (HaskellObj p)
257 // See comment above:
258 // ASSERT(p->header.info == I32zh_con_info ||
259 // p->header.info == I32zh_static_info);
260 return (HsInt32)(HsInt)(p->payload[0]);
264 rts_getInt64 (HaskellObj p)
267 // See comment above:
268 // ASSERT(p->header.info == I64zh_con_info ||
269 // p->header.info == I64zh_static_info);
270 tmp = (HsInt64*)&(p->payload[0]);
274 rts_getWord (HaskellObj p)
276 // See comment above:
277 // ASSERT(p->header.info == Wzh_con_info ||
278 // p->header.info == Wzh_static_info);
279 return (HsWord)(p->payload[0]);
283 rts_getWord8 (HaskellObj p)
285 // See comment above:
286 // ASSERT(p->header.info == W8zh_con_info ||
287 // p->header.info == W8zh_static_info);
288 return (HsWord8)(HsWord)(p->payload[0]);
292 rts_getWord16 (HaskellObj p)
294 // See comment above:
295 // ASSERT(p->header.info == W16zh_con_info ||
296 // p->header.info == W16zh_static_info);
297 return (HsWord16)(HsWord)(p->payload[0]);
301 rts_getWord32 (HaskellObj p)
303 // See comment above:
304 // ASSERT(p->header.info == W32zh_con_info ||
305 // p->header.info == W32zh_static_info);
306 return (HsWord32)(HsWord)(p->payload[0]);
311 rts_getWord64 (HaskellObj p)
314 // See comment above:
315 // ASSERT(p->header.info == W64zh_con_info ||
316 // p->header.info == W64zh_static_info);
317 tmp = (HsWord64*)&(p->payload[0]);
322 rts_getFloat (HaskellObj p)
324 // See comment above:
325 // ASSERT(p->header.info == Fzh_con_info ||
326 // p->header.info == Fzh_static_info);
327 return (float)(PK_FLT((P_)p->payload));
331 rts_getDouble (HaskellObj p)
333 // See comment above:
334 // ASSERT(p->header.info == Dzh_con_info ||
335 // p->header.info == Dzh_static_info);
336 return (double)(PK_DBL((P_)p->payload));
340 rts_getStablePtr (HaskellObj p)
342 // See comment above:
343 // ASSERT(p->header.info == StablePtr_con_info ||
344 // p->header.info == StablePtr_static_info);
345 return (StgStablePtr)(p->payload[0]);
349 rts_getPtr (HaskellObj p)
351 // See comment above:
352 // ASSERT(p->header.info == Ptr_con_info ||
353 // p->header.info == Ptr_static_info);
354 return (Capability *)(p->payload[0]);
358 rts_getFunPtr (HaskellObj p)
360 // See comment above:
361 // ASSERT(p->header.info == FunPtr_con_info ||
362 // p->header.info == FunPtr_static_info);
363 return (void *)(p->payload[0]);
367 rts_getBool (HaskellObj p)
371 info = get_itbl((StgClosure *)p);
372 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
379 /* -----------------------------------------------------------------------------
381 -------------------------------------------------------------------------- */
383 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
389 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
393 t = createThread (cap, stack_size, NO_PRI);
395 t = createThread (cap, stack_size);
397 pushClosure(t, (W_)closure);
398 pushClosure(t, (W_)&stg_enter_info);
403 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
407 t = createThread (cap, stack_size, NO_PRI);
409 t = createThread (cap, stack_size);
411 pushClosure(t, (W_)&stg_noforceIO_info);
412 pushClosure(t, (W_)&stg_ap_v_info);
413 pushClosure(t, (W_)closure);
414 pushClosure(t, (W_)&stg_enter_info);
419 * Same as above, but also evaluate the result of the IO action
420 * to whnf while we're at it.
424 createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
428 t = createThread(cap, stack_size, NO_PRI);
430 t = createThread(cap, stack_size);
432 pushClosure(t, (W_)&stg_forceIO_info);
433 pushClosure(t, (W_)&stg_ap_v_info);
434 pushClosure(t, (W_)closure);
435 pushClosure(t, (W_)&stg_enter_info);
439 /* ----------------------------------------------------------------------------
440 Evaluating Haskell expressions
441 ------------------------------------------------------------------------- */
444 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
448 tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
449 return scheduleWaitThread(tso,ret,cap);
453 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
454 /*out*/HaskellObj *ret)
458 tso = createGenThread(cap, stack_size, p);
459 return scheduleWaitThread(tso,ret,cap);
463 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
464 * result to WHNF before returning.
467 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
471 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
472 return scheduleWaitThread(tso,ret,cap);
476 * rts_evalStableIO() is suitable for calling from Haskell. It
477 * evaluates a value of the form (StablePtr (IO a)), forcing the
478 * action's result to WHNF before returning. The result is returned
482 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
486 SchedulerStatus stat;
488 p = (StgClosure *)deRefStablePtr(s);
489 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
490 cap = scheduleWaitThread(tso,&r,cap);
491 stat = rts_getSchedStatus(cap);
493 if (stat == Success && ret != NULL) {
495 *ret = getStablePtr((StgPtr)r);
502 * Like rts_evalIO(), but doesn't force the action's result.
505 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
509 tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
510 return scheduleWaitThread(tso,ret,cap);
514 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
515 /*out*/HaskellObj *ret)
519 tso = createIOThread(cap, stack_size, p);
520 return scheduleWaitThread(tso,ret,cap);
523 /* Convenience function for decoding the returned status. */
526 rts_checkSchedStatus (char* site, Capability *cap)
528 SchedulerStatus rc = cap->running_task->stat;
533 errorBelch("%s: uncaught exception",site);
534 stg_exit(EXIT_FAILURE);
536 errorBelch("%s: interrupted", site);
537 stg_exit(EXIT_FAILURE);
539 errorBelch("%s: Return code (%d) not ok",(site),(rc));
540 stg_exit(EXIT_FAILURE);
545 rts_getSchedStatus (Capability *cap)
547 return cap->running_task->stat;
556 // ToDo: get rid of this lock in the common case. We could store
557 // a free Task in thread-local storage, for example. That would
558 // leave just one lock on the path into the RTS: cap->lock when
559 // acquiring the Capability.
560 ACQUIRE_LOCK(&sched_mutex);
561 task = newBoundTask();
562 RELEASE_LOCK(&sched_mutex);
565 waitForReturnCapability(&cap, task);
566 return (Capability *)cap;
569 // Exiting the RTS: we hold a Capability that is not necessarily the
570 // same one that was originally returned by rts_lock(), because
571 // rts_evalIO() etc. may return a new one. Now that we have
572 // investigated the return value, we can release the Capability,
573 // and free the Task (in that order).
576 rts_unlock (Capability *cap)
580 task = cap->running_task;
581 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
583 // slightly delicate ordering of operations below, pay attention!
585 // We are no longer a bound task/thread. This is important,
586 // because the GC can run when we release the Capability below,
587 // and we don't want it to treat this as a live TSO pointer.
590 // Now release the Capability. With the capability released, GC
591 // may happen. NB. does not try to put the current Task on the
593 releaseCapability(cap);
595 // Finally, we can release the Task to the free list.
596 boundTaskExiting(task);