{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Futhark.Compiler
(
runPipelineOnProgram
, runCompilerOnProgram
, FutharkConfig (..)
, newFutharkConfig
, dumpError
, module Futhark.Compiler.Program
, readProgram
, readLibrary
, readProgramOrDie
)
where
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Except
import System.Exit (exitWith, ExitCode(..))
import System.IO
import qualified Data.Text.IO as T
import qualified Futhark.Analysis.Alias as Alias
import Futhark.Internalise
import Futhark.Pipeline
import Futhark.MonadFreshNames
import Futhark.Representation.AST
import qualified Futhark.Representation.SOACS as I
import qualified Futhark.TypeCheck as I
import Futhark.Compiler.Program
import Futhark.Util.Log
import Futhark.Util.Pretty (prettyText)
data FutharkConfig = FutharkConfig
{ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose :: (Verbosity, Maybe FilePath)
, FutharkConfig -> Bool
futharkWarn :: Bool
, FutharkConfig -> Bool
futharkWerror :: Bool
, FutharkConfig -> Bool
futharkSafe :: Bool
}
newFutharkConfig :: FutharkConfig
newFutharkConfig :: FutharkConfig
newFutharkConfig = FutharkConfig :: (Verbosity, Maybe FilePath)
-> Bool -> Bool -> Bool -> FutharkConfig
FutharkConfig { futharkVerbose :: (Verbosity, Maybe FilePath)
futharkVerbose = (Verbosity
NotVerbose, Maybe FilePath
forall a. Maybe a
Nothing)
, futharkWarn :: Bool
futharkWarn = Bool
True
, futharkWerror :: Bool
futharkWerror = Bool
False
, futharkSafe :: Bool
futharkSafe = Bool
False
}
dumpError :: FutharkConfig -> CompilerError -> IO ()
dumpError :: FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
config CompilerError
err =
case CompilerError
err of
ExternalError Doc
s -> do
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> Text
forall a. Pretty a => a -> Text
prettyText Doc
s
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
""
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"If you find this error message confusing, uninformative, or wrong, please open an issue at\nhttps://github.com/diku-dk/futhark/issues."
InternalError Text
s Text
info ErrorClass
CompilerBug -> do
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Internal compiler error."
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Please report this at https://github.com/diku-dk/futhark/issues."
Text -> Text -> IO ()
report Text
s Text
info
InternalError Text
s Text
info ErrorClass
CompilerLimitation -> do
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Known compiler limitation encountered. Sorry."
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Revise your program or try a different Futhark compiler."
Text -> Text -> IO ()
report Text
s Text
info
where report :: Text -> Text -> IO ()
report Text
s Text
info = do
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(Text -> IO ())
-> (FilePath -> Text -> IO ()) -> Maybe FilePath -> Text -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Handle -> Text -> IO ()
T.hPutStr Handle
stderr) FilePath -> Text -> IO ()
T.writeFile
((Verbosity, Maybe FilePath) -> Maybe FilePath
forall a b. (a, b) -> b
snd (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config)) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
runCompilerOnProgram :: FutharkConfig
-> Pipeline I.SOACS lore
-> Action lore
-> FilePath
-> IO ()
runCompilerOnProgram :: FutharkConfig
-> Pipeline SOACS lore -> Action lore -> FilePath -> IO ()
runCompilerOnProgram FutharkConfig
config Pipeline SOACS lore
pipeline Action lore
action FilePath
file = do
Either CompilerError ()
res <- FutharkM () -> Verbosity -> IO (Either CompilerError ())
forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM FutharkM ()
compile (Verbosity -> IO (Either CompilerError ()))
-> Verbosity -> IO (Either CompilerError ())
forall a b. (a -> b) -> a -> b
$ (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst ((Verbosity, Maybe FilePath) -> Verbosity)
-> (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config
case Either CompilerError ()
res of
Left CompilerError
err -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
config CompilerError
err
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
Right () ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where compile :: FutharkM ()
compile = do
Prog lore
prog <- FutharkConfig
-> Pipeline SOACS lore -> FilePath -> FutharkM (Prog lore)
forall tolore.
FutharkConfig
-> Pipeline SOACS tolore -> FilePath -> FutharkM (Prog tolore)
runPipelineOnProgram FutharkConfig
config Pipeline SOACS lore
pipeline FilePath
file
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>Verbosity
NotVerbose) (Verbosity -> Bool)
-> ((Verbosity, Maybe FilePath) -> Verbosity)
-> (Verbosity, Maybe FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst ((Verbosity, Maybe FilePath) -> Bool)
-> (Verbosity, Maybe FilePath) -> Bool
forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath -> FutharkM ()) -> FilePath -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Running action " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Action lore -> FilePath
forall lore. Action lore -> FilePath
actionName Action lore
action
Action lore -> Prog lore -> FutharkM ()
forall lore. Action lore -> Prog lore -> FutharkM ()
actionProcedure Action lore
action Prog lore
prog
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>Verbosity
NotVerbose) (Verbosity -> Bool)
-> ((Verbosity, Maybe FilePath) -> Verbosity)
-> (Verbosity, Maybe FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst ((Verbosity, Maybe FilePath) -> Bool)
-> (Verbosity, Maybe FilePath) -> Bool
forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Done." :: String)
runPipelineOnProgram :: FutharkConfig
-> Pipeline I.SOACS tolore
-> FilePath
-> FutharkM (Prog tolore)
runPipelineOnProgram :: FutharkConfig
-> Pipeline SOACS tolore -> FilePath -> FutharkM (Prog tolore)
runPipelineOnProgram FutharkConfig
config Pipeline SOACS tolore
pipeline FilePath
file = do
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Reading and type-checking source program" :: String)
(Warnings
ws, Imports
prog_imports, VNameSource
namesrc) <- FilePath -> FutharkM (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
FilePath -> m (Warnings, Imports, VNameSource)
readProgram FilePath
file
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkConfig -> Bool
futharkWarn FutharkConfig
config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Warnings -> FilePath
forall a. Show a => a -> FilePath
show Warnings
ws
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkConfig -> Bool
futharkWerror FutharkConfig
config Bool -> Bool -> Bool
&& Warnings
ws Warnings -> Warnings -> Bool
forall a. Eq a => a -> a -> Bool
/= Warnings
forall a. Monoid a => a
mempty) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
FilePath -> FutharkM ()
forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> m a
externalErrorS FilePath
"Treating above warnings as errors due to --Werror."
VNameSource -> FutharkM ()
forall (m :: * -> *). MonadFreshNames m => VNameSource -> m ()
putNameSource VNameSource
namesrc
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Internalising program" :: String)
Prog SOACS
int_prog <- Bool -> Imports -> FutharkM (Prog SOACS)
forall (m :: * -> *).
MonadFreshNames m =>
Bool -> Imports -> m (Prog SOACS)
internaliseProg (FutharkConfig -> Bool
futharkSafe FutharkConfig
config) Imports
prog_imports
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Type-checking internalised program" :: String)
Prog SOACS -> FutharkM ()
typeCheckInternalProgram Prog SOACS
int_prog
Pipeline SOACS tolore
-> PipelineConfig -> Prog SOACS -> FutharkM (Prog tolore)
forall fromlore tolore.
Pipeline fromlore tolore
-> PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
runPasses Pipeline SOACS tolore
pipeline PipelineConfig
pipeline_config Prog SOACS
int_prog
where pipeline_config :: PipelineConfig
pipeline_config =
PipelineConfig :: Bool -> Bool -> PipelineConfig
PipelineConfig { pipelineVerbose :: Bool
pipelineVerbose = (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose
, pipelineValidate :: Bool
pipelineValidate = Bool
True
}
typeCheckInternalProgram :: I.Prog I.SOACS -> FutharkM ()
typeCheckInternalProgram :: Prog SOACS -> FutharkM ()
typeCheckInternalProgram Prog SOACS
prog =
case Prog (Aliases SOACS) -> Either (TypeError SOACS) ()
forall lore.
Checkable lore =>
Prog (Aliases lore) -> Either (TypeError lore) ()
I.checkProg Prog (Aliases SOACS)
prog' of
Left TypeError SOACS
err -> FilePath -> Maybe (Prog (Aliases SOACS)) -> FutharkM ()
forall t a. Pretty t => FilePath -> t -> FutharkM a
internalErrorS (FilePath
"After internalisation:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TypeError SOACS -> FilePath
forall a. Show a => a -> FilePath
show TypeError SOACS
err) (Prog (Aliases SOACS) -> Maybe (Prog (Aliases SOACS))
forall a. a -> Maybe a
Just Prog (Aliases SOACS)
prog')
Right () -> () -> FutharkM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where prog' :: Prog (Aliases SOACS)
prog' = Prog SOACS -> Prog (Aliases SOACS)
forall lore.
(Attributes lore, CanBeAliased (Op lore)) =>
Prog lore -> Prog (Aliases lore)
Alias.aliasAnalysis Prog SOACS
prog
readProgram :: (MonadError CompilerError m, MonadIO m) =>
FilePath -> m (Warnings, Imports, VNameSource)
readProgram :: FilePath -> m (Warnings, Imports, VNameSource)
readProgram = [FilePath] -> m (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[FilePath] -> m (Warnings, Imports, VNameSource)
readLibrary ([FilePath] -> m (Warnings, Imports, VNameSource))
-> (FilePath -> [FilePath])
-> FilePath
-> m (Warnings, Imports, VNameSource)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
readLibrary :: (MonadError CompilerError m, MonadIO m) =>
[FilePath] -> m (Warnings, Imports, VNameSource)
readLibrary :: [FilePath] -> m (Warnings, Imports, VNameSource)
readLibrary = Basis -> [FilePath] -> m (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
Basis -> [FilePath] -> m (Warnings, Imports, VNameSource)
readLibraryWithBasis Basis
emptyBasis
readProgramOrDie :: MonadIO m => FilePath -> m (Warnings, Imports, VNameSource)
readProgramOrDie :: FilePath -> m (Warnings, Imports, VNameSource)
readProgramOrDie FilePath
file = IO (Warnings, Imports, VNameSource)
-> m (Warnings, Imports, VNameSource)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Warnings, Imports, VNameSource)
-> m (Warnings, Imports, VNameSource))
-> IO (Warnings, Imports, VNameSource)
-> m (Warnings, Imports, VNameSource)
forall a b. (a -> b) -> a -> b
$ do
Either CompilerError (Warnings, Imports, VNameSource)
res <- FutharkM (Warnings, Imports, VNameSource)
-> Verbosity
-> IO (Either CompilerError (Warnings, Imports, VNameSource))
forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM (FilePath -> FutharkM (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
FilePath -> m (Warnings, Imports, VNameSource)
readProgram FilePath
file) Verbosity
NotVerbose
case Either CompilerError (Warnings, Imports, VNameSource)
res of
Left CompilerError
err -> do
FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
newFutharkConfig CompilerError
err
ExitCode -> IO (Warnings, Imports, VNameSource)
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO (Warnings, Imports, VNameSource))
-> ExitCode -> IO (Warnings, Imports, VNameSource)
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
Right (Warnings, Imports, VNameSource)
res' -> (Warnings, Imports, VNameSource)
-> IO (Warnings, Imports, VNameSource)
forall (m :: * -> *) a. Monad m => a -> m a
return (Warnings, Imports, VNameSource)
res'