X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FRtsAPI.c;h=54d1e7567282544e54a67b29cb5b84e92505cf5e;hb=609e7ddfb10bc04762b820e70e0487ad6c514c2e;hp=b1b1d9c52d7f4c4e53e87547039887ad065e5107;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c index b1b1d9c..54d1e75 100644 --- a/rts/RtsAPI.c +++ b/rts/RtsAPI.c @@ -8,20 +8,22 @@ #include "PosixSource.h" #include "Rts.h" -#include "OSThreads.h" -#include "Storage.h" #include "RtsAPI.h" -#include "SchedAPI.h" -#include "RtsFlags.h" +#include "HsFFI.h" + #include "RtsUtils.h" #include "Prelude.h" #include "Schedule.h" #include "Capability.h" - -#include +#include "Stable.h" +#include "Weak.h" /* ---------------------------------------------------------------------------- Building Haskell objects from C datatypes. + + TODO: Currently this code does not tag created pointers, + however it is not unsafe (the contructor code will do it) + just inefficient. ------------------------------------------------------------------------- */ HaskellObj rts_mkChar (Capability *cap, HsChar c) @@ -47,7 +49,7 @@ rts_mkInt8 (Capability *cap, HsInt8 i) StgClosure *p = (StgClosure *)allocateLocal(cap,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); + p->payload[0] = (StgClosure *)(StgInt)i; return p; } @@ -57,7 +59,7 @@ rts_mkInt16 (Capability *cap, HsInt16 i) StgClosure *p = (StgClosure *)allocateLocal(cap,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); + p->payload[0] = (StgClosure *)(StgInt)i; return p; } @@ -66,18 +68,16 @@ rts_mkInt32 (Capability *cap, HsInt32 i) { StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1)); SET_HDR(p, I32zh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff); + p->payload[0] = (StgClosure *)(StgInt)i; return p; } HaskellObj rts_mkInt64 (Capability *cap, HsInt64 i) { - llong *tmp; StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2)); SET_HDR(p, I64zh_con_info, CCS_SYSTEM); - tmp = (llong*)&(p->payload[0]); - *tmp = (StgInt64)i; + ASSIGN_Int64((P_)&(p->payload[0]), i); return p; } @@ -123,16 +123,14 @@ rts_mkWord32 (Capability *cap, HsWord32 w) HaskellObj rts_mkWord64 (Capability *cap, HsWord64 w) { - ullong *tmp; - StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2)); /* see mk_Int8 comment */ SET_HDR(p, W64zh_con_info, CCS_SYSTEM); - tmp = (ullong*)&(p->payload[0]); - *tmp = (StgWord64)w; + ASSIGN_Word64((P_)&(p->payload[0]), w); return p; } + HaskellObj rts_mkFloat (Capability *cap, HsFloat f) { @@ -221,7 +219,7 @@ rts_getChar (HaskellObj p) // See comment above: // ASSERT(p->header.info == Czh_con_info || // p->header.info == Czh_static_info); - return (StgChar)(StgWord)(p->payload[0]); + return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]); } HsInt @@ -230,7 +228,7 @@ rts_getInt (HaskellObj p) // See comment above: // ASSERT(p->header.info == Izh_con_info || // p->header.info == Izh_static_info); - return (HsInt)(p->payload[0]); + return (HsInt)(UNTAG_CLOSURE(p)->payload[0]); } HsInt8 @@ -239,7 +237,7 @@ rts_getInt8 (HaskellObj p) // See comment above: // ASSERT(p->header.info == I8zh_con_info || // p->header.info == I8zh_static_info); - return (HsInt8)(HsInt)(p->payload[0]); + return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]); } HsInt16 @@ -248,7 +246,7 @@ rts_getInt16 (HaskellObj p) // See comment above: // ASSERT(p->header.info == I16zh_con_info || // p->header.info == I16zh_static_info); - return (HsInt16)(HsInt)(p->payload[0]); + return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]); } HsInt32 @@ -257,26 +255,25 @@ rts_getInt32 (HaskellObj p) // See comment above: // ASSERT(p->header.info == I32zh_con_info || // p->header.info == I32zh_static_info); - return (HsInt32)(HsInt)(p->payload[0]); + return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]); } HsInt64 rts_getInt64 (HaskellObj p) { - 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; + return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0])); } + HsWord rts_getWord (HaskellObj p) { // See comment above: // ASSERT(p->header.info == Wzh_con_info || // p->header.info == Wzh_static_info); - return (HsWord)(p->payload[0]); + return (HsWord)(UNTAG_CLOSURE(p)->payload[0]); } HsWord8 @@ -285,7 +282,7 @@ rts_getWord8 (HaskellObj p) // See comment above: // ASSERT(p->header.info == W8zh_con_info || // p->header.info == W8zh_static_info); - return (HsWord8)(HsWord)(p->payload[0]); + return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]); } HsWord16 @@ -294,7 +291,7 @@ rts_getWord16 (HaskellObj p) // See comment above: // ASSERT(p->header.info == W16zh_con_info || // p->header.info == W16zh_static_info); - return (HsWord16)(HsWord)(p->payload[0]); + return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]); } HsWord32 @@ -303,19 +300,16 @@ rts_getWord32 (HaskellObj p) // See comment above: // ASSERT(p->header.info == W32zh_con_info || // p->header.info == W32zh_static_info); - return (HsWord32)(HsWord)(p->payload[0]); + return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]); } - HsWord64 rts_getWord64 (HaskellObj p) { - 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; + return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0])); } HsFloat @@ -324,7 +318,7 @@ rts_getFloat (HaskellObj p) // See comment above: // ASSERT(p->header.info == Fzh_con_info || // p->header.info == Fzh_static_info); - return (float)(PK_FLT((P_)p->payload)); + return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload)); } HsDouble @@ -333,7 +327,7 @@ rts_getDouble (HaskellObj p) // See comment above: // ASSERT(p->header.info == Dzh_con_info || // p->header.info == Dzh_static_info); - return (double)(PK_DBL((P_)p->payload)); + return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload)); } HsStablePtr @@ -342,7 +336,7 @@ rts_getStablePtr (HaskellObj p) // See comment above: // ASSERT(p->header.info == StablePtr_con_info || // p->header.info == StablePtr_static_info); - return (StgStablePtr)(p->payload[0]); + return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]); } HsPtr @@ -351,7 +345,7 @@ rts_getPtr (HaskellObj p) // See comment above: // ASSERT(p->header.info == Ptr_con_info || // p->header.info == Ptr_static_info); - return (Capability *)(p->payload[0]); + return (Capability *)(UNTAG_CLOSURE(p)->payload[0]); } HsFunPtr @@ -360,7 +354,7 @@ 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]); + return (void *)(UNTAG_CLOSURE(p)->payload[0]); } HsBool @@ -368,7 +362,7 @@ rts_getBool (HaskellObj p) { StgInfoTable *info; - info = get_itbl((StgClosure *)p); + info = get_itbl((StgClosure *)UNTAG_CLOSURE(p)); if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag return 0; } else { @@ -389,11 +383,7 @@ StgTSO * createGenThread (Capability *cap, nat stack_size, StgClosure *closure) { StgTSO *t; -#if defined(GRAN) - t = createThread (cap, stack_size, NO_PRI); -#else t = createThread (cap, stack_size); -#endif pushClosure(t, (W_)closure); pushClosure(t, (W_)&stg_enter_info); return t; @@ -403,11 +393,7 @@ StgTSO * createIOThread (Capability *cap, nat stack_size, StgClosure *closure) { StgTSO *t; -#if defined(GRAN) - t = createThread (cap, stack_size, NO_PRI); -#else t = createThread (cap, stack_size); -#endif pushClosure(t, (W_)&stg_noforceIO_info); pushClosure(t, (W_)&stg_ap_v_info); pushClosure(t, (W_)closure); @@ -424,11 +410,7 @@ StgTSO * createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure) { StgTSO *t; -#if defined(GRAN) - t = createThread(cap, stack_size, NO_PRI); -#else t = createThread(cap, stack_size); -#endif pushClosure(t, (W_)&stg_forceIO_info); pushClosure(t, (W_)&stg_ap_v_info); pushClosure(t, (W_)closure); @@ -487,6 +469,9 @@ rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret) p = (StgClosure *)deRefStablePtr(s); tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p); + // async exceptions are always blocked by default in the created + // thread. See #1048. + tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE; cap = scheduleWaitThread(tso,&r,cap); stat = rts_getSchedStatus(cap); @@ -553,13 +538,15 @@ rts_lock (void) Capability *cap; Task *task; - // ToDo: get rid of this lock in the common case. We could store - // a free Task in thread-local storage, for example. That would - // leave just one lock on the path into the RTS: cap->lock when - // acquiring the Capability. - ACQUIRE_LOCK(&sched_mutex); + if (running_finalizers) { + errorBelch("error: a C finalizer called back into Haskell.\n" + " This was previously allowed, but is disallowed in GHC 6.10.2 and later.\n" + " To create finalizers that may call back into Haskll, use\n" + " Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr."); + stg_exit(EXIT_FAILURE); + } + task = newBoundTask(); - RELEASE_LOCK(&sched_mutex); cap = NULL; waitForReturnCapability(&cap, task); @@ -580,18 +567,20 @@ rts_unlock (Capability *cap) task = cap->running_task; ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task); - // slightly delicate ordering of operations below, pay attention! - - // We are no longer a bound task/thread. This is important, - // because the GC can run when we release the Capability below, - // and we don't want it to treat this as a live TSO pointer. - task->tso = NULL; - // Now release the Capability. With the capability released, GC // may happen. NB. does not try to put the current Task on the // worker queue. - releaseCapability(cap); + // NB. keep cap->lock held while we call boundTaskExiting(). This + // is necessary during shutdown, where we want the invariant that + // after shutdownCapability(), all the Tasks associated with the + // Capability have completed their shutdown too. Otherwise we + // could have boundTaskExiting()/workerTaskStop() running at some + // random point in the future, which causes problems for + // freeTaskManager(). + ACQUIRE_LOCK(&cap->lock); + releaseCapability_(cap,rtsFalse); // Finally, we can release the Task to the free list. boundTaskExiting(task); + RELEASE_LOCK(&cap->lock); }