X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FRtsAPI.c;h=835db722d788e37f95c02135fdcc2eaec41ceb9d;hb=aefc6956f4828708e1343cf4858296fc3141a176;hp=e01a559cdbfb735d6633b0300a67b42604bd187a;hpb=22da500cc55d61e18ae3d8854ff58ca3a2252fa1;p=ghc-hetmet.git diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index e01a559..835db72 100644 --- a/ghc/rts/RtsAPI.c +++ b/ghc/rts/RtsAPI.c @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: RtsAPI.c,v 1.33 2002/02/15 07:40:10 sof Exp $ + * $Id: RtsAPI.c,v 1.48 2003/10/01 10:36:49 wolfgang Exp $ * * (c) The GHC Team, 1998-2001 * @@ -17,56 +17,11 @@ #include "Prelude.h" #include "OSThreads.h" #include "Schedule.h" +#include "Capability.h" -#if defined(THREADED_RTS) -#define WAIT_MAIN_THREAD(tso,ret) waitThread_(tso,ret,rtsFalse) -#else -#define WAIT_MAIN_THREAD(tso,ret) waitThread(tso,ret) -#endif - -#if defined(RTS_SUPPORTS_THREADS) -/* Cheesy locking scheme while waiting for the - * RTS API to change. - */ -static Mutex alloc_mutex = INIT_MUTEX_VAR; -static Condition alloc_cond = INIT_COND_VAR; -#define INVALID_THREAD_ID ((OSThreadId)(-1)) - -/* Thread currently owning the allocator */ -static OSThreadId c_id = INVALID_THREAD_ID; - -static StgPtr alloc(nat n) -{ - OSThreadId tid = osThreadId(); - ACQUIRE_LOCK(&alloc_mutex); - if (tid == c_id) { - /* I've got the lock, just allocate() */ - ; - } else if (c_id == INVALID_THREAD_ID) { - c_id = tid; - } else { - waitCondition(&alloc_cond, &alloc_mutex); - c_id = tid; - } - RELEASE_LOCK(&alloc_mutex); - return allocate(n); -} - -static void releaseAllocLock(void) -{ - ACQUIRE_LOCK(&alloc_mutex); - /* Reset the allocator owner */ - c_id = INVALID_THREAD_ID; - RELEASE_LOCK(&alloc_mutex); - - /* Free up an OS thread waiting to get in */ - signalCondition(&alloc_cond); -} -#else -# define alloc(n) allocate(n) -# define releaseAllocLock() /* nothing */ -#endif +#include +static Capability *rtsApiCapability = NULL; /* ---------------------------------------------------------------------------- Building Haskell objects from C datatypes. @@ -74,16 +29,16 @@ static void releaseAllocLock(void) HaskellObj rts_mkChar (HsChar c) { - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + 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; } HaskellObj rts_mkInt (HsInt i) { - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, Izh_con_info, CCS_SYSTEM); p->payload[0] = (StgClosure *)(StgInt)i; return p; @@ -92,7 +47,7 @@ rts_mkInt (HsInt i) HaskellObj rts_mkInt8 (HsInt8 i) { - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, I8zh_con_info, CCS_SYSTEM); /* Make sure we mask out the bits above the lowest 8 */ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff); @@ -102,7 +57,7 @@ rts_mkInt8 (HsInt8 i) HaskellObj rts_mkInt16 (HsInt16 i) { - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, I16zh_con_info, CCS_SYSTEM); /* Make sure we mask out the relevant bits */ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff); @@ -112,7 +67,7 @@ rts_mkInt16 (HsInt16 i) HaskellObj rts_mkInt32 (HsInt32 i) { - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, I32zh_con_info, CCS_SYSTEM); p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff); return p; @@ -122,7 +77,7 @@ HaskellObj rts_mkInt64 (HsInt64 i) { long long *tmp; - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2)); SET_HDR(p, I64zh_con_info, CCS_SYSTEM); tmp = (long long*)&(p->payload[0]); *tmp = (StgInt64)i; @@ -132,7 +87,7 @@ rts_mkInt64 (HsInt64 i) HaskellObj rts_mkWord (HsWord i) { - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, Wzh_con_info, CCS_SYSTEM); p->payload[0] = (StgClosure *)(StgWord)i; return p; @@ -142,7 +97,7 @@ HaskellObj rts_mkWord8 (HsWord8 w) { /* see rts_mkInt* comments */ - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, W8zh_con_info, CCS_SYSTEM); p->payload[0] = (StgClosure *)(StgWord)(w & 0xff); return p; @@ -152,7 +107,7 @@ HaskellObj rts_mkWord16 (HsWord16 w) { /* see rts_mkInt* comments */ - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, W16zh_con_info, CCS_SYSTEM); p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff); return p; @@ -162,7 +117,7 @@ HaskellObj rts_mkWord32 (HsWord32 w) { /* see rts_mkInt* comments */ - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, W32zh_con_info, CCS_SYSTEM); p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff); return p; @@ -173,7 +128,7 @@ rts_mkWord64 (HsWord64 w) { unsigned long long *tmp; - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,2)); + 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]); @@ -184,7 +139,7 @@ rts_mkWord64 (HsWord64 w) HaskellObj rts_mkFloat (HsFloat f) { - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,1)); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); SET_HDR(p, Fzh_con_info, CCS_SYSTEM); ASSIGN_FLT((P_)p->payload, (StgFloat)f); return p; @@ -193,7 +148,7 @@ rts_mkFloat (HsFloat f) HaskellObj rts_mkDouble (HsDouble d) { - StgClosure *p = (StgClosure *)alloc(CONSTR_sizeW(0,sizeofW(StgDouble))); + StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble))); SET_HDR(p, Dzh_con_info, CCS_SYSTEM); ASSIGN_DBL((P_)p->payload, (StgDouble)d); return p; @@ -202,7 +157,7 @@ rts_mkDouble (HsDouble d) HaskellObj rts_mkStablePtr (HsStablePtr s) { - StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1); + StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1); SET_HDR(p, StablePtr_con_info, CCS_SYSTEM); p->payload[0] = (StgClosure *)s; return p; @@ -211,13 +166,21 @@ rts_mkStablePtr (HsStablePtr s) HaskellObj rts_mkPtr (HsPtr a) { - StgClosure *p = (StgClosure *)alloc(sizeofW(StgHeader)+1); + StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1); SET_HDR(p, Ptr_con_info, CCS_SYSTEM); p->payload[0] = (StgClosure *)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) { @@ -233,215 +196,188 @@ rts_mkString (char *s) { return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s)); } -#endif /* COMPILER */ HaskellObj rts_apply (HaskellObj f, HaskellObj arg) { - StgAP_UPD *ap = (StgAP_UPD *)alloc(AP_sizeW(1)); - SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM); - ap->n_args = 1; - ap->fun = f; - ap->payload[0] = arg; - return (StgClosure *)ap; + StgClosure *ap; + + ap = (StgClosure *)allocate(sizeofW(StgClosure) + 2); + SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM); + ap->payload[0] = f; + ap->payload[1] = arg; + return (StgClosure *)ap; } /* ---------------------------------------------------------------------------- Deconstructing Haskell objects + + We would like to assert that we have the right kind of object in + each case, but this is problematic because in GHCi the info table + for the D# constructor (say) might be dynamically loaded. Hence we + omit these assertions for now. ------------------------------------------------------------------------- */ HsChar rts_getChar (HaskellObj p) { - if ( p->header.info == Czh_con_info || - p->header.info == Czh_static_info) { + // See comment above: + // ASSERT(p->header.info == Czh_con_info || + // p->header.info == Czh_static_info); return (StgChar)(StgWord)(p->payload[0]); - } else { - barf("rts_getChar: not a Char"); - } } HsInt rts_getInt (HaskellObj p) { - if ( 1 || - p->header.info == Izh_con_info || - p->header.info == Izh_static_info ) { + // See comment above: + // ASSERT(p->header.info == Izh_con_info || + // p->header.info == Izh_static_info); return (HsInt)(p->payload[0]); - } else { - barf("rts_getInt: not an Int"); - } } HsInt8 rts_getInt8 (HaskellObj p) { - if ( 1 || - p->header.info == I8zh_con_info || - p->header.info == I8zh_static_info ) { + // See comment above: + // ASSERT(p->header.info == I8zh_con_info || + // p->header.info == I8zh_static_info); return (HsInt8)(HsInt)(p->payload[0]); - } else { - barf("rts_getInt8: not an Int8"); - } } HsInt16 rts_getInt16 (HaskellObj p) { - if ( 1 || - p->header.info == I16zh_con_info || - p->header.info == I16zh_static_info ) { + // See comment above: + // ASSERT(p->header.info == I16zh_con_info || + // p->header.info == I16zh_static_info); return (HsInt16)(HsInt)(p->payload[0]); - } else { - barf("rts_getInt16: not an Int16"); - } } HsInt32 rts_getInt32 (HaskellObj p) { - if ( 1 || - p->header.info == I32zh_con_info || - p->header.info == I32zh_static_info ) { - return (HsInt32)(p->payload[0]); - } else { - barf("rts_getInt32: not an Int32"); - } + // See comment above: + // ASSERT(p->header.info == I32zh_con_info || + // p->header.info == I32zh_static_info); + return (HsInt32)(HsInt)(p->payload[0]); } HsInt64 rts_getInt64 (HaskellObj p) { - HsInt64* tmp; - if ( 1 || - p->header.info == I64zh_con_info || - p->header.info == I64zh_static_info ) { + HsInt64* tmp; + // See comment above: + // ASSERT(p->header.info == I64zh_con_info || + // p->header.info == I64zh_static_info); tmp = (HsInt64*)&(p->payload[0]); return *tmp; - } else { - barf("rts_getInt64: not an Int64"); - } } HsWord rts_getWord (HaskellObj p) { - if ( 1 || /* see above comment */ - p->header.info == Wzh_con_info || - p->header.info == Wzh_static_info ) { + // See comment above: + // ASSERT(p->header.info == Wzh_con_info || + // p->header.info == Wzh_static_info); return (HsWord)(p->payload[0]); - } else { - barf("rts_getWord: not a Word"); - } } HsWord8 rts_getWord8 (HaskellObj p) { - if ( 1 || /* see above comment */ - p->header.info == W8zh_con_info || - p->header.info == W8zh_static_info ) { + // See comment above: + // ASSERT(p->header.info == W8zh_con_info || + // p->header.info == W8zh_static_info); return (HsWord8)(HsWord)(p->payload[0]); - } else { - barf("rts_getWord8: not a Word8"); - } } HsWord16 rts_getWord16 (HaskellObj p) { - if ( 1 || /* see above comment */ - p->header.info == W16zh_con_info || - p->header.info == W16zh_static_info ) { + // See comment above: + // ASSERT(p->header.info == W16zh_con_info || + // p->header.info == W16zh_static_info); return (HsWord16)(HsWord)(p->payload[0]); - } else { - barf("rts_getWord16: not a Word16"); - } } HsWord32 rts_getWord32 (HaskellObj p) { - if ( 1 || /* see above comment */ - p->header.info == W32zh_con_info || - p->header.info == W32zh_static_info ) { - return (unsigned int)(p->payload[0]); - } else { - barf("rts_getWord: not a Word"); - } + // See comment above: + // ASSERT(p->header.info == W32zh_con_info || + // p->header.info == W32zh_static_info); + return (HsWord32)(HsWord)(p->payload[0]); } HsWord64 rts_getWord64 (HaskellObj p) { - HsWord64* tmp; - if ( 1 || /* see above comment */ - p->header.info == W64zh_con_info || - p->header.info == W64zh_static_info ) { + HsWord64* tmp; + // See comment above: + // ASSERT(p->header.info == W64zh_con_info || + // p->header.info == W64zh_static_info); tmp = (HsWord64*)&(p->payload[0]); return *tmp; - } else { - barf("rts_getWord64: not a Word64"); - } } HsFloat rts_getFloat (HaskellObj p) { - if ( p->header.info == Fzh_con_info || - p->header.info == Fzh_static_info ) { + // See comment above: + // ASSERT(p->header.info == Fzh_con_info || + // p->header.info == Fzh_static_info); return (float)(PK_FLT((P_)p->payload)); - } else { - barf("rts_getFloat: not a Float"); - } } HsDouble rts_getDouble (HaskellObj p) { - if ( p->header.info == Dzh_con_info || - p->header.info == Dzh_static_info ) { + // See comment above: + // ASSERT(p->header.info == Dzh_con_info || + // p->header.info == Dzh_static_info); return (double)(PK_DBL((P_)p->payload)); - } else { - barf("rts_getDouble: not a Double"); - } } HsStablePtr rts_getStablePtr (HaskellObj p) { - if ( p->header.info == StablePtr_con_info || - p->header.info == StablePtr_static_info ) { + // See comment above: + // ASSERT(p->header.info == StablePtr_con_info || + // p->header.info == StablePtr_static_info); return (StgStablePtr)(p->payload[0]); - } else { - barf("rts_getStablePtr: not a StablePtr"); - } } HsPtr rts_getPtr (HaskellObj p) { - if ( p->header.info == Ptr_con_info || - p->header.info == Ptr_static_info ) { + // See comment above: + // ASSERT(p->header.info == Ptr_con_info || + // p->header.info == Ptr_static_info); + return (void *)(p->payload[0]); +} + +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]); - } else { - barf("rts_getPtr: not an Ptr"); - } } -#ifdef COMPILER /* GHC has em, Hugs doesn't */ 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 @@ -450,22 +386,22 @@ SchedulerStatus rts_eval (HaskellObj p, /*out*/HaskellObj *ret) { StgTSO *tso; + Capability *cap = rtsApiCapability; + rtsApiCapability = NULL; tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p); - releaseAllocLock(); - scheduleExtThread(tso); - return waitThread(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); - releaseAllocLock(); - scheduleExtThread(tso); - return waitThread(tso, ret); + return scheduleWaitThread(tso,ret,cap); } /* @@ -476,26 +412,11 @@ SchedulerStatus rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret) { StgTSO* tso; + Capability *cap = rtsApiCapability; + rtsApiCapability = NULL; tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p); - releaseAllocLock(); - scheduleExtThread(tso); - return waitThread(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); - releaseAllocLock(); - scheduleThread(tso); - return WAIT_MAIN_THREAD(tso, ret); + return scheduleWaitThread(tso,ret,cap); } /* @@ -513,11 +434,10 @@ rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret) p = (StgClosure *)deRefStablePtr(s); tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p); - releaseAllocLock(); - scheduleExtThread(tso); - stat = waitThread(tso, &r); + stat = scheduleWaitThread(tso,&r,rtsApiCapability); + rtsApiCapability = NULL; - if (stat == Success) { + if (stat == Success && ret != NULL) { ASSERT(r != NULL); *ret = getStablePtr((StgPtr)r); } @@ -529,14 +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); - releaseAllocLock(); - scheduleExtThread(tso); - return waitThread(tso, ret); + return scheduleWaitThread(tso,ret,cap); } /* Convenience function for decoding the returned status. */ @@ -548,10 +479,44 @@ rts_checkSchedStatus ( char* site, SchedulerStatus rc ) case Success: return; case Killed: - barf("%s: uncaught exception",site); + prog_belch("%s: uncaught exception",site); + stg_exit(EXIT_FAILURE); case Interrupted: - barf("%s: interrupted", site); + prog_belch("%s: interrupted", site); + stg_exit(EXIT_FAILURE); default: - barf("%s: Return code (%d) not ok",(site),(rc)); + prog_belch("%s: Return code (%d) not ok",(site),(rc)); + stg_exit(EXIT_FAILURE); } } + +void +rts_lock() +{ +#ifdef RTS_SUPPORTS_THREADS + 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,&rtsApiCapability); + + // 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(); +#endif +} + +void +rts_unlock() +{ +#ifdef RTS_SUPPORTS_THREADS + if(rtsApiCapability) + releaseCapability(rtsApiCapability); + rtsApiCapability = NULL; + RELEASE_LOCK(&sched_mutex); +#endif +}