Ticket #7606: 0001-Red-black-trees-27-no-sleeper-fairness-copy-of-22.patch

includes/RtsAPI.h

@@ -37 +37 @@
  */
 typedef struct Capability_ Capability;
 
+typedef struct StgRB_ StgRB;
+
 /*
  * The public view of a Capability: we can be sure it starts with
  * these two components (but it may have more private fields).

includes/rts/storage/TSO.h

@@ -257 +257 @@
 
 /* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
 #define END_TSO_QUEUE  ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
+#define RB_NULL        ((StgRB *)(void*)&stg_RB_NULL_closure)
 
 #endif /* RTS_STORAGE_TSO_H */

includes/stg/MiscClosures.h

@@ -114 +114 @@
 RTS_ENTRY(stg_MUT_VAR_CLEAN);
 RTS_ENTRY(stg_MUT_VAR_DIRTY);
 RTS_ENTRY(stg_END_TSO_QUEUE);
+RTS_ENTRY(stg_RB_NULL);
 RTS_ENTRY(stg_MSG_TRY_WAKEUP);
 RTS_ENTRY(stg_MSG_THROWTO);
 RTS_ENTRY(stg_MSG_BLACKHOLE);
@@ -142 +143 @@
 /* closures */
 
 RTS_CLOSURE(stg_END_TSO_QUEUE_closure);
+RTS_CLOSURE(stg_RB_NULL_closure);
 RTS_CLOSURE(stg_NO_FINALIZER_closure);
 RTS_CLOSURE(stg_dummy_ret_closure);
 RTS_CLOSURE(stg_forceIO_closure);

rts/Capability.c

@@ -26 +26 @@
 #include "sm/GC.h" // for gcWorkerThread()
 #include "STM.h"
 #include "RtsUtils.h"
+#include "RBTree.h"
 
 #include <string.h>
 
@@ -230 +231 @@
     cap->idle              = 0;
     cap->disabled          = rtsFalse;
 
-    cap->run_queue_hd      = END_TSO_QUEUE;
-    cap->run_queue_tl      = END_TSO_QUEUE;
+    cap->promoted_run_queue_hd = END_TSO_QUEUE;
 
 #if defined(THREADED_RTS)
     initMutex(&cap->lock);
@@ -282 +282 @@
     cap->r.rCCCS = NULL;
 #endif
 
+    cap->rb_free_list      = RB_NULL;
+    cap->run_count         = 0;
+    cap->run_rbtree        = rbCreateNode(cap, END_TSO_QUEUE);
+    cap->run_active        = cap->run_rbtree;
+
     traceCapCreate(cap);
     traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i);
     traceCapsetAssignCap(CAPSET_CLOCKDOMAIN_DEFAULT, i);
@@ -1007 +1012 @@
     // or fewer Capabilities as GC threads, but just in case there
     // are more, we mark every Capability whose number is the GC
     // thread's index plus a multiple of the number of GC threads.
-    evac(user, (StgClosure **)(void *)&cap->run_queue_hd);
-    evac(user, (StgClosure **)(void *)&cap->run_queue_tl);
+    evac(user, (StgClosure **)(void *)&cap->promoted_run_queue_hd);
+    rbEvacuate(evac, user, cap->run_rbtree);
 #if defined(THREADED_RTS)
     evac(user, (StgClosure **)(void *)&cap->inbox);
 #endif

rts/Capability.h

@@ -55 +55 @@
     // access to its run queue, so can wake up threads without
     // taking a lock, and the common path through the scheduler is
     // also lock-free.
-    StgTSO *run_queue_hd;
-    StgTSO *run_queue_tl;
+    StgTSO *promoted_run_queue_hd;
+    // XXX move StgRB somewhere not RBTree.h to break circular dep
+    StgRB *run_rbtree;
+    StgRB *run_active; // cached pointer to min red-black tree element
+    StgRB *rb_free_list; // free list of RBNodes
+    nat run_count;
 
     // [SSS] Stride scheduling extensions.  The Task with this
     // Capability has exclusive access to this variable.
@@ -153 +157 @@
 // These properties should be true when a Task is holding a Capability
 #define ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task)                     \
   ASSERT(cap->running_task != NULL && cap->running_task == task);       \
+  ASSERT((cap->run_rbtree == RB_NULL) == (cap->run_active == RB_NULL)); \
+  ASSERT((cap->run_active == RB_NULL && cap->run_rbtree == RB_NULL) ||\
+         (RB_HEAD_GET(cap->run_active) != END_TSO_QUEUE && RB_TAIL_GET(cap->run_active) != END_TSO_QUEUE) || \
+         (RB_HEAD_GET(cap->run_active) == END_TSO_QUEUE && RB_TAIL_GET(cap->run_active) == END_TSO_QUEUE && \
+            RB_LEFT_GET(cap->run_active) == RB_NULL && RB_RIGHT_GET(cap->run_active) == RB_NULL));\
   ASSERT(task->cap == cap);                                             \
   ASSERT_PARTIAL_CAPABILITY_INVARIANTS(cap,task)
 
@@ -162 +171 @@
 // Task is bound, its thread has just blocked, and it may have been
 // moved to another Capability.
 #define ASSERT_PARTIAL_CAPABILITY_INVARIANTS(cap,task)  \
-  ASSERT(cap->run_queue_hd == END_TSO_QUEUE ?           \
-            cap->run_queue_tl == END_TSO_QUEUE : 1);    \
   ASSERT(myTask() == task);                             \
   ASSERT_TASK_ID(task);
 

(a) /dev/null vs. (b) b/rts/RBTree.c

@@ +1 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2013
+ *
+ * Red-black trees
+ *
+ * The core algorithm is based off of jemalloc's red-black tree
+ * implementation <http://www.canonware.com/rb/>, which has the following license:
+ *
+ * Copyright (C) 2002-2012 Jason Evans <jasone@canonware.com>. All rights reserved.
+ * Copyright (C) 2007-2012 Mozilla Foundation.  All rights reserved.
+ * Copyright (C) 2009-2012 Facebook, Inc.  All rights reserved.
+
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ * 1. Redistributions of source code must retain the above copyright notice(s),
+ *    this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright notice(s),
+ *    this list of conditions and the following disclaimer in the documentation
+ *    and/or other materials provided with the distribution.
+
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER(S) ``AS IS'' AND ANY EXPRESS
+ * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO
+ * EVENT SHALL THE COPYRIGHT HOLDER(S) BE LIABLE FOR ANY DIRECT, INDIRECT,
+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+ * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "PosixSource.h"
+#include "Rts.h"
+
+#include "RtsUtils.h"
+#include "RBTree.h"
+
+STATIC_INLINE StgRB*
+rbRotateLeft(Capability *cap, StgRB *a) {
+    ASSERT(a != RB_NULL);
+    StgRB *r = RB_RIGHT_GET(a);
+    ASSERT(r != RB_NULL);
+    RB_RIGHT_SET(cap, a, RB_LEFT_GET(r));
+    RB_LEFT_SET(cap, r, a);
+    return r;
+}
+
+STATIC_INLINE StgRB*
+rbRotateRight(Capability *cap, StgRB *a) {
+    ASSERT(a != RB_NULL);
+    StgRB *l = RB_LEFT_GET(a);
+    ASSERT(l != RB_NULL);
+    RB_LEFT_SET(cap, a, RB_RIGHT_GET(l));
+    RB_RIGHT_SET(cap, l, a);
+    return l;
+}
+
+int
+checkRBTree(StgRB *r, int forceBlack, int count, int expected)
+{
+    if (r == RB_NULL) {
+        ASSERT(expected == -1 || count == expected);
+        ASSERT(count != 0);
+        return count;
+    }
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(RB_LEFT_GET(r)));
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(RB_RIGHT_GET(r)));
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(RB_HEAD_GET(r)));
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(RB_TAIL_GET(r)));
+    if (count == 0) {
+        // this corresponds to "fast path" empty node
+        if (RB_HEAD_GET(r) == END_TSO_QUEUE) {
+            ASSERT(RB_LEFT_GET(r) == RB_NULL);
+            ASSERT(RB_RIGHT_GET(r) == RB_NULL);
+            ASSERT(RB_TAIL_GET(r) == END_TSO_QUEUE);
+            ASSERT(RB_IS_BLACK(r));
+        }
+        return 0;
+    } else {
+        ASSERT(RB_HEAD_GET(r) != END_TSO_QUEUE);
+        ASSERT(RB_TAIL_GET(r) != END_TSO_QUEUE);
+    }
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(RB_COLOR_GET(r)));
+    ASSERT(RB_COLOR_GET(r) == RB_RED || RB_COLOR_GET(r) == RB_BLACK);
+    if (forceBlack) {
+        ASSERT(RB_IS_BLACK(r));
+    }
+    if (RB_IS_BLACK(r)) {
+        count++;
+    }
+    expected = checkRBTree(RB_LEFT_GET(r), RB_IS_RED(r), count, expected);
+    checkRBTree(RB_RIGHT_GET(r), RB_IS_RED(r), count, expected);
+    return expected;
+}
+
+void
+rbEvacuate(evac_fn evac, void *user, StgRB* r) {
+    if (r == RB_NULL) return;
+    evac(user, (StgClosure **)(void *)&r->head);
+    evac(user, (StgClosure **)(void *)&r->tail);
+    rbEvacuate(evac, user, r->left);
+    rbEvacuate(evac, user, r->right); // XXX maybe manually TCO this
+}
+
+// this function assumes you've checked for fastpath
+StgRB*
+rbInsert(Capability *cap, StgRB **root, StgTSO *tso) {
+    struct {
+        StgRB *node;
+        int cmp;
+    } path[sizeof(void *) << 4], *pathp;
+    path->node = *root;
+    int found = 0;
+    // Wind
+    for (pathp = path; pathp->node != RB_NULL; pathp++) {
+        ASSERT(RB_HEAD_GET(pathp->node) != END_TSO_QUEUE); // e.g. root is NOT a fast path empty node
+        ASSERT(RB_TAIL_GET(pathp->node) != END_TSO_QUEUE);
+        StgWord64 pass = RB_HEAD_GET(pathp->node)->ss_pass;
+        int cmp = pathp->cmp = (tso->ss_pass > pass) - (tso->ss_pass < pass);
+        if (cmp < 0) {
+            pathp[1].node = RB_LEFT_GET(pathp->node);
+        } else if (cmp == 0) {
+            found = 1;
+            break;
+        } else {
+            pathp[1].node = RB_RIGHT_GET(pathp->node);
+        }
+    }
+    if (found) { // O(n log n) pointer traverals but only O(1) edits
+        ASSERT(pathp->node != RB_NULL);
+        ASSERT(RB_HEAD_GET(pathp->node) != END_TSO_QUEUE);
+        setTSOLink(cap, RB_TAIL_GET(pathp->node), tso);
+        RB_TAIL_SET(cap, pathp->node, tso);
+        return pathp->node;
+    }
+    StgRB *node = rbCreateNode(cap, tso);
+    pathp->node = node;
+    // Unwind
+    for (pathp--; (void*)pathp >= (void*)path; pathp--) {
+        StgRB *cnode = pathp->node;
+        ASSERT(cnode != RB_NULL);
+        ASSERT(pathp->cmp != 0);
+        if (pathp->cmp < 0) {
+            StgRB *left = pathp[1].node;
+            RB_LEFT_SET(cap, cnode, left);
+            if (RB_IS_RED(left)) {
+                StgRB *leftleft = RB_LEFT_GET(left);
+                if (RB_IS_RED(leftleft)) {
+                    // fix up 4-node
+                    StgRB *tnode;
+                    RB_COLOR_BLACK(cap, leftleft);
+                    tnode = rbRotateRight(cap, cnode);
+                    cnode = tnode;
+                }
+            } else {
+                return node;
+            }
+        } else {
+            StgRB *right = pathp[1].node;
+            RB_RIGHT_SET(cap, cnode, right);
+            if (RB_IS_RED(right)) {
+                StgRB *left = RB_LEFT_GET(cnode);
+                if (RB_IS_RED(left)) {
+                    // split 4-node
+                    RB_COLOR_BLACK(cap, left);
+                    RB_COLOR_BLACK(cap, right);
+                    RB_COLOR_RED(cap, cnode);
+                } else {
+                    // lean left
+                    StgRB *tnode;
+                    StgClosure *tred = RB_COLOR_GET(cnode);
+                    tnode = rbRotateLeft(cap, cnode);
+                    RB_COLOR_SET(cap, tnode, tred);
+                    RB_COLOR_RED(cap, cnode);
+                    cnode = tnode;
+                }
+            } else {
+                return node;
+            }
+        }
+        pathp->node = cnode;
+    }
+    *root = path->node;
+    RB_COLOR_BLACK(cap, *root);
+    return node;
+}
+
+// this function assumes you've checked for fastpath
+StgTSO*
+rbRemoveMin(Capability *cap, StgRB **root) {
+    struct {
+        StgRB *node;
+        int cmp;
+    } path[sizeof(void *) << 4], *pathp, *nodep;
+    // Wind
+    nodep = NULL;
+    path->node = *root;
+    for (pathp = path; pathp->node != RB_NULL; pathp++) {
+        ASSERT(RB_HEAD_GET(pathp->node) != END_TSO_QUEUE); // e.g. fast path is NOT in effect
+        ASSERT(RB_TAIL_GET(pathp->node) != END_TSO_QUEUE);
+        StgRB *left = RB_LEFT_GET(pathp->node);
+        if (left != RB_NULL) {
+            pathp->cmp = -1;
+            pathp[1].node = left;
+        } else {
+            // Find node's successor, in preparation for swap
+            // XXX defer this for later
+            pathp[1].node = RB_RIGHT_GET(pathp->node);
+            pathp->cmp = 1;
+            nodep = pathp;
+            for (pathp++; pathp->node != RB_NULL; pathp++) {
+                pathp->cmp = -1;
+                pathp[1].node = RB_LEFT_GET(pathp->node);
+            }
+            break;
+        }
+    }
+    ASSERT(nodep->node != RB_NULL);
+    StgTSO *tso = RB_HEAD_GET(nodep->node);
+    if (tso->_link != END_TSO_QUEUE) { // fast-path!
+        RB_HEAD_SET(cap, nodep->node, tso->_link);
+        tso->_link = END_TSO_QUEUE;
+        return tso; // not to cleanup: no free node!
+    }
+    tso->_link = END_TSO_QUEUE;
+    pathp--;
+    StgRB *node = nodep->node; // the node to be deleted
+    if (pathp->node != node) {
+        ASSERT(pathp->node != RB_NULL);
+        // swap node with its successor
+        StgClosure *tred = RB_COLOR_GET(pathp->node);
+        RB_COLOR_SET(cap, pathp->node, RB_COLOR_GET(node));
+        ASSERT(RB_HEAD_GET(pathp->node) != END_TSO_QUEUE); // e.g. fast path is NOT in effect
+        ASSERT(RB_TAIL_GET(pathp->node) != END_TSO_QUEUE);
+        RB_LEFT_SET(cap, pathp->node, RB_LEFT_GET(node));
+        // if node's successor is its right child, the following code
+        // will do the wrong thing for the right child pointer.
+        // However, it doesn't matter, because the pointer will be
+        // properly set when the successor is pruned.
+        RB_RIGHT_SET(cap, pathp->node, RB_RIGHT_GET(node));
+        RB_COLOR_SET(cap, node, tred);
+        // the pruned leaf node's child pointers are never accessed
+        // again, so don't bother setting them to nil
+        nodep->node = pathp->node;
+        pathp->node = node;
+        if (nodep == path) {
+            *root = nodep->node;
+        } else {
+            if (nodep[-1].cmp < 0) {
+                RB_LEFT_SET(cap, nodep[-1].node, nodep->node);
+            } else {
+                RB_RIGHT_SET(cap, nodep[-1].node, nodep->node);
+            }
+        }
+    } else {
+        StgRB *left = RB_LEFT_GET(node);
+        if (left != RB_NULL) {
+            // node has no successor, but it has a left child.
+            // splice node out, without losing the left child
+            ASSERT(RB_IS_BLACK(node));
+            ASSERT(RB_IS_RED(left));
+            RB_COLOR_BLACK(cap, left);
+            if (pathp == path) {
+                *root = left;
+            } else {
+                if (pathp[-1].cmp < 0) {
+                    RB_LEFT_SET(cap, pathp[-1].node, left);
+                } else {
+                    RB_RIGHT_SET(cap, pathp[-1].node, left);
+                }
+            }
+            goto cleanup;
+        } else if (pathp == path) {
+            // the tree contained only one node
+            // *root = RB_NULL;
+            // instead, setup fastpath
+            RB_HEAD_SET(cap, *root, END_TSO_QUEUE);
+            RB_TAIL_SET(cap, *root, END_TSO_QUEUE);
+            ASSERT(RB_LEFT_GET(*root) == RB_NULL);
+            ASSERT(RB_RIGHT_GET(*root) == RB_NULL);
+            // do NOT add to free list
+            return tso;
+        }
+    }
+    if (RB_IS_RED(pathp->node)) {
+        // prune red node, which requires no fixup
+        ASSERT(pathp[-1].cmp < 0);
+        RB_LEFT_SET(cap, pathp[-1].node, RB_NULL);
+        goto cleanup;
+    }
+    // the node to be pruned is black, so unwind until balance
+    // is restored
+    pathp->node = RB_NULL;
+    for (pathp--; (void*)pathp >= (void*)path; pathp--) {
+        ASSERT(pathp->node != RB_NULL);
+        ASSERT(pathp->cmp != 0);
+        if (pathp->cmp < 0) {
+            RB_LEFT_SET(cap, pathp->node, pathp[1].node);
+            ASSERT(RB_IS_BLACK(pathp[1].node));
+            if (RB_IS_RED(pathp->node)) {
+                StgRB *right = RB_RIGHT_GET(pathp->node);
+                ASSERT(right != RB_NULL);
+                StgRB *rightleft = RB_LEFT_GET(right);
+                StgRB *tnode;
+                if (RB_IS_RED(rightleft)) {
+                    /* In the following diagrams, ||, //, and \\      */
+                    /* indicate the path to the removed node.         */
+                    /*                                                */
+                    /*      ||                                        */
+                    /*    pathp(r)                                    */
+                    /*  //        \                                   */
+                    /* (b)        (b)                                 */
+                    /*           /                                    */
+                    /*          (r)                                   */
+                    /*                                                */
+                    RB_COLOR_BLACK(cap, pathp->node);
+                    tnode = rbRotateRight(cap, right);
+                    RB_RIGHT_SET(cap, pathp->node, tnode);
+                    tnode = rbRotateLeft(cap, pathp->node);
+                } else {
+                    /*      ||                                        */
+                    /*    pathp(r)                                    */
+                    /*  //        \                                   */
+                    /* (b)        (b)                                 */
+                    /*           /                                    */
+                    /*          (b)                                   */
+                    /*                                                */
+                    tnode = rbRotateLeft(cap, pathp->node);
+                }
+                // balance restored, but rotation modified subtree root.
+                ASSERT(pathp > path);
+                if (pathp[-1].cmp < 0) {
+                    RB_LEFT_SET(cap, pathp[-1].node, tnode);
+                } else {
+                    RB_RIGHT_SET(cap, pathp[-1].node, tnode);
+                }
+                goto cleanup;
+            } else {
+                StgRB *right = RB_RIGHT_GET(pathp->node);
+                ASSERT(right != RB_NULL);
+                StgRB *rightleft = RB_LEFT_GET(right);
+                if (RB_IS_RED(rightleft)) {
+                    /*      ||                                        */
+                    /*    pathp(b)                                    */
+                    /*  //        \                                   */
+                    /* (b)        (b)                                 */
+                    /*           /                                    */
+                    /*          (r)                                   */
+                    StgRB *tnode;
+                    RB_COLOR_BLACK(cap, rightleft);
+                    tnode = rbRotateRight(cap, right);
+                    RB_RIGHT_SET(cap, pathp->node, tnode);
+                    tnode = rbRotateLeft(cap, pathp->node);
+                    // balance restored, but rotation modified
+                    // subtree root, which may actually be the tree root
+                    if (pathp == path) {
+                        // set root
+                        *root = tnode;
+                    } else {
+                        if (pathp[-1].cmp < 0) {
+                            RB_LEFT_SET(cap, pathp[-1].node, tnode);
+                        } else {
+                            RB_RIGHT_SET(cap, pathp[-1].node, tnode);
+                        }
+                    }
+                    goto cleanup;
+                } else {
+                    /*      ||                                        */
+                    /*    pathp(b)                                    */
+                    /*  //        \                                   */
+                    /* (b)        (b)                                 */
+                    /*           /                                    */
+                    /*          (b)                                   */
+                    StgRB *tnode;
+                    RB_COLOR_RED(cap, pathp->node);
+                    tnode = rbRotateLeft(cap, pathp->node);
+                    pathp->node = tnode;
+                }
+            }
+        } else {
+            StgRB *left;
+            RB_RIGHT_SET(cap, pathp->node, pathp[1].node);
+            left = RB_LEFT_GET(pathp->node);
+            ASSERT(left != RB_NULL);
+            if (RB_IS_RED(left)) {
+                StgRB *tnode;
+                StgRB *leftright = RB_RIGHT_GET(left);
+                ASSERT(leftright != RB_NULL);
+                StgRB *leftrightleft = RB_LEFT_GET(leftright);
+                if (RB_IS_RED(leftrightleft)) {
+                    /*      ||                                        */
+                    /*    pathp(b)                                    */
+                    /*   /        \\                                  */
+                    /* (r)        (b)                                 */
+                    /*   \                                            */
+                    /*   (b)                                          */
+                    /*   /                                            */
+                    /* (r)                                            */
+                    StgRB *unode;
+                    RB_COLOR_BLACK(cap, leftrightleft);
+                    unode = rbRotateRight(cap, pathp->node);
+                    tnode = rbRotateRight(cap, pathp->node);
+                    RB_RIGHT_SET(cap, unode, tnode);
+                    tnode = rbRotateLeft(cap, unode);
+                } else {
+                    /*      ||                                        */
+                    /*    pathp(b)                                    */
+                    /*   /        \\                                  */
+                    /* (r)        (b)                                 */
+                    /*   \                                            */
+                    /*   (b)                                          */
+                    /*   /                                            */
+                    /* (b)                                            */
+                    ASSERT(leftright != RB_NULL);
+                    RB_COLOR_RED(cap, leftright);
+                    tnode = rbRotateRight(cap, pathp->node);
+                    RB_COLOR_BLACK(cap, tnode);
+                }
+                /* Balance restored, but rotation modified subtree    */
+                /* root, which may actually be the tree root.         */
+                if (pathp == path) {
+                    /* Set root. */
+                    *root = tnode;
+                } else {
+                    if (pathp[-1].cmp < 0) {
+                        RB_LEFT_SET(cap, pathp[-1].node, tnode);
+                    } else {
+                        RB_RIGHT_SET(cap, pathp[-1].node, tnode);
+                    }
+                }
+                goto cleanup;
+            } else if (RB_IS_RED(pathp->node)) {
+                StgRB *leftleft = RB_LEFT_GET(left);
+                if (RB_IS_RED(leftleft)) {
+                    /*        ||                                      */
+                    /*      pathp(r)                                  */
+                    /*     /        \\                                */
+                    /*   (b)        (b)                               */
+                    /*   /                                            */
+                    /* (r)                                            */
+                    StgRB *tnode;
+                    RB_COLOR_BLACK(cap, pathp->node);
+                    RB_COLOR_RED(cap, left);
+                    RB_COLOR_BLACK(cap, leftleft);
+                    tnode = rbRotateRight(cap, pathp->node);
+                    /* Balance restored, but rotation modified        */
+                    /* subtree root.                                  */
+                    ASSERT(pathp > path);
+                    if (pathp[-1].cmp < 0) {
+                        RB_LEFT_SET(cap, pathp[-1].node, tnode);
+                    } else {
+                        RB_RIGHT_SET(cap, pathp[-1].node, tnode);
+                    }
+                    goto cleanup;
+                } else {
+                    /*        ||                                      */
+                    /*      pathp(r)                                  */
+                    /*     /        \\                                */
+                    /*   (b)        (b)                               */
+                    /*   /                                            */
+                    /* (b)                                            */
+                    RB_COLOR_RED(cap, left);
+                    RB_COLOR_BLACK(cap, pathp->node);
+                    /* Balance restored. */
+                    goto cleanup;
+                }
+            } else {
+                StgRB *leftleft = RB_LEFT_GET(left);
+                if (RB_IS_RED(leftleft)) {
+                    /*               ||                               */
+                    /*             pathp(b)                           */
+                    /*            /        \\                         */
+                    /*          (b)        (b)                        */
+                    /*          /                                     */
+                    /*        (r)                                     */
+                    StgRB *tnode;
+                    RB_COLOR_BLACK(cap, leftleft);
+                    tnode = rbRotateRight(cap, pathp->node);
+                    /* Balance restored, but rotation modified        */
+                    /* subtree root, which may actually be the tree   */
+                    /* root.                                          */
+                    if (pathp == path) {
+                        /* Set root. */
+                        *root = tnode;
+                    } else {
+                        if (pathp[-1].cmp < 0) {
+                            RB_LEFT_SET(cap, pathp[-1].node, tnode);
+                        } else {
+                            RB_RIGHT_SET(cap, pathp[-1].node, tnode);
+                        }
+                    }
+                    goto cleanup;
+                } else {
+                    /*               ||                               */
+                    /*             pathp(b)                           */
+                    /*            /        \\                         */
+                    /*          (b)        (b)                        */
+                    /*          /                                     */
+                    /*        (b)                                     */
+                    RB_COLOR_RED(cap, left);
+                }
+            }
+        }
+    }
+    // set root
+    *root = path->node;
+    ASSERT(RB_IS_BLACK(*root));
+cleanup:
+    // return node to the free list
+    RB_LEFT_SET(cap, node, cap->rb_free_list);
+#ifdef DEBUG
+    RB_RIGHT_SET(cap, node, RB_NULL);
+    RB_HEAD_SET(cap, node, END_TSO_QUEUE);
+    RB_TAIL_SET(cap, node, END_TSO_QUEUE);
+#endif
+    cap->rb_free_list = node;
+    return tso;
+}

(a) /dev/null vs. (b) b/rts/RBTree.h

@@ +1 @@
+#ifndef RBTREE_H
+#define RBTREE_H
+
+#include "Capability.h"
+#include "RtsUtils.h"
+
+// http://www.canonware.com/rb/
+
+struct StgRB_ {
+    StgRB *left, *right;
+    StgTSO *head, *tail;
+    int color;
+}; // typedef in RtsAPI
+
+#define RB_RED 0
+#define RB_BLACK 1
+
+#define RB_LEFT_GET(n)           ((n)->left)
+#define RB_LEFT_SET(cap, n,p)    (n)->left = p;
+#define RB_RIGHT_GET(n)          ((n)->right)
+#define RB_RIGHT_SET(cap, n,p)   (n)->right = p;
+#define RB_HEAD_GET(n)           ((n)->head)
+#define RB_HEAD_SET(cap, n,p)    (n)->head = p;
+#define RB_TAIL_GET(n)           ((n)->tail)
+#define RB_TAIL_SET(cap, n,p)    (n)->tail = p;
+// alternatively, setup a static RB_NULL closure with the appropriate
+// structure and do the normal thing
+#define RB_IS_RED(n)        ((n) != RB_NULL && (n)->color == RB_RED)
+#define RB_IS_BLACK(n)      ((n) == RB_NULL || (n)->color == RB_BLACK)
+#define RB_COLOR_GET(n)     ((n) == RB_NULL ? RB_BLACK : (n)->color)
+#define RB_COLOR_RED(cap, n)     (n)->color = RB_RED;
+#define RB_COLOR_BLACK(cap, n)   (n)->color = RB_BLACK;
+#define RB_COLOR_SET(cap, n,c)       (n)->color = c;
+
+int checkRBTree(StgRB *r, int forceBlack, int count, int expected);
+StgRB* rbInsert(Capability *cap, StgRB **root, StgTSO *tso);
+StgTSO* rbRemoveMin(Capability *cap, StgRB **root);
+void rbEvacuate(evac_fn evac, void *user, StgRB* r);
+
+// maintain a free list of nodes so we don't have to continually
+// allocate them
+
+#define RB_CHUNK (1024 * sizeof(W_) / sizeof(StgRB))
+
+INLINE_HEADER StgRB*
+rbCreateNode(Capability *cap, StgTSO *tso) {
+    StgRB *n;
+    if (cap->rb_free_list != RB_NULL) {
+        n = cap->rb_free_list;
+        cap->rb_free_list = RB_LEFT_GET(n);
+    } else {
+        n = (StgRB*) stgMallocBytes(RB_CHUNK * sizeof(StgRB), "rbCreateNode");
+        cap->rb_free_list = n + 1;
+        StgRB *p;
+        for (p = cap->rb_free_list; p < n + RB_CHUNK - 1; p++) {
+            p->left = p + 1;
+        }
+        p->left = RB_NULL;
+    }
+    RB_LEFT_SET(cap, n, RB_NULL);
+    RB_RIGHT_SET(cap, n, RB_NULL);
+    RB_HEAD_SET(cap, n, tso);
+    RB_TAIL_SET(cap, n, tso);
+    if (tso == END_TSO_QUEUE) {
+        RB_COLOR_BLACK(cap, n);
+    } else {
+        RB_COLOR_RED(cap, n);
+    }
+    return n;
+}
+
+EXTERN_INLINE StgRB*
+rbFirst(StgRB *n);
+
+EXTERN_INLINE StgRB*
+rbFirst(StgRB *n) {
+    for (; RB_LEFT_GET(n) != RB_NULL; n = RB_LEFT_GET(n)) {}
+    return n;
+}
+
+EXTERN_INLINE StgRB*
+rbLast(StgRB *n);
+
+EXTERN_INLINE StgRB*
+rbLast(StgRB *n) {
+    for (; RB_RIGHT_GET(n) != RB_NULL; n = RB_RIGHT_GET(n)) {}
+    return n;
+}
+
+#endif /* RBTREE_H */

rts/Schedule.c

@@ -560 +560 @@
  * -------------------------------------------------------------------------- */
 
 void
-removeFromRunQueue (Capability *cap, StgTSO *tso)
+removeFromRunQueue (Capability *cap STG_UNUSED, StgTSO *tso STG_UNUSED)
 {
-    if (tso->block_info.prev == END_TSO_QUEUE) {
-        ASSERT(cap->run_queue_hd == tso);
-        cap->run_queue_hd = tso->_link;
-    } else {
-        setTSOLink(cap, tso->block_info.prev, tso->_link);
-    }
-    if (tso->_link == END_TSO_QUEUE) {
-        ASSERT(cap->run_queue_tl == tso);
-        cap->run_queue_tl = tso->block_info.prev;
-    } else {
-        setTSOPrev(cap, tso->_link, tso->block_info.prev);
-    }
-    tso->_link = tso->block_info.prev = END_TSO_QUEUE;
-
-    IF_DEBUG(sanity, checkRunQueue(cap));
+    //barf("removeFromRunQueue");
 }
 
 void
-promoteInRunQueue (Capability *cap, StgTSO *tso)
+promoteInRunQueue (Capability *cap STG_UNUSED, StgTSO *tso STG_UNUSED)
 {
-    removeFromRunQueue(cap, tso);
-    pushOnRunQueue(cap, tso);
+    //removeFromRunQueue(cap, tso);
+    //pushOnRunQueue(cap, tso);
 }
 
 /* ----------------------------------------------------------------------------
@@ -742 +728 @@
     //   - giving low priority to moving long-lived threads
 
     if (n_free_caps > 0) {
-        StgTSO *prev, *t, *next;
+        //StgTSO *prev, *t, *next;
 #ifdef SPARK_PUSHING
         rtsBool pushed_to_all;
 #endif
@@ -759 +745 @@
         pushed_to_all = rtsFalse;
 #endif
 
+        /*
         if (cap->run_queue_hd != END_TSO_QUEUE) {
             prev = cap->run_queue_hd;
             t = prev->_link;
@@ -795 +782 @@
 
             IF_DEBUG(sanity, checkRunQueue(cap));
         }
+        */
 
 #ifdef SPARK_PUSHING
         /* JB I left this code in place, it would work but is not necessary */

rts/Schedule.h

@@ -13 +13 @@
 #include "rts/OSThreads.h"
 #include "Capability.h"
 #include "Trace.h"
+#include "RBTree.h"
 
 #include "BeginPrivate.h"
 
@@ -140 +141 @@
 EXTERN_INLINE void
 appendToRunQueue (Capability *cap, StgTSO *tso)
 {
-    ASSERT(tso->_link == END_TSO_QUEUE);
-    if (cap->run_queue_hd == END_TSO_QUEUE) {
-        cap->run_queue_hd = tso;
-        tso->block_info.prev = END_TSO_QUEUE;
+    tso->block_info.closure = (StgClosure*)END_TSO_QUEUE;
+    tso->ss_pass += STRIDE1 / tso->ss_tickets;
+    StgTSO *cur = RB_HEAD_GET(cap->run_active);
+    cap->run_count++;
+    if (cur == END_TSO_QUEUE) {
+        // fastpath
+        ASSERT(RB_IS_BLACK(cap->run_active));
+        ASSERT(RB_LEFT_GET(cap->run_active) == RB_NULL);
+        ASSERT(RB_RIGHT_GET(cap->run_active) == RB_NULL);
+        RB_HEAD_SET(cap, cap->run_active, tso);
+        RB_TAIL_SET(cap, cap->run_active, tso);
     } else {
-        setTSOLink(cap, cap->run_queue_tl, tso);
-        setTSOPrev(cap, tso, cap->run_queue_tl);
+        StgWord64 pass = cur->ss_pass;
+        if (tso->ss_pass < pass) {
+            cap->run_active = rbInsert(cap, &cap->run_rbtree, tso);
+        } else if (tso->ss_pass == pass) {
+            setTSOLink(cap, RB_TAIL_GET(cap->run_active), tso);
+            RB_TAIL_SET(cap, cap->run_active, tso);
+        } else {
+            rbInsert(cap, &cap->run_rbtree, tso);
+        }
+        IF_DEBUG(sanity, checkRBTree(cap->run_rbtree, 1, 0, -1));
     }
-    cap->run_queue_tl = tso;
 }
 
 EXTERN_INLINE void
@@ -157 +172 @@
 EXTERN_INLINE void
 joinRunQueue(Capability *cap, StgTSO *tso)
 {
+    tso->ss_pass = cap->ss_pass - STRIDE1 / tso->ss_tickets;
     appendToRunQueue(cap, tso);
 }
 
@@ -169 +185 @@
 EXTERN_INLINE void
 pushOnRunQueue (Capability *cap, StgTSO *tso)
 {
-    setTSOLink(cap, tso, cap->run_queue_hd);
-    tso->block_info.prev = END_TSO_QUEUE;
-    if (cap->run_queue_hd != END_TSO_QUEUE) {
-        setTSOPrev(cap, cap->run_queue_hd, tso);
-    }
-    cap->run_queue_hd = tso;
-    if (cap->run_queue_tl == END_TSO_QUEUE) {
-        cap->run_queue_tl = tso;
+    tso->block_info.closure = (StgClosure*)END_TSO_QUEUE;
+    tso->ss_pass += STRIDE1 / tso->ss_tickets;
+    cap->run_count++;
+    if (cap->promoted_run_queue_hd == END_TSO_QUEUE) {
+    } else {
+        setTSOLink(cap, tso, cap->promoted_run_queue_hd);
     }
+    cap->promoted_run_queue_hd = tso;
 }
 
 EXTERN_INLINE void
@@ -186 +201 @@
 EXTERN_INLINE void
 fastJoinRunQueue(Capability *cap, StgTSO *tso)
 {
+    tso->ss_pass = cap->ss_pass - STRIDE1 / tso->ss_tickets;
     pushOnRunQueue(cap, tso);
 }
 
@@ -194 +210 @@
 INLINE_HEADER StgTSO *
 popRunQueue (Capability *cap)
 { 
-    StgTSO *t = cap->run_queue_hd;
-    ASSERT(t != END_TSO_QUEUE);
-    cap->run_queue_hd = t->_link;
-    if (t->_link != END_TSO_QUEUE) {
-        t->_link->block_info.prev = END_TSO_QUEUE;
-    }
-    t->_link = END_TSO_QUEUE; // no write barrier req'd
-    if (cap->run_queue_hd == END_TSO_QUEUE) {
-        cap->run_queue_tl = END_TSO_QUEUE;
+    cap->run_count--;
+    if (cap->promoted_run_queue_hd == END_TSO_QUEUE) {
+        StgTSO *candidate = RB_HEAD_GET(cap->run_active);
+        if (candidate == END_TSO_QUEUE) {
+            barf("popRunQueue: queue is empty");
+        }
+        if ( // unconditional fastpath (no-rb tree)
+             (candidate->_link != END_TSO_QUEUE) ||
+             // fastpath for a queue that just got emptied
+             (cap->run_rbtree == cap->run_active && RB_RIGHT_GET(cap->run_active) == RB_NULL)
+        ) {
+            RB_HEAD_SET(cap, cap->run_active, candidate->_link);
+            if (candidate->_link == END_TSO_QUEUE) {
+                RB_TAIL_SET(cap, cap->run_active, END_TSO_QUEUE);
+            }
+            candidate->_link = END_TSO_QUEUE;
+            return candidate;
+        }
+        StgTSO *t = rbRemoveMin(cap, &cap->run_rbtree);
+        IF_DEBUG(sanity, checkRBTree(cap->run_rbtree, 1, 0, -1));
+        // XXX maybe this can be folded into removeMin
+        cap->run_active = rbFirst(cap->run_rbtree);
+        if (RB_HEAD_GET(cap->run_active) != END_TSO_QUEUE) {
+            StgWord64 npass = RB_HEAD_GET(cap->run_active)->ss_pass;
+            if (npass > cap->ss_pass) {
+                cap->ss_pass = npass;
+            }
+        }
+        return t;
+    } else {
+        StgTSO *t = cap->promoted_run_queue_hd;
+        cap->promoted_run_queue_hd = t->_link;
+        t->_link = END_TSO_QUEUE; // no write barrier req'd
+        return t;
     }
-    return t;
 }
 
 INLINE_HEADER StgTSO *
 peekRunQueue (Capability *cap)
 {
-    return cap->run_queue_hd;
+    if (cap->promoted_run_queue_hd == END_TSO_QUEUE) {
+        return RB_HEAD_GET(cap->run_active);
+    } else {
+        return cap->promoted_run_queue_hd;
+    }
 }
 
 EXTERN_INLINE void
 leaveRunQueue (Capability *cap, StgTSO *tso);
 
 EXTERN_INLINE void
-leaveRunQueue (Capability *cap, StgTSO *tso)
+leaveRunQueue (Capability *cap STG_UNUSED, StgTSO *tso STG_UNUSED)
 {
     // XXX implement me
 }
@@ -233 +277 @@
 {
     ASSERT(tso->_link == END_TSO_QUEUE);
     if (blocked_queue_hd == END_TSO_QUEUE) {
-        blocked_queue_hd = tso;
+       blocked_queue_hd = tso;
     } else {
-        setTSOLink(&MainCapability, blocked_queue_tl, tso);
+       setTSOLink(&MainCapability, blocked_queue_tl, tso);
     }
     blocked_queue_tl = tso;
 }
@@ -252 +296 @@
 INLINE_HEADER rtsBool
 emptyRunQueue(Capability *cap)
 {
-    return emptyQueue(cap->run_queue_hd);
+    return cap->run_count == 0;
 }
 
-/* assumes that the queue is not empty; so combine this with
- * an emptyRunQueue check! */
 INLINE_HEADER rtsBool
 singletonRunQueue(Capability *cap)
 {
-    ASSERT(!emptyRunQueue(cap));
-    return cap->run_queue_hd->_link == END_TSO_QUEUE;
+    return cap->run_count == 1;
 }
 
 INLINE_HEADER void
 truncateRunQueue(Capability *cap)
 {
-    cap->run_queue_hd = END_TSO_QUEUE;
-    cap->run_queue_tl = END_TSO_QUEUE;
+    cap->promoted_run_queue_hd = END_TSO_QUEUE;
+    // XXX leak
+    cap->run_rbtree = cap->run_active = rbCreateNode(cap, END_TSO_QUEUE);
+    cap->run_count = 0;
 }
 
 #if !defined(THREADED_RTS)

rts/StgMiscClosures.cmm

@@ -546 +546 @@
 
 CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE);
 
+INFO_TABLE_CONSTR(stg_RB_NULL,0,0,0,CONSTR_NOCAF_STATIC,"RB_NULL","RB_NULL")
+{ foreign "C" barf("RB_NULL object entered!") never returns; }
+
+CLOSURE(stg_RB_NULL_closure,stg_RB_NULL);
+
 /* ----------------------------------------------------------------------------
    Arrays
 

rts/Threads.c

@@ -113 +113 @@
     tso->trec = NO_TREC;
 
     tso->ss_tickets = DEFAULT_TICKETS;
+    tso->ss_pass = cap->ss_pass;
 
 #ifdef PROFILING
     tso->prof.cccs = CCS_MAIN;
@@ -844 +845 @@
   for (i = 0; i < n_capabilities; i++) {
       cap = &capabilities[i];
       debugBelch("threads on capability %d:\n", cap->no);
+      /*
       for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
           printThreadStatus(t);
       }
+      */
   }
 
   debugBelch("other threads:\n");

rts/sm/Sanity.c

@@ -787 +787 @@
 }
 
 void
-checkRunQueue(Capability *cap)
+checkRunQueue(Capability *cap STG_UNUSED)
 {
+    /*
     StgTSO *prev, *tso;
     prev = END_TSO_QUEUE;
     for (tso = cap->run_queue_hd; tso != END_TSO_QUEUE; 
@@ -797 +798 @@
         ASSERT(tso->block_info.prev == prev);
     }
     ASSERT(cap->run_queue_tl == prev);
+    */
 }
 
 /* -----------------------------------------------------------------------------