remove unused includes, now that Storage.h & Stable.h are included by Rts.h
[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 "RtsAPI.h"
13 #include "SchedAPI.h"
14 #include "RtsFlags.h"
15 #include "RtsUtils.h"
16 #include "Prelude.h"
17 #include "Schedule.h"
18 #include "Capability.h"
19 #include "Stable.h"
20
21 #include <stdlib.h>
22
23 /* ----------------------------------------------------------------------------
24 Building Haskell objects from C datatypes.
25 ------------------------------------------------------------------------- */
26 HaskellObj
27 rts_mkChar (Capability *cap, HsChar c)
28 {
29 StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
30 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
31 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
32 return p;
33 }
34
35 HaskellObj
36 rts_mkInt (Capability *cap, HsInt i)
37 {
38 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
39 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
40 p->payload[0] = (StgClosure *)(StgInt)i;
41 return p;
42 }
43
44 HaskellObj
45 rts_mkInt8 (Capability *cap, HsInt8 i)
46 {
47 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
48 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
49 /* Make sure we mask out the bits above the lowest 8 */
50 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
51 return p;
52 }
53
54 HaskellObj
55 rts_mkInt16 (Capability *cap, HsInt16 i)
56 {
57 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
58 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
59 /* Make sure we mask out the relevant bits */
60 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
61 return p;
62 }
63
64 HaskellObj
65 rts_mkInt32 (Capability *cap, HsInt32 i)
66 {
67 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
68 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
69 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
70 return p;
71 }
72
73 HaskellObj
74 rts_mkInt64 (Capability *cap, HsInt64 i)
75 {
76 llong *tmp;
77 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
78 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
79 tmp = (llong*)&(p->payload[0]);
80 *tmp = (StgInt64)i;
81 return p;
82 }
83
84 HaskellObj
85 rts_mkWord (Capability *cap, HsWord i)
86 {
87 StgClosure *p = (StgClosure *)allocateLocal(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 *)allocateLocal(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 *)allocateLocal(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 *)allocateLocal(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 ullong *tmp;
127
128 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
129 /* see mk_Int8 comment */
130 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
131 tmp = (ullong*)&(p->payload[0]);
132 *tmp = (StgWord64)w;
133 return p;
134 }
135
136 HaskellObj
137 rts_mkFloat (Capability *cap, HsFloat f)
138 {
139 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
140 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
141 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
142 return p;
143 }
144
145 HaskellObj
146 rts_mkDouble (Capability *cap, HsDouble d)
147 {
148 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
149 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
150 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
151 return p;
152 }
153
154 HaskellObj
155 rts_mkStablePtr (Capability *cap, HsStablePtr s)
156 {
157 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
158 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
159 p->payload[0] = (StgClosure *)s;
160 return p;
161 }
162
163 HaskellObj
164 rts_mkPtr (Capability *cap, HsPtr a)
165 {
166 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
167 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
168 p->payload[0] = (StgClosure *)a;
169 return p;
170 }
171
172 HaskellObj
173 rts_mkFunPtr (Capability *cap, HsFunPtr a)
174 {
175 StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
176 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
177 p->payload[0] = (StgClosure *)a;
178 return p;
179 }
180
181 HaskellObj
182 rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
183 {
184 if (b) {
185 return (StgClosure *)True_closure;
186 } else {
187 return (StgClosure *)False_closure;
188 }
189 }
190
191 HaskellObj
192 rts_mkString (Capability *cap, char *s)
193 {
194 return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
195 }
196
197 HaskellObj
198 rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
199 {
200 StgThunk *ap;
201
202 ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
203 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
204 ap->payload[0] = f;
205 ap->payload[1] = arg;
206 return (StgClosure *)ap;
207 }
208
209 /* ----------------------------------------------------------------------------
210 Deconstructing Haskell objects
211
212 We would like to assert that we have the right kind of object in
213 each case, but this is problematic because in GHCi the info table
214 for the D# constructor (say) might be dynamically loaded. Hence we
215 omit these assertions for now.
216 ------------------------------------------------------------------------- */
217
218 HsChar
219 rts_getChar (HaskellObj p)
220 {
221 // See comment above:
222 // ASSERT(p->header.info == Czh_con_info ||
223 // p->header.info == Czh_static_info);
224 return (StgChar)(StgWord)(p->payload[0]);
225 }
226
227 HsInt
228 rts_getInt (HaskellObj p)
229 {
230 // See comment above:
231 // ASSERT(p->header.info == Izh_con_info ||
232 // p->header.info == Izh_static_info);
233 return (HsInt)(p->payload[0]);
234 }
235
236 HsInt8
237 rts_getInt8 (HaskellObj p)
238 {
239 // See comment above:
240 // ASSERT(p->header.info == I8zh_con_info ||
241 // p->header.info == I8zh_static_info);
242 return (HsInt8)(HsInt)(p->payload[0]);
243 }
244
245 HsInt16
246 rts_getInt16 (HaskellObj p)
247 {
248 // See comment above:
249 // ASSERT(p->header.info == I16zh_con_info ||
250 // p->header.info == I16zh_static_info);
251 return (HsInt16)(HsInt)(p->payload[0]);
252 }
253
254 HsInt32
255 rts_getInt32 (HaskellObj p)
256 {
257 // See comment above:
258 // ASSERT(p->header.info == I32zh_con_info ||
259 // p->header.info == I32zh_static_info);
260 return (HsInt32)(HsInt)(p->payload[0]);
261 }
262
263 HsInt64
264 rts_getInt64 (HaskellObj p)
265 {
266 HsInt64* tmp;
267 // See comment above:
268 // ASSERT(p->header.info == I64zh_con_info ||
269 // p->header.info == I64zh_static_info);
270 tmp = (HsInt64*)&(p->payload[0]);
271 return *tmp;
272 }
273 HsWord
274 rts_getWord (HaskellObj p)
275 {
276 // See comment above:
277 // ASSERT(p->header.info == Wzh_con_info ||
278 // p->header.info == Wzh_static_info);
279 return (HsWord)(p->payload[0]);
280 }
281
282 HsWord8
283 rts_getWord8 (HaskellObj p)
284 {
285 // See comment above:
286 // ASSERT(p->header.info == W8zh_con_info ||
287 // p->header.info == W8zh_static_info);
288 return (HsWord8)(HsWord)(p->payload[0]);
289 }
290
291 HsWord16
292 rts_getWord16 (HaskellObj p)
293 {
294 // See comment above:
295 // ASSERT(p->header.info == W16zh_con_info ||
296 // p->header.info == W16zh_static_info);
297 return (HsWord16)(HsWord)(p->payload[0]);
298 }
299
300 HsWord32
301 rts_getWord32 (HaskellObj p)
302 {
303 // See comment above:
304 // ASSERT(p->header.info == W32zh_con_info ||
305 // p->header.info == W32zh_static_info);
306 return (HsWord32)(HsWord)(p->payload[0]);
307 }
308
309
310 HsWord64
311 rts_getWord64 (HaskellObj p)
312 {
313 HsWord64* tmp;
314 // See comment above:
315 // ASSERT(p->header.info == W64zh_con_info ||
316 // p->header.info == W64zh_static_info);
317 tmp = (HsWord64*)&(p->payload[0]);
318 return *tmp;
319 }
320
321 HsFloat
322 rts_getFloat (HaskellObj p)
323 {
324 // See comment above:
325 // ASSERT(p->header.info == Fzh_con_info ||
326 // p->header.info == Fzh_static_info);
327 return (float)(PK_FLT((P_)p->payload));
328 }
329
330 HsDouble
331 rts_getDouble (HaskellObj p)
332 {
333 // See comment above:
334 // ASSERT(p->header.info == Dzh_con_info ||
335 // p->header.info == Dzh_static_info);
336 return (double)(PK_DBL((P_)p->payload));
337 }
338
339 HsStablePtr
340 rts_getStablePtr (HaskellObj p)
341 {
342 // See comment above:
343 // ASSERT(p->header.info == StablePtr_con_info ||
344 // p->header.info == StablePtr_static_info);
345 return (StgStablePtr)(p->payload[0]);
346 }
347
348 HsPtr
349 rts_getPtr (HaskellObj p)
350 {
351 // See comment above:
352 // ASSERT(p->header.info == Ptr_con_info ||
353 // p->header.info == Ptr_static_info);
354 return (Capability *)(p->payload[0]);
355 }
356
357 HsFunPtr
358 rts_getFunPtr (HaskellObj p)
359 {
360 // See comment above:
361 // ASSERT(p->header.info == FunPtr_con_info ||
362 // p->header.info == FunPtr_static_info);
363 return (void *)(p->payload[0]);
364 }
365
366 HsBool
367 rts_getBool (HaskellObj p)
368 {
369 StgInfoTable *info;
370
371 info = get_itbl((StgClosure *)p);
372 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
373 return 0;
374 } else {
375 return 1;
376 }
377 }
378
379 /* -----------------------------------------------------------------------------
380 Creating threads
381 -------------------------------------------------------------------------- */
382
383 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
384 tso->sp--;
385 tso->sp[0] = (W_) c;
386 }
387
388 StgTSO *
389 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
390 {
391 StgTSO *t;
392 #if defined(GRAN)
393 t = createThread (cap, stack_size, NO_PRI);
394 #else
395 t = createThread (cap, stack_size);
396 #endif
397 pushClosure(t, (W_)closure);
398 pushClosure(t, (W_)&stg_enter_info);
399 return t;
400 }
401
402 StgTSO *
403 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
404 {
405 StgTSO *t;
406 #if defined(GRAN)
407 t = createThread (cap, stack_size, NO_PRI);
408 #else
409 t = createThread (cap, stack_size);
410 #endif
411 pushClosure(t, (W_)&stg_noforceIO_info);
412 pushClosure(t, (W_)&stg_ap_v_info);
413 pushClosure(t, (W_)closure);
414 pushClosure(t, (W_)&stg_enter_info);
415 return t;
416 }
417
418 /*
419 * Same as above, but also evaluate the result of the IO action
420 * to whnf while we're at it.
421 */
422
423 StgTSO *
424 createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
425 {
426 StgTSO *t;
427 #if defined(GRAN)
428 t = createThread(cap, stack_size, NO_PRI);
429 #else
430 t = createThread(cap, stack_size);
431 #endif
432 pushClosure(t, (W_)&stg_forceIO_info);
433 pushClosure(t, (W_)&stg_ap_v_info);
434 pushClosure(t, (W_)closure);
435 pushClosure(t, (W_)&stg_enter_info);
436 return t;
437 }
438
439 /* ----------------------------------------------------------------------------
440 Evaluating Haskell expressions
441 ------------------------------------------------------------------------- */
442
443 Capability *
444 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
445 {
446 StgTSO *tso;
447
448 tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
449 return scheduleWaitThread(tso,ret,cap);
450 }
451
452 Capability *
453 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
454 /*out*/HaskellObj *ret)
455 {
456 StgTSO *tso;
457
458 tso = createGenThread(cap, stack_size, p);
459 return scheduleWaitThread(tso,ret,cap);
460 }
461
462 /*
463 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
464 * result to WHNF before returning.
465 */
466 Capability *
467 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
468 {
469 StgTSO* tso;
470
471 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
472 return scheduleWaitThread(tso,ret,cap);
473 }
474
475 /*
476 * rts_evalStableIO() is suitable for calling from Haskell. It
477 * evaluates a value of the form (StablePtr (IO a)), forcing the
478 * action's result to WHNF before returning. The result is returned
479 * in a StablePtr.
480 */
481 Capability *
482 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
483 {
484 StgTSO* tso;
485 StgClosure *p, *r;
486 SchedulerStatus stat;
487
488 p = (StgClosure *)deRefStablePtr(s);
489 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
490 cap = scheduleWaitThread(tso,&r,cap);
491 stat = rts_getSchedStatus(cap);
492
493 if (stat == Success && ret != NULL) {
494 ASSERT(r != NULL);
495 *ret = getStablePtr((StgPtr)r);
496 }
497
498 return cap;
499 }
500
501 /*
502 * Like rts_evalIO(), but doesn't force the action's result.
503 */
504 Capability *
505 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
506 {
507 StgTSO *tso;
508
509 tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
510 return scheduleWaitThread(tso,ret,cap);
511 }
512
513 Capability *
514 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
515 /*out*/HaskellObj *ret)
516 {
517 StgTSO *tso;
518
519 tso = createIOThread(cap, stack_size, p);
520 return scheduleWaitThread(tso,ret,cap);
521 }
522
523 /* Convenience function for decoding the returned status. */
524
525 void
526 rts_checkSchedStatus (char* site, Capability *cap)
527 {
528 SchedulerStatus rc = cap->running_task->stat;
529 switch (rc) {
530 case Success:
531 return;
532 case Killed:
533 errorBelch("%s: uncaught exception",site);
534 stg_exit(EXIT_FAILURE);
535 case Interrupted:
536 errorBelch("%s: interrupted", site);
537 stg_exit(EXIT_FAILURE);
538 default:
539 errorBelch("%s: Return code (%d) not ok",(site),(rc));
540 stg_exit(EXIT_FAILURE);
541 }
542 }
543
544 SchedulerStatus
545 rts_getSchedStatus (Capability *cap)
546 {
547 return cap->running_task->stat;
548 }
549
550 Capability *
551 rts_lock (void)
552 {
553 Capability *cap;
554 Task *task;
555
556 // ToDo: get rid of this lock in the common case. We could store
557 // a free Task in thread-local storage, for example. That would
558 // leave just one lock on the path into the RTS: cap->lock when
559 // acquiring the Capability.
560 ACQUIRE_LOCK(&sched_mutex);
561 task = newBoundTask();
562 RELEASE_LOCK(&sched_mutex);
563
564 cap = NULL;
565 waitForReturnCapability(&cap, task);
566 return (Capability *)cap;
567 }
568
569 // Exiting the RTS: we hold a Capability that is not necessarily the
570 // same one that was originally returned by rts_lock(), because
571 // rts_evalIO() etc. may return a new one. Now that we have
572 // investigated the return value, we can release the Capability,
573 // and free the Task (in that order).
574
575 void
576 rts_unlock (Capability *cap)
577 {
578 Task *task;
579
580 task = cap->running_task;
581 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
582
583 // slightly delicate ordering of operations below, pay attention!
584
585 // We are no longer a bound task/thread. This is important,
586 // because the GC can run when we release the Capability below,
587 // and we don't want it to treat this as a live TSO pointer.
588 task->tso = NULL;
589
590 // Now release the Capability. With the capability released, GC
591 // may happen. NB. does not try to put the current Task on the
592 // worker queue.
593 releaseCapability(cap);
594
595 // Finally, we can release the Task to the free list.
596 boundTaskExiting(task);
597 }