Only shuffle 20% of the time

io-sim/src/Control/Monad/IOSim/Internal.hs

@@ -83,6 +83,7 @@ import           Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent),
                      Trace (SimPORTrace))
 import           Control.Monad.IOSim.Types (SimEvent)
 import System.Random (StdGen, randomR, split)
+import Data.Bifunctor (first)
 
 --
 -- Simulation interpreter
@@ -855,31 +856,51 @@ unblockThreads !onlySTM !wakeup !simstate@SimState {runqueue, threads, stdGen} =
     (unblocked, simstate {
                   runqueue = Deque.fromList (shuffledRunqueue ++ rest),
                   threads  = threads',
-                  stdGen   = stdGen''
+                  stdGen   = stdGen'''
                 })
   where
-    !(shuffledRunqueue, stdGen'') = fisherYatesShuffle stdGen' toShuffle
-    !((toShuffle, rest), stdGen') =
-      let runqueueList = Deque.toList $ runqueue <> Deque.fromList unblocked
-          runqueueListLength = max 1 (length runqueueList)
-          (ix, newGen) = randomR (0, runqueueListLength `div` 2) stdGen
-       in (splitAt ix runqueueList, newGen)
     -- can only unblock if the thread exists and is blocked (not running)
-    !unblocked = [ tid
+    !timerUnblocked = [ tid
                  | tid <- wakeup
                  , case Map.lookup tid threads of
-                    Just Thread { threadStatus = ThreadBlocked BlockedOnSTM }
-                      -> True
                     Just Thread { threadStatus = ThreadBlocked _ }
                       -> not onlySTM
                     _ -> False
                  ]
+
+    !stmUnblocked = [ tid
+                 | tid <- wakeup
+                 , case Map.lookup tid threads of
+                    Just Thread { threadStatus = ThreadBlocked BlockedOnSTM }
+                      -> True
+                    _ -> False
+                 ]
+
+    !unblocked = timerUnblocked ++ stmUnblocked
+
     -- and in which case we mark them as now running
     !threads'  = List.foldl'
                    (flip (Map.adjust (\t -> t { threadStatus = ThreadRunning })))
                    threads
                    unblocked
 
+    -- Shuffle only 1/5th of the time
+    !(shouldShuffle, stdGen') =
+      first (== 0) $ randomR (0 :: Int, 5) stdGen
+
+    -- Only shuffle at most half of the total runqueue
+    !((toShuffle, rest), stdGen'')
+      | shouldShuffle =
+        let runqueueList = Deque.toList $ runqueue <> Deque.fromList unblocked
+            runqueueListLength = max 1 (length runqueueList)
+            (ix, newGen) = randomR (0, runqueueListLength `div` 2) stdGen'
+         in (splitAt ix runqueueList, newGen)
+      | otherwise = (([], Deque.toList $ runqueue <> Deque.fromList unblocked), stdGen')
+
+    !(shuffledRunqueue, stdGen''') = case toShuffle of
+        [] -> ([], stdGen'')
+        _  -> fisherYatesShuffle stdGen'' toShuffle
+
     -- Fisher-Yates shuffle implementation
     fisherYatesShuffle :: StdGen -> [a] -> ([a], StdGen)
     fisherYatesShuffle gen [] = ([], gen)