Split GC.c, and move storage manager into sm/ directory
[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 "OSThreads.h"
12 #include "Storage.h"
13 #include "RtsAPI.h"
14 #include "SchedAPI.h"
15 #include "RtsFlags.h"
16 #include "RtsUtils.h"
17 #include "Prelude.h"
18 #include "Schedule.h"
19 #include "Capability.h"
20 #include "Stable.h"
21
22 #include <stdlib.h>
23
24 /* ----------------------------------------------------------------------------
25 Building Haskell objects from C datatypes.
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)((unsigned)i & 0xff);
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)((unsigned)i & 0xffff);
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)((unsigned)i & 0xffffffff);
71 return p;
72 }
73
74 HaskellObj
75 rts_mkInt64 (Capability *cap, HsInt64 i)
76 {
77 llong *tmp;
78 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
79 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
80 tmp = (llong*)&(p->payload[0]);
81 *tmp = (StgInt64)i;
82 return p;
83 }
84
85 HaskellObj
86 rts_mkWord (Capability *cap, HsWord i)
87 {
88 StgClosure *p = (StgClosure *)allocateLocal(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 *)allocateLocal(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 *)allocateLocal(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 *)allocateLocal(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 ullong *tmp;
128
129 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
130 /* see mk_Int8 comment */
131 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
132 tmp = (ullong*)&(p->payload[0]);
133 *tmp = (StgWord64)w;
134 return p;
135 }
136
137 HaskellObj
138 rts_mkFloat (Capability *cap, HsFloat f)
139 {
140 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
141 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
142 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
143 return p;
144 }
145
146 HaskellObj
147 rts_mkDouble (Capability *cap, HsDouble d)
148 {
149 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
150 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
151 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
152 return p;
153 }
154
155 HaskellObj
156 rts_mkStablePtr (Capability *cap, HsStablePtr s)
157 {
158 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
159 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
160 p->payload[0] = (StgClosure *)s;
161 return p;
162 }
163
164 HaskellObj
165 rts_mkPtr (Capability *cap, HsPtr a)
166 {
167 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
168 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
169 p->payload[0] = (StgClosure *)a;
170 return p;
171 }
172
173 HaskellObj
174 rts_mkFunPtr (Capability *cap, HsFunPtr a)
175 {
176 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
177 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
178 p->payload[0] = (StgClosure *)a;
179 return p;
180 }
181
182 HaskellObj
183 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
184 {
185 if (b) {
186 return (StgClosure *)True_closure;
187 } else {
188 return (StgClosure *)False_closure;
189 }
190 }
191
192 HaskellObj
193 rts_mkString (Capability *cap, char *s)
194 {
195 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
196 }
197
198 HaskellObj
199 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
200 {
201 StgThunk *ap;
202
203 ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
204 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
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)(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)(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)(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)(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)(p->payload[0]);
262 }
263
264 HsInt64
265 rts_getInt64 (HaskellObj p)
266 {
267 HsInt64* tmp;
268 // See comment above:
269 // ASSERT(p->header.info == I64zh_con_info ||
270 // p->header.info == I64zh_static_info);
271 tmp = (HsInt64*)&(p->payload[0]);
272 return *tmp;
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)(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)(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)(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)(p->payload[0]);
308 }
309
310
311 HsWord64
312 rts_getWord64 (HaskellObj p)
313 {
314 HsWord64* tmp;
315 // See comment above:
316 // ASSERT(p->header.info == W64zh_con_info ||
317 // p->header.info == W64zh_static_info);
318 tmp = (HsWord64*)&(p->payload[0]);
319 return *tmp;
320 }
321
322 HsFloat
323 rts_getFloat (HaskellObj p)
324 {
325 // See comment above:
326 // ASSERT(p->header.info == Fzh_con_info ||
327 // p->header.info == Fzh_static_info);
328 return (float)(PK_FLT((P_)p->payload));
329 }
330
331 HsDouble
332 rts_getDouble (HaskellObj p)
333 {
334 // See comment above:
335 // ASSERT(p->header.info == Dzh_con_info ||
336 // p->header.info == Dzh_static_info);
337 return (double)(PK_DBL((P_)p->payload));
338 }
339
340 HsStablePtr
341 rts_getStablePtr (HaskellObj p)
342 {
343 // See comment above:
344 // ASSERT(p->header.info == StablePtr_con_info ||
345 // p->header.info == StablePtr_static_info);
346 return (StgStablePtr)(p->payload[0]);
347 }
348
349 HsPtr
350 rts_getPtr (HaskellObj p)
351 {
352 // See comment above:
353 // ASSERT(p->header.info == Ptr_con_info ||
354 // p->header.info == Ptr_static_info);
355 return (Capability *)(p->payload[0]);
356 }
357
358 HsFunPtr
359 rts_getFunPtr (HaskellObj p)
360 {
361 // See comment above:
362 // ASSERT(p->header.info == FunPtr_con_info ||
363 // p->header.info == FunPtr_static_info);
364 return (void *)(p->payload[0]);
365 }
366
367 HsBool
368 rts_getBool (HaskellObj p)
369 {
370 StgInfoTable *info;
371
372 info = get_itbl((StgClosure *)p);
373 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
374 return 0;
375 } else {
376 return 1;
377 }
378 }
379
380 /* -----------------------------------------------------------------------------
381 Creating threads
382 -------------------------------------------------------------------------- */
383
384 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
385 tso->sp--;
386 tso->sp[0] = (W_) c;
387 }
388
389 StgTSO *
390 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
391 {
392 StgTSO *t;
393 #if defined(GRAN)
394 t = createThread (cap, stack_size, NO_PRI);
395 #else
396 t = createThread (cap, stack_size);
397 #endif
398 pushClosure(t, (W_)closure);
399 pushClosure(t, (W_)&stg_enter_info);
400 return t;
401 }
402
403 StgTSO *
404 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
405 {
406 StgTSO *t;
407 #if defined(GRAN)
408 t = createThread (cap, stack_size, NO_PRI);
409 #else
410 t = createThread (cap, stack_size);
411 #endif
412 pushClosure(t, (W_)&stg_noforceIO_info);
413 pushClosure(t, (W_)&stg_ap_v_info);
414 pushClosure(t, (W_)closure);
415 pushClosure(t, (W_)&stg_enter_info);
416 return t;
417 }
418
419 /*
420 * Same as above, but also evaluate the result of the IO action
421 * to whnf while we're at it.
422 */
423
424 StgTSO *
425 createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
426 {
427 StgTSO *t;
428 #if defined(GRAN)
429 t = createThread(cap, stack_size, NO_PRI);
430 #else
431 t = createThread(cap, stack_size);
432 #endif
433 pushClosure(t, (W_)&stg_forceIO_info);
434 pushClosure(t, (W_)&stg_ap_v_info);
435 pushClosure(t, (W_)closure);
436 pushClosure(t, (W_)&stg_enter_info);
437 return t;
438 }
439
440 /* ----------------------------------------------------------------------------
441 Evaluating Haskell expressions
442 ------------------------------------------------------------------------- */
443
444 Capability *
445 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
446 {
447 StgTSO *tso;
448
449 tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
450 return scheduleWaitThread(tso,ret,cap);
451 }
452
453 Capability *
454 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
455 /*out*/HaskellObj *ret)
456 {
457 StgTSO *tso;
458
459 tso = createGenThread(cap, stack_size, p);
460 return scheduleWaitThread(tso,ret,cap);
461 }
462
463 /*
464 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
465 * result to WHNF before returning.
466 */
467 Capability *
468 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
469 {
470 StgTSO* tso;
471
472 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
473 return scheduleWaitThread(tso,ret,cap);
474 }
475
476 /*
477 * rts_evalStableIO() is suitable for calling from Haskell. It
478 * evaluates a value of the form (StablePtr (IO a)), forcing the
479 * action's result to WHNF before returning. The result is returned
480 * in a StablePtr.
481 */
482 Capability *
483 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
484 {
485 StgTSO* tso;
486 StgClosure *p, *r;
487 SchedulerStatus stat;
488
489 p = (StgClosure *)deRefStablePtr(s);
490 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
491 cap = scheduleWaitThread(tso,&r,cap);
492 stat = rts_getSchedStatus(cap);
493
494 if (stat == Success && ret != NULL) {
495 ASSERT(r != NULL);
496 *ret = getStablePtr((StgPtr)r);
497 }
498
499 return cap;
500 }
501
502 /*
503 * Like rts_evalIO(), but doesn't force the action's result.
504 */
505 Capability *
506 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
507 {
508 StgTSO *tso;
509
510 tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
511 return scheduleWaitThread(tso,ret,cap);
512 }
513
514 Capability *
515 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
516 /*out*/HaskellObj *ret)
517 {
518 StgTSO *tso;
519
520 tso = createIOThread(cap, stack_size, p);
521 return scheduleWaitThread(tso,ret,cap);
522 }
523
524 /* Convenience function for decoding the returned status. */
525
526 void
527 rts_checkSchedStatus (char* site, Capability *cap)
528 {
529 SchedulerStatus rc = cap->running_task->stat;
530 switch (rc) {
531 case Success:
532 return;
533 case Killed:
534 errorBelch("%s: uncaught exception",site);
535 stg_exit(EXIT_FAILURE);
536 case Interrupted:
537 errorBelch("%s: interrupted", site);
538 stg_exit(EXIT_FAILURE);
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->stat;
549 }
550
551 Capability *
552 rts_lock (void)
553 {
554 Capability *cap;
555 Task *task;
556
557 // ToDo: get rid of this lock in the common case. We could store
558 // a free Task in thread-local storage, for example. That would
559 // leave just one lock on the path into the RTS: cap->lock when
560 // acquiring the Capability.
561 ACQUIRE_LOCK(&sched_mutex);
562 task = newBoundTask();
563 RELEASE_LOCK(&sched_mutex);
564
565 cap = NULL;
566 waitForReturnCapability(&cap, task);
567 return (Capability *)cap;
568 }
569
570 // Exiting the RTS: we hold a Capability that is not necessarily the
571 // same one that was originally returned by rts_lock(), because
572 // rts_evalIO() etc. may return a new one. Now that we have
573 // investigated the return value, we can release the Capability,
574 // and free the Task (in that order).
575
576 void
577 rts_unlock (Capability *cap)
578 {
579 Task *task;
580
581 task = cap->running_task;
582 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
583
584 // slightly delicate ordering of operations below, pay attention!
585
586 // We are no longer a bound task/thread. This is important,
587 // because the GC can run when we release the Capability below,
588 // and we don't want it to treat this as a live TSO pointer.
589 task->tso = NULL;
590
591 // Now release the Capability. With the capability released, GC
592 // may happen. NB. does not try to put the current Task on the
593 // worker queue.
594 releaseCapability(cap);
595
596 // Finally, we can release the Task to the free list.
597 boundTaskExiting(task);
598 }