1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.49 2003/10/01 10:49:07 wolfgang Exp $
4 * (c) The GHC Team, 1998-2001
6 * API for invoking Haskell functions via the RTS
8 * --------------------------------------------------------------------------*/
10 #include "PosixSource.h"
18 #include "OSThreads.h"
20 #include "Capability.h"
24 static Capability *rtsApiCapability = NULL;
26 /* ----------------------------------------------------------------------------
27 Building Haskell objects from C datatypes.
28 ------------------------------------------------------------------------- */
32 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
33 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
34 p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
41 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
42 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
43 p->payload[0] = (StgClosure *)(StgInt)i;
50 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
51 SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
52 /* Make sure we mask out the bits above the lowest 8 */
53 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
58 rts_mkInt16 (HsInt16 i)
60 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
61 SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
62 /* Make sure we mask out the relevant bits */
63 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
68 rts_mkInt32 (HsInt32 i)
70 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
71 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
72 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
77 rts_mkInt64 (HsInt64 i)
80 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
81 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
82 tmp = (long long*)&(p->payload[0]);
90 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
91 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
92 p->payload[0] = (StgClosure *)(StgWord)i;
97 rts_mkWord8 (HsWord8 w)
99 /* see rts_mkInt* comments */
100 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
101 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
102 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
107 rts_mkWord16 (HsWord16 w)
109 /* see rts_mkInt* comments */
110 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
111 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
112 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
117 rts_mkWord32 (HsWord32 w)
119 /* see rts_mkInt* comments */
120 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
121 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
122 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
127 rts_mkWord64 (HsWord64 w)
129 unsigned long long *tmp;
131 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
132 /* see mk_Int8 comment */
133 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
134 tmp = (unsigned long long*)&(p->payload[0]);
140 rts_mkFloat (HsFloat f)
142 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
143 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
144 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
149 rts_mkDouble (HsDouble d)
151 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
152 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
153 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
158 rts_mkStablePtr (HsStablePtr s)
160 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
161 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
162 p->payload[0] = (StgClosure *)s;
169 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
170 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
171 p->payload[0] = (StgClosure *)a;
176 rts_mkFunPtr (HsFunPtr a)
178 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
179 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
180 p->payload[0] = (StgClosure *)a;
185 rts_mkBool (HsBool b)
188 return (StgClosure *)True_closure;
190 return (StgClosure *)False_closure;
195 rts_mkString (char *s)
197 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
201 rts_apply (HaskellObj f, HaskellObj arg)
205 ap = (StgClosure *)allocate(sizeofW(StgClosure) + 2);
206 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
208 ap->payload[1] = arg;
209 return (StgClosure *)ap;
212 /* ----------------------------------------------------------------------------
213 Deconstructing Haskell objects
215 We would like to assert that we have the right kind of object in
216 each case, but this is problematic because in GHCi the info table
217 for the D# constructor (say) might be dynamically loaded. Hence we
218 omit these assertions for now.
219 ------------------------------------------------------------------------- */
222 rts_getChar (HaskellObj p)
224 // See comment above:
225 // ASSERT(p->header.info == Czh_con_info ||
226 // p->header.info == Czh_static_info);
227 return (StgChar)(StgWord)(p->payload[0]);
231 rts_getInt (HaskellObj p)
233 // See comment above:
234 // ASSERT(p->header.info == Izh_con_info ||
235 // p->header.info == Izh_static_info);
236 return (HsInt)(p->payload[0]);
240 rts_getInt8 (HaskellObj p)
242 // See comment above:
243 // ASSERT(p->header.info == I8zh_con_info ||
244 // p->header.info == I8zh_static_info);
245 return (HsInt8)(HsInt)(p->payload[0]);
249 rts_getInt16 (HaskellObj p)
251 // See comment above:
252 // ASSERT(p->header.info == I16zh_con_info ||
253 // p->header.info == I16zh_static_info);
254 return (HsInt16)(HsInt)(p->payload[0]);
258 rts_getInt32 (HaskellObj p)
260 // See comment above:
261 // ASSERT(p->header.info == I32zh_con_info ||
262 // p->header.info == I32zh_static_info);
263 return (HsInt32)(HsInt)(p->payload[0]);
267 rts_getInt64 (HaskellObj p)
270 // See comment above:
271 // ASSERT(p->header.info == I64zh_con_info ||
272 // p->header.info == I64zh_static_info);
273 tmp = (HsInt64*)&(p->payload[0]);
277 rts_getWord (HaskellObj p)
279 // See comment above:
280 // ASSERT(p->header.info == Wzh_con_info ||
281 // p->header.info == Wzh_static_info);
282 return (HsWord)(p->payload[0]);
286 rts_getWord8 (HaskellObj p)
288 // See comment above:
289 // ASSERT(p->header.info == W8zh_con_info ||
290 // p->header.info == W8zh_static_info);
291 return (HsWord8)(HsWord)(p->payload[0]);
295 rts_getWord16 (HaskellObj p)
297 // See comment above:
298 // ASSERT(p->header.info == W16zh_con_info ||
299 // p->header.info == W16zh_static_info);
300 return (HsWord16)(HsWord)(p->payload[0]);
304 rts_getWord32 (HaskellObj p)
306 // See comment above:
307 // ASSERT(p->header.info == W32zh_con_info ||
308 // p->header.info == W32zh_static_info);
309 return (HsWord32)(HsWord)(p->payload[0]);
314 rts_getWord64 (HaskellObj p)
317 // See comment above:
318 // ASSERT(p->header.info == W64zh_con_info ||
319 // p->header.info == W64zh_static_info);
320 tmp = (HsWord64*)&(p->payload[0]);
325 rts_getFloat (HaskellObj p)
327 // See comment above:
328 // ASSERT(p->header.info == Fzh_con_info ||
329 // p->header.info == Fzh_static_info);
330 return (float)(PK_FLT((P_)p->payload));
334 rts_getDouble (HaskellObj p)
336 // See comment above:
337 // ASSERT(p->header.info == Dzh_con_info ||
338 // p->header.info == Dzh_static_info);
339 return (double)(PK_DBL((P_)p->payload));
343 rts_getStablePtr (HaskellObj p)
345 // See comment above:
346 // ASSERT(p->header.info == StablePtr_con_info ||
347 // p->header.info == StablePtr_static_info);
348 return (StgStablePtr)(p->payload[0]);
352 rts_getPtr (HaskellObj p)
354 // See comment above:
355 // ASSERT(p->header.info == Ptr_con_info ||
356 // p->header.info == Ptr_static_info);
357 return (void *)(p->payload[0]);
361 rts_getFunPtr (HaskellObj p)
363 // See comment above:
364 // ASSERT(p->header.info == FunPtr_con_info ||
365 // p->header.info == FunPtr_static_info);
366 return (void *)(p->payload[0]);
370 rts_getBool (HaskellObj p)
374 info = get_itbl((StgClosure *)p);
375 if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
382 /* ----------------------------------------------------------------------------
383 Evaluating Haskell expressions
384 ------------------------------------------------------------------------- */
386 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
389 Capability *cap = rtsApiCapability;
390 rtsApiCapability = NULL;
392 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
393 return scheduleWaitThread(tso,ret,cap);
397 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
400 Capability *cap = rtsApiCapability;
401 rtsApiCapability = NULL;
403 tso = createGenThread(stack_size, p);
404 return scheduleWaitThread(tso,ret,cap);
408 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
409 * result to WHNF before returning.
412 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
415 Capability *cap = rtsApiCapability;
416 rtsApiCapability = NULL;
418 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
419 return scheduleWaitThread(tso,ret,cap);
423 * rts_evalStableIO() is suitable for calling from Haskell. It
424 * evaluates a value of the form (StablePtr (IO a)), forcing the
425 * action's result to WHNF before returning. The result is returned
429 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
433 SchedulerStatus stat;
435 p = (StgClosure *)deRefStablePtr(s);
436 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
437 stat = scheduleWaitThread(tso,&r,rtsApiCapability);
438 rtsApiCapability = NULL;
440 if (stat == Success && ret != NULL) {
442 *ret = getStablePtr((StgPtr)r);
449 * Like rts_evalIO(), but doesn't force the action's result.
452 rts_evalLazyIO (HaskellObj p, /*out*/HaskellObj *ret)
455 Capability *cap = rtsApiCapability;
456 rtsApiCapability = NULL;
458 tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
459 return scheduleWaitThread(tso,ret,cap);
463 rts_evalLazyIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
466 Capability *cap = rtsApiCapability;
467 rtsApiCapability = NULL;
469 tso = createIOThread(stack_size, p);
470 return scheduleWaitThread(tso,ret,cap);
473 /* Convenience function for decoding the returned status. */
476 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
482 prog_belch("%s: uncaught exception",site);
483 stg_exit(EXIT_FAILURE);
485 prog_belch("%s: interrupted", site);
486 stg_exit(EXIT_FAILURE);
488 prog_belch("%s: Return code (%d) not ok",(site),(rc));
489 stg_exit(EXIT_FAILURE);
496 #ifdef RTS_SUPPORTS_THREADS
497 ACQUIRE_LOCK(&sched_mutex);
499 // we request to get the capability immediately, in order to
500 // a) stop other threads from using allocate()
501 // b) wake the current worker thread from awaitEvent()
502 // (so that a thread started by rts_eval* will start immediately)
503 grabReturnCapability(&sched_mutex,&rtsApiCapability);
510 #ifdef RTS_SUPPORTS_THREADS
512 releaseCapability(rtsApiCapability);
513 rtsApiCapability = NULL;
514 RELEASE_LOCK(&sched_mutex);