-- | 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.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
  }

-- | 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
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
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
$cpure :: forall a. a -> FutharkM a
pure :: forall a. a -> FutharkM a
$c<*> :: forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b
<*> :: forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
liftA2 :: forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
$c*> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
*> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
$c<* :: forall a b. FutharkM a -> FutharkM b -> FutharkM a
<* :: forall a b. FutharkM a -> FutharkM b -> FutharkM a
Applicative,
      (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
$cfmap :: forall a b. (a -> b) -> FutharkM a -> FutharkM b
fmap :: forall a b. (a -> b) -> FutharkM a -> FutharkM b
$c<$ :: forall a b. a -> FutharkM b -> FutharkM a
<$ :: forall a b. a -> FutharkM b -> FutharkM a
Functor,
      Applicative FutharkM
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
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
$c>>= :: forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM b
>>= :: forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM b
$c>> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
>> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
$creturn :: forall a. a -> FutharkM a
return :: forall a. a -> FutharkM a
Monad,
      MonadError CompilerError,
      MonadState FutharkState,
      MonadReader FutharkEnv,
      Monad FutharkM
Monad FutharkM
-> (forall a. IO a -> FutharkM a) -> MonadIO FutharkM
forall a. IO a -> FutharkM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> FutharkM a
liftIO :: forall a. IO a -> FutharkM a
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 a. IO a -> m a
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 a. IO a -> m a
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 ->
  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 =
  ReaderT FutharkEnv IO (Either CompilerError a, FutharkState)
-> FutharkEnv -> IO (Either CompilerError a, FutharkState)
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, FutharkState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (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)

-- | Run a 'FutharkM' action.
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 (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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VNameSource -> IO VNameSource
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VNameSource
blankNameSource
  (Either CompilerError a, FutharkState) -> Either CompilerError a
forall a b. (a, b) -> a
fst ((Either CompilerError a, FutharkState) -> Either CompilerError a)
-> IO (Either CompilerError a, FutharkState)
-> IO (Either CompilerError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
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 = ExceptT
  CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
-> FutharkM a
forall a.
ExceptT
  CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
-> FutharkM a
FutharkM (ExceptT
   CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
 -> FutharkM a)
-> ExceptT
     CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
-> FutharkM a
forall a b. (a -> b) -> a -> b
$ do
  FutharkState
s <- ExceptT
  CompilerError
  (StateT FutharkState (ReaderT FutharkEnv IO))
  FutharkState
forall s (m :: * -> *). MonadState s m => m s
get
  FutharkEnv
env <- ExceptT
  CompilerError
  (StateT FutharkState (ReaderT FutharkEnv IO))
  FutharkEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Either CompilerError a
x, FutharkState
s') <-
    IO (Either CompilerError a, FutharkState)
-> ExceptT
     CompilerError
     (StateT FutharkState (ReaderT FutharkEnv IO))
     (Either CompilerError a, FutharkState)
forall a.
IO a
-> ExceptT
     CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either CompilerError a, FutharkState)
 -> ExceptT
      CompilerError
      (StateT FutharkState (ReaderT FutharkEnv IO))
      (Either CompilerError a, FutharkState))
-> IO (Either CompilerError a, FutharkState)
-> ExceptT
     CompilerError
     (StateT FutharkState (ReaderT FutharkEnv IO))
     (Either CompilerError a, FutharkState)
forall a b. (a -> b) -> a -> b
$
      FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
forall a.
FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
runFutharkM' FutharkM a
m FutharkState
s FutharkEnv
env IO (Either CompilerError a, FutharkState)
-> (SomeException -> IO (Either CompilerError a, FutharkState))
-> IO (Either CompilerError a, FutharkState)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e ->
        FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
forall a.
FutharkM a
-> FutharkState
-> FutharkEnv
-> IO (Either CompilerError a, FutharkState)
runFutharkM' (SomeException -> FutharkM a
f SomeException
e) FutharkState
s FutharkEnv
env
  FutharkState
-> ExceptT
     CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put FutharkState
s'
  case Either CompilerError a
x of
    Left CompilerError
e -> CompilerError
-> ExceptT
     CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
forall a.
CompilerError
-> ExceptT
     CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CompilerError
e
    Right a
x' -> a
-> ExceptT
     CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
forall a.
a
-> ExceptT
     CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x'

-- | A compilation always ends with some kind of action.
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 ()
  }

-- | 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 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 a.
 PipelineConfig
 -> Prog a -> FutharkM ((Prog a -> FutharkM a) -> FutharkM a))
-> Pipeline a a
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 a -> FutharkM a) -> FutharkM a))
 -> Pipeline a a)
-> (forall a.
    PipelineConfig
    -> Prog a -> FutharkM ((Prog a -> FutharkM a) -> FutharkM a))
-> Pipeline a a
forall a b. (a -> b) -> a -> b
$ \PipelineConfig
_ Prog a
prog -> ((Prog a -> FutharkM a) -> FutharkM a)
-> FutharkM ((Prog a -> FutharkM a) -> FutharkM a)
forall a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Prog a -> FutharkM a) -> FutharkM a)
 -> FutharkM ((Prog a -> FutharkM a) -> FutharkM a))
-> ((Prog a -> FutharkM a) -> FutharkM a)
-> FutharkM ((Prog a -> FutharkM a) -> FutharkM a)
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 a.
 PipelineConfig
 -> Prog a -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a))
-> Pipeline a c
forall fromrep torep.
(forall a.
 PipelineConfig
 -> Prog fromrep
 -> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> Pipeline fromrep torep
Pipeline PipelineConfig
-> Prog a -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a)
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 <- Pipeline a b
-> forall a.
   PipelineConfig
   -> Prog a -> FutharkM ((Prog b -> FutharkM a) -> FutharkM a)
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 ((Prog b -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a))
 -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a))
-> (Prog b -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a))
-> FutharkM ((Prog c -> FutharkM a) -> FutharkM a)
forall a b. (a -> b) -> a -> b
$ Pipeline b c
-> forall a.
   PipelineConfig
   -> Prog b -> FutharkM ((Prog c -> FutharkM a) -> FutharkM a)
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

-- | Run the pipeline on the given program.
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 <- Pipeline fromrep torep
-> forall a.
   PipelineConfig
   -> Prog fromrep
   -> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
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 Prog torep -> FutharkM (Prog torep)
forall a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Construct a pipeline from a single compiler pass.
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 a.
 PipelineConfig
 -> Prog fromrep
 -> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> Pipeline fromrep torep
forall fromrep torep.
(forall a.
 PipelineConfig
 -> Prog fromrep
 -> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> Pipeline fromrep torep
Pipeline PipelineConfig
-> Prog fromrep
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
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
      Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
cfg) (FutharkM () -> FutharkM ())
-> (Text -> FutharkM ()) -> Text -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> FutharkM ()
forall a. ToLog a => a -> 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
      -- Spark validation in a separate task and speculatively execute
      -- next pass.  If the next pass throws an exception, we better
      -- be ready to catch it and check if it might be because the
      -- program was actually ill-typed.
      let check :: Either (Prog (Aliases torep), TypeError torep) ()
check =
            if PipelineConfig -> Bool
pipelineValidate PipelineConfig
cfg
              then Prog torep -> Either (Prog (Aliases torep), TypeError torep) ()
forall {rep}.
Checkable rep =>
Prog rep -> Either (Prog (Aliases rep), TypeError rep) ()
validate Prog torep
prog'
              else () -> Either (Prog (Aliases torep), TypeError torep) ()
forall a b. b -> Either a b
Right ()
      Either (Prog (Aliases torep), TypeError torep) ()
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
forall a b. a -> b -> b
par Either (Prog (Aliases torep), TypeError torep) ()
check (FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
 -> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
forall a b. (a -> b) -> a -> b
$ ((Prog torep -> FutharkM a) -> FutharkM a)
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
forall a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Prog torep -> FutharkM a) -> FutharkM a)
 -> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> ((Prog torep -> FutharkM a) -> FutharkM a)
-> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a)
forall a b. (a -> b) -> a -> b
$ \Prog torep -> FutharkM a
c ->
        (Either (Prog (Aliases torep), TypeError torep) ()
-> (a -> FutharkM a) -> a -> FutharkM a
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 a -> FutharkM a
forall a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> FutharkM a) -> FutharkM a -> FutharkM a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Prog torep -> FutharkM a
c Prog torep
prog')
          FutharkM a -> (SomeException -> FutharkM a) -> FutharkM a
forall a. FutharkM a -> (SomeException -> FutharkM a) -> FutharkM a
`catchIO` Either (Prog (Aliases torep), TypeError torep) ()
-> (SomeException -> FutharkM a) -> SomeException -> FutharkM a
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 (IO a -> FutharkM a
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> FutharkM a)
-> (SomeException -> IO a) -> SomeException -> FutharkM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SomeException -> IO a
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' = Prog rep -> Prog (Aliases rep)
forall rep. AliasableRep rep => Prog rep -> Prog (Aliases rep)
Alias.aliasAnalysis Prog rep
prog
       in case Prog (Aliases rep) -> Either (TypeError rep) ()
forall rep.
Checkable rep =>
Prog (Aliases rep) -> Either (TypeError rep) ()
checkProg Prog (Aliases rep)
prog' of
            Left TypeError rep
err -> (Prog (Aliases rep), TypeError rep)
-> Either (Prog (Aliases rep), TypeError rep) ()
forall a b. a -> Either a b
Left (Prog (Aliases rep)
prog', TypeError rep
err)
            Right () -> () -> Either (Prog (Aliases rep), TypeError rep) ()
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
_ =
      Pass fromrep torep -> Prog rep -> String -> FutharkM a
forall rep fromrep torep a.
PrettyRep rep =>
Pass fromrep torep -> Prog rep -> String -> FutharkM a
validationError Pass fromrep torep
pass Prog rep
prog (String -> FutharkM a) -> String -> FutharkM a
forall a b. (a -> b) -> a -> b
$ a -> String
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

-- | Conditionally run pipeline if predicate is true.
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 a.
 PipelineConfig
 -> Prog rep -> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a))
-> Pipeline rep rep
forall fromrep torep.
(forall a.
 PipelineConfig
 -> Prog fromrep
 -> FutharkM ((Prog torep -> FutharkM a) -> FutharkM a))
-> Pipeline fromrep torep
Pipeline ((forall a.
  PipelineConfig
  -> Prog rep -> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a))
 -> Pipeline rep rep)
-> (forall a.
    PipelineConfig
    -> Prog rep -> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a))
-> Pipeline rep rep
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 -> FutharkM a) -> FutharkM a)
forall a.
PipelineConfig
-> Prog rep -> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a)
f PipelineConfig
cfg Prog rep
prog
      else ((Prog rep -> FutharkM a) -> FutharkM a)
-> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a)
forall a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Prog rep -> FutharkM a) -> FutharkM a)
 -> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a))
-> ((Prog rep -> FutharkM a) -> FutharkM a)
-> FutharkM ((Prog rep -> FutharkM a) -> FutharkM a)
forall a b. (a -> b) -> a -> b
$ \Prog rep -> FutharkM a
c -> Prog rep -> FutharkM a
c Prog rep
prog

-- | Create a pipeline from a list of passes.
passes ::
  (Checkable rep) =>
  [Pass rep rep] ->
  Pipeline rep rep
passes :: forall rep. Checkable rep => [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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. Pipeline a a
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 :: 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 =
  CompilerError -> FutharkM a
forall a. 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 :: 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) <- 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog torep
prog'