RTS tidyup sweep, first phase
[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
20 /* ----------------------------------------------------------------------------
21 Building Haskell objects from C datatypes.
22
23 TODO: Currently this code does not tag created pointers,
24 however it is not unsafe (the contructor code will do it)
25 just inefficient.
26 ------------------------------------------------------------------------- */
27 HaskellObj
28 rts_mkChar (Capability *cap, HsChar c)
29 {
30 StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
31 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
32 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
33 return p;
34 }
35
36 HaskellObj
37 rts_mkInt (Capability *cap, HsInt i)
38 {
39 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
40 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
41 p->payload[0] = (StgClosure *)(StgInt)i;
42 return p;
43 }
44
45 HaskellObj
46 rts_mkInt8 (Capability *cap, HsInt8 i)
47 {
48 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
49 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
50 /* Make sure we mask out the bits above the lowest 8 */
51 p->payload[0] = (StgClosure *)(StgInt)i;
52 return p;
53 }
54
55 HaskellObj
56 rts_mkInt16 (Capability *cap, HsInt16 i)
57 {
58 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
59 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
60 /* Make sure we mask out the relevant bits */
61 p->payload[0] = (StgClosure *)(StgInt)i;
62 return p;
63 }
64
65 HaskellObj
66 rts_mkInt32 (Capability *cap, HsInt32 i)
67 {
68 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
69 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
70 p->payload[0] = (StgClosure *)(StgInt)i;
71 return p;
72 }
73
74 HaskellObj
75 rts_mkInt64 (Capability *cap, HsInt64 i)
76 {
77 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
78 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
79 ASSIGN_Int64((P_)&(p->payload[0]), i);
80 return p;
81 }
82
83 HaskellObj
84 rts_mkWord (Capability *cap, HsWord i)
85 {
86 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
87 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
88 p->payload[0] = (StgClosure *)(StgWord)i;
89 return p;
90 }
91
92 HaskellObj
93 rts_mkWord8 (Capability *cap, HsWord8 w)
94 {
95 /* see rts_mkInt* comments */
96 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
97 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
98 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
99 return p;
100 }
101
102 HaskellObj
103 rts_mkWord16 (Capability *cap, HsWord16 w)
104 {
105 /* see rts_mkInt* comments */
106 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
107 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
108 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
109 return p;
110 }
111
112 HaskellObj
113 rts_mkWord32 (Capability *cap, HsWord32 w)
114 {
115 /* see rts_mkInt* comments */
116 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
117 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
118 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
119 return p;
120 }
121
122 HaskellObj
123 rts_mkWord64 (Capability *cap, HsWord64 w)
124 {
125 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
126 /* see mk_Int8 comment */
127 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
128 ASSIGN_Word64((P_)&(p->payload[0]), w);
129 return p;
130 }
131
132
133 HaskellObj
134 rts_mkFloat (Capability *cap, HsFloat f)
135 {
136 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
137 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
138 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
139 return p;
140 }
141
142 HaskellObj
143 rts_mkDouble (Capability *cap, HsDouble d)
144 {
145 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
146 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
147 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
148 return p;
149 }
150
151 HaskellObj
152 rts_mkStablePtr (Capability *cap, HsStablePtr s)
153 {
154 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
155 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
156 p->payload[0] = (StgClosure *)s;
157 return p;
158 }
159
160 HaskellObj
161 rts_mkPtr (Capability *cap, HsPtr a)
162 {
163 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
164 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
165 p->payload[0] = (StgClosure *)a;
166 return p;
167 }
168
169 HaskellObj
170 rts_mkFunPtr (Capability *cap, HsFunPtr a)
171 {
172 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
173 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
174 p->payload[0] = (StgClosure *)a;
175 return p;
176 }
177
178 HaskellObj
179 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
180 {
181 if (b) {
182 return (StgClosure *)True_closure;
183 } else {
184 return (StgClosure *)False_closure;
185 }
186 }
187
188 HaskellObj
189 rts_mkString (Capability *cap, char *s)
190 {
191 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
192 }
193
194 HaskellObj
195 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
196 {
197 StgThunk *ap;
198
199 ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
200 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
201 ap->payload[0] = f;
202 ap->payload[1] = arg;
203 return (StgClosure *)ap;
204 }
205
206 /* ----------------------------------------------------------------------------
207 Deconstructing Haskell objects
208
209 We would like to assert that we have the right kind of object in
210 each case, but this is problematic because in GHCi the info table
211 for the D# constructor (say) might be dynamically loaded. Hence we
212 omit these assertions for now.
213 ------------------------------------------------------------------------- */
214
215 HsChar
216 rts_getChar (HaskellObj p)
217 {
218 // See comment above:
219 // ASSERT(p->header.info == Czh_con_info ||
220 // p->header.info == Czh_static_info);
221 return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
222 }
223
224 HsInt
225 rts_getInt (HaskellObj p)
226 {
227 // See comment above:
228 // ASSERT(p->header.info == Izh_con_info ||
229 // p->header.info == Izh_static_info);
230 return (HsInt)(UNTAG_CLOSURE(p)->payload[0]);
231 }
232
233 HsInt8
234 rts_getInt8 (HaskellObj p)
235 {
236 // See comment above:
237 // ASSERT(p->header.info == I8zh_con_info ||
238 // p->header.info == I8zh_static_info);
239 return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
240 }
241
242 HsInt16
243 rts_getInt16 (HaskellObj p)
244 {
245 // See comment above:
246 // ASSERT(p->header.info == I16zh_con_info ||
247 // p->header.info == I16zh_static_info);
248 return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
249 }
250
251 HsInt32
252 rts_getInt32 (HaskellObj p)
253 {
254 // See comment above:
255 // ASSERT(p->header.info == I32zh_con_info ||
256 // p->header.info == I32zh_static_info);
257 return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
258 }
259
260 HsInt64
261 rts_getInt64 (HaskellObj p)
262 {
263 // See comment above:
264 // ASSERT(p->header.info == I64zh_con_info ||
265 // p->header.info == I64zh_static_info);
266 return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
267 }
268
269 HsWord
270 rts_getWord (HaskellObj p)
271 {
272 // See comment above:
273 // ASSERT(p->header.info == Wzh_con_info ||
274 // p->header.info == Wzh_static_info);
275 return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
276 }
277
278 HsWord8
279 rts_getWord8 (HaskellObj p)
280 {
281 // See comment above:
282 // ASSERT(p->header.info == W8zh_con_info ||
283 // p->header.info == W8zh_static_info);
284 return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
285 }
286
287 HsWord16
288 rts_getWord16 (HaskellObj p)
289 {
290 // See comment above:
291 // ASSERT(p->header.info == W16zh_con_info ||
292 // p->header.info == W16zh_static_info);
293 return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
294 }
295
296 HsWord32
297 rts_getWord32 (HaskellObj p)
298 {
299 // See comment above:
300 // ASSERT(p->header.info == W32zh_con_info ||
301 // p->header.info == W32zh_static_info);
302 return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
303 }
304
305 HsWord64
306 rts_getWord64 (HaskellObj p)
307 {
308 // See comment above:
309 // ASSERT(p->header.info == W64zh_con_info ||
310 // p->header.info == W64zh_static_info);
311 return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
312 }
313
314 HsFloat
315 rts_getFloat (HaskellObj p)
316 {
317 // See comment above:
318 // ASSERT(p->header.info == Fzh_con_info ||
319 // p->header.info == Fzh_static_info);
320 return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
321 }
322
323 HsDouble
324 rts_getDouble (HaskellObj p)
325 {
326 // See comment above:
327 // ASSERT(p->header.info == Dzh_con_info ||
328 // p->header.info == Dzh_static_info);
329 return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
330 }
331
332 HsStablePtr
333 rts_getStablePtr (HaskellObj p)
334 {
335 // See comment above:
336 // ASSERT(p->header.info == StablePtr_con_info ||
337 // p->header.info == StablePtr_static_info);
338 return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
339 }
340
341 HsPtr
342 rts_getPtr (HaskellObj p)
343 {
344 // See comment above:
345 // ASSERT(p->header.info == Ptr_con_info ||
346 // p->header.info == Ptr_static_info);
347 return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
348 }
349
350 HsFunPtr
351 rts_getFunPtr (HaskellObj p)
352 {
353 // See comment above:
354 // ASSERT(p->header.info == FunPtr_con_info ||
355 // p->header.info == FunPtr_static_info);
356 return (void *)(UNTAG_CLOSURE(p)->payload[0]);
357 }
358
359 HsBool
360 rts_getBool (HaskellObj p)
361 {
362 StgInfoTable *info;
363
364 info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
365 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
366 return 0;
367 } else {
368 return 1;
369 }
370 }
371
372 /* -----------------------------------------------------------------------------
373 Creating threads
374 -------------------------------------------------------------------------- */
375
376 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
377 tso->sp--;
378 tso->sp[0] = (W_) c;
379 }
380
381 StgTSO *
382 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
383 {
384 StgTSO *t;
385 t = createThread (cap, stack_size);
386 pushClosure(t, (W_)closure);
387 pushClosure(t, (W_)&stg_enter_info);
388 return t;
389 }
390
391 StgTSO *
392 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
393 {
394 StgTSO *t;
395 t = createThread (cap, stack_size);
396 pushClosure(t, (W_)&stg_noforceIO_info);
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->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->stat;
532 }
533
534 Capability *
535 rts_lock (void)
536 {
537 Capability *cap;
538 Task *task;
539
540 task = newBoundTask();
541
542 cap = NULL;
543 waitForReturnCapability(&cap, task);
544 return (Capability *)cap;
545 }
546
547 // Exiting the RTS: we hold a Capability that is not necessarily the
548 // same one that was originally returned by rts_lock(), because
549 // rts_evalIO() etc. may return a new one. Now that we have
550 // investigated the return value, we can release the Capability,
551 // and free the Task (in that order).
552
553 void
554 rts_unlock (Capability *cap)
555 {
556 Task *task;
557
558 task = cap->running_task;
559 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
560
561 // Now release the Capability. With the capability released, GC
562 // may happen. NB. does not try to put the current Task on the
563 // worker queue.
564 // NB. keep cap->lock held while we call boundTaskExiting(). This
565 // is necessary during shutdown, where we want the invariant that
566 // after shutdownCapability(), all the Tasks associated with the
567 // Capability have completed their shutdown too. Otherwise we
568 // could have boundTaskExiting()/workerTaskStop() running at some
569 // random point in the future, which causes problems for
570 // freeTaskManager().
571 ACQUIRE_LOCK(&cap->lock);
572 releaseCapability_(cap,rtsFalse);
573
574 // Finally, we can release the Task to the free list.
575 boundTaskExiting(task);
576 RELEASE_LOCK(&cap->lock);
577 }