Experiment with parallel grammar checks

Introduced the function

	parallelCheck :: [Check a] -> Check [a]

that runs independent checks in parallel, potentially allowing faster grammar
compilation on multi-core computers, if you run gf with +RTS -N.

However, on my dual core laptop, this seems to slow down compilation somewhat
even though CPU utilization goes up as high as 170% at times.
(This is with GF compiled with GHC 7.0.4.)

2 files changed, 24 insertions, 8 deletions

diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index f7af80327..5988a20c8 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -56,11 +56,9 @@ checkModule opts mos mo@(m,mi) = do
   infoss <- checkErr $ topoSortJments2 mo
   foldM updateCheckInfos mo infoss
   where
-    updateCheckInfos mo0 = commitCheck . foldM updateCheckInfo mo0 
-
-    updateCheckInfo mo@(m,mi) (i,info) = do
-      info <- accumulateError (checkInfo opts mos mo i) info
-      return (m,mi{jments=updateTree (i,info) (jments mi)})
+    updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
+      where check (i,info) = fmap ((,) i) (checkInfo opts mos mo i info)
+    update mo@(m,mi) (i,info) = (m,mi{jments=updateTree (i,info) (jments mi)})
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs
index 339e63a2b..b998f7508 100644
--- a/src/compiler/GF/Infra/CheckM.hs
+++ b/src/compiler/GF/Infra/CheckM.hs
@@ -16,7 +16,7 @@ module GF.Infra.CheckM
           (Check, CheckResult, Message, runCheck,
 	   checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
 	   checkErr, checkIn, checkMap, checkMapRecover,
-           accumulateError, commitCheck
+           parallelCheck, accumulateError, commitCheck,
 	  ) where
 
 import GF.Data.Operations
@@ -26,6 +26,8 @@ import GF.Grammar.Printer
 
 import qualified Data.Map as Map
 import Text.PrettyPrint
+import Control.Parallel.Strategies(parList,rseq,using)
+import Control.Monad(liftM)
 
 type Message = Doc
 type Error   = Message
@@ -38,6 +40,8 @@ data CheckResult a = Fail Error | Success a
 newtype Check a
   = Check {unCheck :: {-Context ->-} Accumulate NonFatal (CheckResult a)}
 
+instance Functor Check where fmap = liftM
+
 instance Monad Check where
   return x = Check $ \{-ctxt-} ws -> (ws,Success x)
   f >>= g  = Check $ \{-ctxt-} ws ->
@@ -98,14 +102,28 @@ runCheck c =
     bad (es,ws) = Bad (render $ list ws $$ list es)
     list = vcat . reverse
 
+parallelCheck :: [Check a] -> Check [a]
+parallelCheck cs =
+  Check $ \ {-ctxt-} (es0,ws0) ->
+  let os = [unCheck c {-[]-} ([],[])|c<-cs] `using` parList rseq
+      (msgs1,crs) = unzip os
+      (ess,wss) = unzip msgs1
+      rs = [r | Success r<-crs]
+      fs = [f | Fail f<-crs]
+      msgs = (concat ess++es0,concat wss++ws0)
+  in if null fs
+     then (msgs,Success rs)
+     else (msgs,Fail (vcat $ reverse fs))
+
 checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
 checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v
                                              return (k,v)) (Map.toList map)
                     return (Map.fromAscList xs)
 
 checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
-checkMapRecover f mp = commitCheck (checkMap f' mp)
-  where f' key info = accumulateError (f key) info
+checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList
+  where f' (k,v) = fmap ((,)k) (f k v)
+
 {-
 checkMapRecover f mp = do 
   let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)