module Futhark.Analysis.Metrics
( AstMetrics (..),
progMetrics,
OpMetrics (..),
seen,
inside,
MetricsM,
stmMetrics,
lambdaMetrics,
bodyMetrics,
)
where
import Control.Monad
import Control.Monad.Writer
import Data.List (tails)
import Data.Map.Strict qualified as M
import Data.Text (Text)
import Data.Text qualified as T
import Futhark.Analysis.Metrics.Type
import Futhark.IR
import Futhark.Util (showText)
class OpMetrics op where
opMetrics :: op -> MetricsM ()
instance (OpMetrics a) => OpMetrics (Maybe a) where
opMetrics :: Maybe a -> MetricsM ()
opMetrics Maybe a
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
opMetrics (Just a
x) = forall op. OpMetrics op => op -> MetricsM ()
opMetrics a
x
instance OpMetrics (NoOp rep) where
opMetrics :: NoOp rep -> MetricsM ()
opMetrics NoOp rep
NoOp = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
newtype CountMetrics = CountMetrics [([Text], Text)]
instance Semigroup CountMetrics where
CountMetrics [([Text], Text)]
x <> :: CountMetrics -> CountMetrics -> CountMetrics
<> CountMetrics [([Text], Text)]
y = [([Text], Text)] -> CountMetrics
CountMetrics forall a b. (a -> b) -> a -> b
$ [([Text], Text)]
x forall a. Semigroup a => a -> a -> a
<> [([Text], Text)]
y
instance Monoid CountMetrics where
mempty :: CountMetrics
mempty = [([Text], Text)] -> CountMetrics
CountMetrics forall a. Monoid a => a
mempty
actualMetrics :: CountMetrics -> AstMetrics
actualMetrics :: CountMetrics -> AstMetrics
actualMetrics (CountMetrics [([Text], Text)]
metrics) =
Map Text Int -> AstMetrics
AstMetrics forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Num a => a -> a -> a
(+) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b}. Num b => ([Text], Text) -> [(Text, b)]
expand [([Text], Text)]
metrics
where
expand :: ([Text], Text) -> [(Text, b)]
expand ([Text]
ctx, Text
k) =
[ (Text -> [Text] -> Text
T.intercalate Text
"/" ([Text]
ctx' forall a. [a] -> [a] -> [a]
++ [Text
k]), b
1)
| [Text]
ctx' <- forall a. [a] -> [[a]]
tails forall a b. (a -> b) -> a -> b
$ Text
"" forall a. a -> [a] -> [a]
: [Text]
ctx
]
newtype MetricsM a = MetricsM {forall a. MetricsM a -> Writer CountMetrics a
runMetricsM :: Writer CountMetrics a}
deriving
( Applicative MetricsM
forall a. a -> MetricsM a
forall a b. MetricsM a -> MetricsM b -> MetricsM b
forall a b. MetricsM a -> (a -> MetricsM b) -> MetricsM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> MetricsM a
$creturn :: forall a. a -> MetricsM a
>> :: forall a b. MetricsM a -> MetricsM b -> MetricsM b
$c>> :: forall a b. MetricsM a -> MetricsM b -> MetricsM b
>>= :: forall a b. MetricsM a -> (a -> MetricsM b) -> MetricsM b
$c>>= :: forall a b. MetricsM a -> (a -> MetricsM b) -> MetricsM b
Monad,
Functor MetricsM
forall a. a -> MetricsM a
forall a b. MetricsM a -> MetricsM b -> MetricsM a
forall a b. MetricsM a -> MetricsM b -> MetricsM b
forall a b. MetricsM (a -> b) -> MetricsM a -> MetricsM b
forall a b c.
(a -> b -> c) -> MetricsM a -> MetricsM b -> MetricsM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. MetricsM a -> MetricsM b -> MetricsM a
$c<* :: forall a b. MetricsM a -> MetricsM b -> MetricsM a
*> :: forall a b. MetricsM a -> MetricsM b -> MetricsM b
$c*> :: forall a b. MetricsM a -> MetricsM b -> MetricsM b
liftA2 :: forall a b c.
(a -> b -> c) -> MetricsM a -> MetricsM b -> MetricsM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> MetricsM a -> MetricsM b -> MetricsM c
<*> :: forall a b. MetricsM (a -> b) -> MetricsM a -> MetricsM b
$c<*> :: forall a b. MetricsM (a -> b) -> MetricsM a -> MetricsM b
pure :: forall a. a -> MetricsM a
$cpure :: forall a. a -> MetricsM a
Applicative,
forall a b. a -> MetricsM b -> MetricsM a
forall a b. (a -> b) -> MetricsM a -> MetricsM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MetricsM b -> MetricsM a
$c<$ :: forall a b. a -> MetricsM b -> MetricsM a
fmap :: forall a b. (a -> b) -> MetricsM a -> MetricsM b
$cfmap :: forall a b. (a -> b) -> MetricsM a -> MetricsM b
Functor,
MonadWriter CountMetrics
)
seen :: Text -> MetricsM ()
seen :: Text -> MetricsM ()
seen Text
k = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ [([Text], Text)] -> CountMetrics
CountMetrics [([], Text
k)]
inside :: Text -> MetricsM () -> MetricsM ()
inside :: Text -> MetricsM () -> MetricsM ()
inside Text
what MetricsM ()
m = Text -> MetricsM ()
seen Text
what forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor CountMetrics -> CountMetrics
addWhat MetricsM ()
m
where
addWhat :: CountMetrics -> CountMetrics
addWhat (CountMetrics [([Text], Text)]
metrics) =
[([Text], Text)] -> CountMetrics
CountMetrics (forall a b. (a -> b) -> [a] -> [b]
map forall {b}. ([Text], b) -> ([Text], b)
addWhat' [([Text], Text)]
metrics)
addWhat' :: ([Text], b) -> ([Text], b)
addWhat' ([Text]
ctx, b
k) = (Text
what forall a. a -> [a] -> [a]
: [Text]
ctx, b
k)
progMetrics :: (OpMetrics (Op rep)) => Prog rep -> AstMetrics
progMetrics :: forall rep. OpMetrics (Op rep) => Prog rep -> AstMetrics
progMetrics Prog rep
prog =
CountMetrics -> AstMetrics
actualMetrics forall a b. (a -> b) -> a -> b
$
forall w a. Writer w a -> w
execWriter forall a b. (a -> b) -> a -> b
$
forall a. MetricsM a -> Writer CountMetrics a
runMetricsM forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall rep. OpMetrics (Op rep) => FunDef rep -> MetricsM ()
funDefMetrics forall a b. (a -> b) -> a -> b
$ forall rep. Prog rep -> [FunDef rep]
progFuns Prog rep
prog
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall rep. OpMetrics (Op rep) => Stm rep -> MetricsM ()
stmMetrics forall a b. (a -> b) -> a -> b
$ forall rep. Prog rep -> Stms rep
progConsts Prog rep
prog
funDefMetrics :: (OpMetrics (Op rep)) => FunDef rep -> MetricsM ()
funDefMetrics :: forall rep. OpMetrics (Op rep) => FunDef rep -> MetricsM ()
funDefMetrics = forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall rep. FunDef rep -> Body rep
funDefBody
bodyMetrics :: (OpMetrics (Op rep)) => Body rep -> MetricsM ()
bodyMetrics :: forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall rep. OpMetrics (Op rep) => Stm rep -> MetricsM ()
stmMetrics forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall rep. Body rep -> Stms rep
bodyStms
stmMetrics :: (OpMetrics (Op rep)) => Stm rep -> MetricsM ()
stmMetrics :: forall rep. OpMetrics (Op rep) => Stm rep -> MetricsM ()
stmMetrics = forall rep. OpMetrics (Op rep) => Exp rep -> MetricsM ()
expMetrics forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall rep. Stm rep -> Exp rep
stmExp
expMetrics :: (OpMetrics (Op rep)) => Exp rep -> MetricsM ()
expMetrics :: forall rep. OpMetrics (Op rep) => Exp rep -> MetricsM ()
expMetrics (BasicOp BasicOp
op) =
Text -> MetricsM ()
seen Text
"BasicOp" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BasicOp -> MetricsM ()
basicOpMetrics BasicOp
op
expMetrics (Loop [(FParam rep, SubExp)]
_ ForLoop {} Body rep
body) =
Text -> MetricsM () -> MetricsM ()
inside Text
"Loop" forall a b. (a -> b) -> a -> b
$ Text -> MetricsM ()
seen Text
"ForLoop" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics Body rep
body
expMetrics (Loop [(FParam rep, SubExp)]
_ WhileLoop {} Body rep
body) =
Text -> MetricsM () -> MetricsM ()
inside Text
"Loop" forall a b. (a -> b) -> a -> b
$ Text -> MetricsM ()
seen Text
"WhileLoop" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics Body rep
body
expMetrics (Match [SubExp]
_ [Case [Just (BoolValue Bool
True)] Body rep
tb] Body rep
fb MatchDec (BranchType rep)
_) =
Text -> MetricsM () -> MetricsM ()
inside Text
"If" forall a b. (a -> b) -> a -> b
$ do
Text -> MetricsM () -> MetricsM ()
inside Text
"True" forall a b. (a -> b) -> a -> b
$ forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics Body rep
tb
Text -> MetricsM () -> MetricsM ()
inside Text
"False" forall a b. (a -> b) -> a -> b
$ forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics Body rep
fb
expMetrics (Match [SubExp]
_ [Case (Body rep)]
cases Body rep
defbody MatchDec (BranchType rep)
_) =
Text -> MetricsM () -> MetricsM ()
inside Text
"Match" forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Case (Body rep)]
cases) forall a b. (a -> b) -> a -> b
$ \(Int
i, Case (Body rep)
c) ->
Text -> MetricsM () -> MetricsM ()
inside (forall a. Show a => a -> Text
showText (Int
i :: Int)) forall a b. (a -> b) -> a -> b
$ forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics forall a b. (a -> b) -> a -> b
$ forall body. Case body -> body
caseBody Case (Body rep)
c
Text -> MetricsM () -> MetricsM ()
inside Text
"default" forall a b. (a -> b) -> a -> b
$ forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics Body rep
defbody
expMetrics Apply {} =
Text -> MetricsM ()
seen Text
"Apply"
expMetrics (WithAcc [WithAccInput rep]
_ Lambda rep
lam) =
Text -> MetricsM () -> MetricsM ()
inside Text
"WithAcc" forall a b. (a -> b) -> a -> b
$ forall rep. OpMetrics (Op rep) => Lambda rep -> MetricsM ()
lambdaMetrics Lambda rep
lam
expMetrics (Op Op rep
op) =
forall op. OpMetrics op => op -> MetricsM ()
opMetrics Op rep
op
basicOpMetrics :: BasicOp -> MetricsM ()
basicOpMetrics :: BasicOp -> MetricsM ()
basicOpMetrics (SubExp SubExp
_) = Text -> MetricsM ()
seen Text
"SubExp"
basicOpMetrics (Opaque OpaqueOp
_ SubExp
_) = Text -> MetricsM ()
seen Text
"Opaque"
basicOpMetrics ArrayLit {} = Text -> MetricsM ()
seen Text
"ArrayLit"
basicOpMetrics BinOp {} = Text -> MetricsM ()
seen Text
"BinOp"
basicOpMetrics UnOp {} = Text -> MetricsM ()
seen Text
"UnOp"
basicOpMetrics ConvOp {} = Text -> MetricsM ()
seen Text
"ConvOp"
basicOpMetrics CmpOp {} = Text -> MetricsM ()
seen Text
"CmpOp"
basicOpMetrics Assert {} = Text -> MetricsM ()
seen Text
"Assert"
basicOpMetrics Index {} = Text -> MetricsM ()
seen Text
"Index"
basicOpMetrics Update {} = Text -> MetricsM ()
seen Text
"Update"
basicOpMetrics FlatIndex {} = Text -> MetricsM ()
seen Text
"FlatIndex"
basicOpMetrics FlatUpdate {} = Text -> MetricsM ()
seen Text
"FlatUpdate"
basicOpMetrics Concat {} = Text -> MetricsM ()
seen Text
"Concat"
basicOpMetrics Manifest {} = Text -> MetricsM ()
seen Text
"Manifest"
basicOpMetrics Iota {} = Text -> MetricsM ()
seen Text
"Iota"
basicOpMetrics Replicate {} = Text -> MetricsM ()
seen Text
"Replicate"
basicOpMetrics Scratch {} = Text -> MetricsM ()
seen Text
"Scratch"
basicOpMetrics Reshape {} = Text -> MetricsM ()
seen Text
"Reshape"
basicOpMetrics Rearrange {} = Text -> MetricsM ()
seen Text
"Rearrange"
basicOpMetrics UpdateAcc {} = Text -> MetricsM ()
seen Text
"UpdateAcc"
lambdaMetrics :: (OpMetrics (Op rep)) => Lambda rep -> MetricsM ()
lambdaMetrics :: forall rep. OpMetrics (Op rep) => Lambda rep -> MetricsM ()
lambdaMetrics = forall rep. OpMetrics (Op rep) => Body rep -> MetricsM ()
bodyMetrics forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall rep. Lambda rep -> Body rep
lambdaBody