Ticket #7606: ghc-stride-scheduling-sorted-list-2.10.patch

compiler/llvmGen/LlvmCodeGen/CodeGen.hs

@@ -31 +31 @@
 import Unique
 import Util
 
-import Data.List ( partition )
-
+import Data.List  ( partition )
+import Data.Maybe ( fromMaybe )
 
 type LlvmStatements = OrdList LlvmStatement
 
@@ -706 +706 @@
 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 +715 @@
         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 +822 @@
 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 +1258 @@
 
 
 -- | 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 +1290 @@
                 (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 +1316 @@
         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!"
 
 

compiler/prelude/primops.txt.pp

@@ -1839 +1839 @@
    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"
 ------------------------------------------------------------------------

docs/users_guide/intro.xml

@@ -130 +130 @@
       </varlistentry>
 
       <varlistentry>
-        <term>glasgow-haskell-bugs:</term>
+        <term>ghc-devs:</term>
         <listitem>
-          <para>This list is for reporting and discussing GHC bugs.
-            However, please see <xref linkend="bug-reporting" /> before
-            posting here.</para>
+          <para>The hardcore GHC developers hang out here.</para>
 
           <variablelist>
             <varlistentry>
               <term>list email address:</term>
               <listitem>
-                <para><email>glasgow-haskell-bugs@haskell.org</email></para>
+                <para><email>ghc-devs@haskell.org</email></para>
               </listitem>
             </varlistentry>
 
@@ -148 +146 @@
               <term>subscribe at:</term>
               <listitem>
                 <para><ulink
-              url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs"><literal>http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs</literal></ulink>.</para>
+              url="http://www.haskell.org/mailman/listinfo/ghc-devs"><literal>http://www.haskell.org/mailman/listinfo/ghc-devs</literal></ulink>.</para>
               </listitem>
             </varlistentry>
 
             <varlistentry>
               <term>admin email address:</term>
               <listitem>
-                <para><email>glasgow-haskell-bugs-admin@haskell.org</email></para>
+                <para><email>ghc-devs-admin@haskell.org</email></para>
               </listitem>
             </varlistentry>
 
@@ -163 +161 @@
               <term>list archives:</term>
               <listitem>
                 <para><ulink
-                         url="http://www.haskell.org/pipermail/glasgow-haskell-bugs/"><literal>http://www.haskell.org/pipermail/glasgow-haskell-bugs/</literal></ulink></para>
-              </listitem>
-            </varlistentry>
-          </variablelist>
-        </listitem>
-      </varlistentry>
-
-      <varlistentry>
-        <term>cvs-ghc:</term>
-        <listitem>
-          <para>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 <literal>cvs-libraries</literal>).
-          </para>
-
-          <variablelist>
-            <varlistentry>
-              <term>list email address:</term>
-              <listitem>
-                <para><email>cvs-ghc@haskell.org</email></para>
-              </listitem>
-            </varlistentry>
-
-            <varlistentry>
-              <term>subscribe at:</term>
-              <listitem>
-                <para><ulink
-              url="http://www.haskell.org/mailman/listinfo/cvs-ghc"><literal>http://www.haskell.org/mailman/listinfo/cvs-ghc</literal></ulink>.</para>
-              </listitem>
-            </varlistentry>
-
-            <varlistentry>
-              <term>admin email address:</term>
-              <listitem>
-                <para><email>cvs-ghc-admin@haskell.org</email></para>
-              </listitem>
-            </varlistentry>
-
-            <varlistentry>
-              <term>list archives:</term>
-              <listitem>
-                <para><ulink
-          url="http://www.haskell.org/pipermail/cvs-ghc/"><literal>http://www.haskell.org/pipermail/cvs-ghc/</literal></ulink></para>
+          url="http://www.haskell.org/pipermail/ghc-devs/"><literal>http://www.haskell.org/pipermail/ghc-devs/</literal></ulink></para>
               </listitem>
             </varlistentry>
           </variablelist>

docs/users_guide/ug-book.xml.in

@@ -3 +3 @@
 <title>@ProjectName@ User's Guide, Version @ProjectVersion@</title>
 <author><othername>The GHC Team</othername></author>
 <address>
-<email>glasgow-haskell-&lcub;bugs,users&rcub;-request@haskell.org</email>
+<email>glasgow-haskell-users-request@haskell.org</email>
 </address>
 </bookinfo>
 

includes/rts/Constants.h

@@ -273 +273 @@
  */
 #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

includes/rts/storage/TSO.h

@@ -168 +168 @@
      */
     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_ {

includes/stg/MiscClosures.h

@@ -402 +402 @@
 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);
 

rts/Capability.c

@@ -276 +276 @@
     cap->pinned_object_block = NULL;
     cap->pinned_object_blocks = NULL;
 
+    cap->ss_pass = 1;
+
 #ifdef PROFILING
     cap->r.rCCCS = CCS_SYSTEM;
 #else

rts/Capability.h

@@ -58 +58 @@
     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

rts/Linker.c

@@ -1130 +1130 @@
       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)                                       \

rts/PrimOps.cmm

@@ -628 +628 @@
   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;

rts/Schedule.c

@@ -148 +148 @@
 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 +537 @@
         break;
 
     case ThreadBlocked:
-        scheduleHandleThreadBlocked(t);
+        scheduleHandleThreadBlocked(cap, t);
         break;
 
     case ThreadFinished:
@@ -575 +575 @@
         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 +782 @@
                     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 +1219 @@
  * -------------------------------------------------------------------------- */
 
 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 +1232 @@
     //      threadPaused() might have raised a blocked throwTo
     //      exception, see maybePerformBlockedException().
 
+    leaveRunQueue(cap, t);
+
 #ifdef DEBUG
     traceThreadStatus(DEBUG_sched, t);
 #endif
@@ -1257 +1257 @@
     // 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 +2298 @@
 {
     // 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 +2309 @@
 #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 +2339 @@
     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);

rts/Schedule.h

@@ -116 +116 @@
 
 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 +141 @@
 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 +189 @@
 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 +209 @@
     }
     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 +234 @@
     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 +254 @@
     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);
 

rts/Sparks.c

@@ -45 +45 @@
 
     traceEventCreateSparkThread(cap, tso->id);
 
-    appendToRunQueue(cap,tso);
+    joinRunQueue(cap,tso);
 }
 
 /* --------------------------------------------------------------------------

rts/Threads.c

@@ -112 +112 @@
 
     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 +140 @@
 }
 
 /* ---------------------------------------------------------------------------
+ * 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 +290 @@
 void
 tryWakeupThread (Capability *cap, StgTSO *tso)
 {
+    rtsBool migrating = rtsFalse;
     traceEventThreadWakeup (cap, tso, tso->cap->no);
 
 #ifdef THREADED_RTS
@@ -282 +337 @@
         goto unblock;
     }
 
+    case ThreadMigrating:
+        migrating = rtsTrue;
     case BlockedOnBlackHole:
     case BlockedOnSTM:
-    case ThreadMigrating:
         goto unblock;
 
     default:
@@ -296 +352 @@
     // 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 +382 @@
     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);

rts/Threads.h

@@ -13 +13 @@
 
 #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);
 

rts/posix/Select.c

@@ -107 +107 @@
         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 +305 @@
                 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;

rts/win32/AsyncIO.c

@@ -303 +303 @@
                         // 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;