From 963a4d3380ff376470b49f1a0a28d9ef6ba18253 Mon Sep 17 00:00:00 2001 From: Andor Penzes Date: Mon, 10 Feb 2020 22:09:14 +0100 Subject: [PATCH] Eval statistics. --- grin/app/CLI/Lib.hs | 3 ++- grin/src/Pipeline/Eval.hs | 4 +-- grin/src/Pipeline/Pipeline.hs | 21 ++++++++-------- grin/src/Reducer/Base.hs | 27 +++++++++++++++++--- grin/src/Reducer/IO.hs | 4 +-- grin/src/Reducer/Pure.hs | 46 +++++++++++++++++++++++------------ 6 files changed, 70 insertions(+), 35 deletions(-) diff --git a/grin/app/CLI/Lib.hs b/grin/app/CLI/Lib.hs index cd452ddf..a4dd65f8 100644 --- a/grin/app/CLI/Lib.hs +++ b/grin/app/CLI/Lib.hs @@ -121,7 +121,8 @@ pipelineOpts = <|> flg (Pass [Sharing Compile, Sharing Optimise, Sharing RunPure]) "sharing-opt" "Compiles, optimizes and runs the sharing analysis" <|> flg (Pass [LVA Compile, CBy Compile, RunCByWithLVA]) "cby-with-lva" "Compiles the live variable and created-by analyses, then runs the created-by analysis using the LVA result" <|> flg DeadCodeElimination "dce" "Dead Code Elimination" - <|> flg PureEval "eval" "Evaluate the grin program (pure)" + <|> flg (PureEval False) "eval" "Evaluate the grin program (pure)" + <|> (PureEval <$> (option auto (mconcat [long "eval-with-statistics", help "Evaluate the grin program (pure) and render heap statistics."]))) <|> flg JITLLVM "llvm" "JIT with LLVM" <|> flg PrintAST "ast" "Print the Abstract Syntax Tree" <|> (SaveExecutable False . Abs <$> (strOption (mconcat [short 'o', long "save-elf", help "Save an executable ELF"]))) diff --git a/grin/src/Pipeline/Eval.hs b/grin/src/Pipeline/Eval.hs index c7c59a96..2c72779f 100644 --- a/grin/src/Pipeline/Eval.hs +++ b/grin/src/Pipeline/Eval.hs @@ -7,7 +7,7 @@ import Text.Megaparsec import Grin.Grin import Grin.TypeCheck import Grin.Parse -import Reducer.Base (RTVal) +import Reducer.Base (RTVal, Statistics) import qualified Reducer.IO import qualified Reducer.Pure import qualified Reducer.LLVM.JIT as LLVM @@ -22,7 +22,7 @@ data Reducer = PureReducer Reducer.Pure.EvalPlugin | IOReducer -evalProgram :: Reducer -> Program -> IO RTVal +evalProgram :: Reducer -> Program -> IO (RTVal, Maybe Statistics) evalProgram reducer program = case reducer of PureReducer evalPrimOp -> Reducer.Pure.reduceFun evalPrimOp program "grinMain" diff --git a/grin/src/Pipeline/Pipeline.hs b/grin/src/Pipeline/Pipeline.hs index 662c46f1..4d7c1e71 100644 --- a/grin/src/Pipeline/Pipeline.hs +++ b/grin/src/Pipeline/Pipeline.hs @@ -198,8 +198,8 @@ data PipelineStep | T Transformation | Pass [PipelineStep] | PrintGrinH RenderingOption (Hidden (Doc -> Doc)) - | PureEval - | PureEvalPluginH (Hidden EvalPlugin) + | PureEval Bool + | PureEvalPluginH (Hidden EvalPlugin) Bool | JITLLVM | PrintAST | SaveLLVM Path @@ -252,9 +252,9 @@ pattern DebugTransformation :: (Exp -> Exp) -> PipelineStep pattern DebugTransformation t <- DebugTransformationH (H t) where DebugTransformation t = DebugTransformationH (H t) -pattern PureEvalPlugin :: EvalPlugin -> PipelineStep -pattern PureEvalPlugin t <- PureEvalPluginH (H t) - where PureEvalPlugin t = PureEvalPluginH (H t) +pattern PureEvalPlugin :: EvalPlugin -> Bool -> PipelineStep +pattern PureEvalPlugin t b <- PureEvalPluginH (H t) b + where PureEvalPlugin t b = PureEvalPluginH (H t) b data PipelineOpts = PipelineOpts { _poOutputDir :: FilePath @@ -461,8 +461,6 @@ pipelineStep p = do T t -> transformation t Pass pass -> mapM_ pipelineStep pass PrintGrin r d -> printGrinM r d - PureEval -> pureEval (EvalPlugin evalPrimOp) - PureEvalPlugin evalPlugin -> pureEval evalPlugin JITLLVM -> jitLLVM SaveLLVM path -> saveLLVM path SaveExecutable dbg path -> saveExecutable dbg path @@ -480,6 +478,8 @@ pipelineStep p = do errors <- use psErrors pipelineLog $ unlines $ "errors:" : errors DebugPipelineState -> debugPipelineState + PureEval showStatistics -> pureEval (EvalPlugin evalPrimOp) showStatistics + PureEvalPlugin evalPlugin showStatistics -> pureEval evalPlugin showStatistics after <- use psExp let eff = if before == after then None else ExpChanged showMS :: Rational -> String @@ -660,12 +660,13 @@ statistics = do exp <- use psExp saveTransformationInfo "Statistics" $ Statistics.statistics exp -pureEval :: EvalPlugin -> PipelineM () -pureEval evalPlugin = do +pureEval :: EvalPlugin -> Bool -> PipelineM () +pureEval evalPlugin showStatistics = do e <- use psExp - val <- liftIO $ do + (val, stat) <- liftIO $ do hSetBuffering stdout NoBuffering evalProgram (PureReducer evalPlugin) e + when showStatistics $ pipelineLog $ show $ pretty stat pipelineLog $ show $ pretty val printGrinM :: RenderingOption -> (Doc -> Doc) -> PipelineM () diff --git a/grin/src/Reducer/Base.hs b/grin/src/Reducer/Base.hs index c25a6baa..528993bd 100644 --- a/grin/src/Reducer/Base.hs +++ b/grin/src/Reducer/Base.hs @@ -1,13 +1,15 @@ {-# LANGUAGE LambdaCase, TupleSections, BangPatterns #-} module Reducer.Base where +import Data.IntMap.Strict (IntMap) import Data.Map (Map) -import qualified Data.Map as Map - -import Text.PrettyPrint.ANSI.Leijen - import Grin.Grin import Grin.Pretty +import Text.PrettyPrint.ANSI.Leijen + +import qualified Data.Map as Map +import qualified Data.IntMap.Strict as IntMap + -- models cpu registers type Env = Map Name RTVal @@ -35,6 +37,23 @@ instance Pretty RTVal where RT_Loc a -> keyword "loc" <+> int a RT_Undefined -> keyword "undefined" +data Statistics + = Statistics + { storeFetched :: !(IntMap Int) + , storeUpdated :: !(IntMap Int) + } + +emptyStatistics = Statistics mempty mempty + +instance Pretty Statistics where + pretty (Statistics f u) = + vsep + [ text "Fetched:" + , indent 4 $ prettyKeyValue $ IntMap.toList $ IntMap.filter (>0) f + , text "Updated:" + , indent 4 $ prettyKeyValue $ IntMap.toList $ IntMap.filter (>0) u + ] + keyword :: String -> Doc keyword = yellow . text diff --git a/grin/src/Reducer/IO.hs b/grin/src/Reducer/IO.hs index cf0d1f47..5bd28dce 100644 --- a/grin/src/Reducer/IO.hs +++ b/grin/src/Reducer/IO.hs @@ -116,11 +116,11 @@ evalSimpleExp exts env = \case SBlock a -> evalExp exts env a x -> error $ "evalSimpleExp: " ++ show x -reduceFun :: Program -> Name -> IO RTVal +reduceFun :: Program -> Name -> IO (RTVal, Maybe Statistics) reduceFun (Program exts l) n = do store <- emptyStore1 (val, _, _) <- runRWST (evalExp exts mempty e) m store - pure val + pure (val, Nothing) where m = Map.fromList [(n,d) | d@(Def n _ _) <- l] e = case Map.lookup n m of diff --git a/grin/src/Reducer/Pure.hs b/grin/src/Reducer/Pure.hs index e5433b1e..fccfe463 100644 --- a/grin/src/Reducer/Pure.hs +++ b/grin/src/Reducer/Pure.hs @@ -26,8 +26,8 @@ prettyDebug = show . plain . pretty -- models computer memory data StoreMap = StoreMap - { storeMap :: IntMap RTVal - , storeSize :: !Int + { storeMap :: !(IntMap RTVal) + , storeSize :: !Int } emptyStore = StoreMap mempty 0 @@ -42,7 +42,7 @@ data Context = Context , ctxExternals :: [External] , ctxEvalPlugin :: EvalPlugin } -type GrinM a = ReaderT Context (StateT StoreMap IO) a +type GrinM a = ReaderT Context (StateT (StoreMap, Statistics) IO) a lookupStore :: Int -> StoreMap -> RTVal lookupStore i s = IntMap.findWithDefault (error $ printf "missing location: %d" i) i $ storeMap s @@ -71,20 +71,31 @@ evalSimpleExp env s = do evalExp (go env vars args) body SReturn v -> pure $ evalVal env v SStore v -> do - l <- gets storeSize + l <- gets (storeSize . fst) let v' = evalVal env v - modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) (s+1)) + modify' (\(StoreMap m s, Statistics f u) -> + ( StoreMap (IntMap.insert l v' m) (s+1) + , Statistics (IntMap.insert l 0 f) (IntMap.insert l 0 u) + )) pure $ RT_Loc l SFetchI n index -> case lookupEnv n env of - RT_Loc l -> gets $ (selectNodeItem index . lookupStore l) + RT_Loc l -> do + modify' (\(heap, Statistics f u) -> + (heap, Statistics (IntMap.adjust (+1) l f) u)) + gets $ (selectNodeItem index . lookupStore l . fst) x -> error $ printf "evalSimpleExp - Fetch expected location, got: %s" (prettyDebug x) -- | FetchI Name Int -- fetch node component SUpdate n v -> do let v' = evalVal env v case lookupEnv n env of - RT_Loc l -> get >>= \(StoreMap m _) -> case IntMap.member l m of - False -> error $ printf "evalSimpleExp - Update unknown location: %d" l - True -> modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) s) >> pure RT_Unit + RT_Loc l -> do + (StoreMap m _, _) <- get + case IntMap.member l m of + False -> error $ printf "evalSimpleExp - Update unknown location: %d" l + True -> do + modify' (\(StoreMap m s, Statistics f u) -> + (StoreMap (IntMap.insert l v' m) s, Statistics f (IntMap.adjust (+1) l u))) + pure RT_Unit x -> error $ printf "evalSimpleExp - Update expected location, got: %s" (prettyDebug x) SBlock a -> evalExp env a @@ -120,10 +131,13 @@ evalExp env = \case x -> error $ printf "evalExp - invalid Case dispatch value: %s" (prettyDebug x) exp -> evalSimpleExp env exp -reduceFun :: EvalPlugin -> Program -> Name -> IO RTVal -reduceFun evalPrimOp (Program exts l) n = evalStateT (runReaderT (evalExp mempty e) context) emptyStore where - context@(Context m _ _) = Context (Map.fromList [(n,d) | d@(Def n _ _) <- l]) exts evalPrimOp - e = case Map.lookup n m of - Nothing -> error $ printf "missing function: %s" n - Just (Def _ [] a) -> a - _ -> error $ printf "function %s has arguments" n +reduceFun :: EvalPlugin -> Program -> Name -> IO (RTVal, Maybe Statistics) +reduceFun evalPrimOp (Program exts l) n = do + (v, (_, s)) <- runStateT (runReaderT (evalExp mempty e) context) (emptyStore, emptyStatistics) + pure (v, Just s) + where + context@(Context m _ _) = Context (Map.fromList [(n,d) | d@(Def n _ _) <- l]) exts evalPrimOp + e = case Map.lookup n m of + Nothing -> error $ printf "missing function: %s" n + Just (Def _ [] a) -> a + _ -> error $ printf "function %s has arguments" n