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