replace sparc-specific Int64 code with calls to platform-independent macros
[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 TODO: Currently this code does not tag created pointers,
27 however it is not unsafe (the contructor code will do it)
28 just inefficient.
29 ------------------------------------------------------------------------- */
30 HaskellObj
31 rts_mkChar (Capability *cap, HsChar c)
32 {
33 StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
34 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
35 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
36 return p;
37 }
38
39 HaskellObj
40 rts_mkInt (Capability *cap, HsInt i)
41 {
42 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
43 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
44 p->payload[0] = (StgClosure *)(StgInt)i;
45 return p;
46 }
47
48 HaskellObj
49 rts_mkInt8 (Capability *cap, HsInt8 i)
50 {
51 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
52 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
53 /* Make sure we mask out the bits above the lowest 8 */
54 p->payload[0] = (StgClosure *)(StgInt)i;
55 return p;
56 }
57
58 HaskellObj
59 rts_mkInt16 (Capability *cap, HsInt16 i)
60 {
61 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
62 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
63 /* Make sure we mask out the relevant bits */
64 p->payload[0] = (StgClosure *)(StgInt)i;
65 return p;
66 }
67
68 HaskellObj
69 rts_mkInt32 (Capability *cap, HsInt32 i)
70 {
71 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
72 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
73 p->payload[0] = (StgClosure *)(StgInt)i;
74 return p;
75 }
76
77 HaskellObj
78 rts_mkInt64 (Capability *cap, HsInt64 i)
79 {
80 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
81 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
82 ASSIGN_Int64((P_)&(p->payload[0]), i);
83 return p;
84 }
85
86 HaskellObj
87 rts_mkWord (Capability *cap, HsWord i)
88 {
89 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
90 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
91 p->payload[0] = (StgClosure *)(StgWord)i;
92 return p;
93 }
94
95 HaskellObj
96 rts_mkWord8 (Capability *cap, HsWord8 w)
97 {
98 /* see rts_mkInt* comments */
99 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
100 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
101 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
102 return p;
103 }
104
105 HaskellObj
106 rts_mkWord16 (Capability *cap, HsWord16 w)
107 {
108 /* see rts_mkInt* comments */
109 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
110 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
111 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
112 return p;
113 }
114
115 HaskellObj
116 rts_mkWord32 (Capability *cap, HsWord32 w)
117 {
118 /* see rts_mkInt* comments */
119 StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
120 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
121 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
122 return p;
123 }
124
125 HaskellObj
126 rts_mkWord64 (Capability *cap, HsWord64 w)
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 ASSIGN_Word64((P_)&(p->payload[0]), w);
132 return p;
133 }
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)(UNTAG_CLOSURE(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)(UNTAG_CLOSURE(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)(UNTAG_CLOSURE(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)(UNTAG_CLOSURE(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)(UNTAG_CLOSURE(p)->payload[0]);
261 }
262
263 HsInt64
264 rts_getInt64 (HaskellObj p)
265 {
266 // See comment above:
267 // ASSERT(p->header.info == I64zh_con_info ||
268 // p->header.info == I64zh_static_info);
269 return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
270 }
271
272 HsWord
273 rts_getWord (HaskellObj p)
274 {
275 // See comment above:
276 // ASSERT(p->header.info == Wzh_con_info ||
277 // p->header.info == Wzh_static_info);
278 return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
279 }
280
281 HsWord8
282 rts_getWord8 (HaskellObj p)
283 {
284 // See comment above:
285 // ASSERT(p->header.info == W8zh_con_info ||
286 // p->header.info == W8zh_static_info);
287 return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
288 }
289
290 HsWord16
291 rts_getWord16 (HaskellObj p)
292 {
293 // See comment above:
294 // ASSERT(p->header.info == W16zh_con_info ||
295 // p->header.info == W16zh_static_info);
296 return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
297 }
298
299 HsWord32
300 rts_getWord32 (HaskellObj p)
301 {
302 // See comment above:
303 // ASSERT(p->header.info == W32zh_con_info ||
304 // p->header.info == W32zh_static_info);
305 return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
306 }
307
308 HsWord64
309 rts_getWord64 (HaskellObj p)
310 {
311 // See comment above:
312 // ASSERT(p->header.info == W64zh_con_info ||
313 // p->header.info == W64zh_static_info);
314 return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
315 }
316
317 HsFloat
318 rts_getFloat (HaskellObj p)
319 {
320 // See comment above:
321 // ASSERT(p->header.info == Fzh_con_info ||
322 // p->header.info == Fzh_static_info);
323 return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
324 }
325
326 HsDouble
327 rts_getDouble (HaskellObj p)
328 {
329 // See comment above:
330 // ASSERT(p->header.info == Dzh_con_info ||
331 // p->header.info == Dzh_static_info);
332 return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
333 }
334
335 HsStablePtr
336 rts_getStablePtr (HaskellObj p)
337 {
338 // See comment above:
339 // ASSERT(p->header.info == StablePtr_con_info ||
340 // p->header.info == StablePtr_static_info);
341 return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
342 }
343
344 HsPtr
345 rts_getPtr (HaskellObj p)
346 {
347 // See comment above:
348 // ASSERT(p->header.info == Ptr_con_info ||
349 // p->header.info == Ptr_static_info);
350 return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
351 }
352
353 HsFunPtr
354 rts_getFunPtr (HaskellObj p)
355 {
356 // See comment above:
357 // ASSERT(p->header.info == FunPtr_con_info ||
358 // p->header.info == FunPtr_static_info);
359 return (void *)(UNTAG_CLOSURE(p)->payload[0]);
360 }
361
362 HsBool
363 rts_getBool (HaskellObj p)
364 {
365 StgInfoTable *info;
366
367 info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
368 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
369 return 0;
370 } else {
371 return 1;
372 }
373 }
374
375 /* -----------------------------------------------------------------------------
376 Creating threads
377 -------------------------------------------------------------------------- */
378
379 INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
380 tso->sp--;
381 tso->sp[0] = (W_) c;
382 }
383
384 StgTSO *
385 createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
386 {
387 StgTSO *t;
388 t = createThread (cap, stack_size);
389 pushClosure(t, (W_)closure);
390 pushClosure(t, (W_)&stg_enter_info);
391 return t;
392 }
393
394 StgTSO *
395 createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
396 {
397 StgTSO *t;
398 t = createThread (cap, stack_size);
399 pushClosure(t, (W_)&stg_noforceIO_info);
400 pushClosure(t, (W_)&stg_ap_v_info);
401 pushClosure(t, (W_)closure);
402 pushClosure(t, (W_)&stg_enter_info);
403 return t;
404 }
405
406 /*
407 * Same as above, but also evaluate the result of the IO action
408 * to whnf while we're at it.
409 */
410
411 StgTSO *
412 createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
413 {
414 StgTSO *t;
415 t = createThread(cap, stack_size);
416 pushClosure(t, (W_)&stg_forceIO_info);
417 pushClosure(t, (W_)&stg_ap_v_info);
418 pushClosure(t, (W_)closure);
419 pushClosure(t, (W_)&stg_enter_info);
420 return t;
421 }
422
423 /* ----------------------------------------------------------------------------
424 Evaluating Haskell expressions
425 ------------------------------------------------------------------------- */
426
427 Capability *
428 rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
429 {
430 StgTSO *tso;
431
432 tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
433 return scheduleWaitThread(tso,ret,cap);
434 }
435
436 Capability *
437 rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size,
438 /*out*/HaskellObj *ret)
439 {
440 StgTSO *tso;
441
442 tso = createGenThread(cap, stack_size, p);
443 return scheduleWaitThread(tso,ret,cap);
444 }
445
446 /*
447 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
448 * result to WHNF before returning.
449 */
450 Capability *
451 rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
452 {
453 StgTSO* tso;
454
455 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
456 return 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 Capability *
466 rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
467 {
468 StgTSO* tso;
469 StgClosure *p, *r;
470 SchedulerStatus stat;
471
472 p = (StgClosure *)deRefStablePtr(s);
473 tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
474 // async exceptions are always blocked by default in the created
475 // thread. See #1048.
476 tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
477 cap = scheduleWaitThread(tso,&r,cap);
478 stat = rts_getSchedStatus(cap);
479
480 if (stat == Success && ret != NULL) {
481 ASSERT(r != NULL);
482 *ret = getStablePtr((StgPtr)r);
483 }
484
485 return cap;
486 }
487
488 /*
489 * Like rts_evalIO(), but doesn't force the action's result.
490 */
491 Capability *
492 rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
493 {
494 StgTSO *tso;
495
496 tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
497 return scheduleWaitThread(tso,ret,cap);
498 }
499
500 Capability *
501 rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size,
502 /*out*/HaskellObj *ret)
503 {
504 StgTSO *tso;
505
506 tso = createIOThread(cap, stack_size, p);
507 return scheduleWaitThread(tso,ret,cap);
508 }
509
510 /* Convenience function for decoding the returned status. */
511
512 void
513 rts_checkSchedStatus (char* site, Capability *cap)
514 {
515 SchedulerStatus rc = cap->running_task->stat;
516 switch (rc) {
517 case Success:
518 return;
519 case Killed:
520 errorBelch("%s: uncaught exception",site);
521 stg_exit(EXIT_FAILURE);
522 case Interrupted:
523 errorBelch("%s: interrupted", site);
524 stg_exit(EXIT_FAILURE);
525 default:
526 errorBelch("%s: Return code (%d) not ok",(site),(rc));
527 stg_exit(EXIT_FAILURE);
528 }
529 }
530
531 SchedulerStatus
532 rts_getSchedStatus (Capability *cap)
533 {
534 return cap->running_task->stat;
535 }
536
537 Capability *
538 rts_lock (void)
539 {
540 Capability *cap;
541 Task *task;
542
543 task = newBoundTask();
544
545 cap = NULL;
546 waitForReturnCapability(&cap, task);
547 return (Capability *)cap;
548 }
549
550 // Exiting the RTS: we hold a Capability that is not necessarily the
551 // same one that was originally returned by rts_lock(), because
552 // rts_evalIO() etc. may return a new one. Now that we have
553 // investigated the return value, we can release the Capability,
554 // and free the Task (in that order).
555
556 void
557 rts_unlock (Capability *cap)
558 {
559 Task *task;
560
561 task = cap->running_task;
562 ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
563
564 // Now release the Capability. With the capability released, GC
565 // may happen. NB. does not try to put the current Task on the
566 // worker queue.
567 // NB. keep cap->lock held while we call boundTaskExiting(). This
568 // is necessary during shutdown, where we want the invariant that
569 // after shutdownCapability(), all the Tasks associated with the
570 // Capability have completed their shutdown too. Otherwise we
571 // could have boundTaskExiting()/workerTaskStop() running at some
572 // random point in the future, which causes problems for
573 // freeTaskManager().
574 ACQUIRE_LOCK(&cap->lock);
575 releaseCapability_(cap,rtsFalse);
576
577 // Finally, we can release the Task to the free list.
578 boundTaskExiting(task);
579 RELEASE_LOCK(&cap->lock);
580 }