parallel execution (#305): allow in tests

Pinafore/pinafore-app/app/main/Run.hs

@@ -9,36 +9,36 @@ import Shapes
 import System.Environment
 
 runFiles :: Foldable t => (StorageModelOptions, ModuleOptions) -> Bool -> t (FilePath, [String]) -> IO ()
-runFiles (smopts, modopts) fNoRun scripts = do
-    setupExecution defaultExecutionOptions
+runFiles (smopts, modopts) fNoRun scripts =
+    runWithOptions defaultExecutionOptions $
     runLifecycle $
-        runView $
-        for_ scripts $ \(fpath, iiScriptArguments) -> do
-            let
-                iiScriptName = fpath
-                iiStdIn = stdinTextSource
-                iiStdOut = stdoutTextSink
-                iiStdErr = stderrTextSink
-                iiDefaultStorageModel = standardStorageModel smopts
-            iiEnvironment <- liftIO getEnvironment
-            let ?library = standardLibraryContext MkInvocationInfo {..} modopts
-            action <- qInterpretFile fpath
-            if fNoRun
-                then return ()
-                else action
+    runView $
+    for_ scripts $ \(fpath, iiScriptArguments) -> do
+        let
+            iiScriptName = fpath
+            iiStdIn = stdinTextSource
+            iiStdOut = stdoutTextSink
+            iiStdErr = stderrTextSink
+            iiDefaultStorageModel = standardStorageModel smopts
+        iiEnvironment <- liftIO getEnvironment
+        let ?library = standardLibraryContext MkInvocationInfo {..} modopts
+        action <- qInterpretFile fpath
+        if fNoRun
+            then return ()
+            else action
 
 runInteractive :: (StorageModelOptions, ModuleOptions) -> IO ()
-runInteractive (smopts, modopts) = do
-    setupExecution defaultExecutionOptions
+runInteractive (smopts, modopts) =
+    runWithOptions defaultExecutionOptions $
     runLifecycle $
-        runView $ do
-            let
-                iiScriptName = ""
-                iiScriptArguments = []
-                iiStdIn = stdinTextSource
-                iiStdOut = stdoutTextSink
-                iiStdErr = stderrTextSink
-                iiDefaultStorageModel = standardStorageModel smopts
-            iiEnvironment <- liftIO getEnvironment
-            let ?library = standardLibraryContext MkInvocationInfo {..} modopts
-            qInteract
+    runView $ do
+        let
+            iiScriptName = ""
+            iiScriptArguments = []
+            iiStdIn = stdinTextSource
+            iiStdOut = stdoutTextSink
+            iiStdErr = stderrTextSink
+            iiDefaultStorageModel = standardStorageModel smopts
+        iiEnvironment <- liftIO getEnvironment
+        let ?library = standardLibraryContext MkInvocationInfo {..} modopts
+        qInteract

Pinafore/pinafore-app/benchmark/Main.hs

@@ -6,6 +6,7 @@ import Changes.Core
 import Criterion.Main
 import Paths_pinafore_lib_script
 import Pinafore.Libs
+import Pinafore.Main
 import Pinafore.Test.Internal
 import Shapes
 
@@ -148,4 +149,4 @@ benchFiles =
         ]
 
 main :: IO ()
-main = defaultMain [benchHashes, benchScripts, benchUpdates, benchFiles]
+main = runWithOptions defaultExecutionOptions $ defaultMain [benchHashes, benchScripts, benchUpdates, benchFiles]

Pinafore/pinafore-language/lib/Pinafore/Main.hs

@@ -1,8 +1,9 @@
 module Pinafore.Main
-    ( ProcessorCount(..)
+    ( processorCountRef
+    , ProcessorCount(..)
     , ExecutionOptions(..)
     , defaultExecutionOptions
-    , setupExecution
+    , RunWithOptions(..)
     , ModuleOptions(..)
     , InvocationInfo(..)
     , standardLibraryContext
@@ -25,29 +26,44 @@ import Pinafore.Language.Type
 import Pinafore.Storage
 import System.FilePath
 
+class RunWithOptions a where
+    runWithOptions :: a -> IO --> IO
+
+instance RunWithOptions () where
+    runWithOptions () = id
+
+instance RunWithOptions a => RunWithOptions (Maybe a) where
+    runWithOptions Nothing = id
+    runWithOptions (Just a) = runWithOptions a
+
+processorCountRef :: Ref IO Int
+processorCountRef = MkRef getNumCapabilities setNumCapabilities
+
 data ProcessorCount
     = SpecificProcessorCount Int
     | AllProcessorCount
 
+instance RunWithOptions ProcessorCount where
+    runWithOptions pc mr = do
+        nc <-
+            case pc of
+                AllProcessorCount -> getNumProcessors
+                SpecificProcessorCount i -> return i
+        refPutRestore processorCountRef nc mr
+
 data ExecutionOptions = MkExecutionOptions
     { eoProcessorCount :: Maybe ProcessorCount
     }
 
+instance RunWithOptions ExecutionOptions where
+    runWithOptions MkExecutionOptions {..} = runWithOptions eoProcessorCount
+
 defaultProcessorCountINTERNAL :: Maybe ProcessorCount
 defaultProcessorCountINTERNAL = Nothing
 
 defaultExecutionOptions :: ExecutionOptions
 defaultExecutionOptions = MkExecutionOptions {eoProcessorCount = defaultProcessorCountINTERNAL}
 
-setupExecution :: ExecutionOptions -> IO ()
-setupExecution MkExecutionOptions {..} = do
-    for_ eoProcessorCount $ \case
-        SpecificProcessorCount i -> setNumCapabilities i
-        AllProcessorCount -> do
-            np <- getNumProcessors
-            -- use all processors
-            setNumCapabilities np
-
 data StorageModelOptions = MkStorageModelOptions
     { smoCache :: Bool
     , smoDataDir :: FilePath

Pinafore/pinafore-language/lib/Pinafore/Test.hs

@@ -95,8 +95,8 @@ instance MonadUnliftIO Tester where
     liftIOWithUnlift call = MkTester $ liftIOWithUnlift $ \unlift -> call $ unlift . unTester
 
 runTester :: TesterOptions -> Tester () -> IO ()
-runTester MkTesterOptions {..} (MkTester ta) = do
-    setupExecution tstExecutionOptions
+runTester MkTesterOptions {..} (MkTester ta) =
+    runWithOptions tstExecutionOptions $
     runLifecycle $ do
         (ii, getTableState) <- makeTestInvocationInfo tstOutput
         let library = mkLibraryContext ii mempty

Pinafore/pinafore-language/test/Test/Entity.hs

@@ -248,11 +248,15 @@ testEntity =
               , tModify (ignoreTestBecause "slow") $
                 tGroup
                     "issue-304"
-                    [ testExpectSuccess $
+                    [ tParallel $
+                      testExpectSuccess $
+                      scriptAsync 32 $
                       scriptRepeat
                           1000000
                           "do r <- newMem.WholeModel; r := [10,20,30]; r := [10,15,20,30];  l <- get r; testeqval [10,15,20,30] l; end"
-                    , testExpectSuccess $
+                    , tParallel $
+                      testExpectSuccess $
+                      scriptAsync 32 $
                       scriptRepeat
                           1000000
                           "do r <- newMem.ListModel; r := [10,20,30]; ir <- item.ListModel False 1 r; delete ir; ir := 15; l <- get r; testeqval [10,15,20,30] l; end"

Pinafore/pinafore-language/test/Test/RunScript.hs

@@ -13,8 +13,9 @@ module Test.RunScript
     , testOpenUHStore
     , tModule
     , tLibrary
+    , tParallel
     , scriptRepeat
-    , scriptParallel
+    , scriptAsync
     , runScriptTestTree
     , testExpression
     , ScriptExpectation(..)
@@ -26,13 +27,15 @@ module Test.RunScript
     ) where
 
 import Data.Shim
+import Pinafore.Main
 import Pinafore.Test.Internal
 import Shapes
 import Shapes.Test
 import Shapes.Test.Context
 
 data ScriptContext = MkScriptContext
-    { scLoadModule :: LoadModule
+    { scTesterOptions :: TesterOptions
+    , scLoadModule :: LoadModule
     , scPrefix :: Text
     }
 
@@ -77,18 +80,26 @@ tModule name script =
             then Just script
             else Nothing
 
+tParallel :: ScriptTestTree -> ScriptTestTree
+tParallel =
+    tContext $ \sc -> let
+        topts = scTesterOptions sc
+        eopts = tstExecutionOptions topts
+        in sc {scTesterOptions = topts {tstExecutionOptions = eopts {eoProcessorCount = Just AllProcessorCount}}}
+
 tLibrary :: LibraryModule () -> ScriptTestTree -> ScriptTestTree
 tLibrary libm = tLoadModule $ libraryLoadModule () [libm]
 
 scriptRepeat :: Int -> Text -> Text
 scriptRepeat i script = "for_ (range 1 " <> showText i <> ") $ fn _ => " <> script
 
-scriptParallel :: Int -> Text -> Text
-scriptParallel i script = scriptRepeat i $ "map.Action (fn _ => ()) $ async.Task. $ " <> script
+scriptAsync :: Int -> Text -> Text
+scriptAsync i script = scriptRepeat i $ "map.Action (fn _ => ()) $ async.Task. $ " <> script
 
 runScriptTestTree :: ScriptTestTree -> TestTree
 runScriptTestTree =
     runContextTestTree $ let
+        scTesterOptions = defaultTester
         scLoadModule = mempty
         scPrefix = mempty
         in MkScriptContext {..}
@@ -103,7 +114,7 @@ testExpression name script call =
     MkContextTestTree $ \MkScriptContext {..} ->
         testTree (unpack name) $ let
             fullscript = scPrefix <> script
-            in runTester defaultTester $
+            in runTester scTesterOptions $
                testerLoad scLoadModule $ do call $ testerLiftInterpreter $ parseValueUnify fullscript
 
 testScript :: Text -> Text -> (Tester (Action ()) -> Tester ()) -> ScriptTestTree