[commit: ghc] master: STM: Only wake up once (a23661d)

[Simon Marlow]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/a23661d242e8dd55007c4aee8a053f35de7705bd

>---------------------------------------------------------------

commit a23661d242e8dd55007c4aee8a053f35de7705bd
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Mon Jan 28 11:15:08 2013 -0500

    STM: Only wake up once
    
    Previously, threads blocked on an STM retry would be sent a wakeup
    message each time an unpark was requested. This could result in the
    accumulation of a large number of wake-up messages, which would slow
    wake-up once the sleeping thread is finally scheduled.
    
    Here, we introduce a new closure type, STM_AWOKEN, which marks a TSO
    which has been sent a wake-up message, allowing us to send only one
    wakeup.

>---------------------------------------------------------------

 includes/Cmm.h              |    1 +
 includes/rts/storage/TSO.h  |    4 +++-
 includes/stg/MiscClosures.h |    2 ++
 rts/STM.c                   |   16 +++++++++++-----
 rts/StgMiscClosures.cmm     |   12 ++++++++++++
 5 files changed, 29 insertions(+), 6 deletions(-)

diff --git a/includes/Cmm.h b/includes/Cmm.h
index 5ef6c2d..41e7b89 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -744,6 +744,7 @@
 
 #define NO_TREC                   stg_NO_TREC_closure
 #define END_TSO_QUEUE             stg_END_TSO_QUEUE_closure
+#define STM_AWOKEN                stg_STM_AWOKEN_closure
 #define END_INVARIANT_CHECK_QUEUE stg_END_INVARIANT_CHECK_QUEUE_closure
 
 #define recordMutableCap(p, gen)                                        \
diff --git a/includes/rts/storage/TSO.h b/includes/rts/storage/TSO.h
index 82f5a75..e9c2655 100644
--- a/includes/rts/storage/TSO.h
+++ b/includes/rts/storage/TSO.h
@@ -218,7 +218,8 @@ void dirty_STACK (Capability *cap, StgStack *stack);
 	
         BlockedOnMVar          the MVAR             the MVAR's queue
 
-	BlockedOnSTM           END_TSO_QUEUE        STM wait queue(s)
+        BlockedOnSTM           END_TSO_QUEUE        STM wait queue(s)
+        BlockedOnSTM           STM_AWOKEN           run queue
 	
         BlockedOnMsgThrowTo    MessageThrowTo *     TSO->blocked_exception
 
@@ -252,5 +253,6 @@ void dirty_STACK (Capability *cap, StgStack *stack);
 
 /* 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 STM_AWOKEN     ((StgTSO *)(void*)&stg_STM_AWOKEN_closure)
 
 #endif /* RTS_STORAGE_TSO_H */
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 61e6b09..0eccfbf 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -114,6 +114,7 @@ RTS_ENTRY(stg_MUT_ARR_PTRS_FROZEN0);
 RTS_ENTRY(stg_MUT_VAR_CLEAN);
 RTS_ENTRY(stg_MUT_VAR_DIRTY);
 RTS_ENTRY(stg_END_TSO_QUEUE);
+RTS_ENTRY(stg_STM_AWOKEN);
 RTS_ENTRY(stg_MSG_TRY_WAKEUP);
 RTS_ENTRY(stg_MSG_THROWTO);
 RTS_ENTRY(stg_MSG_BLACKHOLE);
@@ -142,6 +143,7 @@ RTS_ENTRY(stg_NO_TREC);
 /* closures */
 
 RTS_CLOSURE(stg_END_TSO_QUEUE_closure);
+RTS_CLOSURE(stg_STM_AWOKEN_closure);
 RTS_CLOSURE(stg_NO_FINALIZER_closure);
 RTS_CLOSURE(stg_dummy_ret_closure);
 RTS_CLOSURE(stg_forceIO_closure);
diff --git a/rts/STM.c b/rts/STM.c
index 62ced25..7400d57 100644
--- a/rts/STM.c
+++ b/rts/STM.c
@@ -380,13 +380,19 @@ static void unpark_tso(Capability *cap, StgTSO *tso) {
 
     // Unblocking a TSO from BlockedOnSTM is done under the TSO lock,
     // to avoid multiple CPUs unblocking the same TSO, and also to
-    // synchronise with throwTo().
+    // synchronise with throwTo(). The first time the TSO is unblocked
+    // we mark this fact by setting block_info.closure == STM_AWOKEN.
+    // This way we can avoid sending further wakeup messages in the
+    // future.
     lockTSO(tso);
-    if (tso -> why_blocked == BlockedOnSTM) {
-	TRACE("unpark_tso on tso=%p", tso);
-        tryWakeupThread(cap,tso);
+    if (tso->why_blocked == BlockedOnSTM && tso->block_info.closure == STM_AWOKEN) {
+      TRACE("unpark_tso already woken up tso=%p", tso);
+    } else if (tso -> why_blocked == BlockedOnSTM) {
+      TRACE("unpark_tso on tso=%p", tso);
+      tso->block_info.closure = STM_AWOKEN;
+      tryWakeupThread(cap,tso);
     } else {
-	TRACE("spurious unpark_tso on tso=%p", tso);
+      TRACE("spurious unpark_tso on tso=%p", tso);
     }
     unlockTSO(tso);
 }
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 4341013..28a41ad 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -547,6 +547,18 @@ INFO_TABLE_CONSTR(stg_END_TSO_QUEUE,0,0,0,CONSTR_NOCAF_STATIC,"END_TSO_QUEUE","E
 CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE);
 
 /* ----------------------------------------------------------------------------
+   STM_AWOKEN
+
+   This is a static nullary constructor (like []) that we use to mark a
+   thread waiting on an STM wakeup
+   ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_STM_AWOKEN,0,0,0,CONSTR_NOCAF_STATIC,"STM_AWOKEN","STM_AWOKEN")
+{ foreign "C" barf("STM_AWOKEN object entered!") never returns; }
+
+CLOSURE(stg_STM_AWOKEN_closure,stg_STM_AWOKEN);
+
+/* ----------------------------------------------------------------------------
    Arrays
 
    These come in two basic flavours: arrays of data (StgArrWords) and arrays of