Merge branch 'master' of http://darcs.haskell.org/ghc
[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, W_ 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, W_ 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, W_ 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 void rts_eval (/* inout */ Capability **cap,
425 /* in */ HaskellObj p,
426 /* out */ HaskellObj *ret)
427 {
428 StgTSO *tso;
429
430 tso = createGenThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
431 scheduleWaitThread(tso,ret,cap);
432 }
433
434 void rts_eval_ (/* inout */ Capability **cap,
435 /* in */ HaskellObj p,
436 /* in */ unsigned int stack_size,
437 /* out */ HaskellObj *ret)
438 {
439 StgTSO *tso;
440
441 tso = createGenThread(*cap, stack_size, p);
442 scheduleWaitThread(tso,ret,cap);
443 }
444
445 /*
446 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
447 * result to WHNF before returning.
448 */
449 void rts_evalIO (/* inout */ Capability **cap,
450 /* in */ HaskellObj p,
451 /* out */ HaskellObj *ret)
452 {
453 StgTSO* tso;
454
455 tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
456 scheduleWaitThread(tso,ret,cap);
457 }
458
459 /*
460 * rts_evalStableIO() is suitable for calling from Haskell. It
461 * evaluates a value of the form (StablePtr (IO a)), forcing the
462 * action's result to WHNF before returning. The result is returned
463 * in a StablePtr.
464 */
465 void rts_evalStableIO (/* inout */ Capability **cap,
466 /* in */ HsStablePtr s,
467 /* out */ HsStablePtr *ret)
468 {
469 StgTSO* tso;
470 StgClosure *p, *r;
471 SchedulerStatus stat;
472
473 p = (StgClosure *)deRefStablePtr(s);
474 tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
475 // async exceptions are always blocked by default in the created
476 // thread. See #1048.
477 tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
478 scheduleWaitThread(tso,&r,cap);
479 stat = rts_getSchedStatus(*cap);
480
481 if (stat == Success && ret != NULL) {
482 ASSERT(r != NULL);
483 *ret = getStablePtr((StgPtr)r);
484 }
485 }
486
487 /*
488 * Like rts_evalIO(), but doesn't force the action's result.
489 */
490 void rts_evalLazyIO (/* inout */ Capability **cap,
491 /* in */ HaskellObj p,
492 /* out */ HaskellObj *ret)
493 {
494 StgTSO *tso;
495
496 tso = createIOThread(*cap, RtsFlags.GcFlags.initialStkSize, p);
497 scheduleWaitThread(tso,ret,cap);
498 }
499
500 void rts_evalLazyIO_ (/* inout */ Capability **cap,
501 /* in */ HaskellObj p,
502 /* in */ unsigned int stack_size,
503 /* out */ HaskellObj *ret)
504 {
505 StgTSO *tso;
506
507 tso = createIOThread(*cap, stack_size, p);
508 scheduleWaitThread(tso,ret,cap);
509 }
510
511 /* Convenience function for decoding the returned status. */
512
513 void
514 rts_checkSchedStatus (char* site, Capability *cap)
515 {
516 SchedulerStatus rc = cap->running_task->incall->stat;
517 switch (rc) {
518 case Success:
519 return;
520 case Killed:
521 errorBelch("%s: uncaught exception",site);
522 stg_exit(EXIT_FAILURE);
523 case Interrupted:
524 errorBelch("%s: interrupted", site);
525 stg_exit(EXIT_FAILURE);
526 default:
527 errorBelch("%s: Return code (%d) not ok",(site),(rc));
528 stg_exit(EXIT_FAILURE);
529 }
530 }
531
532 SchedulerStatus
533 rts_getSchedStatus (Capability *cap)
534 {
535 return cap->running_task->incall->stat;
536 }
537
538 Capability *
539 rts_lock (void)
540 {
541 Capability *cap;
542 Task *task;
543
544 task = newBoundTask();
545
546 if (task->running_finalizers) {
547 errorBelch("error: a C finalizer called back into Haskell.\n"
548 " This was previously allowed, but is disallowed in GHC 6.10.2 and later.\n"
549 " To create finalizers that may call back into Haskell, use\n"
550 " Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr.");
551 stg_exit(EXIT_FAILURE);
552 }
553
554 cap = NULL;
555 waitForReturnCapability(&cap, task);
556
557 if (task->incall->prev_stack == NULL) {
558 // This is a new outermost call from C into Haskell land.
559 // Until the corresponding call to rts_unlock, this task
560 // is doing work on behalf of the RTS.
561 traceTaskCreate(task, cap);
562 }
563
564 return (Capability *)cap;
565 }
566
567 // Exiting the RTS: we hold a Capability that is not necessarily the
568 // same one that was originally returned by rts_lock(), because
569 // rts_evalIO() etc. may return a new one. Now that we have
570 // investigated the return value, we can release the Capability,
571 // and free the Task (in that order).
572
573 void
574 rts_unlock (Capability *cap)
575 {
576 Task *task;
577
578 task = cap->running_task;
579 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
580
581 // Now release the Capability. With the capability released, GC
582 // may happen. NB. does not try to put the current Task on the
583 // worker queue.
584 // NB. keep cap->lock held while we call boundTaskExiting(). This
585 // is necessary during shutdown, where we want the invariant that
586 // after shutdownCapability(), all the Tasks associated with the
587 // Capability have completed their shutdown too. Otherwise we
588 // could have boundTaskExiting()/workerTaskStop() running at some
589 // random point in the future, which causes problems for
590 // freeTaskManager().
591 ACQUIRE_LOCK(&cap->lock);
592 releaseCapability_(cap,rtsFalse);
593
594 // Finally, we can release the Task to the free list.
595 boundTaskExiting(task);
596 RELEASE_LOCK(&cap->lock);
597
598 if (task->incall == NULL) {
599 // This is the end of an outermost call from C into Haskell land.
600 // From here on, the task goes back to C land and we should not count
601 // it as doing work on behalf of the RTS.
602 traceTaskDelete(task);
603 }
604 }