-- | Definition of the core compiler driver building blocks.  The
-- spine of the compiler is the 'FutharkM' monad, although note that
-- individual passes are pure functions, and do not use the 'FutharkM'
-- monad (see "Futhark.Pass").
--
-- Running the compiler involves producing an initial IR program (see
-- "Futhark.Compiler.Program"), running a 'Pipeline' to produce a
-- final program (still in IR), then running an 'Action', which is
-- usually a code generator.
module Futhark.Pipeline
  ( Pipeline,
    PipelineConfig (..),
    Action (..),
    FutharkM,
    runFutharkM,
    Verbosity (..),
    module Futhark.Error,
    onePass,
    passes,
    condPipeline,
    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 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
  }

-- | The main Futhark compiler driver monad - basically some state
-- tracking on top if 'IO'.
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

-- | Run a 'FutharkM' action.
runFutharkM :: FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM :: forall a. 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 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 r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (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

-- | A compilation always ends with some kind of action.
data Action rep = Action
  { forall {k} (rep :: k). Action rep -> String
actionName :: String,
    forall {k} (rep :: k). Action rep -> String
actionDescription :: String,
    forall {k} (rep :: k). Action rep -> Prog rep -> FutharkM ()
actionProcedure :: Prog rep -> FutharkM ()
  }

-- | Configuration object for running a compiler pipeline.
data PipelineConfig = PipelineConfig
  { PipelineConfig -> Bool
pipelineVerbose :: Bool,
    PipelineConfig -> Bool
pipelineValidate :: Bool
  }

-- | A compiler pipeline is conceptually a function from programs to
-- programs, where the actual representation may change.  Pipelines
-- can be composed using their 'Category' instance.
newtype Pipeline fromrep torep = Pipeline {forall {k} {k} (fromrep :: k) (torep :: k).
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
unPipeline :: PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)}

instance Category Pipeline where
  id :: forall (a :: k). Pipeline a a
id = forall {k} {k} (fromrep :: k) (torep :: k).
(PipelineConfig -> Prog fromrep -> FutharkM (Prog torep))
-> Pipeline fromrep torep
Pipeline forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Pipeline b c
p2 . :: forall (b :: k) (c :: k) (a :: k).
Pipeline b c -> Pipeline a b -> Pipeline a c
. Pipeline a b
p1 = forall {k} {k} (fromrep :: k) (torep :: k).
(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 =
        forall {k} {k} (fromrep :: k) (torep :: k).
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline Pipeline b c
p2 PipelineConfig
cfg forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} {k} (fromrep :: k) (torep :: k).
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline Pipeline a b
p1 PipelineConfig
cfg Prog a
prog

-- | Run the pipeline on the given program.
runPipeline ::
  Pipeline fromrep torep ->
  PipelineConfig ->
  Prog fromrep ->
  FutharkM (Prog torep)
runPipeline :: forall {k} {k} (fromrep :: k) (torep :: k).
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline = forall {k} {k} (fromrep :: k) (torep :: k).
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
unPipeline

-- | Construct a pipeline from a single compiler pass.
onePass ::
  Checkable torep =>
  Pass fromrep torep ->
  Pipeline fromrep torep
onePass :: forall {k} {k} (torep :: k) (fromrep :: k).
Checkable torep =>
Pass fromrep torep -> Pipeline fromrep torep
onePass Pass fromrep torep
pass = forall {k} {k} (fromrep :: k) (torep :: k).
(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
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
cfg) forall a b. (a -> b) -> a -> b
$
        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 {k1} {k2} (fromrep :: k1) (torep :: k2).
Pass fromrep torep -> String
passName Pass fromrep torep
pass)
      Prog torep
prog' <- forall {k} {k} (fromrep :: k) (torep :: k).
Pass fromrep torep -> Prog fromrep -> FutharkM (Prog torep)
runPass Pass fromrep torep
pass Prog fromrep
prog
      let prog'' :: Prog (Aliases torep)
prog'' = forall {k} (rep :: k).
(ASTRep rep, CanBeAliased (Op rep)) =>
Prog rep -> Prog (Aliases rep)
Alias.aliasAnalysis Prog torep
prog'
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineValidate PipelineConfig
cfg) forall a b. (a -> b) -> a -> b
$
        case forall {k} (rep :: k).
Checkable rep =>
Prog (Aliases rep) -> Either (TypeError rep) ()
checkProg Prog (Aliases torep)
prog'' of
          Left TypeError torep
err -> forall {k} {k} {k1} (rep :: k) (fromrep :: k) (torep :: k1) a.
PrettyRep rep =>
Pass fromrep torep -> Prog rep -> String -> FutharkM a
validationError Pass fromrep torep
pass Prog (Aliases torep)
prog'' forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show TypeError torep
err
          Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog torep
prog'

-- | Conditionally run pipeline if predicate is true.
condPipeline ::
  (Prog rep -> Bool) -> Pipeline rep rep -> Pipeline rep rep
condPipeline :: forall {k} (rep :: k).
(Prog rep -> Bool) -> Pipeline rep rep -> Pipeline rep rep
condPipeline Prog rep -> Bool
cond (Pipeline PipelineConfig -> Prog rep -> FutharkM (Prog rep)
f) =
  forall {k} {k} (fromrep :: k) (torep :: k).
(PipelineConfig -> Prog fromrep -> FutharkM (Prog torep))
-> 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 PipelineConfig -> Prog rep -> FutharkM (Prog rep)
f PipelineConfig
cfg Prog rep
prog
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog rep
prog

-- | Create a pipeline from a list of passes.
passes ::
  Checkable rep =>
  [Pass rep rep] ->
  Pipeline rep rep
passes :: forall {k} (rep :: k).
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 {k} {k} (torep :: k) (fromrep :: k).
Checkable torep =>
Pass fromrep torep -> Pipeline fromrep torep
onePass

validationError ::
  PrettyRep rep =>
  Pass fromrep torep ->
  Prog rep ->
  String ->
  FutharkM a
validationError :: forall {k} {k} {k1} (rep :: k) (fromrep :: k) (torep :: k1) 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 {k1} {k2} (fromrep :: k1) (torep :: k2).
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 {k} {k} (fromrep :: k) (torep :: k).
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 {k1} {k2} (fromrep :: k1) (torep :: k2).
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'