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"
21 /* ----------------------------------------------------------------------------
22 Building Haskell objects from C datatypes.
24 TODO: Currently this code does not tag created pointers,
25 however it is not unsafe (the contructor code will do it)
27 ------------------------------------------------------------------------- */
29 rts_mkChar (Capability *cap, HsChar c)
31 StgClosure *p = (StgClosure *)allocate(cap, CONSTR_sizeW(0,1));
32 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
33 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
38 rts_mkInt (Capability *cap, HsInt i)
40 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
41 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
42 p->payload[0] = (StgClosure *)(StgInt)i;
47 rts_mkInt8 (Capability *cap, HsInt8 i)
49 StgClosure *p = (StgClosure *)allocate(cap,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)i;
57 rts_mkInt16 (Capability *cap, HsInt16 i)
59 StgClosure *p = (StgClosure *)allocate(cap,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)i;
67 rts_mkInt32 (Capability *cap, HsInt32 i)
69 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
70 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
71 p->payload[0] = (StgClosure *)(StgInt)i;
76 rts_mkInt64 (Capability *cap, HsInt64 i)
78 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,2));
79 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
80 ASSIGN_Int64((P_)&(p->payload[0]), i);
85 rts_mkWord (Capability *cap, HsWord i)
87 StgClosure *p = (StgClosure *)allocate(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 *)allocate(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 *)allocate(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 *)allocate(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)
126 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,2));
127 /* see mk_Int8 comment */
128 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
129 ASSIGN_Word64((P_)&(p->payload[0]), w);
135 rts_mkFloat (Capability *cap, HsFloat f)
137 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
138 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
139 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
144 rts_mkDouble (Capability *cap, HsDouble d)
146 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
147 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
148 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
153 rts_mkStablePtr (Capability *cap, HsStablePtr s)
155 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
156 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
157 p->payload[0] = (StgClosure *)s;
162 rts_mkPtr (Capability *cap, HsPtr a)
164 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
165 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
166 p->payload[0] = (StgClosure *)a;
171 rts_mkFunPtr (Capability *cap, HsFunPtr a)
173 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
174 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
175 p->payload[0] = (StgClosure *)a;
180 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
183 return (StgClosure *)True_closure;
185 return (StgClosure *)False_closure;
190 rts_mkString (Capability *cap, char *s)
192 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
196 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
200 ap = (StgThunk *)allocate(cap,sizeofW(StgThunk) + 2);
201 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
203 ap->payload[1] = arg;
204 return (StgClosure *)ap;
207 /* ----------------------------------------------------------------------------
208 Deconstructing Haskell objects
210 We would like to assert that we have the right kind of object in
211 each case, but this is problematic because in GHCi the info table
212 for the D# constructor (say) might be dynamically loaded. Hence we
213 omit these assertions for now.
214 ------------------------------------------------------------------------- */
217 rts_getChar (HaskellObj p)
219 // See comment above:
220 // ASSERT(p->header.info == Czh_con_info ||
221 // p->header.info == Czh_static_info);
222 return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
226 rts_getInt (HaskellObj p)
228 // See comment above:
229 // ASSERT(p->header.info == Izh_con_info ||
230 // p->header.info == Izh_static_info);
231 return (HsInt)(UNTAG_CLOSURE(p)->payload[0]);
235 rts_getInt8 (HaskellObj p)
237 // See comment above:
238 // ASSERT(p->header.info == I8zh_con_info ||
239 // p->header.info == I8zh_static_info);
240 return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
244 rts_getInt16 (HaskellObj p)
246 // See comment above:
247 // ASSERT(p->header.info == I16zh_con_info ||
248 // p->header.info == I16zh_static_info);
249 return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
253 rts_getInt32 (HaskellObj p)
255 // See comment above:
256 // ASSERT(p->header.info == I32zh_con_info ||
257 // p->header.info == I32zh_static_info);
258 return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
262 rts_getInt64 (HaskellObj p)
264 // See comment above:
265 // ASSERT(p->header.info == I64zh_con_info ||
266 // p->header.info == I64zh_static_info);
267 return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
271 rts_getWord (HaskellObj p)
273 // See comment above:
274 // ASSERT(p->header.info == Wzh_con_info ||
275 // p->header.info == Wzh_static_info);
276 return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
280 rts_getWord8 (HaskellObj p)
282 // See comment above:
283 // ASSERT(p->header.info == W8zh_con_info ||
284 // p->header.info == W8zh_static_info);
285 return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
289 rts_getWord16 (HaskellObj p)
291 // See comment above:
292 // ASSERT(p->header.info == W16zh_con_info ||
293 // p->header.info == W16zh_static_info);
294 return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
298 rts_getWord32 (HaskellObj p)
300 // See comment above:
301 // ASSERT(p->header.info == W32zh_con_info ||
302 // p->header.info == W32zh_static_info);
303 return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
307 rts_getWord64 (HaskellObj p)
309 // See comment above:
310 // ASSERT(p->header.info == W64zh_con_info ||
311 // p->header.info == W64zh_static_info);
312 return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
316 rts_getFloat (HaskellObj p)
318 // See comment above:
319 // ASSERT(p->header.info == Fzh_con_info ||
320 // p->header.info == Fzh_static_info);
321 return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
325 rts_getDouble (HaskellObj p)
327 // See comment above:
328 // ASSERT(p->header.info == Dzh_con_info ||
329 // p->header.info == Dzh_static_info);
330 return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
334 rts_getStablePtr (HaskellObj p)
336 // See comment above:
337 // ASSERT(p->header.info == StablePtr_con_info ||
338 // p->header.info == StablePtr_static_info);
339 return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
343 rts_getPtr (HaskellObj p)
345 // See comment above:
346 // ASSERT(p->header.info == Ptr_con_info ||
347 // p->header.info == Ptr_static_info);
348 return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
352 rts_getFunPtr (HaskellObj p)
354 // See comment above:
355 // ASSERT(p->header.info == FunPtr_con_info ||
356 // p->header.info == FunPtr_static_info);
357 return (void *)(UNTAG_CLOSURE(p)->payload[0]);
361 rts_getBool (HaskellObj p)
365 info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
366 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
373 /* -----------------------------------------------------------------------------
375 -------------------------------------------------------------------------- */
377 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
383 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
386 t = createThread (cap, stack_size);
387 pushClosure(t, (W_)closure);
388 pushClosure(t, (W_)&stg_enter_info);
393 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
396 t = createThread (cap, stack_size);
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->incall->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->incall->stat;
540 task = newBoundTask();
542 if (task->running_finalizers) {
543 errorBelch("error: a C finalizer called back into Haskell.\n"
544 " This was previously allowed, but is disallowed in GHC 6.10.2 and later.\n"
545 " To create finalizers that may call back into Haskell, use\n"
546 " Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr.");
547 stg_exit(EXIT_FAILURE);
551 waitForReturnCapability(&cap, task);
552 return (Capability *)cap;
555 // Exiting the RTS: we hold a Capability that is not necessarily the
556 // same one that was originally returned by rts_lock(), because
557 // rts_evalIO() etc. may return a new one. Now that we have
558 // investigated the return value, we can release the Capability,
559 // and free the Task (in that order).
562 rts_unlock (Capability *cap)
566 task = cap->running_task;
567 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
569 // Now release the Capability. With the capability released, GC
570 // may happen. NB. does not try to put the current Task on the
572 // NB. keep cap->lock held while we call boundTaskExiting(). This
573 // is necessary during shutdown, where we want the invariant that
574 // after shutdownCapability(), all the Tasks associated with the
575 // Capability have completed their shutdown too. Otherwise we
576 // could have boundTaskExiting()/workerTaskStop() running at some
577 // random point in the future, which causes problems for
578 // freeTaskManager().
579 ACQUIRE_LOCK(&cap->lock);
580 releaseCapability_(cap,rtsFalse);
582 // Finally, we can release the Task to the free list.
583 boundTaskExiting(task);
584 RELEASE_LOCK(&cap->lock);