Fold integer-gmp.git into ghc.git (re #8545)
[ghc.git] / rts / RtsAPI.c
1 /* ----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 1998-2001
4 *
5 * API for invoking Haskell functions via the RTS
6 *
7 * --------------------------------------------------------------------------*/
8
9 #include "PosixSource.h"
10 #include "Rts.h"
11 #include "RtsAPI.h"
12 #include "HsFFI.h"
13
14 #include "RtsUtils.h"
15 #include "Prelude.h"
16 #include "Schedule.h"
17 #include "Capability.h"
18 #include "Stable.h"
19 #include "Weak.h"
20
21 /* ----------------------------------------------------------------------------
22 Building Haskell objects from C datatypes.
23
24 TODO: Currently this code does not tag created pointers,
25 however it is not unsafe (the contructor code will do it)
26 just inefficient.
27 ------------------------------------------------------------------------- */
28 HaskellObj
29 rts_mkChar (Capability *cap, HsChar c)
30 {
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;
34 return p;
35 }
36
37 HaskellObj
38 rts_mkInt (Capability *cap, HsInt i)
39 {
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;
43 return p;
44 }
45
46 HaskellObj
47 rts_mkInt8 (Capability *cap, HsInt8 i)
48 {
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;
53 return p;
54 }
55
56 HaskellObj
57 rts_mkInt16 (Capability *cap, HsInt16 i)
58 {
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;
63 return p;
64 }
65
66 HaskellObj
67 rts_mkInt32 (Capability *cap, HsInt32 i)
68 {
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;
72 return p;
73 }
74
75 HaskellObj
76 rts_mkInt64 (Capability *cap, HsInt64 i)
77 {
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);
81 return p;
82 }
83
84 HaskellObj
85 rts_mkWord (Capability *cap, HsWord i)
86 {
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;
90 return p;
91 }
92
93 HaskellObj
94 rts_mkWord8 (Capability *cap, HsWord8 w)
95 {
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);
100 return p;
101 }
102
103 HaskellObj
104 rts_mkWord16 (Capability *cap, HsWord16 w)
105 {
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);
110 return p;
111 }
112
113 HaskellObj
114 rts_mkWord32 (Capability *cap, HsWord32 w)
115 {
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);
120 return p;
121 }
122
123 HaskellObj
124 rts_mkWord64 (Capability *cap, HsWord64 w)
125 {
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);
130 return p;
131 }
132
133
134 HaskellObj
135 rts_mkFloat (Capability *cap, HsFloat f)
136 {
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);
140 return p;
141 }
142
143 HaskellObj
144 rts_mkDouble (Capability *cap, HsDouble d)
145 {
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);
149 return p;
150 }
151
152 HaskellObj
153 rts_mkStablePtr (Capability *cap, HsStablePtr s)
154 {
155 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
156 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
157 p->payload[0] = (StgClosure *)s;
158 return p;
159 }
160
161 HaskellObj
162 rts_mkPtr (Capability *cap, HsPtr a)
163 {
164 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
165 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
166 p->payload[0] = (StgClosure *)a;
167 return p;
168 }
169
170 HaskellObj
171 rts_mkFunPtr (Capability *cap, HsFunPtr a)
172 {
173 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
174 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
175 p->payload[0] = (StgClosure *)a;
176 return p;
177 }
178
179 HaskellObj
180 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
181 {
182 if (b) {
183 return (StgClosure *)True_closure;
184 } else {
185 return (StgClosure *)False_closure;
186 }
187 }
188
189 HaskellObj
190 rts_mkString (Capability *cap, char *s)
191 {
192 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
193 }
194
195 HaskellObj
196 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
197 {
198 StgThunk *ap;
199
200 ap = (StgThunk *)allocate(cap,sizeofW(StgThunk) + 2);
201 // Here we don't want to use CCS_SYSTEM, because it's a hidden cost centre,
202 // and evaluating Haskell code under a hidden cost centre leads to
203 // confusing profiling output. (#7753)
204 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_MAIN);
205 ap->payload[0] = f;
206 ap->payload[1] = arg;
207 return (StgClosure *)ap;
208 }
209
210 /* ----------------------------------------------------------------------------
211 Deconstructing Haskell objects
212
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 ------------------------------------------------------------------------- */
218
219 HsChar
220 rts_getChar (HaskellObj p)
221 {
222 // See comment above:
223 // ASSERT(p->header.info == Czh_con_info ||
224 // p->header.info == Czh_static_info);
225 return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
226 }
227
228 HsInt
229 rts_getInt (HaskellObj p)
230 {
231 // See comment above:
232 // ASSERT(p->header.info == Izh_con_info ||
233 // p->header.info == Izh_static_info);
234 return (HsInt)(UNTAG_CLOSURE(p)->payload[0]);
235 }
236
237 HsInt8
238 rts_getInt8 (HaskellObj p)
239 {
240 // See comment above:
241 // ASSERT(p->header.info == I8zh_con_info ||
242 // p->header.info == I8zh_static_info);
243 return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
244 }
245
246 HsInt16
247 rts_getInt16 (HaskellObj p)
248 {
249 // See comment above:
250 // ASSERT(p->header.info == I16zh_con_info ||
251 // p->header.info == I16zh_static_info);
252 return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
253 }
254
255 HsInt32
256 rts_getInt32 (HaskellObj p)
257 {
258 // See comment above:
259 // ASSERT(p->header.info == I32zh_con_info ||
260 // p->header.info == I32zh_static_info);
261 return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
262 }
263
264 HsInt64
265 rts_getInt64 (HaskellObj p)
266 {
267 // See comment above:
268 // ASSERT(p->header.info == I64zh_con_info ||
269 // p->header.info == I64zh_static_info);
270 return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
271 }
272
273 HsWord
274 rts_getWord (HaskellObj p)
275 {
276 // See comment above:
277 // ASSERT(p->header.info == Wzh_con_info ||
278 // p->header.info == Wzh_static_info);
279 return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
280 }
281
282 HsWord8
283 rts_getWord8 (HaskellObj p)
284 {
285 // See comment above:
286 // ASSERT(p->header.info == W8zh_con_info ||
287 // p->header.info == W8zh_static_info);
288 return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
289 }
290
291 HsWord16
292 rts_getWord16 (HaskellObj p)
293 {
294 // See comment above:
295 // ASSERT(p->header.info == W16zh_con_info ||
296 // p->header.info == W16zh_static_info);
297 return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
298 }
299
300 HsWord32
301 rts_getWord32 (HaskellObj p)
302 {
303 // See comment above:
304 // ASSERT(p->header.info == W32zh_con_info ||
305 // p->header.info == W32zh_static_info);
306 return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
307 }
308
309 HsWord64
310 rts_getWord64 (HaskellObj p)
311 {
312 // See comment above:
313 // ASSERT(p->header.info == W64zh_con_info ||
314 // p->header.info == W64zh_static_info);
315 return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
316 }
317
318 HsFloat
319 rts_getFloat (HaskellObj p)
320 {
321 // See comment above:
322 // ASSERT(p->header.info == Fzh_con_info ||
323 // p->header.info == Fzh_static_info);
324 return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
325 }
326
327 HsDouble
328 rts_getDouble (HaskellObj p)
329 {
330 // See comment above:
331 // ASSERT(p->header.info == Dzh_con_info ||
332 // p->header.info == Dzh_static_info);
333 return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
334 }
335
336 HsStablePtr
337 rts_getStablePtr (HaskellObj p)
338 {
339 // See comment above:
340 // ASSERT(p->header.info == StablePtr_con_info ||
341 // p->header.info == StablePtr_static_info);
342 return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
343 }
344
345 HsPtr
346 rts_getPtr (HaskellObj p)
347 {
348 // See comment above:
349 // ASSERT(p->header.info == Ptr_con_info ||
350 // p->header.info == Ptr_static_info);
351 return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
352 }
353
354 HsFunPtr
355 rts_getFunPtr (HaskellObj p)
356 {
357 // See comment above:
358 // ASSERT(p->header.info == FunPtr_con_info ||
359 // p->header.info == FunPtr_static_info);
360 return (void *)(UNTAG_CLOSURE(p)->payload[0]);
361 }
362
363 HsBool
364 rts_getBool (HaskellObj p)
365 {
366 StgInfoTable *info;
367
368 info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
369 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
370 return 0;
371 } else {
372 return 1;
373 }
374 }
375
376 /* -----------------------------------------------------------------------------
377 Creating threads
378 -------------------------------------------------------------------------- */
379
380 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
381 tso->stackobj->sp--;
382 tso->stackobj->sp[0] = (W_) c;
383 }
384
385 StgTSO *
386 createGenThread (Capability *cap, W_ stack_size, StgClosure *closure)
387 {
388 StgTSO *t;
389 t = createThread (cap, stack_size);
390 pushClosure(t, (W_)closure);
391 pushClosure(t, (W_)&stg_enter_info);
392 return t;
393 }
394
395 StgTSO *
396 createIOThread (Capability *cap, W_ stack_size, StgClosure *closure)
397 {
398 StgTSO *t;
399 t = createThread (cap, stack_size);
400 pushClosure(t, (W_)&stg_ap_v_info);
401 pushClosure(t, (W_)closure);
402 pushClosure(t, (W_)&stg_enter_info);
403 return t;
404 }
405
406 /*
407 * Same as above, but also evaluate the result of the IO action
408 * to whnf while we're at it.
409 */
410
411 StgTSO *
412 createStrictIOThread(Capability *cap, W_ stack_size, StgClosure *closure)
413 {
414 StgTSO *t;
415 t = createThread(cap, stack_size);
416 pushClosure(t, (W_)&stg_forceIO_info);
417 pushClosure(t, (W_)&stg_ap_v_info);
418 pushClosure(t, (W_)closure);
419 pushClosure(t, (W_)&stg_enter_info);
420 return t;
421 }
422
423 /* ----------------------------------------------------------------------------
424 Evaluating Haskell expressions
425 ------------------------------------------------------------------------- */
426
427 void rts_eval (/* inout */ Capability **cap,
428 /* in */ HaskellObj p,
429 /* out */ HaskellObj *ret)
430 {
431 StgTSO *tso;
432
433 tso = createGenThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
434 scheduleWaitThread(tso,ret,cap);
435 }
436
437 void rts_eval_ (/* inout */ Capability **cap,
438 /* in */ HaskellObj p,
439 /* in */ unsigned int stack_size,
440 /* out */ HaskellObj *ret)
441 {
442 StgTSO *tso;
443
444 tso = createGenThread(*cap, stack_size, p);
445 scheduleWaitThread(tso,ret,cap);
446 }
447
448 /*
449 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
450 * result to WHNF before returning.
451 */
452 void rts_evalIO (/* inout */ Capability **cap,
453 /* in */ HaskellObj p,
454 /* out */ HaskellObj *ret)
455 {
456 StgTSO* tso;
457
458 tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
459 scheduleWaitThread(tso,ret,cap);
460 }
461
462 /*
463 * rts_evalStableIO() is suitable for calling from Haskell. It
464 * evaluates a value of the form (StablePtr (IO a)), forcing the
465 * action's result to WHNF before returning. The result is returned
466 * in a StablePtr.
467 */
468 void rts_evalStableIO (/* inout */ Capability **cap,
469 /* in */ HsStablePtr s,
470 /* out */ HsStablePtr *ret)
471 {
472 StgTSO* tso;
473 StgClosure *p, *r;
474 SchedulerStatus stat;
475
476 p = (StgClosure *)deRefStablePtr(s);
477 tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
478 // async exceptions are always blocked by default in the created
479 // thread. See #1048.
480 tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
481 scheduleWaitThread(tso,&r,cap);
482 stat = rts_getSchedStatus(*cap);
483
484 if (stat == Success && ret != NULL) {
485 ASSERT(r != NULL);
486 *ret = getStablePtr((StgPtr)r);
487 }
488 }
489
490 /*
491 * Like rts_evalIO(), but doesn't force the action's result.
492 */
493 void rts_evalLazyIO (/* inout */ Capability **cap,
494 /* in */ HaskellObj p,
495 /* out */ HaskellObj *ret)
496 {
497 StgTSO *tso;
498
499 tso = createIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
500 scheduleWaitThread(tso,ret,cap);
501 }
502
503 void rts_evalLazyIO_ (/* inout */ Capability **cap,
504 /* in */ HaskellObj p,
505 /* in */ unsigned int stack_size,
506 /* out */ HaskellObj *ret)
507 {
508 StgTSO *tso;
509
510 tso = createIOThread(*cap, stack_size, p);
511 scheduleWaitThread(tso,ret,cap);
512 }
513
514 /* Convenience function for decoding the returned status. */
515
516 void
517 rts_checkSchedStatus (char* site, Capability *cap)
518 {
519 SchedulerStatus rc = cap->running_task->incall->stat;
520 switch (rc) {
521 case Success:
522 return;
523 case Killed:
524 errorBelch("%s: uncaught exception",site);
525 stg_exit(EXIT_FAILURE);
526 case Interrupted:
527 errorBelch("%s: interrupted", site);
528 #ifdef THREADED_RTS
529 // The RTS is shutting down, and the process will probably
530 // soon exit. We don't want to preempt the shutdown
531 // by exiting the whole process here, so we just terminate the
532 // current thread. Don't forget to release the cap first though.
533 rts_unlock(cap);
534 shutdownThread();
535 #else
536 stg_exit(EXIT_FAILURE);
537 #endif
538 default:
539 errorBelch("%s: Return code (%d) not ok",(site),(rc));
540 stg_exit(EXIT_FAILURE);
541 }
542 }
543
544 SchedulerStatus
545 rts_getSchedStatus (Capability *cap)
546 {
547 return cap->running_task->incall->stat;
548 }
549
550 Capability *
551 rts_lock (void)
552 {
553 Capability *cap;
554 Task *task;
555
556 task = newBoundTask();
557
558 if (task->running_finalizers) {
559 errorBelch("error: a C finalizer called back into Haskell.\n"
560 " This was previously allowed, but is disallowed in GHC 6.10.2 and later.\n"
561 " To create finalizers that may call back into Haskell, use\n"
562 " Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr.");
563 stg_exit(EXIT_FAILURE);
564 }
565
566 cap = NULL;
567 waitForReturnCapability(&cap, task);
568
569 if (task->incall->prev_stack == NULL) {
570 // This is a new outermost call from C into Haskell land.
571 // Until the corresponding call to rts_unlock, this task
572 // is doing work on behalf of the RTS.
573 traceTaskCreate(task, cap);
574 }
575
576 return (Capability *)cap;
577 }
578
579 // Exiting the RTS: we hold a Capability that is not necessarily the
580 // same one that was originally returned by rts_lock(), because
581 // rts_evalIO() etc. may return a new one. Now that we have
582 // investigated the return value, we can release the Capability,
583 // and free the Task (in that order).
584
585 void
586 rts_unlock (Capability *cap)
587 {
588 Task *task;
589
590 task = cap->running_task;
591 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
592
593 // Now release the Capability. With the capability released, GC
594 // may happen. NB. does not try to put the current Task on the
595 // worker queue.
596 // NB. keep cap->lock held while we call boundTaskExiting(). This
597 // is necessary during shutdown, where we want the invariant that
598 // after shutdownCapability(), all the Tasks associated with the
599 // Capability have completed their shutdown too. Otherwise we
600 // could have boundTaskExiting()/workerTaskStop() running at some
601 // random point in the future, which causes problems for
602 // freeTaskManager().
603 ACQUIRE_LOCK(&cap->lock);
604 releaseCapability_(cap,rtsFalse);
605
606 // Finally, we can release the Task to the free list.
607 boundTaskExiting(task);
608 RELEASE_LOCK(&cap->lock);
609
610 if (task->incall == NULL) {
611 // This is the end of an outermost call from C into Haskell land.
612 // From here on, the task goes back to C land and we should not count
613 // it as doing work on behalf of the RTS.
614 traceTaskDelete(task);
615 }
616 }
617
618 void rts_done (void)
619 {
620 freeMyTask();
621 }
622