Implement stack chunks and separate TSO/STACK objects
[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 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
202 ap->payload[0] = f;
203 ap->payload[1] = arg;
204 return (StgClosure *)ap;
205 }
206
207 /* ----------------------------------------------------------------------------
208 Deconstructing Haskell objects
209
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 ------------------------------------------------------------------------- */
215
216 HsChar
217 rts_getChar (HaskellObj p)
218 {
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]);
223 }
224
225 HsInt
226 rts_getInt (HaskellObj p)
227 {
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]);
232 }
233
234 HsInt8
235 rts_getInt8 (HaskellObj p)
236 {
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]);
241 }
242
243 HsInt16
244 rts_getInt16 (HaskellObj p)
245 {
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]);
250 }
251
252 HsInt32
253 rts_getInt32 (HaskellObj p)
254 {
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]);
259 }
260
261 HsInt64
262 rts_getInt64 (HaskellObj p)
263 {
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]));
268 }
269
270 HsWord
271 rts_getWord (HaskellObj p)
272 {
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]);
277 }
278
279 HsWord8
280 rts_getWord8 (HaskellObj p)
281 {
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]);
286 }
287
288 HsWord16
289 rts_getWord16 (HaskellObj p)
290 {
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]);
295 }
296
297 HsWord32
298 rts_getWord32 (HaskellObj p)
299 {
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]);
304 }
305
306 HsWord64
307 rts_getWord64 (HaskellObj p)
308 {
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]));
313 }
314
315 HsFloat
316 rts_getFloat (HaskellObj p)
317 {
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));
322 }
323
324 HsDouble
325 rts_getDouble (HaskellObj p)
326 {
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));
331 }
332
333 HsStablePtr
334 rts_getStablePtr (HaskellObj p)
335 {
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]);
340 }
341
342 HsPtr
343 rts_getPtr (HaskellObj p)
344 {
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]);
349 }
350
351 HsFunPtr
352 rts_getFunPtr (HaskellObj p)
353 {
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]);
358 }
359
360 HsBool
361 rts_getBool (HaskellObj p)
362 {
363 StgInfoTable *info;
364
365 info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
366 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
367 return 0;
368 } else {
369 return 1;
370 }
371 }
372
373 /* -----------------------------------------------------------------------------
374 Creating threads
375 -------------------------------------------------------------------------- */
376
377 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
378 tso->stackobj->sp--;
379 tso->stackobj->sp[0] = (W_) c;
380 }
381
382 StgTSO *
383 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
384 {
385 StgTSO *t;
386 t = createThread (cap, stack_size);
387 pushClosure(t, (W_)closure);
388 pushClosure(t, (W_)&stg_enter_info);
389 return t;
390 }
391
392 StgTSO *
393 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
394 {
395 StgTSO *t;
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);
400 return t;
401 }
402
403 /*
404 * Same as above, but also evaluate the result of the IO action
405 * to whnf while we're at it.
406 */
407
408 StgTSO *
409 createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
410 {
411 StgTSO *t;
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);
417 return t;
418 }
419
420 /* ----------------------------------------------------------------------------
421 Evaluating Haskell expressions
422 ------------------------------------------------------------------------- */
423
424 Capability *
425 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
426 {
427 StgTSO *tso;
428
429 tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
430 return scheduleWaitThread(tso,ret,cap);
431 }
432
433 Capability *
434 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
435 /*out*/HaskellObj *ret)
436 {
437 StgTSO *tso;
438
439 tso = createGenThread(cap, stack_size, p);
440 return scheduleWaitThread(tso,ret,cap);
441 }
442
443 /*
444 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
445 * result to WHNF before returning.
446 */
447 Capability *
448 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
449 {
450 StgTSO* tso;
451
452 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
453 return scheduleWaitThread(tso,ret,cap);
454 }
455
456 /*
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
460 * in a StablePtr.
461 */
462 Capability *
463 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
464 {
465 StgTSO* tso;
466 StgClosure *p, *r;
467 SchedulerStatus stat;
468
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);
476
477 if (stat == Success && ret != NULL) {
478 ASSERT(r != NULL);
479 *ret = getStablePtr((StgPtr)r);
480 }
481
482 return cap;
483 }
484
485 /*
486 * Like rts_evalIO(), but doesn't force the action's result.
487 */
488 Capability *
489 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
490 {
491 StgTSO *tso;
492
493 tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
494 return scheduleWaitThread(tso,ret,cap);
495 }
496
497 Capability *
498 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
499 /*out*/HaskellObj *ret)
500 {
501 StgTSO *tso;
502
503 tso = createIOThread(cap, stack_size, p);
504 return scheduleWaitThread(tso,ret,cap);
505 }
506
507 /* Convenience function for decoding the returned status. */
508
509 void
510 rts_checkSchedStatus (char* site, Capability *cap)
511 {
512 SchedulerStatus rc = cap->running_task->incall->stat;
513 switch (rc) {
514 case Success:
515 return;
516 case Killed:
517 errorBelch("%s: uncaught exception",site);
518 stg_exit(EXIT_FAILURE);
519 case Interrupted:
520 errorBelch("%s: interrupted", site);
521 stg_exit(EXIT_FAILURE);
522 default:
523 errorBelch("%s: Return code (%d) not ok",(site),(rc));
524 stg_exit(EXIT_FAILURE);
525 }
526 }
527
528 SchedulerStatus
529 rts_getSchedStatus (Capability *cap)
530 {
531 return cap->running_task->incall->stat;
532 }
533
534 Capability *
535 rts_lock (void)
536 {
537 Capability *cap;
538 Task *task;
539
540 task = newBoundTask();
541
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);
548 }
549
550 cap = NULL;
551 waitForReturnCapability(&cap, task);
552 return (Capability *)cap;
553 }
554
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).
560
561 void
562 rts_unlock (Capability *cap)
563 {
564 Task *task;
565
566 task = cap->running_task;
567 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
568
569 // Now release the Capability. With the capability released, GC
570 // may happen. NB. does not try to put the current Task on the
571 // worker queue.
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);
581
582 // Finally, we can release the Task to the free list.
583 boundTaskExiting(task);
584 RELEASE_LOCK(&cap->lock);
585 }