diff --git a/app/PerfTestApp/PerfFTL.hs b/app/PerfTestApp/PerfFTL.hs index f1f1d79..e3ffcb6 100644 --- a/app/PerfTestApp/PerfFTL.hs +++ b/app/PerfTestApp/PerfFTL.hs @@ -16,6 +16,8 @@ import PerfTypes import Hydra.FTLI () +-- TODO: join this with the FT approach in the MeteorCounter app + getRandomMeteor :: FTL.RandomL m => m Meteor getRandomMeteor = Meteor <$> FTL.getRandomInt (1, 100) diff --git a/app/PerfTestApp2/Church.hs b/app/PerfTestApp2/Church.hs new file mode 100644 index 0000000..16ed577 --- /dev/null +++ b/app/PerfTestApp2/Church.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Church where + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Hydra.Prelude + +import qualified Hydra.ChurchL as L +import qualified Hydra.Domain as D +import qualified Hydra.Runtime as R + + +flow :: IORef Int -> L.AppL () +flow ref = L.scenario $ do + val' <- L.evalIO $ readIORef ref + val <- L.getRandomInt (1, 100) + L.evalIO $ writeIORef ref $ val' + val + + +scenario :: Int -> R.AppRuntime -> IO () +scenario ops appRt = do + ref <- newIORef 0 + void $ R.startApp appRt (replicateM_ ops $ flow ref) + val <- readIORef ref + print val diff --git a/app/PerfTestApp2/FTL.hs b/app/PerfTestApp2/FTL.hs new file mode 100644 index 0000000..8714f11 --- /dev/null +++ b/app/PerfTestApp2/FTL.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module FTL where + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Hydra.Prelude + +import qualified Hydra.Domain as D +import qualified Hydra.FTL as FTL +import qualified Hydra.Runtime as R + +import Hydra.FTLI () + + +flow :: (MonadIO m, FTL.LangL m) => IORef Int -> m () +flow ref = do + val' <- liftIO $ readIORef ref + val <- FTL.getRandomInt (1, 100) + liftIO $ writeIORef ref $ val' + val + +scenario :: Int -> R.CoreRuntime -> IO () +scenario ops coreRt = do + ref <- newIORef 0 + void $ runReaderT (replicateM_ ops $ flow ref) coreRt + val <- readIORef ref + print val diff --git a/app/PerfTestApp2/Free.hs b/app/PerfTestApp2/Free.hs new file mode 100644 index 0000000..736921e --- /dev/null +++ b/app/PerfTestApp2/Free.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Free where + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Hydra.Prelude + +import qualified Hydra.Domain as D +import qualified Hydra.Language as L +import qualified Hydra.Runtime as R + + +flow :: IORef Int -> L.AppL () +flow ref = L.scenario $ do + val' <- L.evalIO $ readIORef ref + val <- L.getRandomInt (1, 100) + L.evalIO $ writeIORef ref $ val' + val + + +scenario :: Int -> R.AppRuntime -> IO () +scenario ops appRt = do + ref <- newIORef 0 + void $ R.startApp appRt (replicateM_ ops $ flow ref) + val <- readIORef ref + print val diff --git a/app/PerfTestApp2/IO.hs b/app/PerfTestApp2/IO.hs new file mode 100644 index 0000000..12bd012 --- /dev/null +++ b/app/PerfTestApp2/IO.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module IO where + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Hydra.Prelude + +import System.Entropy +import System.Random hiding (next) + +flow :: IORef Int -> IO () +flow ref = do + val' <- readIORef ref + val <- randomRIO (1, 100) + writeIORef ref $ val' + val + +scenario :: Int -> IO () +scenario ops = do + ref <- newIORef 0 + void $ replicateM_ ops $ flow ref + val <- readIORef ref + print val diff --git a/app/PerfTestApp2/Main.hs b/app/PerfTestApp2/Main.hs new file mode 100644 index 0000000..99ce37d --- /dev/null +++ b/app/PerfTestApp2/Main.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Hydra.Prelude + +import qualified Free as Free +import qualified FTL as FTL +import qualified Church as Church +import qualified IO as IO +import qualified Hydra.Domain as D +import qualified Hydra.Runtime as R +import qualified Hydra.Framework.RLens as RLens + +data Method = FT | FreeM | ChurchM | IO + deriving (Show, Read, Eq, Ord) + +data Config = Config + { method :: Method + , iterations :: Int + } + deriving (Show, Read, Eq, Ord) + +loggerCfg :: D.LoggerConfig +loggerCfg = D.LoggerConfig + { D._format = "$prio $loggername: $msg" + , D._level = D.Debug + , D._logFilePath = "" + , D._logToConsole = True + , D._logToFile = False + } + +main :: IO () +main = do + cfgStr <- readFile "perf_test_app2.cfg" + let cfg :: Config = read $ toString cfgStr + + putStrLn @String $ "Method: " <> show (method cfg) <> ", iterations: " <> show (iterations cfg) + + let ops = iterations cfg + + R.withAppRuntime Nothing $ \appRt -> do + when (method cfg == FT) + $ FTL.scenario ops $ appRt ^. RLens.coreRuntime + + when (method cfg == FreeM) + $ Free.scenario ops appRt + + when (method cfg == ChurchM) + $ Church.scenario ops appRt + + when (method cfg == IO) + $ IO.scenario ops diff --git a/package.yaml b/package.yaml index 7e88acf..1a5ebbd 100644 --- a/package.yaml +++ b/package.yaml @@ -135,6 +135,18 @@ executables: dependencies: - Hydra + perf-test-app2: + main: Main.hs + source-dirs: app/PerfTestApp2 + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall + - -O2 + dependencies: + - Hydra + meteor-counter-app: main: Main.hs source-dirs: app/MeteorCounter diff --git a/perf_test_app2.cfg b/perf_test_app2.cfg new file mode 100644 index 0000000..b6a74b8 --- /dev/null +++ b/perf_test_app2.cfg @@ -0,0 +1,4 @@ +Config + { method = FreeM + , iterations = 10000 + } diff --git a/src/Hydra/Core/Lang/ChurchL.hs b/src/Hydra/Core/Lang/ChurchL.hs index bb5556b..c6bf599 100644 --- a/src/Hydra/Core/Lang/ChurchL.hs +++ b/src/Hydra/Core/Lang/ChurchL.hs @@ -37,11 +37,8 @@ makeFunctorInstance ''LangF type LangL = F LangF --- class IOL m where --- evalIO :: IO a -> m a --- --- instance IOL LangL where --- evalIO io = liftF $ EvalIO io id +instance C.IOL LangL where + evalIO io = liftFC $ EvalIO io id evalStateAtomically' :: CL.StateL a -> LangL a evalStateAtomically' action = liftFC $ EvalStateAtomically action id diff --git a/src/Hydra/Core/Lang/Class.hs b/src/Hydra/Core/Lang/Class.hs index 7cdcab4..54406f9 100644 --- a/src/Hydra/Core/Lang/Class.hs +++ b/src/Hydra/Core/Lang/Class.hs @@ -21,3 +21,8 @@ class (C.Logger l, C.Random r, C.ControlFlow cf, C.State' s, Monad m) evalStateAtomically :: s a -> m a evalControlFlow :: cf a -> m a -- todo: io + + +-- TODO: this should not be here. +class IOL m where + evalIO :: IO a -> m a diff --git a/src/Hydra/Core/Lang/Language.hs b/src/Hydra/Core/Lang/Language.hs index 01ea321..ccdee11 100644 --- a/src/Hydra/Core/Lang/Language.hs +++ b/src/Hydra/Core/Lang/Language.hs @@ -62,10 +62,7 @@ instance Functor LangF where type LangL = Free LangF -class IOL m where - evalIO :: IO a -> m a - -instance IOL LangL where +instance C.IOL LangL where evalIO io = liftF $ EvalIO io id evalStateAtomically' :: L.StateL a -> LangL a diff --git a/src/Hydra/Framework/App/ChurchL.hs b/src/Hydra/Framework/App/ChurchL.hs index f207c18..9e60652 100644 --- a/src/Hydra/Framework/App/ChurchL.hs +++ b/src/Hydra/Framework/App/ChurchL.hs @@ -48,6 +48,9 @@ fork = evalProcess' . L.forkProcess' process :: L.LangL a -> AppL () process action = void $ fork action +instance C.IOL AppL where + evalIO = evalLang' . C.evalIO + instance L.StateIO AppL where newVarIO = evalLang' . L.newVarIO readVarIO = evalLang' . L.readVarIO diff --git a/src/Hydra/Framework/App/Language.hs b/src/Hydra/Framework/App/Language.hs index 3953fba..af38ac2 100644 --- a/src/Hydra/Framework/App/Language.hs +++ b/src/Hydra/Framework/App/Language.hs @@ -100,8 +100,8 @@ fork = evalProcess' . L.forkProcess' process :: L.LangL a -> AppL () process action = void $ fork action -instance L.IOL AppL where - evalIO = evalLang' . L.evalIO +instance C.IOL AppL where + evalIO = evalLang' . C.evalIO instance L.StateIO AppL where newVarIO = evalLang' . L.newVarIO