From: Simon Marlow <marlowsd@gmail.com>
Date: Thu, 6 Nov 2008 09:54:19 +0000 (+0000)
Subject: add GHC.Conc.runSparks (required by GHC patch "Run sparks in batches")
X-Git-Tag: 2009-06-25~100
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=fd3cb3407135648330c8ae7e8790e3a6e0604f63;p=ghc-base.git

add GHC.Conc.runSparks (required by GHC patch "Run sparks in batches")
---

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 96e00e0..5379292 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -37,6 +37,7 @@ module GHC.Conc
         , throwTo       -- :: ThreadId -> Exception -> IO ()
         , par           -- :: a -> b -> b
         , pseq          -- :: a -> b -> b
+        , runSparks
         , yield         -- :: IO ()
         , labelThread   -- :: ThreadId -> String -> IO ()
 
@@ -363,6 +364,13 @@ pseq  x y = x `seq` lazy y
 par :: a -> b -> b
 par  x y = case (par# x) of { _ -> lazy y }
 
+-- | Internal function used by the RTS to run sparks.
+runSparks :: IO ()
+runSparks = IO loop
+  where loop s = case getSpark# s of
+                   (# s', n, p #) ->
+                      if n ==# 0# then (# s', () #)
+                                  else p `seq` loop s'
 
 data BlockReason
   = BlockedOnMVar