diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 763656a..f6cd118 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -31,8 +31,8 @@ import UniqSupply import Unique import Util -import Data.List ( partition ) - +import Data.List ( partition ) +import Data.Maybe ( fromMaybe ) type LlvmStatements = OrdList LlvmStatement @@ -706,6 +706,7 @@ genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData genCondBranch env cond idT idF = do let labelT = blockIdToLlvm idT let labelF = blockIdToLlvm idF + -- See Note [Literals and branch conditions] (env', vc, stmts, top) <- exprToVarOpt env i1Option cond if getVarType vc == i1 then do @@ -714,6 +715,57 @@ genCondBranch env cond idT idF = do else panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")" +{- Note [Literals and branch conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is important that whenever we generate branch conditions for +literals like '1', they are properly narrowed to an LLVM expression of +type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert +a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt +must be certain to return a properly narrowed type. genLit is +responsible for this, in the case of literal integers. + +Often, we won't see direct statements like: + + if(1) { + ... + } else { + ... + } + +at this point in the pipeline, because the Glorious Code Generator +will do trivial branch elimination in the sinking pass (among others,) +which will eliminate the expression entirely. + +However, it's certainly possible and reasonable for this to occur in +hand-written C-- code. Consider something like: + + #ifndef SOME_CONDITIONAL + #define CHECK_THING(x) 1 + #else + #define CHECK_THING(x) some_operation((x)) + #endif + + f() { + + if (CHECK_THING(xyz)) { + ... + } else { + ... + } + + } + +In such an instance, CHECK_THING might result in an *expression* in +one case, and a *literal* in the other, depending on what in +particular was #define'd. So we must be sure to properly narrow the +literal in this case to i1 as it won't be eliminated beforehand. + +For a real example of this, see ./rts/StgStdThunks.cmm + +-} + + -- | Switch branch -- @@ -770,7 +822,7 @@ exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData exprToVarOpt env opt e = case e of CmmLit lit - -> genLit env lit + -> genLit opt env lit -- See Note [Literals and branch conditions] CmmLoad e' ty -> genLoad env e' ty @@ -1206,15 +1258,17 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" -- | Generate code for a literal -genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData -genLit env (CmmInt i w) - = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, []) +genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData +genLit (EOption opt) env (CmmInt i w) + -- See Note [Literals and branch conditions] + = let width = fromMaybe (LMInt $ widthInBits w) opt + in return (env, mkIntLit width i, nilOL, []) -genLit env (CmmFloat r w) +genLit _ env (CmmFloat r w) = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), nilOL, []) -genLit env cmm@(CmmLabel l) +genLit _ env cmm@(CmmLabel l) = let dflags = getDflags env label = strCLabel_llvm env l ty = funLookup label env @@ -1236,17 +1290,17 @@ genLit env cmm@(CmmLabel l) (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) return (env, v1, unitOL s1, []) -genLit env (CmmLabelOff label off) = do +genLit opt env (CmmLabelOff label off) = do let dflags = getDflags env - (env', vlbl, stmts, stat) <- genLit env (CmmLabel label) + (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label) let voff = toIWord dflags off (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff return (env', v1, stmts `snocOL` s1, stat) -genLit env (CmmLabelDiffOff l1 l2 off) = do +genLit opt env (CmmLabelDiffOff l1 l2 off) = do let dflags = getDflags env - (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1) - (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2) + (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1) + (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2) let voff = toIWord dflags off let ty1 = getVarType vl1 let ty2 = getVarType vl2 @@ -1262,10 +1316,10 @@ genLit env (CmmLabelDiffOff l1 l2 off) = do else panic "genLit: CmmLabelDiffOff encountered with different label ty!" -genLit env (CmmBlock b) - = genLit env (CmmLabel $ infoTblLbl b) +genLit opt env (CmmBlock b) + = genLit opt env (CmmLabel $ infoTblLbl b) -genLit _ CmmHighStackMark +genLit _ _ CmmHighStackMark = panic "genStaticLit - CmmHighStackMark unsupported!" diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 6d551d9..0ff7e2c 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1839,6 +1839,24 @@ primop ThreadStatusOp "threadStatus#" GenPrimOp out_of_line = True has_side_effects = True +primop SetTicketsOp "setTickets#" GenPrimOp + ThreadId# -> Int# -> State# RealWorld -> State# RealWorld + with + out_of_line = True + has_side_effects = True + +primop GetTicketsOp "getTickets#" GenPrimOp + ThreadId# -> State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + has_side_effects = True + +primop ModifyTicketsOp "modifyTickets#" GenPrimOp + ThreadId# -> Int# -> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + has_side_effects = True + ------------------------------------------------------------------------ section "Weak pointers" ------------------------------------------------------------------------ diff --git a/docs/users_guide/intro.xml b/docs/users_guide/intro.xml index 5ec013f..b21b793 100644 --- a/docs/users_guide/intro.xml +++ b/docs/users_guide/intro.xml @@ -130,17 +130,15 @@ - glasgow-haskell-bugs: + ghc-devs: - This list is for reporting and discussing GHC bugs. - However, please see before - posting here. + The hardcore GHC developers hang out here. list email address: - glasgow-haskell-bugs@haskell.org + ghc-devs@haskell.org @@ -148,14 +146,14 @@ subscribe at: http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs. + url="http://www.haskell.org/mailman/listinfo/ghc-devs">http://www.haskell.org/mailman/listinfo/ghc-devs. admin email address: - glasgow-haskell-bugs-admin@haskell.org + ghc-devs-admin@haskell.org @@ -163,50 +161,7 @@ list archives: http://www.haskell.org/pipermail/glasgow-haskell-bugs/ - - - - - - - - cvs-ghc: - - The hardcore GHC developers hang out here. This list - also gets commit message from the GHC darcs repository. There are - other lists for other darcs - repositories (most notably cvs-libraries). - - - - - list email address: - - cvs-ghc@haskell.org - - - - - subscribe at: - - http://www.haskell.org/mailman/listinfo/cvs-ghc. - - - - - admin email address: - - cvs-ghc-admin@haskell.org - - - - - list archives: - - http://www.haskell.org/pipermail/cvs-ghc/ + url="http://www.haskell.org/pipermail/ghc-devs/">http://www.haskell.org/pipermail/ghc-devs/ diff --git a/docs/users_guide/ug-book.xml.in b/docs/users_guide/ug-book.xml.in index 4d4489f..dc5d4f7 100644 --- a/docs/users_guide/ug-book.xml.in +++ b/docs/users_guide/ug-book.xml.in @@ -3,7 +3,7 @@ @ProjectName@ User's Guide, Version @ProjectVersion@ The GHC Team
-glasgow-haskell-{bugs,users}-request@haskell.org +glasgow-haskell-users-request@haskell.org
diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h index 5ff4d4e..5ec5e11 100644 --- a/includes/rts/Constants.h +++ b/includes/rts/Constants.h @@ -273,6 +273,12 @@ */ #define TSO_SQUEEZED 128 +/** + * Used to indicate that the TSO got promoted in the run queue, and thus + * that its ss_pass is not indicative of the true state of the system. + */ +#define TSO_PROMOTED 256 + /* * The number of times we spin in a spin lock before yielding (see * #3758). To tune this value, use the benchmark in #3758: run the diff --git a/includes/rts/storage/TSO.h b/includes/rts/storage/TSO.h index 82f5a75..583c7e1 100644 --- a/includes/rts/storage/TSO.h +++ b/includes/rts/storage/TSO.h @@ -168,6 +168,12 @@ typedef struct StgTSO_ { */ StgWord32 tot_stack_size; + // These are bounded above by STRIDE1, which is less than a max + // 32-bit word. + StgWord32 ss_tickets, ss_stride, ss_remain; + // 64-bit to prevent overflows; only ever accessed by the task which owns TSO. + StgWord64 ss_pass; + } *StgTSOPtr; typedef struct StgStack_ { diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 61e6b09..e6d5fcd 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -402,6 +402,9 @@ RTS_FUN_DECL(stg_maskUninterruptiblezh); RTS_FUN_DECL(stg_unmaskAsyncExceptionszh); RTS_FUN_DECL(stg_myThreadIdzh); RTS_FUN_DECL(stg_labelThreadzh); +RTS_FUN_DECL(stg_getTicketszh); +RTS_FUN_DECL(stg_setTicketszh); +RTS_FUN_DECL(stg_modifyTicketszh); RTS_FUN_DECL(stg_isCurrentThreadBoundzh); RTS_FUN_DECL(stg_threadStatuszh); diff --git a/rts/Capability.c b/rts/Capability.c index 811df58..903f6ad 100644 --- a/rts/Capability.c +++ b/rts/Capability.c @@ -276,6 +276,8 @@ initCapability( Capability *cap, nat i ) cap->pinned_object_block = NULL; cap->pinned_object_blocks = NULL; + cap->ss_pass = 1; + #ifdef PROFILING cap->r.rCCCS = CCS_SYSTEM; #else diff --git a/rts/Capability.h b/rts/Capability.h index 3348f88..81322c8 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -58,6 +58,10 @@ struct Capability_ { StgTSO *run_queue_hd; StgTSO *run_queue_tl; + // [SSS] Stride scheduling extensions. The Task with this + // Capability has exclusive access to this variable. + StgWord64 ss_pass; + // Tasks currently making safe foreign calls. Doubly-linked. // When returning, a task first acquires the Capability before // removing itself from this list, so that the GC can find all diff --git a/rts/Linker.c b/rts/Linker.c index fa1de89..c673bac 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1130,6 +1130,9 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_mkApUpd0zh) \ SymI_HasProto(stg_myThreadIdzh) \ SymI_HasProto(stg_labelThreadzh) \ + SymI_HasProto(stg_getTicketszh) \ + SymI_HasProto(stg_setTicketszh) \ + SymI_HasProto(stg_modifyTicketszh) \ SymI_HasProto(stg_newArrayzh) \ SymI_HasProto(stg_newArrayArrayzh) \ SymI_HasProto(stg_newBCOzh) \ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index ebcee6a..a737508 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -628,6 +628,26 @@ stg_labelThreadzh ( gcptr threadid, W_ addr ) return (); } +stg_setTicketszh ( gcptr threadid, W_ n ) +{ + ccall setTickets(threadid "ptr", n); + return (); +} + +stg_getTicketszh ( gcptr threadid ) +{ + W_ r; + (r) = ccall getTickets(threadid "ptr"); + return (r); +} + +stg_modifyTicketszh ( gcptr threadid, W_ n, W_ d, W_ x ) +{ + W_ r; + (r) = ccall modifyTickets(threadid "ptr", n, d, x); + return (r); +} + stg_isCurrentThreadBoundzh (/* no args */) { W_ r; diff --git a/rts/Schedule.c b/rts/Schedule.c index a21b312..96cfebc 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -148,7 +148,7 @@ static void schedulePostRunThread(Capability *cap, StgTSO *t); static rtsBool scheduleHandleHeapOverflow( Capability *cap, StgTSO *t ); static rtsBool scheduleHandleYield( Capability *cap, StgTSO *t, nat prev_what_next ); -static void scheduleHandleThreadBlocked( StgTSO *t ); +static void scheduleHandleThreadBlocked( Capability *cap, StgTSO *t ); static rtsBool scheduleHandleThreadFinished( Capability *cap, Task *task, StgTSO *t ); static rtsBool scheduleNeedHeapProfile(rtsBool ready_to_gc); @@ -537,7 +537,7 @@ run_thread: break; case ThreadBlocked: - scheduleHandleThreadBlocked(t); + scheduleHandleThreadBlocked(cap, t); break; case ThreadFinished: @@ -575,6 +575,7 @@ removeFromRunQueue (Capability *cap, StgTSO *tso) setTSOPrev(cap, tso->_link, tso->block_info.prev); } tso->_link = tso->block_info.prev = END_TSO_QUEUE; + tso->flags &= ~TSO_PROMOTED; IF_DEBUG(sanity, checkRunQueue(cap)); } @@ -781,7 +782,8 @@ schedulePushWork(Capability *cap USED_IF_THREADS, setTSOPrev(cap, t, prev); prev = t; } else { - appendToRunQueue(free_caps[i],t); + leaveRunQueue(cap,t); + joinRunQueue(free_caps[i],t); traceEventMigrateThread (cap, t, free_caps[i]->no); @@ -1217,11 +1219,7 @@ scheduleHandleYield( Capability *cap, StgTSO *t, nat prev_what_next ) * -------------------------------------------------------------------------- */ static void -scheduleHandleThreadBlocked( StgTSO *t -#if !defined(DEBUG) - STG_UNUSED -#endif - ) +scheduleHandleThreadBlocked( Capability *cap, StgTSO *t ) { // We don't need to do anything. The thread is blocked, and it @@ -1234,6 +1232,8 @@ scheduleHandleThreadBlocked( StgTSO *t // threadPaused() might have raised a blocked throwTo // exception, see maybePerformBlockedException(). + leaveRunQueue(cap, t); + #ifdef DEBUG traceThreadStatus(DEBUG_sched, t); #endif @@ -1257,6 +1257,8 @@ scheduleHandleThreadFinished (Capability *cap STG_UNUSED, Task *task, StgTSO *t) // blocked mode (see #2910). awakenBlockedExceptionQueue (cap, t); + leaveRunQueue(cap, t); + // // Check whether the thread that just completed was a bound // thread, and if so return with the result. @@ -2296,7 +2298,7 @@ scheduleThread(Capability *cap, StgTSO *tso) { // The thread goes at the *end* of the run-queue, to avoid possible // starvation of any threads already on the queue. - appendToRunQueue(cap,tso); + joinRunQueue(cap,tso); } void @@ -2307,12 +2309,12 @@ scheduleThreadOn(Capability *cap, StgWord cpu USED_IF_THREADS, StgTSO *tso) #if defined(THREADED_RTS) cpu %= enabled_capabilities; if (cpu == cap->no) { - appendToRunQueue(cap,tso); + joinRunQueue(cap,tso); } else { migrateThread(cap, tso, &capabilities[cpu]); } #else - appendToRunQueue(cap,tso); + joinRunQueue(cap,tso); #endif } @@ -2337,7 +2339,7 @@ scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability **pcap) task->incall->ret = ret; task->incall->stat = NoStatus; - appendToRunQueue(cap,tso); + joinRunQueue(cap,tso); DEBUG_ONLY( id = tso->id ); debugTrace(DEBUG_sched, "new bound thread (%lu)", (unsigned long)id); diff --git a/rts/Schedule.h b/rts/Schedule.h index 8b7caea..0677295 100644 --- a/rts/Schedule.h +++ b/rts/Schedule.h @@ -116,6 +116,12 @@ void interruptStgRts (void); void resurrectThreads (StgTSO *); +// STRIDE1 defines the maximum resolution we can achieve in scheduling. +#define STRIDE1 (1 << 20) +// Defualt tickets is set to STRIDE1, so that the IO manager gets +// maximum priority. +#define DEFAULT_TICKETS (1 << 20) + /* ----------------------------------------------------------------------------- * Some convenient macros/inline functions... */ @@ -135,14 +141,46 @@ EXTERN_INLINE void appendToRunQueue (Capability *cap, StgTSO *tso) { ASSERT(tso->_link == END_TSO_QUEUE); + tso->ss_pass += tso->ss_stride; if (cap->run_queue_hd == END_TSO_QUEUE) { cap->run_queue_hd = tso; tso->block_info.prev = END_TSO_QUEUE; + cap->run_queue_tl = tso; } else { - setTSOLink(cap, cap->run_queue_tl, tso); - setTSOPrev(cap, tso, cap->run_queue_tl); + StgTSO *t, *next; + next = END_TSO_QUEUE; + for (t = cap->run_queue_tl; t != END_TSO_QUEUE; next = t, t = t->block_info.prev) { + if (tso->ss_pass >= t->ss_pass || t->flags & TSO_PROMOTED) { + if (next == END_TSO_QUEUE) { + // it's the last one! + // this should overwhelmingly be the case when priorities + // are not being set + setTSOLink(cap, cap->run_queue_tl, tso); + setTSOPrev(cap, tso, cap->run_queue_tl); + cap->run_queue_tl = tso; + } else { + // XXX is there like a necessary order or something? + setTSOLink(cap, tso, next); + setTSOPrev(cap, tso, t); + setTSOLink(cap, t, tso); + setTSOPrev(cap, next, tso); + } + break; + } + } + if (t == END_TSO_QUEUE) { + setTSOLink(cap, tso, cap->run_queue_hd); + tso->block_info.prev = END_TSO_QUEUE; + cap->run_queue_hd = tso; + } } - cap->run_queue_tl = tso; +} + +INLINE_HEADER void +joinRunQueue(Capability *cap, StgTSO *tso) { + tso->ss_pass = cap->ss_pass + tso->ss_remain; + tso->flags &= ~TSO_PROMOTED; + appendToRunQueue(cap, tso); } /* Push a thread on the beginning of the run queue. @@ -151,9 +189,19 @@ appendToRunQueue (Capability *cap, StgTSO *tso) EXTERN_INLINE void pushOnRunQueue (Capability *cap, StgTSO *tso); +// This code is a little dangerous, since it temporarily bypasses +// stride scheduling. However, since we do increase ss_pass, +// as long as the process doesn't continually get rescheduled with +// pushOn, it will eventually be penalized for the time it took. +// Since I think the old code was written to avoid this kid of +// starvation, deferred punishment should be OK. (Also, failing +// to put threads in front after they allocate causes massive +// performance problems.) EXTERN_INLINE void pushOnRunQueue (Capability *cap, StgTSO *tso) { + tso->ss_pass += tso->ss_stride; + tso->flags |= TSO_PROMOTED; setTSOLink(cap, tso, cap->run_queue_hd); tso->block_info.prev = END_TSO_QUEUE; if (cap->run_queue_hd != END_TSO_QUEUE) { @@ -161,10 +209,16 @@ pushOnRunQueue (Capability *cap, StgTSO *tso) } cap->run_queue_hd = tso; if (cap->run_queue_tl == END_TSO_QUEUE) { - cap->run_queue_tl = tso; + cap->run_queue_tl = tso; } } +INLINE_HEADER void +fastJoinRunQueue(Capability *cap, StgTSO *tso) { + tso->ss_pass = cap->ss_pass + tso->ss_remain; + pushOnRunQueue(cap, tso); +} + /* Pop the first thread off the runnable queue. */ INLINE_HEADER StgTSO * @@ -180,6 +234,17 @@ popRunQueue (Capability *cap) if (cap->run_queue_hd == END_TSO_QUEUE) { cap->run_queue_tl = END_TSO_QUEUE; } + if (t->flags & TSO_PROMOTED) { + t->flags &= ~TSO_PROMOTED; + // its pass is nonsense, don't count it + } else { + if (cap->run_queue_hd != END_TSO_QUEUE) { + // relies on a PROMOTED invariant: promoted elements + // are ALWAYS in the front of the queue + ASSERT(cap->run_queue_hd->flags & TSO_PROMOTED == 0); + cap->ss_pass = cap->run_queue_hd->ss_pass; + } + } return t; } @@ -189,6 +254,17 @@ peekRunQueue (Capability *cap) return cap->run_queue_hd; } +INLINE_HEADER void +leaveRunQueue (Capability *cap STG_UNUSED, StgTSO *tso STG_UNUSED) +{ + int r = tso->ss_pass - cap->ss_pass; + if (r > 0) { + tso->ss_remain = (StgWord32)r; + } else { + tso->ss_remain = 0; + } +} + void removeFromRunQueue (Capability *cap, StgTSO *tso); extern void promoteInRunQueue (Capability *cap, StgTSO *tso); diff --git a/rts/Sparks.c b/rts/Sparks.c index 4241656..4e9b5a5 100644 --- a/rts/Sparks.c +++ b/rts/Sparks.c @@ -45,7 +45,7 @@ createSparkThread (Capability *cap) traceEventCreateSparkThread(cap, tso->id); - appendToRunQueue(cap,tso); + joinRunQueue(cap,tso); } /* -------------------------------------------------------------------------- diff --git a/rts/Threads.c b/rts/Threads.c index b617616..a8f38fb 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -112,6 +112,10 @@ createThread(Capability *cap, W_ size) tso->trec = NO_TREC; + tso->ss_tickets = DEFAULT_TICKETS; + tso->ss_stride = STRIDE1 / tso->ss_tickets; + tso->ss_remain = tso->ss_stride; // avoid starvation when lots of new threads are being created + #ifdef PROFILING tso->prof.cccs = CCS_MAIN; #endif @@ -136,6 +140,56 @@ createThread(Capability *cap, W_ size) } /* --------------------------------------------------------------------------- + * Ticket allocations on threads + * ------------------------------------------------------------------------ */ + +#define TICKET_ERROR (STRIDE1 + 1) + +void +setTickets(StgTSO *tso, W_ tickets) +{ + if (tickets > STRIDE1) { + barf("setTickets: too many tickets"); + } else if (tickets <= 0) { + barf("setTickets: too few tickets"); + } + ACQUIRE_LOCK(&sched_mutex); + StgWord64 stride = STRIDE1 / tickets; + StgWord64 remain = (tso->ss_remain * stride) / tso->ss_stride; + tso->ss_tickets = tickets; + tso->ss_stride = stride; + tso->ss_remain = remain; + RELEASE_LOCK(&sched_mutex); +} + +W_ +modifyTickets(StgTSO *tso, W_ n, W_ d, W_ x) +{ + ACQUIRE_LOCK(&sched_mutex); + W_ tickets = (tso->ss_tickets * n) / d + x; + W_ delta; + if (tickets > STRIDE1 || tickets <= 0) { + delta = TICKET_ERROR; + goto cleanup; + } + StgWord64 stride = STRIDE1 / tickets; + StgWord64 remain = (tso->ss_remain * stride) / tso->ss_stride; + delta = tso->ss_tickets - tickets; + tso->ss_tickets = tickets; + tso->ss_stride = stride; + tso->ss_remain = remain; +cleanup: + RELEASE_LOCK(&sched_mutex); + return delta; +} + +W_ +getTickets(StgTSO *tso) +{ + return tso->ss_tickets; +} + +/* --------------------------------------------------------------------------- * Comparing Thread ids. * * This is used from STG land in the implementation of the @@ -236,6 +290,7 @@ removeThreadFromDeQueue (Capability *cap, void tryWakeupThread (Capability *cap, StgTSO *tso) { + rtsBool migrating = rtsFalse; traceEventThreadWakeup (cap, tso, tso->cap->no); #ifdef THREADED_RTS @@ -282,9 +337,10 @@ tryWakeupThread (Capability *cap, StgTSO *tso) goto unblock; } + case ThreadMigrating: + migrating = rtsTrue; case BlockedOnBlackHole: case BlockedOnSTM: - case ThreadMigrating: goto unblock; default: @@ -296,7 +352,11 @@ unblock: // just run the thread now, if the BH is not really available, // we'll block again. tso->why_blocked = NotBlocked; - appendToRunQueue(cap,tso); + if (migrating) { + joinRunQueue(cap, tso); + } else { + appendToRunQueue(cap,tso); + } // We used to set the context switch flag here, which would // trigger a context switch a short time in the future (at the end @@ -322,6 +382,7 @@ migrateThread (Capability *from, StgTSO *tso, Capability *to) traceEventMigrateThread (from, tso, to->no); // ThreadMigrating tells the target cap that it needs to be added to // the run queue when it receives the MSG_TRY_WAKEUP. + leaveRunQueue(from, tso); tso->why_blocked = ThreadMigrating; tso->cap = to; tryWakeupThread(from, tso); diff --git a/rts/Threads.h b/rts/Threads.h index 6d26610..39794f3 100644 --- a/rts/Threads.h +++ b/rts/Threads.h @@ -13,6 +13,10 @@ #define END_BLOCKED_EXCEPTIONS_QUEUE ((MessageThrowTo*)END_TSO_QUEUE) +void setTickets(StgTSO *tso, W_ n); +W_ modifyTickets(StgTSO *tso, W_ n, W_ d, W_ x); +W_ getTickets(StgTSO *tso); + StgTSO * unblockOne (Capability *cap, StgTSO *tso); StgTSO * unblockOne_ (Capability *cap, StgTSO *tso, rtsBool allow_migrate); diff --git a/rts/posix/Select.c b/rts/posix/Select.c index 3d92a46..b39338b 100644 --- a/rts/posix/Select.c +++ b/rts/posix/Select.c @@ -107,7 +107,7 @@ static rtsBool wakeUpSleepingThreads (LowResTime now) tso->_link = END_TSO_QUEUE; IF_DEBUG(scheduler,debugBelch("Waking up sleeping thread %lu\n", (unsigned long)tso->id)); // MainCapability: this code is !THREADED_RTS - pushOnRunQueue(&MainCapability,tso); + fastJoinRunQueue(&MainCapability,tso); flag = rtsTrue; } return flag; @@ -305,7 +305,7 @@ awaitEvent(rtsBool wait) IF_DEBUG(scheduler,debugBelch("Waking up blocked thread %lu\n", (unsigned long)tso->id)); tso->why_blocked = NotBlocked; tso->_link = END_TSO_QUEUE; - pushOnRunQueue(&MainCapability,tso); + fastJoinRunQueue(&MainCapability,tso); } else { if (prev == NULL) blocked_queue_hd = tso; diff --git a/rts/win32/AsyncIO.c b/rts/win32/AsyncIO.c index 979df0c..cfd2c0f 100644 --- a/rts/win32/AsyncIO.c +++ b/rts/win32/AsyncIO.c @@ -303,9 +303,9 @@ start: // save the StgAsyncIOResult in the // stg_block_async_info stack frame, because // the block_info field will be overwritten by - // pushOnRunQueue(). + // fastJoinRunQueue(). tso->stackobj->sp[1] = (W_)tso->block_info.async_result; - pushOnRunQueue(&MainCapability, tso); + fastJoinRunQueue(&MainCapability, tso); break; } break;