module Futhark.Pipeline
( Pipeline,
PipelineConfig (..),
Action (..),
FutharkM,
runFutharkM,
Verbosity (..),
module Futhark.Error,
onePass,
passes,
condPipeline,
runPipeline,
)
where
import Control.Category
import Control.Exception (SomeException, catch, throwIO)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Parallel
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Time.Clock
import Futhark.Analysis.Alias qualified as Alias
import Futhark.Compiler.Config (Verbosity (..))
import Futhark.Error
import Futhark.IR (PrettyRep, Prog)
import Futhark.IR.TypeCheck
import Futhark.MonadFreshNames
import Futhark.Pass
import Futhark.Util.Log
import Futhark.Util.Pretty (prettyText)
import System.IO
import Text.Printf
import Prelude hiding (id, (.))
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
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
<* :: forall a b. FutharkM a -> FutharkM b -> FutharkM a
$c<* :: forall a b. FutharkM a -> FutharkM b -> FutharkM a
*> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
$c*> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
liftA2 :: forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
<*> :: forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b
$c<*> :: forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b
pure :: forall a. a -> FutharkM a
$cpure :: forall a. a -> FutharkM a
Applicative,
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
<$ :: forall a b. a -> FutharkM b -> FutharkM a
$c<$ :: forall a b. a -> FutharkM b -> FutharkM a
fmap :: forall a b. (a -> b) -> FutharkM a -> FutharkM b
$cfmap :: forall a b. (a -> b) -> FutharkM a -> FutharkM b
Functor,
Applicative FutharkM
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 :: forall a. a -> FutharkM a
$creturn :: forall a. a -> FutharkM a
>> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
$c>> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
>>= :: forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM b
$c>>= :: forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM b
Monad,
MonadError CompilerError,
MonadState FutharkState,
MonadReader FutharkEnv,
Monad FutharkM
forall a. IO a -> FutharkM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> FutharkM a
$cliftIO :: forall a. IO a -> FutharkM a
MonadIO
)
instance MonadFreshNames FutharkM where
getNameSource :: FutharkM VNameSource
getNameSource = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkState -> VNameSource
futharkNameSource
putNameSource :: VNameSource -> FutharkM ()
putNameSource VNameSource
src = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkState
s -> FutharkState
s {futharkNameSource :: VNameSource
futharkNameSource = VNameSource
src}
instance MonadLogger FutharkM where
addLog :: Log -> FutharkM ()
addLog = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}.
(MonadReader FutharkEnv m, MonadState FutharkState m, MonadIO m) =>
Text -> m ()
perLine 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 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ (forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbose) 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkState -> UTCTime
futharkPrevLog
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let delta :: Double
delta :: Double
delta = forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
prev)
prefix :: String
prefix = forall r. PrintfType r => String -> r
printf String
"[ +%.6f] " Double
delta
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkState
s -> FutharkState
s {futharkPrevLog :: UTCTime
futharkPrevLog = UTCTime
now}
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
prefix forall a. Semigroup a => a -> a -> a
<> Text
msg
runFutharkM' ::
FutharkM a ->
FutharkState ->
FutharkEnv ->
IO (Either CompilerError a, FutharkState)
runFutharkM' :: forall a.
FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
runFutharkM' (FutharkM ExceptT
CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
m) FutharkState
s =
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
m) FutharkState
s)
runFutharkM :: FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM :: forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM FutharkM a
m Verbosity
verbose = do
FutharkState
s <- UTCTime -> VNameSource -> FutharkState
FutharkState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure VNameSource
blankNameSource
forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
runFutharkM' FutharkM a
m FutharkState
s (Verbosity -> FutharkEnv
FutharkEnv Verbosity
verbose)
catchIO :: FutharkM a -> (SomeException -> FutharkM a) -> FutharkM a
catchIO :: forall a. FutharkM a -> (SomeException -> FutharkM a) -> FutharkM a
catchIO FutharkM a
m SomeException -> FutharkM a
f = forall a.
ExceptT
CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
-> FutharkM a
FutharkM forall a b. (a -> b) -> a -> b
$ do
FutharkState
s <- forall s (m :: * -> *). MonadState s m => m s
get
FutharkEnv
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
(Either CompilerError a
x, FutharkState
s') <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall a.
FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
runFutharkM' FutharkM a
m FutharkState
s FutharkEnv
env forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e ->
forall a.
FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
runFutharkM' (SomeException -> FutharkM a
f SomeException
e) FutharkState
s FutharkEnv
env
forall s (m :: * -> *). MonadState s m => s -> m ()
put FutharkState
s'
case Either CompilerError a
x of
Left CompilerError
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CompilerError
e
Right a
x' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x'
data Action rep = Action
{ forall rep. Action rep -> String
actionName :: String,
forall rep. Action rep -> String
actionDescription :: String,
forall rep. 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
{ forall fromrep torep.
Pipeline fromrep torep
-> forall a.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
unPipeline ::
forall a.
PipelineConfig ->
Prog fromrep ->
FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
}
instance Category Pipeline where
id :: forall a. Pipeline a a
id = forall fromrep torep.
(forall a.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> Pipeline fromrep torep
Pipeline forall a b. (a -> b) -> a -> b
$ \PipelineConfig
_ Prog a
prog -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Prog a -> FutharkM a
c -> Prog a -> FutharkM a
c Prog a
prog
Pipeline b c
p2 . :: forall b c a. Pipeline b c -> Pipeline a b -> Pipeline a c
. Pipeline a b
p1 = forall fromrep torep.
(forall a.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> Pipeline fromrep torep
Pipeline forall {a}.
PipelineConfig
-> Prog a -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a)
perform
where
perform :: PipelineConfig
-> Prog a -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a)
perform PipelineConfig
cfg Prog a
prog = do
(Prog b -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a))
-> FutharkM ((Prog c -> FutharkM a) -> FutharkM a)
rc <- forall fromrep torep.
Pipeline fromrep torep
-> forall a.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
unPipeline Pipeline a b
p1 PipelineConfig
cfg Prog a
prog
(Prog b -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a))
-> FutharkM ((Prog c -> FutharkM a) -> FutharkM a)
rc forall a b. (a -> b) -> a -> b
$ forall fromrep torep.
Pipeline fromrep torep
-> forall a.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
unPipeline Pipeline b c
p2 PipelineConfig
cfg
runPipeline ::
Pipeline fromrep torep ->
PipelineConfig ->
Prog fromrep ->
FutharkM (Prog torep)
runPipeline :: forall fromrep torep.
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline Pipeline fromrep torep
p PipelineConfig
cfg Prog fromrep
prog = do
(Prog torep -> FutharkM (Prog torep)) -> FutharkM (Prog torep)
rc <- forall fromrep torep.
Pipeline fromrep torep
-> forall a.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
unPipeline Pipeline fromrep torep
p PipelineConfig
cfg Prog fromrep
prog
(Prog torep -> FutharkM (Prog torep)) -> FutharkM (Prog torep)
rc forall (f :: * -> *) a. Applicative f => a -> f a
pure
onePass ::
Checkable torep =>
Pass fromrep torep ->
Pipeline fromrep torep
onePass :: forall torep fromrep.
Checkable torep =>
Pass fromrep torep -> Pipeline fromrep torep
onePass Pass fromrep torep
pass = forall fromrep torep.
(forall a.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> Pipeline fromrep torep
Pipeline forall {a}.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
perform
where
perform :: PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
perform PipelineConfig
cfg Prog fromrep
prog = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
cfg) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$
Text
"Running pass " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall fromrep torep. Pass fromrep torep -> String
passName Pass fromrep torep
pass)
Prog torep
prog' <- forall fromrep torep.
Pass fromrep torep -> Prog fromrep -> FutharkM (Prog torep)
runPass Pass fromrep torep
pass Prog fromrep
prog
let check :: Either (Prog (Aliases torep), TypeError torep) ()
check =
if PipelineConfig -> Bool
pipelineValidate PipelineConfig
cfg
then forall {rep}.
Checkable rep =>
Prog rep -> Either (Prog (Aliases rep), TypeError rep) ()
validate Prog torep
prog'
else forall a b. b -> Either a b
Right ()
forall a b. a -> b -> b
par Either (Prog (Aliases torep), TypeError torep) ()
check forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Prog torep -> FutharkM a
c ->
(forall {rep} {a} {b} {t} {a}.
(PrettyRep rep, Show a) =>
Either (Prog rep, a) b -> (t -> FutharkM a) -> t -> FutharkM a
errorOnError Either (Prog (Aliases torep), TypeError torep) ()
check forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Prog torep -> FutharkM a
c Prog torep
prog')
forall a. FutharkM a -> (SomeException -> FutharkM a) -> FutharkM a
`catchIO` forall {rep} {a} {b} {t} {a}.
(PrettyRep rep, Show a) =>
Either (Prog rep, a) b -> (t -> FutharkM a) -> t -> FutharkM a
errorOnError Either (Prog (Aliases torep), TypeError torep) ()
check (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e a. Exception e => e -> IO a
throwIO)
validate :: Prog rep -> Either (Prog (Aliases rep), TypeError rep) ()
validate Prog rep
prog =
let prog' :: Prog (Aliases rep)
prog' = forall rep. AliasableRep rep => Prog rep -> Prog (Aliases rep)
Alias.aliasAnalysis Prog rep
prog
in case forall rep.
Checkable rep =>
Prog (Aliases rep) -> Either (TypeError rep) ()
checkProg Prog (Aliases rep)
prog' of
Left TypeError rep
err -> forall a b. a -> Either a b
Left (Prog (Aliases rep)
prog', TypeError rep
err)
Right () -> forall a b. b -> Either a b
Right ()
errorOnError :: Either (Prog rep, a) b -> (t -> FutharkM a) -> t -> FutharkM a
errorOnError (Left (Prog rep
prog, a
err)) t -> FutharkM a
_ t
_ =
forall rep fromrep torep a.
PrettyRep rep =>
Pass fromrep torep -> Prog rep -> String -> FutharkM a
validationError Pass fromrep torep
pass Prog rep
prog forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
err
errorOnError Either (Prog rep, a) b
_ t -> FutharkM a
c t
x = t -> FutharkM a
c t
x
condPipeline ::
(Prog rep -> Bool) -> Pipeline rep rep -> Pipeline rep rep
condPipeline :: forall rep.
(Prog rep -> Bool) -> Pipeline rep rep -> Pipeline rep rep
condPipeline Prog rep -> Bool
cond (Pipeline forall a.
PipelineConfig
-> Prog rep -> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a)
f) =
forall fromrep torep.
(forall a.
PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> Pipeline fromrep torep
Pipeline forall a b. (a -> b) -> a -> b
$ \PipelineConfig
cfg Prog rep
prog ->
if Prog rep -> Bool
cond Prog rep
prog
then forall a.
PipelineConfig
-> Prog rep -> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a)
f PipelineConfig
cfg Prog rep
prog
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Prog rep -> FutharkM a
c -> Prog rep -> FutharkM a
c Prog rep
prog
passes ::
Checkable rep =>
[Pass rep rep] ->
Pipeline rep rep
passes :: forall rep. Checkable rep => [Pass rep rep] -> Pipeline rep rep
passes = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a -> b) -> [a] -> [b]
map forall torep fromrep.
Checkable torep =>
Pass fromrep torep -> Pipeline fromrep torep
onePass
validationError ::
PrettyRep rep =>
Pass fromrep torep ->
Prog rep ->
String ->
FutharkM a
validationError :: forall rep fromrep torep a.
PrettyRep rep =>
Pass fromrep torep -> Prog rep -> String -> FutharkM a
validationError Pass fromrep torep
pass Prog rep
prog String
err =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text -> ErrorClass -> CompilerError
InternalError Text
msg (forall a. Pretty a => a -> Text
prettyText Prog rep
prog) ErrorClass
CompilerBug
where
msg :: Text
msg = Text
"Type error after pass '" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall fromrep torep. Pass fromrep torep -> String
passName Pass fromrep torep
pass) forall a. Semigroup a => a -> a -> a
<> Text
"':\n" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
runPass ::
Pass fromrep torep ->
Prog fromrep ->
FutharkM (Prog torep)
runPass :: forall fromrep torep.
Pass fromrep torep -> Prog fromrep -> FutharkM (Prog torep)
runPass Pass fromrep torep
pass Prog fromrep
prog = do
(Prog torep
prog', Log
logged) <- forall (m :: * -> *) a. MonadFreshNames m => PassM a -> m (a, Log)
runPassM (forall fromrep torep.
Pass fromrep torep -> Prog fromrep -> PassM (Prog torep)
passFunction Pass fromrep torep
pass Prog fromrep
prog)
Bool
verb <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ (forall a. Ord a => a -> a -> Bool
>= Verbosity
VeryVerbose) 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadLogger m => Log -> m ()
addLog Log
logged
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog torep
prog'