{-# 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
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 {k} (rep :: k).
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 {k} (torep :: k).
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 {k} (rep :: k). Action rep -> FilePath
actionName Action rep
action
forall {k} (rep :: k). 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 {k} (torep :: k).
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 {k1} {k2} (fromrep :: k1) (torep :: k2).
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 {k} (rep :: k).
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 {k} (rep :: k).
(ASTRep rep, CanBeAliased (Op 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