{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
module Fusion.Plugin
(
plugin
)
where
#if MIN_VERSION_ghc(8,6,0)
import Control.Monad (mzero, when, unless)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State
import Data.Char (isSpace)
import Data.Maybe (mapMaybe)
import Data.Generics.Schemes (everywhere)
import Data.Generics.Aliases (mkT)
import Data.IORef (readIORef, writeIORef)
import Data.Time (getCurrentTime)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory)
import System.IO (Handle, IOMode(..), withFile, hSetEncoding, utf8)
import Text.Printf (printf)
import ErrUtils (mkDumpDoc, Severity(..))
import PprCore (pprCoreBindingsWithSize, pprRules)
import qualified Data.List as DL
import qualified Data.Set as Set
#endif
import GhcPlugins
import Fusion.Plugin.Types (Fuse(..))
#if MIN_VERSION_ghc(8,6,0)
data Options = Options
{ Options -> Bool
optionsDumpCore :: Bool
, Options -> ReportMode
optionsVerbosityLevel :: ReportMode
} deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: Bool -> ReportMode -> Options
Options
{ optionsDumpCore :: Bool
optionsDumpCore = Bool
False
, optionsVerbosityLevel :: ReportMode
optionsVerbosityLevel = ReportMode
ReportSilent
}
setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m ()
setDumpCore :: Bool -> StateT ([String], Options) m ()
setDumpCore Bool
val = do
([String]
args, Options
opts) <- StateT ([String], Options) m ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
([String], Options) -> StateT ([String], Options) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([String]
args, Options
opts { optionsDumpCore :: Bool
optionsDumpCore = Bool
val })
setVerbosityLevel :: Monad m
=> ReportMode -> StateT ([CommandLineOption], Options) m ()
setVerbosityLevel :: ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
val = do
([String]
args, Options
opts) <- StateT ([String], Options) m ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
([String], Options) -> StateT ([String], Options) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([String]
args, Options
opts { optionsVerbosityLevel :: ReportMode
optionsVerbosityLevel = ReportMode
val })
shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
shift = do
([String], Options)
s <- StateT ([String], Options) (MaybeT IO) ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
case ([String], Options)
s of
([], Options
_) -> Maybe String
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
(String
x : [String]
xs, Options
opts) -> ([String], Options) -> StateT ([String], Options) (MaybeT IO) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([String]
xs, Options
opts) StateT ([String], Options) (MaybeT IO) ()
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
x)
parseOptions :: [CommandLineOption] -> IO Options
parseOptions :: [String] -> IO Options
parseOptions [String]
args = do
Maybe Options
maybeOptions <- MaybeT IO Options -> IO (Maybe Options)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
(MaybeT IO Options -> IO (Maybe Options))
-> MaybeT IO Options -> IO (Maybe Options)
forall a b. (a -> b) -> a -> b
$ (StateT ([String], Options) (MaybeT IO) Options
-> ([String], Options) -> MaybeT IO Options)
-> ([String], Options)
-> StateT ([String], Options) (MaybeT IO) Options
-> MaybeT IO Options
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT ([String], Options) (MaybeT IO) Options
-> ([String], Options) -> MaybeT IO Options
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ([String]
args, Options
defaultOptions)
(StateT ([String], Options) (MaybeT IO) Options
-> MaybeT IO Options)
-> StateT ([String], Options) (MaybeT IO) Options
-> MaybeT IO Options
forall a b. (a -> b) -> a -> b
$ do StateT ([String], Options) (MaybeT IO) ()
parseLoop
(([String], Options) -> Options)
-> StateT ([String], Options) (MaybeT IO) ([String], Options)
-> StateT ([String], Options) (MaybeT IO) Options
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String], Options) -> Options
forall a b. (a, b) -> b
snd StateT ([String], Options) (MaybeT IO) ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
Options -> IO Options
forall (m :: * -> *) a. Monad m => a -> m a
return (Options -> IO Options) -> Options -> IO Options
forall a b. (a -> b) -> a -> b
$ Options -> (Options -> Options) -> Maybe Options -> Options
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Options
defaultOptions Options -> Options
forall a. a -> a
id Maybe Options
maybeOptions
where
parseOpt :: String -> StateT ([String], Options) m ()
parseOpt String
opt =
case String
opt of
String
"dump-core" -> Bool -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
Bool -> StateT ([String], Options) m ()
setDumpCore Bool
True
String
"verbose=1" -> ReportMode -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportWarn
String
"verbose=2" -> ReportMode -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose
String
"verbose=3" -> ReportMode -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose1
String
"verbose=4" -> ReportMode -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose2
String
str -> do
IO () -> StateT ([String], Options) m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO () -> StateT ([String], Options) m ())
-> IO () -> StateT ([String], Options) m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: Unrecognized option - \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
StateT ([String], Options) m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
parseLoop :: StateT ([String], Options) (MaybeT IO) ()
parseLoop = do
Maybe String
next <- StateT ([String], Options) (MaybeT IO) (Maybe String)
shift
case Maybe String
next of
Just String
opt -> String -> StateT ([String], Options) (MaybeT IO) ()
forall (m :: * -> *).
(MonadIO m, MonadPlus m) =>
String -> StateT ([String], Options) m ()
parseOpt String
opt StateT ([String], Options) (MaybeT IO) ()
-> StateT ([String], Options) (MaybeT IO) ()
-> StateT ([String], Options) (MaybeT IO) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT ([String], Options) (MaybeT IO) ()
parseLoop
Maybe String
Nothing -> () -> StateT ([String], Options) (MaybeT IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
unfoldCompulsory :: Arity -> Unfolding -> Unfolding
unfoldCompulsory :: Int -> Unfolding -> Unfolding
unfoldCompulsory Int
arity cuf :: Unfolding
cuf@CoreUnfolding{} =
Unfolding
cuf {uf_src :: UnfoldingSource
uf_src=UnfoldingSource
InlineStable, uf_guidance :: UnfoldingGuidance
uf_guidance = Int -> Bool -> Bool -> UnfoldingGuidance
UnfWhen Int
arity Bool
True Bool
True}
unfoldCompulsory Int
_ Unfolding
x = Unfolding
x
setAlwaysInlineOnBndr :: CoreBndr -> CoreBndr
setAlwaysInlineOnBndr :: CoreBndr -> CoreBndr
setAlwaysInlineOnBndr CoreBndr
n =
let info :: IdInfo
info =
case IdInfo -> Maybe IdInfo
zapUsageInfo (IdInfo -> Maybe IdInfo) -> IdInfo -> Maybe IdInfo
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
n of
Just IdInfo
i -> IdInfo
i
Maybe IdInfo
Nothing ->
String -> IdInfo
forall a. HasCallStack => String -> a
error String
"The impossible happened!! Or GHC changed their api."
unf :: Unfolding
unf = IdInfo -> Unfolding
unfoldingInfo IdInfo
info
info' :: IdInfo
info' =
IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo
(IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo IdInfo
info InlinePragma
alwaysInlinePragma)
(Int -> Unfolding -> Unfolding
unfoldCompulsory (IdInfo -> Int
arityInfo IdInfo
info) Unfolding
unf)
in CoreBndr -> IdInfo -> CoreBndr
lazySetIdInfo CoreBndr
n IdInfo
info'
setInlineOnBndrs :: [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs :: [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs [CoreBndr]
bndrs = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((forall a. Data a => a -> a) -> forall a. Data a => a -> a)
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall a b. (a -> b) -> a -> b
$ (CoreBind -> CoreBind) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT CoreBind -> CoreBind
go
where
go :: CoreBind -> CoreBind
go :: CoreBind -> CoreBind
go (NonRec CoreBndr
b Expr CoreBndr
expr) | (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CoreBndr
b CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
==) [CoreBndr]
bndrs =
CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (CoreBndr -> CoreBndr
setAlwaysInlineOnBndr CoreBndr
b) Expr CoreBndr
expr
go CoreBind
x = CoreBind
x
hasInlineBinder :: CoreBndr -> Bool
hasInlineBinder :: CoreBndr -> Bool
hasInlineBinder CoreBndr
bndr =
let inl :: InlinePragma
inl = IdInfo -> InlinePragma
inlinePragInfo (IdInfo -> InlinePragma) -> IdInfo -> InlinePragma
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
bndr
in InlinePragma -> Bool
isInlinePragma InlinePragma
inl Bool -> Bool -> Bool
&& Int -> Activation -> Bool
isActiveIn Int
0 (InlinePragma -> Activation
inlinePragmaActivation InlinePragma
inl)
altsContainsAnn :: UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn :: UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn UniqFM [Fuse]
_ [] = Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
altsContainsAnn UniqFM [Fuse]
anns (bndr :: Alt CoreBndr
bndr@(DataAlt DataCon
dcon, [CoreBndr]
_, Expr CoreBndr
_):[Alt CoreBndr]
_) =
case UniqFM [Fuse] -> Unique -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Fuse]
anns (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Unique) -> TyCon -> Unique
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dcon) of
Maybe [Fuse]
Nothing -> Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
Just [Fuse]
_ -> Alt CoreBndr -> Maybe (Alt CoreBndr)
forall a. a -> Maybe a
Just Alt CoreBndr
bndr
altsContainsAnn UniqFM [Fuse]
anns ((AltCon
DEFAULT, [CoreBndr]
_, Expr CoreBndr
_):[Alt CoreBndr]
alts) = UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn UniqFM [Fuse]
anns [Alt CoreBndr]
alts
altsContainsAnn UniqFM [Fuse]
_ [Alt CoreBndr]
_ = Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
needInlineCaseAlt
:: CoreBind -> UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
needInlineCaseAlt :: CoreBind -> UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
needInlineCaseAlt CoreBind
parent UniqFM [Fuse]
anns [Alt CoreBndr]
bndr =
case UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn UniqFM [Fuse]
anns [Alt CoreBndr]
bndr of
Just Alt CoreBndr
alt | Bool -> Bool
not (CoreBndr -> Bool
hasInlineBinder (CoreBndr -> Bool) -> CoreBndr -> Bool
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder CoreBind
parent) -> Alt CoreBndr -> Maybe (Alt CoreBndr)
forall a. a -> Maybe a
Just Alt CoreBndr
alt
Maybe (Alt CoreBndr)
_ -> Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
letBndrsThatAreCases
:: UniqFM [Fuse]
-> CoreBind
-> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases UniqFM [Fuse]
anns CoreBind
bind = [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [] CoreBind
bind
where
go :: [CoreBind] -> Bool -> CoreExpr -> [([CoreBind], Alt CoreBndr)]
go :: [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
True (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
let binders :: [([CoreBind], Alt CoreBndr)]
binders = [Alt CoreBndr]
alts [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], Alt CoreBndr)])
-> [([CoreBind], Alt CoreBndr)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(AltCon
_, [CoreBndr]
_, Expr CoreBndr
expr1) -> [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1)
in case CoreBind -> UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
needInlineCaseAlt ([CoreBind] -> CoreBind
forall a. [a] -> a
head [CoreBind]
parents) UniqFM [Fuse]
anns [Alt CoreBndr]
alts of
Just Alt CoreBndr
x -> ([CoreBind]
parents, Alt CoreBndr
x) ([CoreBind], Alt CoreBndr)
-> [([CoreBind], Alt CoreBndr)] -> [([CoreBind], Alt CoreBndr)]
forall a. a -> [a] -> [a]
: [([CoreBind], Alt CoreBndr)]
binders
Maybe (Alt CoreBndr)
Nothing -> [([CoreBind], Alt CoreBndr)]
binders
go [CoreBind]
parents Bool
False (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
[Alt CoreBndr]
alts [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], Alt CoreBndr)])
-> [([CoreBind], Alt CoreBndr)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(AltCon
_, [CoreBndr]
_, Expr CoreBndr
expr1) -> [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1)
go [CoreBind]
parents Bool
_ (Let CoreBind
bndr Expr CoreBndr
expr1) = [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [CoreBind]
parents CoreBind
bndr
[([CoreBind], Alt CoreBndr)]
-> [([CoreBind], Alt CoreBndr)] -> [([CoreBind], Alt CoreBndr)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1
go [CoreBind]
parents Bool
_ (App Expr CoreBndr
expr1 Expr CoreBndr
expr2) = [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1
[([CoreBind], Alt CoreBndr)]
-> [([CoreBind], Alt CoreBndr)] -> [([CoreBind], Alt CoreBndr)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr2
go [CoreBind]
parents Bool
x (Lam CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
x Expr CoreBndr
expr1
go [CoreBind]
parents Bool
_ (Cast Expr CoreBndr
expr1 Coercion
_) = [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1
go [CoreBind]
_ Bool
_ (Var CoreBndr
_) = []
go [CoreBind]
_ Bool
_ (Lit Literal
_) = []
go [CoreBind]
_ Bool
_ (Tick Tickish CoreBndr
_ Expr CoreBndr
_) = []
go [CoreBind]
_ Bool
_ (Type Type
_) = []
go [CoreBind]
_ Bool
_ (Coercion Coercion
_) = []
goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [CoreBind]
parents bndr :: CoreBind
bndr@(NonRec CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go (CoreBind
bndr CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
parents) Bool
True Expr CoreBndr
expr1
goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
[(CoreBndr, Expr CoreBndr)]
bs [(CoreBndr, Expr CoreBndr)]
-> ((CoreBndr, Expr CoreBndr) -> [([CoreBind], Alt CoreBndr)])
-> [([CoreBind], Alt CoreBndr)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CoreBndr
b, Expr CoreBndr
expr1) -> [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [CoreBind]
parents (CoreBind -> [([CoreBind], Alt CoreBndr)])
-> CoreBind -> [([CoreBind], Alt CoreBndr)]
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)
needInlineConstr :: CoreBind -> UniqFM [Fuse] -> DataCon -> Bool
needInlineConstr :: CoreBind -> UniqFM [Fuse] -> DataCon -> Bool
needInlineConstr CoreBind
parent UniqFM [Fuse]
anns DataCon
dcon =
case UniqFM [Fuse] -> Unique -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Fuse]
anns (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Unique) -> TyCon -> Unique
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dcon) of
Just [Fuse]
_ | Bool -> Bool
not (CoreBndr -> Bool
hasInlineBinder (CoreBndr -> Bool) -> CoreBndr -> Bool
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder CoreBind
parent) -> Bool
True
Maybe [Fuse]
_ -> Bool
False
constructingBinders :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], DataCon)]
constructingBinders :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], DataCon)]
constructingBinders UniqFM [Fuse]
anns CoreBind
bind = [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
goLet [] CoreBind
bind
where
go :: [CoreBind] -> CoreExpr -> [([CoreBind], DataCon)]
go :: [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents (Let CoreBind
bndr Expr CoreBndr
expr1) = [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
goLet [CoreBind]
parents CoreBind
bndr [([CoreBind], DataCon)]
-> [([CoreBind], DataCon)] -> [([CoreBind], DataCon)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
[Alt CoreBndr]
alts [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], DataCon)])
-> [([CoreBind], DataCon)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(AltCon
_, [CoreBndr]
_, Expr CoreBndr
expr1) -> [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1)
go [CoreBind]
parents (App Expr CoreBndr
expr1 Expr CoreBndr
expr2) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1 [([CoreBind], DataCon)]
-> [([CoreBind], DataCon)] -> [([CoreBind], DataCon)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr2
go [CoreBind]
parents (Lam CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (Cast Expr CoreBndr
expr1 Coercion
_) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (Var CoreBndr
i) =
let needInline :: DataCon -> Bool
needInline = CoreBind -> UniqFM [Fuse] -> DataCon -> Bool
needInlineConstr ([CoreBind] -> CoreBind
forall a. [a] -> a
head [CoreBind]
parents) UniqFM [Fuse]
anns
in case CoreBndr -> IdDetails
idDetails CoreBndr
i of
DataConWorkId DataCon
dcon | DataCon -> Bool
needInline DataCon
dcon -> [([CoreBind]
parents, DataCon
dcon)]
IdDetails
_ -> []
go [CoreBind]
_ (Lit Literal
_) = []
go [CoreBind]
_ (Tick Tickish CoreBndr
_ Expr CoreBndr
_) = []
go [CoreBind]
_ (Type Type
_) = []
go [CoreBind]
_ (Coercion Coercion
_) = []
goLet :: [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
goLet :: [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
goLet [CoreBind]
parents bndr :: CoreBind
bndr@(NonRec CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go (CoreBind
bndr CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
parents) Expr CoreBndr
expr1
goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
[(CoreBndr, Expr CoreBndr)]
bs [(CoreBndr, Expr CoreBndr)]
-> ((CoreBndr, Expr CoreBndr) -> [([CoreBind], DataCon)])
-> [([CoreBind], DataCon)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CoreBndr
b, Expr CoreBndr
expr1) -> [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
goLet [CoreBind]
parents (CoreBind -> [([CoreBind], DataCon)])
-> CoreBind -> [([CoreBind], DataCon)]
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)
data Context = CaseAlt (Alt CoreBndr) | Constr DataCon
containsAnns :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns UniqFM [Fuse]
anns CoreBind
bind =
[CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet [] CoreBind
bind
where
go :: [CoreBind] -> CoreExpr -> [([CoreBind], Context)]
go :: [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
let binders :: [([CoreBind], Context)]
binders = [Alt CoreBndr]
alts [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], Context)])
-> [([CoreBind], Context)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(AltCon
_, [CoreBndr]
_, Expr CoreBndr
expr1) -> [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1)
in case UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn UniqFM [Fuse]
anns [Alt CoreBndr]
alts of
Just Alt CoreBndr
x -> ([CoreBind]
parents, Alt CoreBndr -> Context
CaseAlt Alt CoreBndr
x) ([CoreBind], Context)
-> [([CoreBind], Context)] -> [([CoreBind], Context)]
forall a. a -> [a] -> [a]
: [([CoreBind], Context)]
binders
Maybe (Alt CoreBndr)
Nothing -> [([CoreBind], Context)]
binders
go [CoreBind]
parents (Let CoreBind
bndr Expr CoreBndr
expr1) = [CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet [CoreBind]
parents CoreBind
bndr [([CoreBind], Context)]
-> [([CoreBind], Context)] -> [([CoreBind], Context)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (App Expr CoreBndr
expr1 Expr CoreBndr
expr2) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1 [([CoreBind], Context)]
-> [([CoreBind], Context)] -> [([CoreBind], Context)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr2
go [CoreBind]
parents (Lam CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (Cast Expr CoreBndr
expr1 Coercion
_) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (Var CoreBndr
i) =
case CoreBndr -> IdDetails
idDetails CoreBndr
i of
DataConWorkId DataCon
dcon ->
case UniqFM [Fuse] -> Unique -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Fuse]
anns (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Unique) -> TyCon -> Unique
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dcon) of
Just [Fuse]
_ -> [([CoreBind]
parents, DataCon -> Context
Constr DataCon
dcon)]
Maybe [Fuse]
Nothing -> []
IdDetails
_ -> []
go [CoreBind]
_ (Lit Literal
_) = []
go [CoreBind]
_ (Tick Tickish CoreBndr
_ Expr CoreBndr
_) = []
go [CoreBind]
_ (Type Type
_) = []
go [CoreBind]
_ (Coercion Coercion
_) = []
goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet [CoreBind]
parents bndr :: CoreBind
bndr@(NonRec CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go (CoreBind
bndr CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
parents) Expr CoreBndr
expr1
goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
[(CoreBndr, Expr CoreBndr)]
bs [(CoreBndr, Expr CoreBndr)]
-> ((CoreBndr, Expr CoreBndr) -> [([CoreBind], Context)])
-> [([CoreBind], Context)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CoreBndr
b, Expr CoreBndr
expr1) -> [CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet [CoreBind]
parents (CoreBind -> [([CoreBind], Context)])
-> CoreBind -> [([CoreBind], Context)]
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)
data ReportMode =
ReportSilent
| ReportWarn
| ReportVerbose
| ReportVerbose1
| ReportVerbose2
deriving (Int -> ReportMode -> ShowS
[ReportMode] -> ShowS
ReportMode -> String
(Int -> ReportMode -> ShowS)
-> (ReportMode -> String)
-> ([ReportMode] -> ShowS)
-> Show ReportMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReportMode] -> ShowS
$cshowList :: [ReportMode] -> ShowS
show :: ReportMode -> String
$cshow :: ReportMode -> String
showsPrec :: Int -> ReportMode -> ShowS
$cshowsPrec :: Int -> ReportMode -> ShowS
Show)
getNonRecBinder :: CoreBind -> CoreBndr
getNonRecBinder :: CoreBind -> CoreBndr
getNonRecBinder (NonRec CoreBndr
b Expr CoreBndr
_) = CoreBndr
b
getNonRecBinder (Rec [(CoreBndr, Expr CoreBndr)]
_) = String -> CoreBndr
forall a. HasCallStack => String -> a
error String
"markInline: expecting only nonrec binders"
addMissingUnique :: (Outputable a, Uniquable a) => DynFlags -> a -> String
addMissingUnique :: DynFlags -> a -> String
addMissingUnique DynFlags
dflags a
bndr =
let suffix :: String
suffix = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (a -> Unique
forall a. Uniquable a => a -> Unique
getUnique a
bndr)
bndrName :: String
bndrName = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
bndr
in if String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
DL.isSuffixOf String
suffix String
bndrName
then String
bndrName
else String
bndrName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix
listPath :: DynFlags -> [CoreBind] -> [Char]
listPath :: DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds =
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
DL.intercalate String
"/"
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (CoreBndr -> String) -> [CoreBndr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> CoreBndr -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
addMissingUnique DynFlags
dflags)
([CoreBndr] -> [String]) -> [CoreBndr] -> [String]
forall a b. (a -> b) -> a -> b
$ (CoreBind -> CoreBndr) -> [CoreBind] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map CoreBind -> CoreBndr
getNonRecBinder [CoreBind]
binds
showDetailsCaseMatch
:: DynFlags
-> ReportMode
-> ([CoreBind], Alt CoreBndr)
-> String
showDetailsCaseMatch :: DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String
showDetailsCaseMatch DynFlags
dflags ReportMode
reportMode ([CoreBind]
binds, c :: Alt CoreBndr
c@(AltCon
con,[CoreBndr]
_,Expr CoreBndr
_)) =
DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++
case ReportMode
reportMode of
ReportMode
ReportVerbose -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con)
ReportMode
ReportVerbose1 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Alt CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Alt CoreBndr
c)
ReportMode
ReportVerbose2 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBind -> SDoc) -> CoreBind -> SDoc
forall a b. (a -> b) -> a -> b
$ [CoreBind] -> CoreBind
forall a. [a] -> a
head [CoreBind]
binds)
ReportMode
_ -> ShowS
forall a. HasCallStack => String -> a
error String
"transformBind: unreachable"
showDetailsConstr
:: DynFlags
-> ReportMode
-> ([CoreBind], DataCon)
-> String
showDetailsConstr :: DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String
showDetailsConstr DynFlags
dflags ReportMode
reportMode ([CoreBind]
binds, DataCon
con) =
DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++
case ReportMode
reportMode of
ReportMode
ReportVerbose -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con)
ReportMode
ReportVerbose1 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con)
ReportMode
ReportVerbose2 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBind -> SDoc) -> CoreBind -> SDoc
forall a b. (a -> b) -> a -> b
$ [CoreBind] -> CoreBind
forall a. [a] -> a
head [CoreBind]
binds)
ReportMode
_ -> ShowS
forall a. HasCallStack => String -> a
error String
"transformBind: unreachable"
showInfo
:: CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo :: CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
parent DynFlags
dflags ReportMode
reportMode Bool
failIt
String
tag [CoreBndr]
uniqBinders [([CoreBind], a)]
annotated DynFlags -> ReportMode -> ([CoreBind], a) -> String
showDetails =
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([CoreBndr]
uniqBinders [CoreBndr] -> [CoreBndr] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
let msg :: String
msg = String
"In "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> CoreBndr -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
addMissingUnique DynFlags
dflags CoreBndr
parent
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" binders "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((CoreBndr -> String) -> [CoreBndr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> CoreBndr -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
addMissingUnique DynFlags
dflags) ([CoreBndr]
uniqBinders))
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tag
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" data types annotated with "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Fuse -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fuse
Fuse)
case ReportMode
reportMode of
ReportMode
ReportSilent -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ReportMode
ReportWarn -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ReportMode
_ -> do
String -> CoreM ()
putMsgS String
msg
String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
DL.nub
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (([CoreBind], a) -> String) -> [([CoreBind], a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ReportMode -> ([CoreBind], a) -> String
showDetails DynFlags
dflags ReportMode
reportMode) [([CoreBind], a)]
annotated
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
failIt (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String -> CoreM ()
forall a. HasCallStack => String -> a
error String
"failing"
markInline :: ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline :: ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline ReportMode
reportMode Bool
failIt Bool
transform ModGuts
guts = do
String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: Checking bindings to inline..."
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
UniqFM [Fuse]
anns <- ([Word8] -> Fuse) -> ModGuts -> CoreM (UniqFM [Fuse])
forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
getAnnotations [Word8] -> Fuse
forall a. Data a => [Word8] -> a
deserializeWithData ModGuts
guts
if (([Fuse] -> Bool) -> UniqFM [Fuse] -> Bool
forall elt. (elt -> Bool) -> UniqFM elt -> Bool
anyUFM ((Fuse -> Bool) -> [Fuse] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Fuse -> Fuse -> Bool
forall a. Eq a => a -> a -> Bool
== Fuse
Fuse)) UniqFM [Fuse]
anns)
then ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts
bindsOnlyPass ((CoreBind -> CoreM CoreBind) -> [CoreBind] -> CoreM [CoreBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM [Fuse]
anns)) ModGuts
guts
else ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
where
transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind
transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM [Fuse]
anns bind :: CoreBind
bind@(NonRec CoreBndr
b Expr CoreBndr
_) = do
let patternMatches :: [([CoreBind], Alt CoreBndr)]
patternMatches = UniqFM [Fuse] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases UniqFM [Fuse]
anns CoreBind
bind
let uniqPat :: [CoreBndr]
uniqPat = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], Alt CoreBndr) -> CoreBndr)
-> [([CoreBind], Alt CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder(CoreBind -> CoreBndr)
-> (([CoreBind], Alt CoreBndr) -> CoreBind)
-> ([CoreBind], Alt CoreBndr)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> ([CoreBind], Alt CoreBndr)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst) [([CoreBind], Alt CoreBndr)]
patternMatches)
let constrs :: [([CoreBind], DataCon)]
constrs = UniqFM [Fuse] -> CoreBind -> [([CoreBind], DataCon)]
constructingBinders UniqFM [Fuse]
anns CoreBind
bind
let uniqConstr :: [CoreBndr]
uniqConstr = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], DataCon) -> CoreBndr)
-> [([CoreBind], DataCon)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder(CoreBind -> CoreBndr)
-> (([CoreBind], DataCon) -> CoreBind)
-> ([CoreBind], DataCon)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], DataCon) -> [CoreBind])
-> ([CoreBind], DataCon)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], DataCon) -> [CoreBind]
forall a b. (a, b) -> a
fst) [([CoreBind], DataCon)]
constrs)
case ReportMode
reportMode of
ReportMode
ReportSilent -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ReportMode
ReportWarn -> do
let allBinds :: [[CoreBind]]
allBinds = (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> [([CoreBind], Alt CoreBndr)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], Alt CoreBndr)]
patternMatches [[CoreBind]] -> [[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a] -> [a]
++ (([CoreBind], DataCon) -> [CoreBind])
-> [([CoreBind], DataCon)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], DataCon) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], DataCon)]
constrs
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [[CoreBind]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[CoreBind]]
allBinds) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
String -> CoreM ()
putMsgS String
"INLINE required on:"
String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
DL.nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([CoreBind] -> String) -> [[CoreBind]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags) [[CoreBind]]
allBinds
ReportMode
_ -> do
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], Alt CoreBndr)]
-> (DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String)
-> CoreM ()
forall a.
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
b DynFlags
dflags ReportMode
reportMode Bool
failIt String
"SCRUTINIZE"
[CoreBndr]
uniqPat [([CoreBind], Alt CoreBndr)]
patternMatches DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String
showDetailsCaseMatch
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], DataCon)]
-> (DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String)
-> CoreM ()
forall a.
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
b DynFlags
dflags ReportMode
reportMode Bool
failIt String
"CONSTRUCT"
[CoreBndr]
uniqConstr [([CoreBind], DataCon)]
constrs DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String
showDetailsConstr
let bind' :: CoreBind
bind' = do
let allBinders :: [CoreBndr]
allBinders = [CoreBndr]
uniqPat [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
uniqConstr
if Bool
transform Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
allBinders)
then [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs [CoreBndr]
allBinders CoreBind
bind
else CoreBind
bind
CoreBind -> CoreM CoreBind
forall (m :: * -> *) a. Monad m => a -> m a
return CoreBind
bind'
transformBind DynFlags
dflags UniqFM [Fuse]
anns (Rec [(CoreBndr, Expr CoreBndr)]
bs) = do
([(CoreBndr, Expr CoreBndr)] -> CoreBind)
-> CoreM [(CoreBndr, Expr CoreBndr)] -> CoreM CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec (((CoreBndr, Expr CoreBndr) -> CoreM (CoreBndr, Expr CoreBndr))
-> [(CoreBndr, Expr CoreBndr)] -> CoreM [(CoreBndr, Expr CoreBndr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CoreBndr, Expr CoreBndr) -> CoreM (CoreBndr, Expr CoreBndr)
transformAsNonRec [(CoreBndr, Expr CoreBndr)]
bs)
where
transformAsNonRec :: (CoreBndr, Expr CoreBndr) -> CoreM (CoreBndr, Expr CoreBndr)
transformAsNonRec (CoreBndr
b, Expr CoreBndr
expr) = do
CoreBind
r <- DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM [Fuse]
anns (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr)
case CoreBind
r of
NonRec CoreBndr
b1 Expr CoreBndr
expr1 -> (CoreBndr, Expr CoreBndr) -> CoreM (CoreBndr, Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr
b1, Expr CoreBndr
expr1)
CoreBind
_ -> String -> CoreM (CoreBndr, Expr CoreBndr)
forall a. HasCallStack => String -> a
error String
"Bug: expecting NonRec binder"
fusionMarkInline :: ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline :: ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
opt Bool
failIt Bool
transform =
String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
"Mark for inlining" (ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline ReportMode
opt Bool
failIt Bool
transform)
fusionSimplify :: DynFlags -> CoreToDo
fusionSimplify :: DynFlags -> CoreToDo
fusionSimplify DynFlags
dflags =
Int -> SimplMode -> CoreToDo
CoreDoSimplify
(DynFlags -> Int
maxSimplIterations DynFlags
dflags)
SimplMode :: [String]
-> CompilerPhase
-> DynFlags
-> Bool
-> Bool
-> Bool
-> Bool
-> SimplMode
SimplMode
{ sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
, sm_names :: [String]
sm_names = [String
"Fusion Plugin Inlining"]
, sm_dflags :: DynFlags
sm_dflags = DynFlags
dflags
, sm_rules :: Bool
sm_rules = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags
, sm_eta_expand :: Bool
sm_eta_expand = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion DynFlags
dflags
, sm_inline :: Bool
sm_inline = Bool
True
, sm_case_case :: Bool
sm_case_case = Bool
True
}
fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
msg ReportMode
reportMode ModGuts
guts = do
String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
UniqFM [Fuse]
anns <- ([Word8] -> Fuse) -> ModGuts -> CoreM (UniqFM [Fuse])
forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
getAnnotations [Word8] -> Fuse
forall a. Data a => [Word8] -> a
deserializeWithData ModGuts
guts
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (([Fuse] -> Bool) -> UniqFM [Fuse] -> Bool
forall elt. (elt -> Bool) -> UniqFM elt -> Bool
anyUFM ((Fuse -> Bool) -> [Fuse] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Fuse -> Fuse -> Bool
forall a. Eq a => a -> a -> Bool
== Fuse
Fuse)) UniqFM [Fuse]
anns) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
(CoreBind -> CoreM ()) -> [CoreBind] -> CoreM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM [Fuse]
anns) ([CoreBind] -> CoreM ()) -> [CoreBind] -> CoreM ()
forall a b. (a -> b) -> a -> b
$ ModGuts -> [CoreBind]
mg_binds ModGuts
guts
ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
where
transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM ()
transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM [Fuse]
anns bind :: CoreBind
bind@(NonRec CoreBndr
b Expr CoreBndr
_) = do
let results :: [([CoreBind], Context)]
results = UniqFM [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns UniqFM [Fuse]
anns CoreBind
bind
let getAlts :: (a, Context) -> Maybe (a, Alt CoreBndr)
getAlts (a, Context)
x =
case (a, Context)
x of
(a
bs, CaseAlt Alt CoreBndr
alt) -> (a, Alt CoreBndr) -> Maybe (a, Alt CoreBndr)
forall a. a -> Maybe a
Just (a
bs, Alt CoreBndr
alt)
(a, Context)
_ -> Maybe (a, Alt CoreBndr)
forall a. Maybe a
Nothing
let patternMatches :: [([CoreBind], Alt CoreBndr)]
patternMatches = (([CoreBind], Context) -> Maybe ([CoreBind], Alt CoreBndr))
-> [([CoreBind], Context)] -> [([CoreBind], Alt CoreBndr)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([CoreBind], Context) -> Maybe ([CoreBind], Alt CoreBndr)
forall a. (a, Context) -> Maybe (a, Alt CoreBndr)
getAlts [([CoreBind], Context)]
results
let uniqBinders :: [CoreBndr]
uniqBinders = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], Alt CoreBndr) -> CoreBndr)
-> [([CoreBind], Alt CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder (CoreBind -> CoreBndr)
-> (([CoreBind], Alt CoreBndr) -> CoreBind)
-> ([CoreBind], Alt CoreBndr)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> ([CoreBind], Alt CoreBndr)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst)
[([CoreBind], Alt CoreBndr)]
patternMatches)
let getConstrs :: (a, Context) -> Maybe (a, DataCon)
getConstrs (a, Context)
x =
case (a, Context)
x of
(a
bs, Constr DataCon
con) -> (a, DataCon) -> Maybe (a, DataCon)
forall a. a -> Maybe a
Just (a
bs, DataCon
con)
(a, Context)
_ -> Maybe (a, DataCon)
forall a. Maybe a
Nothing
let constrs :: [([CoreBind], DataCon)]
constrs = (([CoreBind], Context) -> Maybe ([CoreBind], DataCon))
-> [([CoreBind], Context)] -> [([CoreBind], DataCon)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([CoreBind], Context) -> Maybe ([CoreBind], DataCon)
forall a. (a, Context) -> Maybe (a, DataCon)
getConstrs [([CoreBind], Context)]
results
let uniqConstr :: [CoreBndr]
uniqConstr = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], DataCon) -> CoreBndr)
-> [([CoreBind], DataCon)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder(CoreBind -> CoreBndr)
-> (([CoreBind], DataCon) -> CoreBind)
-> ([CoreBind], DataCon)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], DataCon) -> [CoreBind])
-> ([CoreBind], DataCon)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], DataCon) -> [CoreBind]
forall a b. (a, b) -> a
fst) [([CoreBind], DataCon)]
constrs)
case ReportMode
reportMode of
ReportMode
ReportSilent -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ReportMode
ReportWarn -> do
let allBinds :: [[CoreBind]]
allBinds = (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> [([CoreBind], Alt CoreBndr)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], Alt CoreBndr)]
patternMatches [[CoreBind]] -> [[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a] -> [a]
++ (([CoreBind], DataCon) -> [CoreBind])
-> [([CoreBind], DataCon)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], DataCon) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], DataCon)]
constrs
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [[CoreBind]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[CoreBind]]
allBinds) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
String -> CoreM ()
putMsgS String
"Unfused bindings:"
String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
DL.nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([CoreBind] -> String) -> [[CoreBind]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags) [[CoreBind]]
allBinds
ReportMode
_ -> do
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], Alt CoreBndr)]
-> (DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String)
-> CoreM ()
forall a.
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
b DynFlags
dflags ReportMode
reportMode Bool
False String
"SCRUTINIZE"
[CoreBndr]
uniqBinders [([CoreBind], Alt CoreBndr)]
patternMatches DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String
showDetailsCaseMatch
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], DataCon)]
-> (DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String)
-> CoreM ()
forall a.
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
b DynFlags
dflags ReportMode
reportMode Bool
False String
"CONSTRUCT"
[CoreBndr]
uniqConstr [([CoreBind], DataCon)]
constrs DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String
showDetailsConstr
transformBind DynFlags
dflags UniqFM [Fuse]
anns (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
((CoreBndr, Expr CoreBndr) -> CoreM ())
-> [(CoreBndr, Expr CoreBndr)] -> CoreM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(CoreBndr
b, Expr CoreBndr
expr) -> DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM [Fuse]
anns (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr)) [(CoreBndr, Expr CoreBndr)]
bs
chooseDumpFile :: DynFlags -> FilePath -> Maybe FilePath
chooseDumpFile :: DynFlags -> String -> Maybe String
chooseDumpFile DynFlags
dflags String
suffix
| Just String
prefix <- Maybe String
getPrefix
= String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ShowS
setDir (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix)
| Bool
otherwise
= Maybe String
forall a. Maybe a
Nothing
where getPrefix :: Maybe String
getPrefix
| Just String
prefix <- DynFlags -> Maybe String
dumpPrefixForce DynFlags
dflags
= String -> Maybe String
forall a. a -> Maybe a
Just String
prefix
| Just String
prefix <- DynFlags -> Maybe String
dumpPrefix DynFlags
dflags
= String -> Maybe String
forall a. a -> Maybe a
Just String
prefix
| Bool
otherwise
= Maybe String
forall a. Maybe a
Nothing
setDir :: ShowS
setDir String
f = case DynFlags -> Maybe String
dumpDir DynFlags
dflags of
Just String
d -> String
d String -> ShowS
</> String
f
Maybe String
Nothing -> String
f
withDumpFileHandle :: DynFlags -> FilePath -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle :: DynFlags -> String -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DynFlags
dflags String
suffix Maybe Handle -> IO ()
action = do
let mFile :: Maybe String
mFile = DynFlags -> String -> Maybe String
chooseDumpFile DynFlags
dflags String
suffix
case Maybe String
mFile of
Just String
fileName -> do
let gdref :: IORef (Set String)
gdref = DynFlags -> IORef (Set String)
generatedDumps DynFlags
dflags
Set String
gd <- IORef (Set String) -> IO (Set String)
forall a. IORef a -> IO a
readIORef IORef (Set String)
gdref
let append :: Bool
append = String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
fileName Set String
gd
mode :: IOMode
mode = if Bool
append then IOMode
AppendMode else IOMode
WriteMode
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
append (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IORef (Set String) -> Set String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Set String)
gdref (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
fileName Set String
gd)
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
fileName)
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fileName IOMode
mode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
utf8
Maybe Handle -> IO ()
action (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle)
Maybe String
Nothing -> Maybe Handle -> IO ()
action Maybe Handle
forall a. Maybe a
Nothing
dumpSDocWithStyle :: PprStyle -> DynFlags -> FilePath -> String -> SDoc -> IO ()
dumpSDocWithStyle :: PprStyle -> DynFlags -> String -> String -> SDoc -> IO ()
dumpSDocWithStyle PprStyle
sty DynFlags
dflags String
suffix String
hdr SDoc
doc =
DynFlags -> String -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DynFlags
dflags String
suffix Maybe Handle -> IO ()
writeDump
where
writeDump :: Maybe Handle -> IO ()
writeDump (Just Handle
handle) = do
SDoc
doc' <- if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hdr
then SDoc -> IO SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc
else do UTCTime
t <- IO UTCTime
getCurrentTime
let timeStamp :: SDoc
timeStamp = if (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTimestamps DynFlags
dflags)
then SDoc
empty
else String -> SDoc
text (UTCTime -> String
forall a. Show a => a -> String
show UTCTime
t)
let d :: SDoc
d = SDoc
timeStamp
SDoc -> SDoc -> SDoc
$$ SDoc
blankLine
SDoc -> SDoc -> SDoc
$$ SDoc
doc
SDoc -> IO SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> IO SDoc) -> SDoc -> IO SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> SDoc
mkDumpDoc String
hdr SDoc
d
DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPrintDoc DynFlags
dflags Handle
handle SDoc
doc' PprStyle
sty
writeDump Maybe Handle
Nothing = do
let (SDoc
doc', Severity
severity)
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hdr = (SDoc
doc, Severity
SevOutput)
| Bool
otherwise = (String -> SDoc -> SDoc
mkDumpDoc String
hdr SDoc
doc, Severity
SevDump)
DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
severity SrcSpan
noSrcSpan PprStyle
sty SDoc
doc'
dumpSDoc :: DynFlags -> PrintUnqualified -> FilePath -> String -> SDoc -> IO ()
dumpSDoc :: DynFlags -> PrintUnqualified -> String -> String -> SDoc -> IO ()
dumpSDoc DynFlags
dflags PrintUnqualified
print_unqual
= PprStyle -> DynFlags -> String -> String -> SDoc -> IO ()
dumpSDocWithStyle PprStyle
dump_style DynFlags
dflags
where dump_style :: PprStyle
dump_style = DynFlags -> PrintUnqualified -> PprStyle
mkDumpStyle DynFlags
dflags PrintUnqualified
print_unqual
dumpPassResult :: DynFlags
-> PrintUnqualified
-> FilePath
-> SDoc
-> SDoc
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult :: DynFlags
-> PrintUnqualified
-> String
-> SDoc
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpPassResult DynFlags
dflags PrintUnqualified
unqual String
suffix SDoc
hdr SDoc
extra_info [CoreBind]
binds [CoreRule]
rules = do
DynFlags -> PrintUnqualified -> String -> String -> SDoc -> IO ()
dumpSDoc DynFlags
dflags PrintUnqualified
unqual String
suffix (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
hdr) SDoc
dump_doc
where
dump_doc :: SDoc
dump_doc = [SDoc] -> SDoc
vcat [ Int -> SDoc -> SDoc
nest Int
2 SDoc
extra_info
, SDoc
blankLine
, [CoreBind] -> SDoc
pprCoreBindingsWithSize [CoreBind]
binds
, Bool -> SDoc -> SDoc
ppUnless ([CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules) SDoc
pp_rules ]
pp_rules :: SDoc
pp_rules = [SDoc] -> SDoc
vcat [ SDoc
blankLine
, String -> SDoc
text String
"------ Local rules for imported ids --------"
, [CoreRule] -> SDoc
pprRules [CoreRule]
rules ]
filterOutLast :: (a -> Bool) -> [a] -> [a]
filterOutLast :: (a -> Bool) -> [a] -> [a]
filterOutLast a -> Bool
_ [] = []
filterOutLast a -> Bool
p [a
x]
| a -> Bool
p a
x = []
| Bool
otherwise = [a
x]
filterOutLast a -> Bool
p (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filterOutLast a -> Bool
p [a]
xs
dumpResult
:: DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
dumpResult :: DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpResult DynFlags
dflags PrintUnqualified
print_unqual Int
counter SDoc
todo [CoreBind]
binds [CoreRule]
rules =
DynFlags
-> PrintUnqualified
-> String
-> SDoc
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpPassResult DynFlags
dflags PrintUnqualified
print_unqual String
suffix SDoc
hdr (String -> SDoc
text String
"") [CoreBind]
binds [CoreRule]
rules
where
hdr :: SDoc
hdr = String -> SDoc
text String
"["
SDoc -> SDoc -> SDoc
GhcPlugins.<> Int -> SDoc
int Int
counter
SDoc -> SDoc -> SDoc
GhcPlugins.<> String -> SDoc
text String
"] "
SDoc -> SDoc -> SDoc
GhcPlugins.<> SDoc
todo
suffix :: String
suffix = String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02d" Int
counter String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isSpace Char
x then Char
'-' else Char
x)
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filterOutLast Char -> Bool
isSpace
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(')
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
todo)
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
counter SDoc
todo
guts :: ModGuts
guts@(ModGuts
{ mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env
, mg_binds :: ModGuts -> [CoreBind]
mg_binds = [CoreBind]
binds
, mg_rules :: ModGuts -> [CoreRule]
mg_rules = [CoreRule]
rules
}) = do
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: dumping core "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
counter String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
todo
let print_unqual :: PrintUnqualified
print_unqual = DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
rdr_env
IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpResult DynFlags
dflags PrintUnqualified
print_unqual Int
counter SDoc
todo [CoreBind]
binds [CoreRule]
rules
ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
dumpCorePass :: Int -> SDoc -> CoreToDo
dumpCorePass :: Int -> SDoc -> CoreToDo
dumpCorePass Int
counter SDoc
todo =
String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
"Fusion plugin dump core" (Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
counter SDoc
todo)
_insertDumpCore :: [CoreToDo] -> [CoreToDo]
_insertDumpCore :: [CoreToDo] -> [CoreToDo]
_insertDumpCore [CoreToDo]
todos = Int -> SDoc -> CoreToDo
dumpCorePass Int
0 (String -> SDoc
text String
"Initial ") CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Int -> [CoreToDo] -> [CoreToDo]
go Int
1 [CoreToDo]
todos
where
go :: Int -> [CoreToDo] -> [CoreToDo]
go Int
_ [] = []
go Int
counter (CoreToDo
todo:[CoreToDo]
rest) =
CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Int -> SDoc -> CoreToDo
dumpCorePass Int
counter (String -> SDoc
text String
"After " SDoc -> SDoc -> SDoc
GhcPlugins.<> CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
todo)
CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Int -> [CoreToDo] -> [CoreToDo]
go (Int
counter Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [CoreToDo]
rest
insertAfterSimplPhase0
:: [CoreToDo] -> [CoreToDo] -> CoreToDo -> [CoreToDo]
insertAfterSimplPhase0 :: [CoreToDo] -> [CoreToDo] -> CoreToDo -> [CoreToDo]
insertAfterSimplPhase0 [CoreToDo]
origTodos [CoreToDo]
ourTodos CoreToDo
report =
Bool -> [CoreToDo] -> [CoreToDo]
go Bool
False [CoreToDo]
origTodos [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [CoreToDo
report]
where
go :: Bool -> [CoreToDo] -> [CoreToDo]
go Bool
False [] = String -> [CoreToDo]
forall a. HasCallStack => String -> a
error String
"Simplifier phase 0/\"main\" not found"
go Bool
True [] = []
go Bool
_ (todo :: CoreToDo
todo@(CoreDoSimplify Int
_ SimplMode
{ sm_phase :: SimplMode -> CompilerPhase
sm_phase = Phase Int
0
, sm_names :: SimplMode -> [String]
sm_names = [String
"main"]
}):[CoreToDo]
todos)
= CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: [CoreToDo]
ourTodos [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ Bool -> [CoreToDo] -> [CoreToDo]
go Bool
True [CoreToDo]
todos
go Bool
found (CoreToDo
todo:[CoreToDo]
todos) = CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Bool -> [CoreToDo] -> [CoreToDo]
go Bool
found [CoreToDo]
todos
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: [String] -> [CoreToDo] -> CoreM [CoreToDo]
install [String]
args [CoreToDo]
todos = do
Options
options <- IO Options -> CoreM Options
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Options -> CoreM Options) -> IO Options -> CoreM Options
forall a b. (a -> b) -> a -> b
$ [String] -> IO Options
parseOptions [String]
args
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
[CoreToDo] -> CoreM [CoreToDo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreToDo] -> CoreM [CoreToDo]) -> [CoreToDo] -> CoreM [CoreToDo]
forall a b. (a -> b) -> a -> b
$
(if Options -> Bool
optionsDumpCore Options
options then [CoreToDo] -> [CoreToDo]
_insertDumpCore else [CoreToDo] -> [CoreToDo]
forall a. a -> a
id) ([CoreToDo] -> [CoreToDo]) -> [CoreToDo] -> [CoreToDo]
forall a b. (a -> b) -> a -> b
$
[CoreToDo] -> [CoreToDo] -> CoreToDo -> [CoreToDo]
insertAfterSimplPhase0
[CoreToDo]
todos
[ ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
ReportSilent Bool
False Bool
True
, DynFlags -> CoreToDo
fusionSimplify DynFlags
dflags
, ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
ReportSilent Bool
False Bool
True
, DynFlags -> CoreToDo
fusionSimplify DynFlags
dflags
, ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
ReportSilent Bool
False Bool
True
, DynFlags -> CoreToDo
fusionSimplify DynFlags
dflags
, let msg :: String
msg = String
"Check unfused (post inlining)"
in String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
msg (String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
msg ReportMode
ReportSilent)
]
(let msg :: String
msg = String
"Check unfused (final)"
report :: ModGuts -> CoreM ModGuts
report = String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
msg (Options -> ReportMode
optionsVerbosityLevel Options
options)
in String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
msg ModGuts -> CoreM ModGuts
report)
#else
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todos = do
putMsgS "Warning! fusion-plugin does nothing on ghc versions prior to 8.6"
return todos
#endif
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
{ installCoreToDos :: [String] -> [CoreToDo] -> CoreM [CoreToDo]
installCoreToDos = [String] -> [CoreToDo] -> CoreM [CoreToDo]
install
#if MIN_VERSION_ghc(8,6,0)
, pluginRecompile :: [String] -> IO PluginRecompile
pluginRecompile = [String] -> IO PluginRecompile
purePlugin
#endif
}
instance Outputable Fuse where
ppr :: Fuse -> SDoc
ppr Fuse
_ = String -> SDoc
text String
"Fuse"