1 /* ----------------------------------------------------------------------------
2 * $Id: RtsAPI.c,v 1.44 2003/05/23 08:28:48 simonmar 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 /* ----------------------------------------------------------------------------
25 Building Haskell objects from C datatypes.
26 ------------------------------------------------------------------------- */
30 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
31 SET_HDR(p, Czh_con_info, CCS_SYSTEM);
32 p->payload[0] = (StgClosure *)(StgChar)c;
39 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
40 SET_HDR(p, Izh_con_info, CCS_SYSTEM);
41 p->payload[0] = (StgClosure *)(StgInt)i;
48 StgClosure *p = (StgClosure *)allocate(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);
56 rts_mkInt16 (HsInt16 i)
58 StgClosure *p = (StgClosure *)allocate(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);
66 rts_mkInt32 (HsInt32 i)
68 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
69 SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
70 p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
75 rts_mkInt64 (HsInt64 i)
78 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
79 SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
80 tmp = (long long*)&(p->payload[0]);
88 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
89 SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
90 p->payload[0] = (StgClosure *)(StgWord)i;
95 rts_mkWord8 (HsWord8 w)
97 /* see rts_mkInt* comments */
98 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
99 SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
100 p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
105 rts_mkWord16 (HsWord16 w)
107 /* see rts_mkInt* comments */
108 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
109 SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
110 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
115 rts_mkWord32 (HsWord32 w)
117 /* see rts_mkInt* comments */
118 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
119 SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
120 p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
125 rts_mkWord64 (HsWord64 w)
127 unsigned long long *tmp;
129 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
130 /* see mk_Int8 comment */
131 SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
132 tmp = (unsigned long long*)&(p->payload[0]);
138 rts_mkFloat (HsFloat f)
140 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
141 SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
142 ASSIGN_FLT((P_)p->payload, (StgFloat)f);
147 rts_mkDouble (HsDouble d)
149 StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
150 SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
151 ASSIGN_DBL((P_)p->payload, (StgDouble)d);
156 rts_mkStablePtr (HsStablePtr s)
158 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
159 SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
160 p->payload[0] = (StgClosure *)s;
167 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
168 SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
169 p->payload[0] = (StgClosure *)a;
174 rts_mkFunPtr (HsFunPtr a)
176 StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
177 SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
178 p->payload[0] = (StgClosure *)a;
183 rts_mkBool (HsBool b)
186 return (StgClosure *)True_closure;
188 return (StgClosure *)False_closure;
193 rts_mkString (char *s)
195 return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
199 rts_apply (HaskellObj f, HaskellObj arg)
203 ap = (StgClosure *)allocate(sizeofW(StgClosure) + 2);
204 SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
206 ap->payload[1] = arg;
207 return (StgClosure *)ap;
210 /* ----------------------------------------------------------------------------
211 Deconstructing Haskell objects
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 ------------------------------------------------------------------------- */
220 rts_getChar (HaskellObj p)
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]);
229 rts_getInt (HaskellObj p)
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]);
238 rts_getInt8 (HaskellObj p)
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]);
247 rts_getInt16 (HaskellObj p)
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]);
256 rts_getInt32 (HaskellObj p)
258 // See comment above:
259 // ASSERT(p->header.info == I32zh_con_info ||
260 // p->header.info == I32zh_static_info);
261 return (HsInt32)(p->payload[0]);
265 rts_getInt64 (HaskellObj p)
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]);
275 rts_getWord (HaskellObj p)
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]);
284 rts_getWord8 (HaskellObj p)
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]);
293 rts_getWord16 (HaskellObj p)
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]);
302 rts_getWord32 (HaskellObj p)
304 // See comment above:
305 // ASSERT(p->header.info == W32zh_con_info ||
306 // p->header.info == W32zh_static_info);
307 return (HsWord32)(p->payload[0]);
312 rts_getWord64 (HaskellObj p)
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]);
323 rts_getFloat (HaskellObj p)
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));
332 rts_getDouble (HaskellObj p)
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));
341 rts_getStablePtr (HaskellObj p)
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]);
350 rts_getPtr (HaskellObj p)
352 // See comment above:
353 // ASSERT(p->header.info == Ptr_con_info ||
354 // p->header.info == Ptr_static_info);
355 return (void *)(p->payload[0]);
359 rts_getFunPtr (HaskellObj p)
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]);
368 rts_getBool (HaskellObj p)
370 if (p == True_closure) {
372 } else if (p == False_closure) {
375 barf("rts_getBool: not a Bool");
379 /* ----------------------------------------------------------------------------
380 Evaluating Haskell expressions
381 ------------------------------------------------------------------------- */
383 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
387 tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
388 return scheduleWaitThread(tso,ret);
392 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
396 tso = createGenThread(stack_size, p);
397 return scheduleWaitThread(tso,ret);
401 * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
402 * result to WHNF before returning.
405 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
409 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
410 return scheduleWaitThread(tso,ret);
414 * Identical to rts_evalLazyIO(), but won't create a new task/OS thread
415 * to evaluate the Haskell thread. Used by main() only. Hack.
419 rts_mainLazyIO(HaskellObj p, /*out*/HaskellObj *ret)
423 tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
425 return waitThread(tso, ret);
429 * rts_evalStableIO() is suitable for calling from Haskell. It
430 * evaluates a value of the form (StablePtr (IO a)), forcing the
431 * action's result to WHNF before returning. The result is returned
435 rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
439 SchedulerStatus stat;
441 p = (StgClosure *)deRefStablePtr(s);
442 tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
443 stat = scheduleWaitThread(tso,&r);
445 if (stat == Success) {
447 *ret = getStablePtr((StgPtr)r);
454 * Like rts_evalIO(), but doesn't force the action's result.
457 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
461 tso = createIOThread(stack_size, p);
462 return scheduleWaitThread(tso,ret);
465 /* Convenience function for decoding the returned status. */
468 rts_checkSchedStatus ( char* site, SchedulerStatus rc )
474 prog_belch("%s: uncaught exception",site);
475 stg_exit(EXIT_FAILURE);
477 prog_belch("%s: interrupted", site);
478 stg_exit(EXIT_FAILURE);
480 prog_belch("%s: Return code (%d) not ok",(site),(rc));
481 stg_exit(EXIT_FAILURE);
488 #ifdef RTS_SUPPORTS_THREADS
490 ACQUIRE_LOCK(&sched_mutex);
492 // we request to get the capability immediately, in order to
493 // a) stop other threads from using allocate()
494 // b) wake the current worker thread from awaitEvent()
495 // (so that a thread started by rts_eval* will start immediately)
496 grabReturnCapability(&sched_mutex,&cap);
498 // now that we have the capability, we don't need it anymore
499 // (other threads will continue to run as soon as we release the sched_mutex)
500 releaseCapability(cap);
502 // In the RTS hasn't been entered yet,
504 // If there is already a task available (waiting for the work capability),
505 // this will do nothing.
506 startSchedulerTask();
513 #ifdef RTS_SUPPORTS_THREADS
514 RELEASE_LOCK(&sched_mutex);