Eval statistics.

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"])))

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"

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 ()

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
 

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

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