diff --git a/Pinafore/pinafore-app/app/main/Run.hs b/Pinafore/pinafore-app/app/main/Run.hs index 377a30a04..94a632bca 100644 --- a/Pinafore/pinafore-app/app/main/Run.hs +++ b/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 diff --git a/Pinafore/pinafore-app/benchmark/Main.hs b/Pinafore/pinafore-app/benchmark/Main.hs index 837f67be9..023f91b6b 100644 --- a/Pinafore/pinafore-app/benchmark/Main.hs +++ b/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] diff --git a/Pinafore/pinafore-language/lib/Pinafore/Main.hs b/Pinafore/pinafore-language/lib/Pinafore/Main.hs index c8b6186de..4757579d7 100644 --- a/Pinafore/pinafore-language/lib/Pinafore/Main.hs +++ b/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 diff --git a/Pinafore/pinafore-language/lib/Pinafore/Test.hs b/Pinafore/pinafore-language/lib/Pinafore/Test.hs index a1bfe0c06..a3d3eef40 100644 --- a/Pinafore/pinafore-language/lib/Pinafore/Test.hs +++ b/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 diff --git a/Pinafore/pinafore-language/test/Test/Entity.hs b/Pinafore/pinafore-language/test/Test/Entity.hs index 25d8a5d68..730b386d4 100644 --- a/Pinafore/pinafore-language/test/Test/Entity.hs +++ b/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" diff --git a/Pinafore/pinafore-language/test/Test/RunScript.hs b/Pinafore/pinafore-language/test/Test/RunScript.hs index a93789b7a..198b02087 100644 --- a/Pinafore/pinafore-language/test/Test/RunScript.hs +++ b/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 diff --git a/external/monadology b/external/monadology index 08bc53f3e..c5b3deb5f 160000 --- a/external/monadology +++ b/external/monadology @@ -1 +1 @@ -Subproject commit 08bc53f3ef6533f7e6ad70b847bb809bda87e62c +Subproject commit c5b3deb5f5d3828cd03e4b4c8cd1df404d03e5ef