{-# LANGUAGE Strict #-}
module Futhark.Compiler
( runPipelineOnProgram,
runCompilerOnProgram,
dumpError,
handleWarnings,
prettyProgErrors,
module Futhark.Compiler.Program,
module Futhark.Compiler.Config,
readProgramFile,
readProgramFiles,
readProgramOrDie,
readUntypedProgram,
readUntypedProgramOrDie,
)
where
import Control.Monad
import Control.Monad.Except (MonadError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bifunctor (first)
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NE
import Data.Loc (Loc (..), posCoff, posFile)
import Data.Text.IO qualified as T
import Futhark.Analysis.Alias qualified as Alias
import Futhark.Compiler.Config
import Futhark.Compiler.Program
import Futhark.IR
import Futhark.IR.SOACS qualified as I
import Futhark.IR.TypeCheck qualified as I
import Futhark.Internalise
import Futhark.MonadFreshNames
import Futhark.Pipeline
import Futhark.Util.Log
import Futhark.Util.Pretty
import Language.Futhark qualified as E
import Language.Futhark.Semantic (includeToString)
import Language.Futhark.Warnings
import System.Exit (ExitCode (..), exitWith)
import System.IO
dumpError :: FutharkConfig -> CompilerError -> IO ()
dumpError :: FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
config CompilerError
err =
case CompilerError
err of
ExternalError Doc AnsiStyle
s -> do
Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr Doc AnsiStyle
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:"
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
" https://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. Please report this:"
Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
" 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a b. (a, b) -> a
fst (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose)
forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Handle -> Text -> IO ()
T.hPutStr Handle
stderr)
FilePath -> Text -> IO ()
T.writeFile
(forall a b. (a, b) -> b
snd (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config))
forall a b. (a -> b) -> a -> b
$ Text
info forall a. Semigroup a => a -> a -> a
<> Text
"\n"
runCompilerOnProgram ::
FutharkConfig ->
Pipeline I.SOACS rep ->
Action rep ->
FilePath ->
IO ()
runCompilerOnProgram :: forall rep.
FutharkConfig
-> Pipeline SOACS rep -> Action rep -> FilePath -> IO ()
runCompilerOnProgram FutharkConfig
config Pipeline SOACS rep
pipeline Action rep
action FilePath
file = do
Either CompilerError ()
res <- forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM FutharkM ()
compile forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config
case Either CompilerError ()
res of
Left CompilerError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
config CompilerError
err
forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
Right () ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
compile :: FutharkM ()
compile = do
Prog rep
prog <- forall torep.
FutharkConfig
-> Pipeline SOACS torep -> FilePath -> FutharkM (Prog torep)
runPipelineOnProgram FutharkConfig
config Pipeline SOACS rep
pipeline FilePath
file
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$
FilePath
"Running action " forall a. [a] -> [a] -> [a]
++ forall rep. Action rep -> FilePath
actionName Action rep
action
forall rep. Action rep -> Prog rep -> FutharkM ()
actionProcedure Action rep
action Prog rep
prog
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Done." :: String)
runPipelineOnProgram ::
FutharkConfig ->
Pipeline I.SOACS torep ->
FilePath ->
FutharkM (Prog torep)
runPipelineOnProgram :: forall torep.
FutharkConfig
-> Pipeline SOACS torep -> FilePath -> FutharkM (Prog torep)
runPipelineOnProgram FutharkConfig
config Pipeline SOACS torep
pipeline FilePath
file = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Reading and type-checking source program" :: String)
(Imports
prog_imports, VNameSource
namesrc) <-
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
config forall a b. (a -> b) -> a -> b
$
(\(Warnings
a, Imports
b, VNameSource
c) -> (Warnings
a, (Imports
b, VNameSource
c)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> FilePath -> m (Warnings, Imports, VNameSource)
readProgramFile (FutharkConfig -> [Name]
futharkEntryPoints FutharkConfig
config) FilePath
file
forall (m :: * -> *). MonadFreshNames m => VNameSource -> m ()
putNameSource VNameSource
namesrc
Prog SOACS
int_prog <- forall (m :: * -> *).
(MonadFreshNames m, MonadLogger m) =>
FutharkConfig -> Imports -> m (Prog SOACS)
internaliseProg FutharkConfig
config Imports
prog_imports
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Type-checking internalised program" :: String)
Prog SOACS -> FutharkM ()
typeCheckInternalProgram Prog SOACS
int_prog
forall fromrep torep.
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline Pipeline SOACS torep
pipeline PipelineConfig
pipeline_config Prog SOACS
int_prog
where
pipeline_config :: PipelineConfig
pipeline_config =
PipelineConfig
{ pipelineVerbose :: Bool
pipelineVerbose = forall a b. (a, b) -> a
fst (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose,
pipelineValidate :: Bool
pipelineValidate = FutharkConfig -> Bool
futharkTypeCheck FutharkConfig
config
}
typeCheckInternalProgram :: I.Prog I.SOACS -> FutharkM ()
typeCheckInternalProgram :: Prog SOACS -> FutharkM ()
typeCheckInternalProgram Prog SOACS
prog =
case forall rep.
Checkable rep =>
Prog (Aliases rep) -> Either (TypeError rep) ()
I.checkProg Prog (Aliases SOACS)
prog' of
Left TypeError SOACS
err -> forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> Doc AnsiStyle -> m a
internalErrorS (FilePath
"After internalisation:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show TypeError SOACS
err) (forall a ann. Pretty a => a -> Doc ann
pretty Prog (Aliases SOACS)
prog')
Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
prog' :: Prog (Aliases SOACS)
prog' = forall rep. AliasableRep rep => Prog rep -> Prog (Aliases rep)
Alias.aliasAnalysis Prog SOACS
prog
prettyProgErrors :: NE.NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors :: NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors = forall a. [Doc a] -> Doc a
stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ProgError -> Doc AnsiStyle
onError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Loc -> (FilePath, Int)
rep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a => a -> Loc
locOf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList
where
rep :: Loc -> (FilePath, Int)
rep Loc
NoLoc = (FilePath
"", Int
0)
rep (Loc Pos
p Pos
_) = (Pos -> FilePath
posFile Pos
p, Pos -> Int
posCoff Pos
p)
onError :: ProgError -> Doc AnsiStyle
onError (ProgError Loc
NoLoc Doc ()
msg) =
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
onError (ProgError Loc
loc Doc ()
msg) =
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (Doc AnsiStyle
"Error at " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Located a => a -> Text
locText (forall a. Located a => a -> SrcLoc
srclocOf Loc
loc))) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall a. Doc a -> Doc a -> Doc a
</> forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
onError (ProgWarning Loc
NoLoc Doc ()
msg) =
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
onError (ProgWarning Loc
loc Doc ()
msg) =
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Warning at " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Located a => a -> Text
locText (forall a. Located a => a -> SrcLoc
srclocOf Loc
loc)) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall a. Doc a -> Doc a -> Doc a
</> forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
throwOnProgError ::
MonadError CompilerError m =>
Either (NE.NonEmpty ProgError) a ->
m a
throwOnProgError :: forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgError) a -> m a
throwOnProgError =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a.
MonadError CompilerError m =>
Doc AnsiStyle -> m a
externalError forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors) forall (f :: * -> *) a. Applicative f => a -> f a
pure
readProgramFile ::
(MonadError CompilerError m, MonadIO m) =>
[I.Name] ->
FilePath ->
m (Warnings, Imports, VNameSource)
readProgramFile :: forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> FilePath -> m (Warnings, Imports, VNameSource)
readProgramFile [Name]
extra_eps =
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
readProgramFiles [Name]
extra_eps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
readProgramFiles ::
(MonadError CompilerError m, MonadIO m) =>
[I.Name] ->
[FilePath] ->
m (Warnings, Imports, VNameSource)
readProgramFiles :: forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
readProgramFiles [Name]
extra_eps =
forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgError) a -> m a
throwOnProgError forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name]
-> [FilePath]
-> IO
(Either (NonEmpty ProgError) (Warnings, Imports, VNameSource))
readLibrary [Name]
extra_eps
readUntypedProgram ::
(MonadError CompilerError m, MonadIO m) =>
FilePath ->
m [(String, E.UncheckedProg)]
readUntypedProgram :: forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
FilePath -> m [(FilePath, UncheckedProg)]
readUntypedProgram =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ImportName -> FilePath
includeToString)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgError) a -> m a
throwOnProgError
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath]
-> IO (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)])
readUntypedLibrary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
orDie :: MonadIO m => FutharkM a -> m a
orDie :: forall (m :: * -> *) a. MonadIO m => FutharkM a -> m a
orDie FutharkM a
m = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Either CompilerError a
res <- forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM FutharkM a
m Verbosity
NotVerbose
case Either CompilerError a
res of
Left CompilerError
err -> do
FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
newFutharkConfig CompilerError
err
forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
Right a
res' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res'
readProgramOrDie :: MonadIO m => FilePath -> m (Warnings, Imports, VNameSource)
readProgramOrDie :: forall (m :: * -> *).
MonadIO m =>
FilePath -> m (Warnings, Imports, VNameSource)
readProgramOrDie FilePath
file = forall (m :: * -> *) a. MonadIO m => FutharkM a -> m a
orDie forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> FilePath -> m (Warnings, Imports, VNameSource)
readProgramFile forall a. Monoid a => a
mempty FilePath
file
readUntypedProgramOrDie :: MonadIO m => FilePath -> m [(String, E.UncheckedProg)]
readUntypedProgramOrDie :: forall (m :: * -> *).
MonadIO m =>
FilePath -> m [(FilePath, UncheckedProg)]
readUntypedProgramOrDie FilePath
file = forall (m :: * -> *) a. MonadIO m => FutharkM a -> m a
orDie forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
FilePath -> m [(FilePath, UncheckedProg)]
readUntypedProgram FilePath
file
handleWarnings :: FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings :: forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
config FutharkM (Warnings, a)
m = do
(Warnings
ws, a
a) <- FutharkM (Warnings, a)
m
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkConfig -> Bool
futharkWarn FutharkConfig
config Bool -> Bool -> Bool
&& Warnings -> Bool
anyWarnings Warnings
ws) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr forall a b. (a -> b) -> a -> b
$ Warnings -> Doc AnsiStyle
prettyWarnings Warnings
ws
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkConfig -> Bool
futharkWerror FutharkConfig
config) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> m a
externalErrorS FilePath
"Treating above warnings as errors due to --Werror."
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a