X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FRtsAPI.c;h=4ca1225bebf2f0d9729e08388edcffa96d59ddfc;hb=ea22f57fe6b77cde3c3ec040f1246bf0e8ecef36;hp=1a0620f9d2559493b212a2777d54e6d8c9ff11c0;hpb=cc50ad9890a5de79103236a01003e1908c7e75cf;p=ghc-hetmet.git diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index 1a0620f..4ca1225 100644 --- a/ghc/rts/RtsAPI.c +++ b/ghc/rts/RtsAPI.c @@ -1,5 +1,4 @@ /* ---------------------------------------------------------------------------- - * $Id: RtsAPI.c,v 1.40 2003/01/27 11:08:16 wolfgang Exp $ * * (c) The GHC Team, 1998-2001 * @@ -21,6 +20,8 @@ #include +static Capability *rtsApiCapability = NULL; + /* ---------------------------------------------------------------------------- Building Haskell objects from C datatypes. ------------------------------------------------------------------------- */ @@ -29,7 +30,7 @@ rts_mkChar (HsChar c) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, Czh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgChar)c; + p->payload[0] = (StgClosure *)(StgWord)(StgChar)c; return p; } @@ -74,10 +75,10 @@ rts_mkInt32 (HsInt32 i) HaskellObj rts_mkInt64 (HsInt64 i) { - long long *tmp; + llong *tmp; StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2)); SET_HDR(p, I64zh_con_info, CCS_SYSTEM); - tmp = (long long*)&(p->payload[0]); + tmp = (llong*)&(p->payload[0]); *tmp = (StgInt64)i; return p; } @@ -124,12 +125,12 @@ rts_mkWord32 (HsWord32 w) HaskellObj rts_mkWord64 (HsWord64 w) { - unsigned long long *tmp; + ullong *tmp; StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2)); /* see mk_Int8 comment */ SET_HDR(p, W64zh_con_info, CCS_SYSTEM); - tmp = (unsigned long long*)&(p->payload[0]); + tmp = (ullong*)&(p->payload[0]); *tmp = (StgWord64)w; return p; } @@ -170,7 +171,15 @@ rts_mkPtr (HsPtr a) return p; } -#ifdef COMPILER /* GHC has em, Hugs doesn't */ +HaskellObj +rts_mkFunPtr (HsFunPtr a) +{ + StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1); + SET_HDR(p, FunPtr_con_info, CCS_SYSTEM); + p->payload[0] = (StgClosure *)a; + return p; +} + HaskellObj rts_mkBool (HsBool b) { @@ -186,7 +195,6 @@ rts_mkString (char *s) { return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s)); } -#endif /* COMPILER */ HaskellObj rts_apply (HaskellObj f, HaskellObj arg) @@ -251,7 +259,7 @@ rts_getInt32 (HaskellObj p) // See comment above: // ASSERT(p->header.info == I32zh_con_info || // p->header.info == I32zh_static_info); - return (HsInt32)(p->payload[0]); + return (HsInt32)(HsInt)(p->payload[0]); } HsInt64 @@ -297,7 +305,7 @@ rts_getWord32 (HaskellObj p) // See comment above: // ASSERT(p->header.info == W32zh_con_info || // p->header.info == W32zh_static_info); - return (HsWord32)(p->payload[0]); + return (HsWord32)(HsWord)(p->payload[0]); } @@ -348,19 +356,27 @@ rts_getPtr (HaskellObj p) return (void *)(p->payload[0]); } -#ifdef COMPILER /* GHC has em, Hugs doesn't */ +HsFunPtr +rts_getFunPtr (HaskellObj p) +{ + // See comment above: + // ASSERT(p->header.info == FunPtr_con_info || + // p->header.info == FunPtr_static_info); + return (void *)(p->payload[0]); +} + HsBool rts_getBool (HaskellObj p) { - if (p == True_closure) { - return 1; - } else if (p == False_closure) { - return 0; - } else { - barf("rts_getBool: not a Bool"); - } + StgInfoTable *info; + + info = get_itbl((StgClosure *)p); + if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag + return 0; + } else { + return 1; + } } -#endif /* COMPILER */ /* ---------------------------------------------------------------------------- Evaluating Haskell expressions @@ -369,18 +385,22 @@ SchedulerStatus rts_eval (HaskellObj p, /*out*/HaskellObj *ret) { StgTSO *tso; + Capability *cap = rtsApiCapability; + rtsApiCapability = NULL; tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p); - return scheduleWaitThread(tso,ret); + return scheduleWaitThread(tso,ret,cap); } SchedulerStatus rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret) { StgTSO *tso; + Capability *cap = rtsApiCapability; + rtsApiCapability = NULL; tso = createGenThread(stack_size, p); - return scheduleWaitThread(tso,ret); + return scheduleWaitThread(tso,ret,cap); } /* @@ -391,24 +411,11 @@ SchedulerStatus rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret) { StgTSO* tso; + Capability *cap = rtsApiCapability; + rtsApiCapability = NULL; tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p); - return scheduleWaitThread(tso,ret); -} - -/* - * Identical to rts_evalIO(), but won't create a new task/OS thread - * to evaluate the Haskell thread. Used by main() only. Hack. - */ - -SchedulerStatus -rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret) -{ - StgTSO* tso; - - tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p); - scheduleThread(tso); - return waitThread(tso, ret); + return scheduleWaitThread(tso,ret,cap); } /* @@ -423,12 +430,14 @@ rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret) StgTSO* tso; StgClosure *p, *r; SchedulerStatus stat; + Capability *cap = rtsApiCapability; + rtsApiCapability = NULL; p = (StgClosure *)deRefStablePtr(s); tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p); - stat = scheduleWaitThread(tso,&r); + stat = scheduleWaitThread(tso,&r,cap); - if (stat == Success) { + if (stat == Success && ret != NULL) { ASSERT(r != NULL); *ret = getStablePtr((StgPtr)r); } @@ -440,12 +449,25 @@ rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret) * Like rts_evalIO(), but doesn't force the action's result. */ SchedulerStatus -rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret) +rts_evalLazyIO (HaskellObj p, /*out*/HaskellObj *ret) { StgTSO *tso; + Capability *cap = rtsApiCapability; + rtsApiCapability = NULL; + + tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p); + return scheduleWaitThread(tso,ret,cap); +} + +SchedulerStatus +rts_evalLazyIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret) +{ + StgTSO *tso; + Capability *cap = rtsApiCapability; + rtsApiCapability = NULL; tso = createIOThread(stack_size, p); - return scheduleWaitThread(tso,ret); + return scheduleWaitThread(tso,ret,cap); } /* Convenience function for decoding the returned status. */ @@ -457,13 +479,13 @@ rts_checkSchedStatus ( char* site, SchedulerStatus rc ) case Success: return; case Killed: - prog_belch("%s: uncaught exception",site); + errorBelch("%s: uncaught exception",site); stg_exit(EXIT_FAILURE); case Interrupted: - prog_belch("%s: interrupted", site); + errorBelch("%s: interrupted", site); stg_exit(EXIT_FAILURE); default: - prog_belch("%s: Return code (%d) not ok",(site),(rc)); + errorBelch("%s: Return code (%d) not ok",(site),(rc)); stg_exit(EXIT_FAILURE); } } @@ -472,24 +494,13 @@ void rts_lock() { #ifdef RTS_SUPPORTS_THREADS - Capability *cap; - ACQUIRE_LOCK(&sched_mutex); - - // we request to get the capability immediately, in order to - // a) stop other threads from using allocate() - // b) wake the current worker thread from awaitEvent() - // (so that a thread started by rts_eval* will start immediately) - grabReturnCapability(&sched_mutex,&cap); + ACQUIRE_LOCK(&sched_mutex); - // now that we have the capability, we don't need it anymore - // (other threads will continue to run as soon as we release the sched_mutex) - releaseCapability(cap); - - // In the RTS hasn't been entered yet, - // start a RTS task. - // If there is already a task available (waiting for the work capability), - // this will do nothing. - startSchedulerTask(); + // we request to get the capability immediately, in order to + // a) stop other threads from using allocate() + // b) wake the current worker thread from awaitEvent() + // (so that a thread started by rts_eval* will start immediately) + waitForReturnCapability(&sched_mutex,&rtsApiCapability); #endif } @@ -497,6 +508,10 @@ void rts_unlock() { #ifdef RTS_SUPPORTS_THREADS - RELEASE_LOCK(&sched_mutex); + if (rtsApiCapability) { + releaseCapability(rtsApiCapability); + } + rtsApiCapability = NULL; + RELEASE_LOCK(&sched_mutex); #endif }