{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
module Futhark.Pipeline
( Pipeline,
PipelineConfig (..),
Action (..),
FutharkM,
runFutharkM,
Verbosity (..),
module Futhark.Error,
onePass,
passes,
runPipeline,
)
where
import Control.Category
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer.Strict hiding (pass)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Clock
import qualified Futhark.Analysis.Alias as Alias
import Futhark.Error
import Futhark.IR (PrettyRep, Prog)
import Futhark.MonadFreshNames
import Futhark.Pass
import Futhark.TypeCheck
import Futhark.Util.Log
import Futhark.Util.Pretty (prettyText)
import System.IO
import Text.Printf
import Prelude hiding (id, (.))
data Verbosity
=
NotVerbose
|
Verbose
|
VeryVerbose
deriving (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord)
newtype FutharkEnv = FutharkEnv {FutharkEnv -> Verbosity
futharkVerbose :: Verbosity}
data FutharkState = FutharkState
{ FutharkState -> UTCTime
futharkPrevLog :: UTCTime,
FutharkState -> VNameSource
futharkNameSource :: VNameSource
}
newtype FutharkM a = FutharkM (ExceptT CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a)
deriving
( Functor FutharkM
a -> FutharkM a
Functor FutharkM
-> (forall a. a -> FutharkM a)
-> (forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b)
-> (forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c)
-> (forall a b. FutharkM a -> FutharkM b -> FutharkM b)
-> (forall a b. FutharkM a -> FutharkM b -> FutharkM a)
-> Applicative FutharkM
FutharkM a -> FutharkM b -> FutharkM b
FutharkM a -> FutharkM b -> FutharkM a
FutharkM (a -> b) -> FutharkM a -> FutharkM b
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
forall a. a -> FutharkM a
forall a b. FutharkM a -> FutharkM b -> FutharkM a
forall a b. FutharkM a -> FutharkM b -> FutharkM b
forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b
forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM 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
<* :: FutharkM a -> FutharkM b -> FutharkM a
$c<* :: forall a b. FutharkM a -> FutharkM b -> FutharkM a
*> :: FutharkM a -> FutharkM b -> FutharkM b
$c*> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
liftA2 :: (a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
<*> :: FutharkM (a -> b) -> FutharkM a -> FutharkM b
$c<*> :: forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b
pure :: a -> FutharkM a
$cpure :: forall a. a -> FutharkM a
$cp1Applicative :: Functor FutharkM
Applicative,
a -> FutharkM b -> FutharkM a
(a -> b) -> FutharkM a -> FutharkM b
(forall a b. (a -> b) -> FutharkM a -> FutharkM b)
-> (forall a b. a -> FutharkM b -> FutharkM a) -> Functor FutharkM
forall a b. a -> FutharkM b -> FutharkM a
forall a b. (a -> b) -> FutharkM a -> FutharkM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FutharkM b -> FutharkM a
$c<$ :: forall a b. a -> FutharkM b -> FutharkM a
fmap :: (a -> b) -> FutharkM a -> FutharkM b
$cfmap :: forall a b. (a -> b) -> FutharkM a -> FutharkM b
Functor,
Applicative FutharkM
a -> FutharkM a
Applicative FutharkM
-> (forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM b)
-> (forall a b. FutharkM a -> FutharkM b -> FutharkM b)
-> (forall a. a -> FutharkM a)
-> Monad FutharkM
FutharkM a -> (a -> FutharkM b) -> FutharkM b
FutharkM a -> FutharkM b -> FutharkM b
forall a. a -> FutharkM a
forall a b. FutharkM a -> FutharkM b -> FutharkM b
forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM 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 :: a -> FutharkM a
$creturn :: forall a. a -> FutharkM a
>> :: FutharkM a -> FutharkM b -> FutharkM b
$c>> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
>>= :: FutharkM a -> (a -> FutharkM b) -> FutharkM b
$c>>= :: forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM b
$cp1Monad :: Applicative FutharkM
Monad,
MonadError CompilerError,
MonadState FutharkState,
MonadReader FutharkEnv,
Monad FutharkM
Monad FutharkM
-> (forall a. IO a -> FutharkM a) -> MonadIO FutharkM
IO a -> FutharkM a
forall a. IO a -> FutharkM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> FutharkM a
$cliftIO :: forall a. IO a -> FutharkM a
$cp1MonadIO :: Monad FutharkM
MonadIO
)
instance MonadFreshNames FutharkM where
getNameSource :: FutharkM VNameSource
getNameSource = (FutharkState -> VNameSource) -> FutharkM VNameSource
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkState -> VNameSource
futharkNameSource
putNameSource :: VNameSource -> FutharkM ()
putNameSource VNameSource
src = (FutharkState -> FutharkState) -> FutharkM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkState -> FutharkState) -> FutharkM ())
-> (FutharkState -> FutharkState) -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ \FutharkState
s -> FutharkState
s {futharkNameSource :: VNameSource
futharkNameSource = VNameSource
src}
instance MonadLogger FutharkM where
addLog :: Log -> FutharkM ()
addLog = (Text -> FutharkM ()) -> [Text] -> FutharkM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> FutharkM ()
forall (m :: * -> *).
(MonadReader FutharkEnv m, MonadState FutharkState m, MonadIO m) =>
Text -> m ()
perLine ([Text] -> FutharkM ()) -> (Log -> [Text]) -> Log -> FutharkM ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [Text]
T.lines (Text -> [Text]) -> (Log -> Text) -> Log -> [Text]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Log -> Text
toText
where
perLine :: Text -> m ()
perLine Text
msg = do
Bool
verb <- (FutharkEnv -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FutharkEnv -> Bool) -> m Bool) -> (FutharkEnv -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ (Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbose) (Verbosity -> Bool)
-> (FutharkEnv -> Verbosity) -> FutharkEnv -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. FutharkEnv -> Verbosity
futharkVerbose
UTCTime
prev <- (FutharkState -> UTCTime) -> m UTCTime
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkState -> UTCTime
futharkPrevLog
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let delta :: Double
delta :: Double
delta = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
prev)
prefix :: String
prefix = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"[ +%.6f] " Double
delta
(FutharkState -> FutharkState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkState -> FutharkState) -> m ())
-> (FutharkState -> FutharkState) -> m ()
forall a b. (a -> b) -> a -> b
$ \FutharkState
s -> FutharkState
s {futharkPrevLog :: UTCTime
futharkPrevLog = UTCTime
now}
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
runFutharkM :: FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM :: FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM (FutharkM ExceptT
CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
m) Verbosity
verbose = do
FutharkState
s <- UTCTime -> VNameSource -> FutharkState
FutharkState (UTCTime -> VNameSource -> FutharkState)
-> IO UTCTime -> IO (VNameSource -> FutharkState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime IO (VNameSource -> FutharkState)
-> IO VNameSource -> IO FutharkState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VNameSource -> IO VNameSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure VNameSource
blankNameSource
ReaderT FutharkEnv IO (Either CompilerError a)
-> FutharkEnv -> IO (Either CompilerError a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT
FutharkState (ReaderT FutharkEnv IO) (Either CompilerError a)
-> FutharkState -> ReaderT FutharkEnv IO (Either CompilerError a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ExceptT
CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
-> StateT
FutharkState (ReaderT FutharkEnv IO) (Either CompilerError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
m) FutharkState
s) FutharkEnv
newEnv
where
newEnv :: FutharkEnv
newEnv = Verbosity -> FutharkEnv
FutharkEnv Verbosity
verbose
data Action rep = Action
{ Action rep -> String
actionName :: String,
Action rep -> String
actionDescription :: String,
Action rep -> Prog rep -> FutharkM ()
actionProcedure :: Prog rep -> FutharkM ()
}
data PipelineConfig = PipelineConfig
{ PipelineConfig -> Bool
pipelineVerbose :: Bool,
PipelineConfig -> Bool
pipelineValidate :: Bool
}
newtype Pipeline fromrep torep = Pipeline {Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
unPipeline :: PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)}
instance Category Pipeline where
id :: Pipeline a a
id = (PipelineConfig -> Prog a -> FutharkM (Prog a)) -> Pipeline a a
forall fromrep torep.
(PipelineConfig -> Prog fromrep -> FutharkM (Prog torep))
-> Pipeline fromrep torep
Pipeline ((PipelineConfig -> Prog a -> FutharkM (Prog a)) -> Pipeline a a)
-> (PipelineConfig -> Prog a -> FutharkM (Prog a)) -> Pipeline a a
forall a b. (a -> b) -> a -> b
$ (Prog a -> FutharkM (Prog a))
-> PipelineConfig -> Prog a -> FutharkM (Prog a)
forall a b. a -> b -> a
const Prog a -> FutharkM (Prog a)
forall (m :: * -> *) a. Monad m => a -> m a
return
Pipeline b c
p2 . :: Pipeline b c -> Pipeline a b -> Pipeline a c
. Pipeline a b
p1 = (PipelineConfig -> Prog a -> FutharkM (Prog c)) -> Pipeline a c
forall fromrep torep.
(PipelineConfig -> Prog fromrep -> FutharkM (Prog torep))
-> Pipeline fromrep torep
Pipeline PipelineConfig -> Prog a -> FutharkM (Prog c)
perform
where
perform :: PipelineConfig -> Prog a -> FutharkM (Prog c)
perform PipelineConfig
cfg Prog a
prog =
Pipeline b c -> PipelineConfig -> Prog b -> FutharkM (Prog c)
forall fromrep torep.
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline Pipeline b c
p2 PipelineConfig
cfg (Prog b -> FutharkM (Prog c))
-> FutharkM (Prog b) -> FutharkM (Prog c)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pipeline a b -> PipelineConfig -> Prog a -> FutharkM (Prog b)
forall fromrep torep.
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline Pipeline a b
p1 PipelineConfig
cfg Prog a
prog
runPipeline ::
Pipeline fromrep torep ->
PipelineConfig ->
Prog fromrep ->
FutharkM (Prog torep)
runPipeline :: Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline = Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
forall fromrep torep.
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
unPipeline
onePass ::
Checkable torep =>
Pass fromrep torep ->
Pipeline fromrep torep
onePass :: Pass fromrep torep -> Pipeline fromrep torep
onePass Pass fromrep torep
pass = (PipelineConfig -> Prog fromrep -> FutharkM (Prog torep))
-> Pipeline fromrep torep
forall fromrep torep.
(PipelineConfig -> Prog fromrep -> FutharkM (Prog torep))
-> Pipeline fromrep torep
Pipeline PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
perform
where
perform :: PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
perform PipelineConfig
cfg Prog fromrep
prog = do
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
cfg) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
Text -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (Text -> FutharkM ()) -> Text -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
Text
"Running pass " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Pass fromrep torep -> String
forall fromrep torep. Pass fromrep torep -> String
passName Pass fromrep torep
pass)
Prog torep
prog' <- Pass fromrep torep -> Prog fromrep -> FutharkM (Prog torep)
forall fromrep torep.
Pass fromrep torep -> Prog fromrep -> FutharkM (Prog torep)
runPass Pass fromrep torep
pass Prog fromrep
prog
let prog'' :: Prog (Aliases torep)
prog'' = Prog torep -> Prog (Aliases torep)
forall rep.
(ASTRep rep, CanBeAliased (Op rep)) =>
Prog rep -> Prog (Aliases rep)
Alias.aliasAnalysis Prog torep
prog'
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineValidate PipelineConfig
cfg) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
case Prog (Aliases torep) -> Either (TypeError torep) ()
forall rep.
Checkable rep =>
Prog (Aliases rep) -> Either (TypeError rep) ()
checkProg Prog (Aliases torep)
prog'' of
Left TypeError torep
err -> Pass fromrep torep -> Prog (Aliases torep) -> String -> FutharkM ()
forall rep fromrep torep a.
PrettyRep rep =>
Pass fromrep torep -> Prog rep -> String -> FutharkM a
validationError Pass fromrep torep
pass Prog (Aliases torep)
prog'' (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ TypeError torep -> String
forall a. Show a => a -> String
show TypeError torep
err
Right () -> () -> FutharkM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Prog torep -> FutharkM (Prog torep)
forall (m :: * -> *) a. Monad m => a -> m a
return Prog torep
prog'
passes ::
Checkable rep =>
[Pass rep rep] ->
Pipeline rep rep
passes :: [Pass rep rep] -> Pipeline rep rep
passes = (Pipeline rep rep -> Pipeline rep rep -> Pipeline rep rep)
-> Pipeline rep rep -> [Pipeline rep rep] -> Pipeline rep rep
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Pipeline rep rep -> Pipeline rep rep -> Pipeline rep rep
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) Pipeline rep rep
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id ([Pipeline rep rep] -> Pipeline rep rep)
-> ([Pass rep rep] -> [Pipeline rep rep])
-> [Pass rep rep]
-> Pipeline rep rep
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Pass rep rep -> Pipeline rep rep)
-> [Pass rep rep] -> [Pipeline rep rep]
forall a b. (a -> b) -> [a] -> [b]
map Pass rep rep -> Pipeline rep rep
forall torep fromrep.
Checkable torep =>
Pass fromrep torep -> Pipeline fromrep torep
onePass
validationError ::
PrettyRep rep =>
Pass fromrep torep ->
Prog rep ->
String ->
FutharkM a
validationError :: Pass fromrep torep -> Prog rep -> String -> FutharkM a
validationError Pass fromrep torep
pass Prog rep
prog String
err =
CompilerError -> FutharkM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompilerError -> FutharkM a) -> CompilerError -> FutharkM a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ErrorClass -> CompilerError
InternalError Text
msg (Prog rep -> Text
forall a. Pretty a => a -> Text
prettyText Prog rep
prog) ErrorClass
CompilerBug
where
msg :: Text
msg = Text
"Type error after pass '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Pass fromrep torep -> String
forall fromrep torep. Pass fromrep torep -> String
passName Pass fromrep torep
pass) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"':\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
runPass ::
Pass fromrep torep ->
Prog fromrep ->
FutharkM (Prog torep)
runPass :: Pass fromrep torep -> Prog fromrep -> FutharkM (Prog torep)
runPass Pass fromrep torep
pass Prog fromrep
prog = do
(Prog torep
prog', Log
logged) <- PassM (Prog torep) -> FutharkM (Prog torep, Log)
forall (m :: * -> *) a. MonadFreshNames m => PassM a -> m (a, Log)
runPassM (Pass fromrep torep -> Prog fromrep -> PassM (Prog torep)
forall fromrep torep.
Pass fromrep torep -> Prog fromrep -> PassM (Prog torep)
passFunction Pass fromrep torep
pass Prog fromrep
prog)
Bool
verb <- (FutharkEnv -> Bool) -> FutharkM Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FutharkEnv -> Bool) -> FutharkM Bool)
-> (FutharkEnv -> Bool) -> FutharkM Bool
forall a b. (a -> b) -> a -> b
$ (Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
VeryVerbose) (Verbosity -> Bool)
-> (FutharkEnv -> Verbosity) -> FutharkEnv -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. FutharkEnv -> Verbosity
futharkVerbose
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ Log -> FutharkM ()
forall (m :: * -> *). MonadLogger m => Log -> m ()
addLog Log
logged
Prog torep -> FutharkM (Prog torep)
forall (m :: * -> *) a. Monad m => a -> m a
return Prog torep
prog'