Fix memory leak from #12664
[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 "Threads.h"
20 #include "Weak.h"
21
22 /* ----------------------------------------------------------------------------
23 Building Haskell objects from C datatypes.
24
25 TODO: Currently this code does not tag created pointers,
26 however it is not unsafe (the constructor code will do it)
27 just inefficient.
28 ------------------------------------------------------------------------- */
29 HaskellObj
30 rts_mkChar (Capability *cap, HsChar c)
31 {
32 StgClosure *p = (StgClosure *)allocate(cap, CONSTR_sizeW(0,1));
33 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
34 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
35 return p;
36 }
37
38 HaskellObj
39 rts_mkInt (Capability *cap, HsInt i)
40 {
41 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
42 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
43 p->payload[0] = (StgClosure *)(StgInt)i;
44 return p;
45 }
46
47 HaskellObj
48 rts_mkInt8 (Capability *cap, HsInt8 i)
49 {
50 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
51 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
52 /* Make sure we mask out the bits above the lowest 8 */
53 p->payload[0] = (StgClosure *)(StgInt)i;
54 return p;
55 }
56
57 HaskellObj
58 rts_mkInt16 (Capability *cap, HsInt16 i)
59 {
60 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
61 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
62 /* Make sure we mask out the relevant bits */
63 p->payload[0] = (StgClosure *)(StgInt)i;
64 return p;
65 }
66
67 HaskellObj
68 rts_mkInt32 (Capability *cap, HsInt32 i)
69 {
70 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
71 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
72 p->payload[0] = (StgClosure *)(StgInt)i;
73 return p;
74 }
75
76 HaskellObj
77 rts_mkInt64 (Capability *cap, HsInt64 i)
78 {
79 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,2));
80 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
81 ASSIGN_Int64((P_)&(p->payload[0]), i);
82 return p;
83 }
84
85 HaskellObj
86 rts_mkWord (Capability *cap, HsWord i)
87 {
88 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
89 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
90 p->payload[0] = (StgClosure *)(StgWord)i;
91 return p;
92 }
93
94 HaskellObj
95 rts_mkWord8 (Capability *cap, HsWord8 w)
96 {
97 /* see rts_mkInt* comments */
98 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
99 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
100 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
101 return p;
102 }
103
104 HaskellObj
105 rts_mkWord16 (Capability *cap, HsWord16 w)
106 {
107 /* see rts_mkInt* comments */
108 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
109 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
110 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
111 return p;
112 }
113
114 HaskellObj
115 rts_mkWord32 (Capability *cap, HsWord32 w)
116 {
117 /* see rts_mkInt* comments */
118 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
119 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
120 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
121 return p;
122 }
123
124 HaskellObj
125 rts_mkWord64 (Capability *cap, HsWord64 w)
126 {
127 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,2));
128 /* see mk_Int8 comment */
129 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
130 ASSIGN_Word64((P_)&(p->payload[0]), w);
131 return p;
132 }
133
134
135 HaskellObj
136 rts_mkFloat (Capability *cap, HsFloat f)
137 {
138 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
139 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
140 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
141 return p;
142 }
143
144 HaskellObj
145 rts_mkDouble (Capability *cap, HsDouble d)
146 {
147 StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
148 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
149 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
150 return p;
151 }
152
153 HaskellObj
154 rts_mkStablePtr (Capability *cap, HsStablePtr s)
155 {
156 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
157 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
158 p->payload[0] = (StgClosure *)s;
159 return p;
160 }
161
162 HaskellObj
163 rts_mkPtr (Capability *cap, HsPtr a)
164 {
165 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
166 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
167 p->payload[0] = (StgClosure *)a;
168 return p;
169 }
170
171 HaskellObj
172 rts_mkFunPtr (Capability *cap, HsFunPtr a)
173 {
174 StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
175 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
176 p->payload[0] = (StgClosure *)a;
177 return p;
178 }
179
180 HaskellObj
181 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
182 {
183 if (b) {
184 return (StgClosure *)True_closure;
185 } else {
186 return (StgClosure *)False_closure;
187 }
188 }
189
190 HaskellObj
191 rts_mkString (Capability *cap, char *s)
192 {
193 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
194 }
195
196 HaskellObj
197 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
198 {
199 StgThunk *ap;
200
201 ap = (StgThunk *)allocate(cap,sizeofW(StgThunk) + 2);
202 // Here we don't want to use CCS_SYSTEM, because it's a hidden cost centre,
203 // and evaluating Haskell code under a hidden cost centre leads to
204 // confusing profiling output. (#7753)
205 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_MAIN);
206 ap->payload[0] = f;
207 ap->payload[1] = arg;
208 return (StgClosure *)ap;
209 }
210
211 /* ----------------------------------------------------------------------------
212 Deconstructing Haskell objects
213
214 We would like to assert that we have the right kind of object in
215 each case, but this is problematic because in GHCi the info table
216 for the D# constructor (say) might be dynamically loaded. Hence we
217 omit these assertions for now.
218 ------------------------------------------------------------------------- */
219
220 HsChar
221 rts_getChar (HaskellObj p)
222 {
223 // See comment above:
224 // ASSERT(p->header.info == Czh_con_info ||
225 // p->header.info == Czh_static_info);
226 return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
227 }
228
229 HsInt
230 rts_getInt (HaskellObj p)
231 {
232 // See comment above:
233 // ASSERT(p->header.info == Izh_con_info ||
234 // p->header.info == Izh_static_info);
235 return (HsInt)(UNTAG_CLOSURE(p)->payload[0]);
236 }
237
238 HsInt8
239 rts_getInt8 (HaskellObj p)
240 {
241 // See comment above:
242 // ASSERT(p->header.info == I8zh_con_info ||
243 // p->header.info == I8zh_static_info);
244 return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
245 }
246
247 HsInt16
248 rts_getInt16 (HaskellObj p)
249 {
250 // See comment above:
251 // ASSERT(p->header.info == I16zh_con_info ||
252 // p->header.info == I16zh_static_info);
253 return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
254 }
255
256 HsInt32
257 rts_getInt32 (HaskellObj p)
258 {
259 // See comment above:
260 // ASSERT(p->header.info == I32zh_con_info ||
261 // p->header.info == I32zh_static_info);
262 return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
263 }
264
265 HsInt64
266 rts_getInt64 (HaskellObj p)
267 {
268 // See comment above:
269 // ASSERT(p->header.info == I64zh_con_info ||
270 // p->header.info == I64zh_static_info);
271 return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
272 }
273
274 HsWord
275 rts_getWord (HaskellObj p)
276 {
277 // See comment above:
278 // ASSERT(p->header.info == Wzh_con_info ||
279 // p->header.info == Wzh_static_info);
280 return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
281 }
282
283 HsWord8
284 rts_getWord8 (HaskellObj p)
285 {
286 // See comment above:
287 // ASSERT(p->header.info == W8zh_con_info ||
288 // p->header.info == W8zh_static_info);
289 return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
290 }
291
292 HsWord16
293 rts_getWord16 (HaskellObj p)
294 {
295 // See comment above:
296 // ASSERT(p->header.info == W16zh_con_info ||
297 // p->header.info == W16zh_static_info);
298 return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
299 }
300
301 HsWord32
302 rts_getWord32 (HaskellObj p)
303 {
304 // See comment above:
305 // ASSERT(p->header.info == W32zh_con_info ||
306 // p->header.info == W32zh_static_info);
307 return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
308 }
309
310 HsWord64
311 rts_getWord64 (HaskellObj p)
312 {
313 // See comment above:
314 // ASSERT(p->header.info == W64zh_con_info ||
315 // p->header.info == W64zh_static_info);
316 return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
317 }
318
319 HsFloat
320 rts_getFloat (HaskellObj p)
321 {
322 // See comment above:
323 // ASSERT(p->header.info == Fzh_con_info ||
324 // p->header.info == Fzh_static_info);
325 return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
326 }
327
328 HsDouble
329 rts_getDouble (HaskellObj p)
330 {
331 // See comment above:
332 // ASSERT(p->header.info == Dzh_con_info ||
333 // p->header.info == Dzh_static_info);
334 return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
335 }
336
337 HsStablePtr
338 rts_getStablePtr (HaskellObj p)
339 {
340 // See comment above:
341 // ASSERT(p->header.info == StablePtr_con_info ||
342 // p->header.info == StablePtr_static_info);
343 return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
344 }
345
346 HsPtr
347 rts_getPtr (HaskellObj p)
348 {
349 // See comment above:
350 // ASSERT(p->header.info == Ptr_con_info ||
351 // p->header.info == Ptr_static_info);
352 return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
353 }
354
355 HsFunPtr
356 rts_getFunPtr (HaskellObj p)
357 {
358 // See comment above:
359 // ASSERT(p->header.info == FunPtr_con_info ||
360 // p->header.info == FunPtr_static_info);
361 return (void *)(UNTAG_CLOSURE(p)->payload[0]);
362 }
363
364 HsBool
365 rts_getBool (HaskellObj p)
366 {
367 const StgInfoTable *info;
368
369 info = get_itbl((const StgClosure *)UNTAG_CONST_CLOSURE(p));
370 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
371 return 0;
372 } else {
373 return 1;
374 }
375 }
376
377 /* -----------------------------------------------------------------------------
378 Creating threads
379 -------------------------------------------------------------------------- */
380
381 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
382 tso->stackobj->sp--;
383 tso->stackobj->sp[0] = (W_) c;
384 }
385
386 StgTSO *
387 createGenThread (Capability *cap, W_ stack_size, StgClosure *closure)
388 {
389 StgTSO *t;
390 t = createThread (cap, stack_size);
391 pushClosure(t, (W_)closure);
392 pushClosure(t, (W_)&stg_enter_info);
393 return t;
394 }
395
396 StgTSO *
397 createIOThread (Capability *cap, W_ stack_size, StgClosure *closure)
398 {
399 StgTSO *t;
400 t = createThread (cap, stack_size);
401 pushClosure(t, (W_)&stg_ap_v_info);
402 pushClosure(t, (W_)closure);
403 pushClosure(t, (W_)&stg_enter_info);
404 return t;
405 }
406
407 /*
408 * Same as above, but also evaluate the result of the IO action
409 * to whnf while we're at it.
410 */
411
412 StgTSO *
413 createStrictIOThread(Capability *cap, W_ stack_size, StgClosure *closure)
414 {
415 StgTSO *t;
416 t = createThread(cap, stack_size);
417 pushClosure(t, (W_)&stg_forceIO_info);
418 pushClosure(t, (W_)&stg_ap_v_info);
419 pushClosure(t, (W_)closure);
420 pushClosure(t, (W_)&stg_enter_info);
421 return t;
422 }
423
424 /* ----------------------------------------------------------------------------
425 Evaluating Haskell expressions
426 ------------------------------------------------------------------------- */
427
428 void rts_eval (/* inout */ Capability **cap,
429 /* in */ HaskellObj p,
430 /* out */ HaskellObj *ret)
431 {
432 StgTSO *tso;
433
434 tso = createGenThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
435 scheduleWaitThread(tso,ret,cap);
436 }
437
438 void rts_eval_ (/* inout */ Capability **cap,
439 /* in */ HaskellObj p,
440 /* in */ unsigned int stack_size,
441 /* out */ HaskellObj *ret)
442 {
443 StgTSO *tso;
444
445 tso = createGenThread(*cap, stack_size, p);
446 scheduleWaitThread(tso,ret,cap);
447 }
448
449 /*
450 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
451 * result to WHNF before returning.
452 */
453 void rts_evalIO (/* inout */ Capability **cap,
454 /* in */ HaskellObj p,
455 /* out */ HaskellObj *ret)
456 {
457 StgTSO* tso;
458
459 tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
460 scheduleWaitThread(tso,ret,cap);
461 }
462
463 /*
464 * rts_evalStableIO() is suitable for calling from Haskell. It
465 * evaluates a value of the form (StablePtr (IO a)), forcing the
466 * action's result to WHNF before returning. The result is returned
467 * in a StablePtr.
468 */
469 void rts_evalStableIO (/* inout */ Capability **cap,
470 /* in */ HsStablePtr s,
471 /* out */ HsStablePtr *ret)
472 {
473 StgTSO* tso;
474 StgClosure *p, *r;
475 SchedulerStatus stat;
476
477 p = (StgClosure *)deRefStablePtr(s);
478 tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
479 // async exceptions are always blocked by default in the created
480 // thread. See #1048.
481 tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
482 scheduleWaitThread(tso,&r,cap);
483 stat = rts_getSchedStatus(*cap);
484
485 if (stat == Success && ret != NULL) {
486 ASSERT(r != NULL);
487 *ret = getStablePtr((StgPtr)r);
488 }
489 }
490
491 /*
492 * Like rts_evalIO(), but doesn't force the action's result.
493 */
494 void rts_evalLazyIO (/* inout */ Capability **cap,
495 /* in */ HaskellObj p,
496 /* out */ HaskellObj *ret)
497 {
498 StgTSO *tso;
499
500 tso = createIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
501 scheduleWaitThread(tso,ret,cap);
502 }
503
504 void rts_evalLazyIO_ (/* inout */ Capability **cap,
505 /* in */ HaskellObj p,
506 /* in */ unsigned int stack_size,
507 /* out */ HaskellObj *ret)
508 {
509 StgTSO *tso;
510
511 tso = createIOThread(*cap, stack_size, p);
512 scheduleWaitThread(tso,ret,cap);
513 }
514
515 /* Convenience function for decoding the returned status. */
516
517 void
518 rts_checkSchedStatus (char* site, Capability *cap)
519 {
520 SchedulerStatus rc = cap->running_task->incall->rstat;
521 switch (rc) {
522 case Success:
523 return;
524 case Killed:
525 errorBelch("%s: uncaught exception",site);
526 stg_exit(EXIT_FAILURE);
527 case Interrupted:
528 errorBelch("%s: interrupted", site);
529 #ifdef THREADED_RTS
530 // The RTS is shutting down, and the process will probably
531 // soon exit. We don't want to preempt the shutdown
532 // by exiting the whole process here, so we just terminate the
533 // current thread. Don't forget to release the cap first though.
534 rts_unlock(cap);
535 shutdownThread();
536 #else
537 stg_exit(EXIT_FAILURE);
538 #endif
539 default:
540 errorBelch("%s: Return code (%d) not ok",(site),(rc));
541 stg_exit(EXIT_FAILURE);
542 }
543 }
544
545 SchedulerStatus
546 rts_getSchedStatus (Capability *cap)
547 {
548 return cap->running_task->incall->rstat;
549 }
550
551 Capability *
552 rts_lock (void)
553 {
554 Capability *cap;
555 Task *task;
556
557 task = newBoundTask();
558
559 if (task->running_finalizers) {
560 errorBelch("error: a C finalizer called back into Haskell.\n"
561 " This was previously allowed, but is disallowed in GHC 6.10.2 and later.\n"
562 " To create finalizers that may call back into Haskell, use\n"
563 " Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr.");
564 stg_exit(EXIT_FAILURE);
565 }
566
567 cap = NULL;
568 waitForCapability(&cap, task);
569
570 if (task->incall->prev_stack == NULL) {
571 // This is a new outermost call from C into Haskell land.
572 // Until the corresponding call to rts_unlock, this task
573 // is doing work on behalf of the RTS.
574 traceTaskCreate(task, cap);
575 }
576
577 return (Capability *)cap;
578 }
579
580 // Exiting the RTS: we hold a Capability that is not necessarily the
581 // same one that was originally returned by rts_lock(), because
582 // rts_evalIO() etc. may return a new one. Now that we have
583 // investigated the return value, we can release the Capability,
584 // and free the Task (in that order).
585
586 void
587 rts_unlock (Capability *cap)
588 {
589 Task *task;
590
591 task = cap->running_task;
592 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
593
594 // Now release the Capability. With the capability released, GC
595 // may happen. NB. does not try to put the current Task on the
596 // worker queue.
597 // NB. keep cap->lock held while we call boundTaskExiting(). This
598 // is necessary during shutdown, where we want the invariant that
599 // after shutdownCapability(), all the Tasks associated with the
600 // Capability have completed their shutdown too. Otherwise we
601 // could have boundTaskExiting()/workerTaskStop() running at some
602 // random point in the future, which causes problems for
603 // freeTaskManager().
604 ACQUIRE_LOCK(&cap->lock);
605 releaseCapability_(cap,rtsFalse);
606
607 // Finally, we can release the Task to the free list.
608 boundTaskExiting(task);
609 RELEASE_LOCK(&cap->lock);
610
611 if (task->incall == NULL) {
612 // This is the end of an outermost call from C into Haskell land.
613 // From here on, the task goes back to C land and we should not count
614 // it as doing work on behalf of the RTS.
615 traceTaskDelete(task);
616 }
617 }
618
619 void rts_done (void)
620 {
621 freeMyTask();
622 }
623
624 /* -----------------------------------------------------------------------------
625 tryPutMVar from outside Haskell
626
627 The C call
628
629 hs_try_putmvar(cap, mvar)
630
631 is equivalent to the Haskell call
632
633 tryPutMVar mvar ()
634
635 but it is
636
637 * non-blocking: takes a bounded, short, amount of time
638 * asynchronous: the actual putMVar may be performed after the
639 call returns. That's why hs_try_putmvar() doesn't return a
640 result to say whether the put succeeded.
641
642 NOTE: this call transfers ownership of the StablePtr to the RTS, which will
643 free it after the tryPutMVar has taken place. The reason is that otherwise,
644 it would be very difficult for the caller to arrange to free the StablePtr
645 in all circumstances.
646
647 For more details, see the section "Waking up Haskell threads from C" in the
648 User's Guide.
649 -------------------------------------------------------------------------- */
650
651 void hs_try_putmvar (/* in */ int capability,
652 /* in */ HsStablePtr mvar)
653 {
654 Task *task = getTask();
655 Capability *cap;
656
657 if (capability < 0) {
658 capability = task->preferred_capability;
659 if (capability < 0) {
660 capability = 0;
661 }
662 }
663 cap = capabilities[capability % enabled_capabilities];
664
665 #if !defined(THREADED_RTS)
666
667 performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), Unit_closure);
668 freeStablePtr(mvar);
669
670 #else
671
672 ACQUIRE_LOCK(&cap->lock);
673 // If the capability is free, we can perform the tryPutMVar immediately
674 if (cap->running_task == NULL) {
675 cap->running_task = task;
676 task->cap = cap;
677 RELEASE_LOCK(&cap->lock);
678
679 performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), Unit_closure);
680
681 freeStablePtr(mvar);
682
683 // Wake up the capability, which will start running the thread that we
684 // just awoke (if there was one).
685 releaseCapability(cap);
686 } else {
687 PutMVar *p = stgMallocBytes(sizeof(PutMVar),"hs_try_putmvar");
688 // We cannot deref the StablePtr if we don't have a capability,
689 // so we have to store it and deref it later.
690 p->mvar = mvar;
691 p->link = cap->putMVars;
692 cap->putMVars = p;
693 RELEASE_LOCK(&cap->lock);
694 }
695
696 #endif
697 }