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"
24 /* ----------------------------------------------------------------------------
25 Building Haskell objects from C datatypes.
26 ------------------------------------------------------------------------- */
28 rts_mkChar (Capability *cap, HsChar c)
30 StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
31 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
32 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
37 rts_mkInt (Capability *cap, HsInt i)
39 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
40 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
41 p->payload[0] = (StgClosure *)(StgInt)i;
46 rts_mkInt8 (Capability *cap, HsInt8 i)
48 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
49 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
50 /* Make sure we mask out the bits above the lowest 8 */
51 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
56 rts_mkInt16 (Capability *cap, HsInt16 i)
58 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
59 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
60 /* Make sure we mask out the relevant bits */
61 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
66 rts_mkInt32 (Capability *cap, HsInt32 i)
68 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
69 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
70 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
75 rts_mkInt64 (Capability *cap, HsInt64 i)
78 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
79 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
80 tmp = (llong*)&(p->payload[0]);
86 rts_mkWord (Capability *cap, HsWord i)
88 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
89 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
90 p->payload[0] = (StgClosure *)(StgWord)i;
95 rts_mkWord8 (Capability *cap, HsWord8 w)
97 /* see rts_mkInt* comments */
98 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
99 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
100 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
105 rts_mkWord16 (Capability *cap, HsWord16 w)
107 /* see rts_mkInt* comments */
108 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
109 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
110 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
115 rts_mkWord32 (Capability *cap, HsWord32 w)
117 /* see rts_mkInt* comments */
118 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
119 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
120 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
125 rts_mkWord64 (Capability *cap, HsWord64 w)
129 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
130 /* see mk_Int8 comment */
131 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
132 tmp = (ullong*)&(p->payload[0]);
138 rts_mkFloat (Capability *cap, HsFloat f)
140 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
141 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
142 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
147 rts_mkDouble (Capability *cap, HsDouble d)
149 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
150 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
151 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
156 rts_mkStablePtr (Capability *cap, HsStablePtr s)
158 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
159 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
160 p->payload[0] = (StgClosure *)s;
165 rts_mkPtr (Capability *cap, HsPtr a)
167 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
168 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
169 p->payload[0] = (StgClosure *)a;
174 rts_mkFunPtr (Capability *cap, HsFunPtr a)
176 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
177 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
178 p->payload[0] = (StgClosure *)a;
183 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
186 return (StgClosure *)True_closure;
188 return (StgClosure *)False_closure;
193 rts_mkString (Capability *cap, char *s)
195 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
199 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
203 ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
204 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
206 ap->payload[1] = arg;
207 return (StgClosure *)ap;
210 /* ----------------------------------------------------------------------------
211 Deconstructing Haskell objects
213 We would like to assert that we have the right kind of object in
214 each case, but this is problematic because in GHCi the info table
215 for the D# constructor (say) might be dynamically loaded. Hence we
216 omit these assertions for now.
217 ------------------------------------------------------------------------- */
220 rts_getChar (HaskellObj p)
222 // See comment above:
223 // ASSERT(p->header.info == Czh_con_info ||
224 // p->header.info == Czh_static_info);
225 return (StgChar)(StgWord)(p->payload[0]);
229 rts_getInt (HaskellObj p)
231 // See comment above:
232 // ASSERT(p->header.info == Izh_con_info ||
233 // p->header.info == Izh_static_info);
234 return (HsInt)(p->payload[0]);
238 rts_getInt8 (HaskellObj p)
240 // See comment above:
241 // ASSERT(p->header.info == I8zh_con_info ||
242 // p->header.info == I8zh_static_info);
243 return (HsInt8)(HsInt)(p->payload[0]);
247 rts_getInt16 (HaskellObj p)
249 // See comment above:
250 // ASSERT(p->header.info == I16zh_con_info ||
251 // p->header.info == I16zh_static_info);
252 return (HsInt16)(HsInt)(p->payload[0]);
256 rts_getInt32 (HaskellObj p)
258 // See comment above:
259 // ASSERT(p->header.info == I32zh_con_info ||
260 // p->header.info == I32zh_static_info);
261 return (HsInt32)(HsInt)(p->payload[0]);
265 rts_getInt64 (HaskellObj p)
268 // See comment above:
269 // ASSERT(p->header.info == I64zh_con_info ||
270 // p->header.info == I64zh_static_info);
271 tmp = (HsInt64*)&(p->payload[0]);
275 rts_getWord (HaskellObj p)
277 // See comment above:
278 // ASSERT(p->header.info == Wzh_con_info ||
279 // p->header.info == Wzh_static_info);
280 return (HsWord)(p->payload[0]);
284 rts_getWord8 (HaskellObj p)
286 // See comment above:
287 // ASSERT(p->header.info == W8zh_con_info ||
288 // p->header.info == W8zh_static_info);
289 return (HsWord8)(HsWord)(p->payload[0]);
293 rts_getWord16 (HaskellObj p)
295 // See comment above:
296 // ASSERT(p->header.info == W16zh_con_info ||
297 // p->header.info == W16zh_static_info);
298 return (HsWord16)(HsWord)(p->payload[0]);
302 rts_getWord32 (HaskellObj p)
304 // See comment above:
305 // ASSERT(p->header.info == W32zh_con_info ||
306 // p->header.info == W32zh_static_info);
307 return (HsWord32)(HsWord)(p->payload[0]);
312 rts_getWord64 (HaskellObj p)
315 // See comment above:
316 // ASSERT(p->header.info == W64zh_con_info ||
317 // p->header.info == W64zh_static_info);
318 tmp = (HsWord64*)&(p->payload[0]);
323 rts_getFloat (HaskellObj p)
325 // See comment above:
326 // ASSERT(p->header.info == Fzh_con_info ||
327 // p->header.info == Fzh_static_info);
328 return (float)(PK_FLT((P_)p->payload));
332 rts_getDouble (HaskellObj p)
334 // See comment above:
335 // ASSERT(p->header.info == Dzh_con_info ||
336 // p->header.info == Dzh_static_info);
337 return (double)(PK_DBL((P_)p->payload));
341 rts_getStablePtr (HaskellObj p)
343 // See comment above:
344 // ASSERT(p->header.info == StablePtr_con_info ||
345 // p->header.info == StablePtr_static_info);
346 return (StgStablePtr)(p->payload[0]);
350 rts_getPtr (HaskellObj p)
352 // See comment above:
353 // ASSERT(p->header.info == Ptr_con_info ||
354 // p->header.info == Ptr_static_info);
355 return (Capability *)(p->payload[0]);
359 rts_getFunPtr (HaskellObj p)
361 // See comment above:
362 // ASSERT(p->header.info == FunPtr_con_info ||
363 // p->header.info == FunPtr_static_info);
364 return (void *)(p->payload[0]);
368 rts_getBool (HaskellObj p)
372 info = get_itbl((StgClosure *)p);
373 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
380 /* -----------------------------------------------------------------------------
382 -------------------------------------------------------------------------- */
384 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
390 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
394 t = createThread (cap, stack_size, NO_PRI);
396 t = createThread (cap, stack_size);
398 pushClosure(t, (W_)closure);
399 pushClosure(t, (W_)&stg_enter_info);
404 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
408 t = createThread (cap, stack_size, NO_PRI);
410 t = createThread (cap, stack_size);
412 pushClosure(t, (W_)&stg_noforceIO_info);
413 pushClosure(t, (W_)&stg_ap_v_info);
414 pushClosure(t, (W_)closure);
415 pushClosure(t, (W_)&stg_enter_info);
420 * Same as above, but also evaluate the result of the IO action
421 * to whnf while we're at it.
425 createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
429 t = createThread(cap, stack_size, NO_PRI);
431 t = createThread(cap, stack_size);
433 pushClosure(t, (W_)&stg_forceIO_info);
434 pushClosure(t, (W_)&stg_ap_v_info);
435 pushClosure(t, (W_)closure);
436 pushClosure(t, (W_)&stg_enter_info);
440 /* ----------------------------------------------------------------------------
441 Evaluating Haskell expressions
442 ------------------------------------------------------------------------- */
445 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
449 tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
450 return scheduleWaitThread(tso,ret,cap);
454 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
455 /*out*/HaskellObj *ret)
459 tso = createGenThread(cap, stack_size, p);
460 return scheduleWaitThread(tso,ret,cap);
464 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
465 * result to WHNF before returning.
468 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
472 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
473 return scheduleWaitThread(tso,ret,cap);
477 * rts_evalStableIO() is suitable for calling from Haskell. It
478 * evaluates a value of the form (StablePtr (IO a)), forcing the
479 * action's result to WHNF before returning. The result is returned
483 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
487 SchedulerStatus stat;
489 p = (StgClosure *)deRefStablePtr(s);
490 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
491 cap = scheduleWaitThread(tso,&r,cap);
492 stat = rts_getSchedStatus(cap);
494 if (stat == Success && ret != NULL) {
496 *ret = getStablePtr((StgPtr)r);
503 * Like rts_evalIO(), but doesn't force the action's result.
506 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
510 tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
511 return scheduleWaitThread(tso,ret,cap);
515 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
516 /*out*/HaskellObj *ret)
520 tso = createIOThread(cap, stack_size, p);
521 return scheduleWaitThread(tso,ret,cap);
524 /* Convenience function for decoding the returned status. */
527 rts_checkSchedStatus (char* site, Capability *cap)
529 SchedulerStatus rc = cap->running_task->stat;
534 errorBelch("%s: uncaught exception",site);
535 stg_exit(EXIT_FAILURE);
537 errorBelch("%s: interrupted", site);
538 stg_exit(EXIT_FAILURE);
540 errorBelch("%s: Return code (%d) not ok",(site),(rc));
541 stg_exit(EXIT_FAILURE);
546 rts_getSchedStatus (Capability *cap)
548 return cap->running_task->stat;
557 // ToDo: get rid of this lock in the common case. We could store
558 // a free Task in thread-local storage, for example. That would
559 // leave just one lock on the path into the RTS: cap->lock when
560 // acquiring the Capability.
561 ACQUIRE_LOCK(&sched_mutex);
562 task = newBoundTask();
563 RELEASE_LOCK(&sched_mutex);
566 waitForReturnCapability(&cap, task);
567 return (Capability *)cap;
570 // Exiting the RTS: we hold a Capability that is not necessarily the
571 // same one that was originally returned by rts_lock(), because
572 // rts_evalIO() etc. may return a new one. Now that we have
573 // investigated the return value, we can release the Capability,
574 // and free the Task (in that order).
577 rts_unlock (Capability *cap)
581 task = cap->running_task;
582 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
584 // slightly delicate ordering of operations below, pay attention!
586 // We are no longer a bound task/thread. This is important,
587 // because the GC can run when we release the Capability below,
588 // and we don't want it to treat this as a live TSO pointer.
591 // Now release the Capability. With the capability released, GC
592 // may happen. NB. does not try to put the current Task on the
594 releaseCapability(cap);
596 // Finally, we can release the Task to the free list.
597 boundTaskExiting(task);