1 /* ----------------------------------------------------------------------------
3 * (c) The GHC Team, 1998-2001
5 * API for invoking Haskell functions via the RTS
7 * --------------------------------------------------------------------------*/
9 #include "PosixSource.h"
17 #include "Capability.h"
20 /* ----------------------------------------------------------------------------
21 Building Haskell objects from C datatypes.
23 TODO: Currently this code does not tag created pointers,
24 however it is not unsafe (the contructor code will do it)
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)i;
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)i;
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)i;
75 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 ASSIGN_Int64((P_)&(p->payload[0]), i);
84 rts_mkWord (Capability *cap, HsWord i)
86 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
87 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
88 p->payload[0] = (StgClosure *)(StgWord)i;
93 rts_mkWord8 (Capability *cap, HsWord8 w)
95 /* see rts_mkInt* comments */
96 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
97 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
98 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
103 rts_mkWord16 (Capability *cap, HsWord16 w)
105 /* see rts_mkInt* comments */
106 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
107 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
108 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
113 rts_mkWord32 (Capability *cap, HsWord32 w)
115 /* see rts_mkInt* comments */
116 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
117 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
118 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
123 rts_mkWord64 (Capability *cap, HsWord64 w)
125 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
126 /* see mk_Int8 comment */
127 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
128 ASSIGN_Word64((P_)&(p->payload[0]), w);
134 rts_mkFloat (Capability *cap, HsFloat f)
136 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
137 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
138 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
143 rts_mkDouble (Capability *cap, HsDouble d)
145 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
146 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
147 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
152 rts_mkStablePtr (Capability *cap, HsStablePtr s)
154 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
155 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
156 p->payload[0] = (StgClosure *)s;
161 rts_mkPtr (Capability *cap, HsPtr a)
163 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
164 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
165 p->payload[0] = (StgClosure *)a;
170 rts_mkFunPtr (Capability *cap, HsFunPtr a)
172 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
173 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
174 p->payload[0] = (StgClosure *)a;
179 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
182 return (StgClosure *)True_closure;
184 return (StgClosure *)False_closure;
189 rts_mkString (Capability *cap, char *s)
191 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
195 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
199 ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
200 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
202 ap->payload[1] = arg;
203 return (StgClosure *)ap;
206 /* ----------------------------------------------------------------------------
207 Deconstructing Haskell objects
209 We would like to assert that we have the right kind of object in
210 each case, but this is problematic because in GHCi the info table
211 for the D# constructor (say) might be dynamically loaded. Hence we
212 omit these assertions for now.
213 ------------------------------------------------------------------------- */
216 rts_getChar (HaskellObj p)
218 // See comment above:
219 // ASSERT(p->header.info == Czh_con_info ||
220 // p->header.info == Czh_static_info);
221 return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
225 rts_getInt (HaskellObj p)
227 // See comment above:
228 // ASSERT(p->header.info == Izh_con_info ||
229 // p->header.info == Izh_static_info);
230 return (HsInt)(UNTAG_CLOSURE(p)->payload[0]);
234 rts_getInt8 (HaskellObj p)
236 // See comment above:
237 // ASSERT(p->header.info == I8zh_con_info ||
238 // p->header.info == I8zh_static_info);
239 return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
243 rts_getInt16 (HaskellObj p)
245 // See comment above:
246 // ASSERT(p->header.info == I16zh_con_info ||
247 // p->header.info == I16zh_static_info);
248 return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
252 rts_getInt32 (HaskellObj p)
254 // See comment above:
255 // ASSERT(p->header.info == I32zh_con_info ||
256 // p->header.info == I32zh_static_info);
257 return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
261 rts_getInt64 (HaskellObj p)
263 // See comment above:
264 // ASSERT(p->header.info == I64zh_con_info ||
265 // p->header.info == I64zh_static_info);
266 return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
270 rts_getWord (HaskellObj p)
272 // See comment above:
273 // ASSERT(p->header.info == Wzh_con_info ||
274 // p->header.info == Wzh_static_info);
275 return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
279 rts_getWord8 (HaskellObj p)
281 // See comment above:
282 // ASSERT(p->header.info == W8zh_con_info ||
283 // p->header.info == W8zh_static_info);
284 return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
288 rts_getWord16 (HaskellObj p)
290 // See comment above:
291 // ASSERT(p->header.info == W16zh_con_info ||
292 // p->header.info == W16zh_static_info);
293 return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
297 rts_getWord32 (HaskellObj p)
299 // See comment above:
300 // ASSERT(p->header.info == W32zh_con_info ||
301 // p->header.info == W32zh_static_info);
302 return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
306 rts_getWord64 (HaskellObj p)
308 // See comment above:
309 // ASSERT(p->header.info == W64zh_con_info ||
310 // p->header.info == W64zh_static_info);
311 return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
315 rts_getFloat (HaskellObj p)
317 // See comment above:
318 // ASSERT(p->header.info == Fzh_con_info ||
319 // p->header.info == Fzh_static_info);
320 return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
324 rts_getDouble (HaskellObj p)
326 // See comment above:
327 // ASSERT(p->header.info == Dzh_con_info ||
328 // p->header.info == Dzh_static_info);
329 return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
333 rts_getStablePtr (HaskellObj p)
335 // See comment above:
336 // ASSERT(p->header.info == StablePtr_con_info ||
337 // p->header.info == StablePtr_static_info);
338 return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
342 rts_getPtr (HaskellObj p)
344 // See comment above:
345 // ASSERT(p->header.info == Ptr_con_info ||
346 // p->header.info == Ptr_static_info);
347 return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
351 rts_getFunPtr (HaskellObj p)
353 // See comment above:
354 // ASSERT(p->header.info == FunPtr_con_info ||
355 // p->header.info == FunPtr_static_info);
356 return (void *)(UNTAG_CLOSURE(p)->payload[0]);
360 rts_getBool (HaskellObj p)
364 info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
365 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
372 /* -----------------------------------------------------------------------------
374 -------------------------------------------------------------------------- */
376 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
382 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
385 t = createThread (cap, stack_size);
386 pushClosure(t, (W_)closure);
387 pushClosure(t, (W_)&stg_enter_info);
392 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
395 t = createThread (cap, stack_size);
396 pushClosure(t, (W_)&stg_noforceIO_info);
397 pushClosure(t, (W_)&stg_ap_v_info);
398 pushClosure(t, (W_)closure);
399 pushClosure(t, (W_)&stg_enter_info);
404 * Same as above, but also evaluate the result of the IO action
405 * to whnf while we're at it.
409 createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
412 t = createThread(cap, stack_size);
413 pushClosure(t, (W_)&stg_forceIO_info);
414 pushClosure(t, (W_)&stg_ap_v_info);
415 pushClosure(t, (W_)closure);
416 pushClosure(t, (W_)&stg_enter_info);
420 /* ----------------------------------------------------------------------------
421 Evaluating Haskell expressions
422 ------------------------------------------------------------------------- */
425 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
429 tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
430 return scheduleWaitThread(tso,ret,cap);
434 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
435 /*out*/HaskellObj *ret)
439 tso = createGenThread(cap, stack_size, p);
440 return scheduleWaitThread(tso,ret,cap);
444 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
445 * result to WHNF before returning.
448 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
452 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
453 return scheduleWaitThread(tso,ret,cap);
457 * rts_evalStableIO() is suitable for calling from Haskell. It
458 * evaluates a value of the form (StablePtr (IO a)), forcing the
459 * action's result to WHNF before returning. The result is returned
463 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
467 SchedulerStatus stat;
469 p = (StgClosure *)deRefStablePtr(s);
470 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
471 // async exceptions are always blocked by default in the created
472 // thread. See #1048.
473 tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
474 cap = scheduleWaitThread(tso,&r,cap);
475 stat = rts_getSchedStatus(cap);
477 if (stat == Success && ret != NULL) {
479 *ret = getStablePtr((StgPtr)r);
486 * Like rts_evalIO(), but doesn't force the action's result.
489 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
493 tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
494 return scheduleWaitThread(tso,ret,cap);
498 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
499 /*out*/HaskellObj *ret)
503 tso = createIOThread(cap, stack_size, p);
504 return scheduleWaitThread(tso,ret,cap);
507 /* Convenience function for decoding the returned status. */
510 rts_checkSchedStatus (char* site, Capability *cap)
512 SchedulerStatus rc = cap->running_task->stat;
517 errorBelch("%s: uncaught exception",site);
518 stg_exit(EXIT_FAILURE);
520 errorBelch("%s: interrupted", site);
521 stg_exit(EXIT_FAILURE);
523 errorBelch("%s: Return code (%d) not ok",(site),(rc));
524 stg_exit(EXIT_FAILURE);
529 rts_getSchedStatus (Capability *cap)
531 return cap->running_task->stat;
540 task = newBoundTask();
543 waitForReturnCapability(&cap, task);
544 return (Capability *)cap;
547 // Exiting the RTS: we hold a Capability that is not necessarily the
548 // same one that was originally returned by rts_lock(), because
549 // rts_evalIO() etc. may return a new one. Now that we have
550 // investigated the return value, we can release the Capability,
551 // and free the Task (in that order).
554 rts_unlock (Capability *cap)
558 task = cap->running_task;
559 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
561 // Now release the Capability. With the capability released, GC
562 // may happen. NB. does not try to put the current Task on the
564 // NB. keep cap->lock held while we call boundTaskExiting(). This
565 // is necessary during shutdown, where we want the invariant that
566 // after shutdownCapability(), all the Tasks associated with the
567 // Capability have completed their shutdown too. Otherwise we
568 // could have boundTaskExiting()/workerTaskStop() running at some
569 // random point in the future, which causes problems for
570 // freeTaskManager().
571 ACQUIRE_LOCK(&cap->lock);
572 releaseCapability_(cap,rtsFalse);
574 // Finally, we can release the Task to the free list.
575 boundTaskExiting(task);
576 RELEASE_LOCK(&cap->lock);