{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
module Fusion.Plugin
(
plugin
)
where
#if MIN_VERSION_ghc(8,6,0)
import Control.Monad (mzero, when)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.State (StateT, evalStateT, get, put)
import Data.Maybe (mapMaybe)
import Data.Generics.Schemes (everywhere)
import Data.Generics.Aliases (mkT)
import Debug.Trace (trace)
import qualified Data.List as DL
#if MIN_VERSION_ghc(9,2,0)
import Data.Char (isSpace)
import Text.Printf (printf)
import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules)
import GHC.Types.Name.Ppr (mkPrintUnqualified)
import GHC.Utils.Logger (Logger)
#endif
#if MIN_VERSION_ghc(9,3,0)
import GHC.Utils.Logger (putDumpFile, logFlags, LogFlags(..))
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Utils.Logger (putDumpMsg)
#elif MIN_VERSION_ghc(9,0,0)
#else
import Control.Monad (unless)
import Data.Char (isSpace)
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.Set as Set
#endif
#endif
#if MIN_VERSION_ghc(9,0,0)
import GHC.Plugins
import qualified GHC.Plugins as GhcPlugins
#else
import GhcPlugins
#endif
import Fusion.Plugin.Types (Fuse(..))
#if MIN_VERSION_ghc(8,6,0)
dbgLevel :: Int
dbgLevel :: Int
dbgLevel = Int
0
debug :: Int -> String -> a -> a
debug :: forall a. Int -> String -> a -> a
debug Int
level String
str a
x =
if Int
dbgLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
level
then String -> a -> a
forall a. String -> a -> a
trace String
str a
x
else a
x
showBndr :: Outputable a => DynFlags -> a -> String
showBndr :: forall a. Outputable a => DynFlags -> a -> String
showBndr DynFlags
dflags a
bndr = 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
showWithUnique :: (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique :: forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique 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 -> a -> String
forall a. Outputable a => DynFlags -> a -> String
showBndr DynFlags
dflags 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
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
showWithUnique 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
data ReportMode =
ReportSilent
| ReportWarn
| ReportVerbose
| ReportVerbose1
| ReportVerbose2
deriving (Int -> ReportMode -> String -> String
[ReportMode] -> String -> String
ReportMode -> String
(Int -> ReportMode -> String -> String)
-> (ReportMode -> String)
-> ([ReportMode] -> String -> String)
-> Show ReportMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ReportMode -> String -> String
showsPrec :: Int -> ReportMode -> String -> String
$cshow :: ReportMode -> String
show :: ReportMode -> String
$cshowList :: [ReportMode] -> String -> String
showList :: [ReportMode] -> String -> String
Show)
data Options = Options
{ Options -> Bool
optionsDumpCore :: Bool
, Options -> ReportMode
optionsVerbosityLevel :: ReportMode
} deriving Int -> Options -> String -> String
[Options] -> String -> String
Options -> String
(Int -> Options -> String -> String)
-> (Options -> String)
-> ([Options] -> String -> String)
-> Show Options
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Options -> String -> String
showsPrec :: Int -> Options -> String -> String
$cshow :: Options -> String
show :: Options -> String
$cshowList :: [Options] -> String -> String
showList :: [Options] -> String -> String
Show
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
{ optionsDumpCore :: Bool
optionsDumpCore = Bool
False
, optionsVerbosityLevel :: ReportMode
optionsVerbosityLevel = ReportMode
ReportSilent
}
setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m ()
setDumpCore :: forall (m :: * -> *).
Monad m =>
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 :: forall (m :: * -> *).
Monad m =>
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 a. a -> StateT ([String], Options) (MaybeT IO) a
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 a b.
StateT ([String], Options) (MaybeT IO) a
-> StateT ([String], Options) (MaybeT IO) b
-> StateT ([String], Options) (MaybeT IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
forall a. a -> StateT ([String], Options) (MaybeT IO) a
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 a b.
(a -> b)
-> StateT ([String], Options) (MaybeT IO) a
-> StateT ([String], Options) (MaybeT IO) b
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 a. a -> IO a
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 a. IO a -> StateT ([String], Options) m a
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
StateT ([String], Options) m ()
forall a. StateT ([String], Options) m a
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 a b.
StateT ([String], Options) (MaybeT IO) a
-> StateT ([String], Options) (MaybeT IO) b
-> StateT ([String], Options) (MaybeT IO) b
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 a. a -> StateT ([String], Options) (MaybeT IO) a
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 :: DynFlags -> CoreBndr -> CoreBndr
setAlwaysInlineOnBndr :: DynFlags -> CoreBndr -> CoreBndr
setAlwaysInlineOnBndr DynFlags
dflags CoreBndr
n =
let info :: IdInfo
info =
case IdInfo -> Maybe IdInfo
zapUsageInfo (IdInfo -> Maybe IdInfo) -> IdInfo -> Maybe IdInfo
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => 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 Int -> String -> CoreBndr -> CoreBndr
forall a. Int -> String -> a -> a
debug Int
1
(String
"Forcing inline on: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> CoreBndr -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags CoreBndr
n)
(CoreBndr -> IdInfo -> CoreBndr
lazySetIdInfo CoreBndr
n IdInfo
info')
setInlineOnBndrs :: DynFlags -> [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs :: DynFlags -> [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs DynFlags
dflags [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 (DynFlags -> CoreBndr -> CoreBndr
setAlwaysInlineOnBndr DynFlags
dflags CoreBndr
b) Expr CoreBndr
expr
go CoreBind
x = CoreBind
x
#if MIN_VERSION_ghc(9,0,0)
#define IS_ACTIVE isActive (Phase 0)
#define UNIQ_FM UniqFM Name [Fuse]
#define GET_NAME getName
#define FMAP_SND fmap snd $
#else
#define IS_ACTIVE isActiveIn 0
#define UNIQ_FM UniqFM [Fuse]
#define GET_NAME getUnique
#define FMAP_SND
#endif
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
$ (() :: Constraint) => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
bndr
in InlinePragma -> Bool
isInlinePragma InlinePragma
inl Bool -> Bool -> Bool
&& IS_ACTIVE (inlinePragmaActivation inl)
#if MIN_VERSION_ghc(9,2,0)
#define ALT_CONSTR(x,y,z) Alt (x) y z
#else
#define ALT_CONSTR(x,y,z) (x, y, z)
#endif
altsContainsAnn ::
DynFlags -> UNIQ_FM -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn :: DynFlags
-> UniqFM Name [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn DynFlags
_ UniqFM Name [Fuse]
_ [] = Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
altsContainsAnn DynFlags
_ UniqFM Name [Fuse]
_ ((ALT_CONSTR(DEFAULT,_,_)):[]) =
Int -> String -> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a. Int -> String -> a -> a
debug Int
2 String
"Case trivial default" Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
altsContainsAnn DynFlags
dflags UniqFM Name [Fuse]
anns (bndr :: Alt CoreBndr
bndr@(ALT_CONSTR(DataAlt dcon,[Alt CoreBndr]
_,_)):_) =
let name :: Name
name = GET_NAME $ dataConTyCon dcon
mesg :: String
mesg = String
"Case DataAlt type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> Name -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags Name
name
in case UniqFM Name [Fuse] -> Name -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Name [Fuse]
anns Name
name of
Maybe [Fuse]
Nothing -> Int -> String -> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a. Int -> String -> a -> a
debug Int
2 (String
mesg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not annotated") Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
Just [Fuse]
_ -> Int -> String -> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a. Int -> String -> a -> a
debug Int
2 (String
mesg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" annotated") (Alt CoreBndr -> Maybe (Alt CoreBndr)
forall a. a -> Maybe a
Just Alt CoreBndr
bndr)
altsContainsAnn DynFlags
dflags UniqFM Name [Fuse]
anns ((ALT_CONSTR(DEFAULT,_,_)):alts) =
DynFlags
-> UniqFM Name [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn DynFlags
dflags UniqFM Name [Fuse]
anns [Alt CoreBndr]
alts
altsContainsAnn DynFlags
_ UniqFM Name [Fuse]
_ ((ALT_CONSTR(LitAlt _,[Alt CoreBndr]
_,_)):_) =
Int -> String -> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a. Int -> String -> a -> a
debug Int
2 String
"Case LitAlt" Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
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"
needInlineCaseAlt
:: DynFlags
-> [CoreBind]
-> UNIQ_FM
-> [Alt CoreBndr]
-> Maybe (Alt CoreBndr)
needInlineCaseAlt :: DynFlags
-> [CoreBind]
-> UniqFM Name [Fuse]
-> [Alt CoreBndr]
-> Maybe (Alt CoreBndr)
needInlineCaseAlt DynFlags
dflags [CoreBind]
parents UniqFM Name [Fuse]
anns [Alt CoreBndr]
bndr =
let mesg :: String
mesg = String
"Binder: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
parents
in if Bool -> Bool
not (CoreBndr -> Bool
hasInlineBinder (CoreBndr -> Bool) -> CoreBndr -> Bool
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder ([CoreBind] -> CoreBind
forall a. HasCallStack => [a] -> a
head [CoreBind]
parents))
then
Int -> String -> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a. Int -> String -> a -> a
debug Int
2
(String
mesg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not inlined")
(Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr))
-> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a b. (a -> b) -> a -> b
$ case DynFlags
-> UniqFM Name [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn DynFlags
dflags UniqFM Name [Fuse]
anns [Alt CoreBndr]
bndr of
Just Alt CoreBndr
alt -> 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
else Int -> String -> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a. Int -> String -> a -> a
debug Int
2 (String
mesg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" already inlined") Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
letBndrsThatAreCases
:: DynFlags
-> UNIQ_FM
-> CoreBind
-> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases :: DynFlags
-> UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases DynFlags
dflags UniqFM Name [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 a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents False expr1)
in case DynFlags
-> [CoreBind]
-> UniqFM Name [Fuse]
-> [Alt CoreBndr]
-> Maybe (Alt CoreBndr)
needInlineCaseAlt DynFlags
dflags [CoreBind]
parents UniqFM Name [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 a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents False 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 CoercionR
_) = [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 CoreTickish
_ Expr CoreBndr
_) = []
go [CoreBind]
_ Bool
_ (Type Type
_) = []
go [CoreBind]
_ Bool
_ (Coercion CoercionR
_) = []
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 a b. [a] -> (a -> [b]) -> [b]
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)
needInlineTyCon :: CoreBind -> UNIQ_FM -> TyCon -> Bool
needInlineTyCon :: CoreBind -> UniqFM Name [Fuse] -> TyCon -> Bool
needInlineTyCon CoreBind
parent UniqFM Name [Fuse]
anns TyCon
tycon =
case UniqFM Name [Fuse] -> Name -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Name [Fuse]
anns (GET_NAME tycon) 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 :: UNIQ_FM -> CoreBind -> [([CoreBind], Id)]
constructingBinders :: UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], CoreBndr)]
constructingBinders UniqFM Name [Fuse]
anns CoreBind
bind = [CoreBind] -> CoreBind -> [([CoreBind], CoreBndr)]
goLet [] CoreBind
bind
where
go :: [CoreBind] -> CoreExpr -> [([CoreBind], Id)]
go :: [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
go [CoreBind]
parents (Let CoreBind
bndr Expr CoreBndr
expr1) = [CoreBind] -> CoreBind -> [([CoreBind], CoreBndr)]
goLet [CoreBind]
parents CoreBind
bndr [([CoreBind], CoreBndr)]
-> [([CoreBind], CoreBndr)] -> [([CoreBind], CoreBndr)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
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], CoreBndr)])
-> [([CoreBind], CoreBndr)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1)
go [CoreBind]
parents (App Expr CoreBndr
expr1 Expr CoreBndr
expr2) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
go [CoreBind]
parents Expr CoreBndr
expr1 [([CoreBind], CoreBndr)]
-> [([CoreBind], CoreBndr)] -> [([CoreBind], CoreBndr)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
go [CoreBind]
parents Expr CoreBndr
expr2
go [CoreBind]
parents (Lam CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (Cast Expr CoreBndr
expr1 CoercionR
_) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (Var CoreBndr
i) =
let needInline :: TyCon -> Bool
needInline = CoreBind -> UniqFM Name [Fuse] -> TyCon -> Bool
needInlineTyCon ([CoreBind] -> CoreBind
forall a. HasCallStack => [a] -> a
head [CoreBind]
parents) UniqFM Name [Fuse]
anns
in case Type -> Maybe TyCon
tyConAppTyConPicky_maybe (CoreBndr -> Type
varType CoreBndr
i) of
Just TyCon
tycon | TyCon -> Bool
needInline TyCon
tycon -> [([CoreBind]
parents, CoreBndr
i)]
Maybe TyCon
_ -> []
go [CoreBind]
_ (Lit Literal
_) = []
go [CoreBind]
_ (Tick CoreTickish
_ Expr CoreBndr
_) = []
go [CoreBind]
_ (Type Type
_) = []
go [CoreBind]
_ (Coercion CoercionR
_) = []
goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Id)]
goLet :: [CoreBind] -> CoreBind -> [([CoreBind], CoreBndr)]
goLet [CoreBind]
parents bndr :: CoreBind
bndr@(NonRec CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
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], CoreBndr)])
-> [([CoreBind], CoreBndr)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CoreBndr
b, Expr CoreBndr
expr1) -> [CoreBind] -> CoreBind -> [([CoreBind], CoreBndr)]
goLet [CoreBind]
parents (CoreBind -> [([CoreBind], CoreBndr)])
-> CoreBind -> [([CoreBind], 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)
data Context = CaseAlt (Alt CoreBndr) | Constr Id
containsAnns :: DynFlags -> UNIQ_FM -> CoreBind -> [([CoreBind], Context)]
containsAnns :: DynFlags
-> UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns DynFlags
dflags UniqFM Name [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 a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1)
in case DynFlags
-> UniqFM Name [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn DynFlags
dflags UniqFM Name [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 CoercionR
_) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1
go [CoreBind]
parents (Var CoreBndr
i) =
case Type -> Maybe TyCon
tyConAppTyConPicky_maybe (CoreBndr -> Type
varType CoreBndr
i) of
Just TyCon
tycon ->
case UniqFM Name [Fuse] -> Name -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Name [Fuse]
anns (GET_NAME tycon) of
Just [Fuse]
_ -> [([CoreBind]
parents, CoreBndr -> Context
Constr CoreBndr
i)]
Maybe [Fuse]
Nothing -> []
Maybe TyCon
Nothing -> []
go [CoreBind]
_ (Lit Literal
_) = []
go [CoreBind]
_ (Tick CoreTickish
_ Expr CoreBndr
_) = []
go [CoreBind]
_ (Type Type
_) = []
go [CoreBind]
_ (Coercion CoercionR
_) = []
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 a b. [a] -> (a -> [b]) -> [b]
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)
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@(ALT_CONSTR[CoreBndr]
(con,_,_))) =
DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
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. HasCallStack => [a] -> a
head [CoreBind]
binds)
ReportMode
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"transformBind: unreachable"
showDetailsConstr
:: DynFlags
-> ReportMode
-> ([CoreBind], Id)
-> String
showDetailsConstr :: DynFlags -> ReportMode -> ([CoreBind], CoreBndr) -> String
showDetailsConstr DynFlags
dflags ReportMode
reportMode ([CoreBind]
binds, CoreBndr
con) =
let t :: Maybe TyCon
t = Type -> Maybe TyCon
tyConAppTyConPicky_maybe (CoreBndr -> Type
varType CoreBndr
con)
vstr :: String
vstr =
case ReportMode
reportMode of
ReportMode
ReportVerbose -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
con)
ReportMode
ReportVerbose1 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
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. HasCallStack => [a] -> a
head [CoreBind]
binds)
ReportMode
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"transformBind: unreachable"
tstr :: String
tstr =
case Maybe TyCon
t of
Maybe TyCon
Nothing -> String
" :: Not a Type Constructor"
Just TyCon
x -> String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
x)
in DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vstr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tstr
instance Outputable Fuse where
ppr :: Fuse -> SDoc
ppr Fuse
_ = String -> SDoc
text String
"Fuse"
showInfo
:: CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo :: forall a.
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 mesg :: String
mesg = String
"In "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> CoreBndr -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags CoreBndr
parent
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" binders "
String -> String -> String
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
showWithUnique DynFlags
dflags) ([CoreBndr]
uniqBinders))
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" data types annotated with "
String -> String -> String
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 a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ReportMode
ReportWarn -> () -> CoreM ()
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ReportMode
_ -> do
String -> CoreM ()
putMsgS String
mesg
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 :: Int -> ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline :: Int -> ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline Int
pass 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 Name [Fuse]
anns <- FMAP_SND getAnnotations deserializeWithData guts
if (([Fuse] -> Bool) -> UniqFM Name [Fuse] -> Bool
forall elt key. (elt -> Bool) -> UniqFM key 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 Name [Fuse]
anns)
then do
ModGuts
r <- ([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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (DynFlags -> UniqFM Name [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns)) ModGuts
guts
if Int
dbgLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
0 (String -> SDoc
text (String
"Fusion-plugin-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
pass)) ModGuts
r
else ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
r
else ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
where
transformBind :: DynFlags -> UniqFM Name [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns bind :: CoreBind
bind@(NonRec CoreBndr
b Expr CoreBndr
_) = do
let patternMatches :: [([CoreBind], Alt CoreBndr)]
patternMatches = DynFlags
-> UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases DynFlags
dflags UniqFM Name [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. HasCallStack => [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], CoreBndr)]
constrs = UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], CoreBndr)]
constructingBinders UniqFM Name [Fuse]
anns CoreBind
bind
let uniqConstr :: [CoreBndr]
uniqConstr = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], CoreBndr) -> CoreBndr)
-> [([CoreBind], CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder(CoreBind -> CoreBndr)
-> (([CoreBind], CoreBndr) -> CoreBind)
-> ([CoreBind], CoreBndr)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. HasCallStack => [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], CoreBndr) -> [CoreBind])
-> ([CoreBind], CoreBndr)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst) [([CoreBind], CoreBndr)]
constrs)
case ReportMode
reportMode of
ReportMode
ReportSilent -> () -> CoreM ()
forall a. a -> CoreM a
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], CoreBndr) -> [CoreBind])
-> [([CoreBind], CoreBndr)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], CoreBndr)]
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 a. [a] -> 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], CoreBndr)]
-> (DynFlags -> ReportMode -> ([CoreBind], 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
"CONSTRUCT"
[CoreBndr]
uniqConstr [([CoreBind], CoreBndr)]
constrs DynFlags -> ReportMode -> ([CoreBind], CoreBndr) -> 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
allBinders)
then DynFlags -> [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs DynFlags
dflags [CoreBndr]
allBinders CoreBind
bind
else CoreBind
bind
CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreBind
bind'
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns (Rec [(CoreBndr, Expr CoreBndr)]
bs) = do
([(CoreBndr, Expr CoreBndr)] -> CoreBind)
-> CoreM [(CoreBndr, Expr CoreBndr)] -> CoreM CoreBind
forall a b. (a -> b) -> CoreM a -> CoreM b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 Name [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM Name [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 a. a -> CoreM a
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 :: Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline :: Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
pass ReportMode
opt Bool
failIt Bool
transform =
String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
"Mark for inlining" (Int -> ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline Int
pass ReportMode
opt Bool
failIt Bool
transform)
fusionSimplify :: HscEnv -> DynFlags -> CoreToDo
fusionSimplify :: HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
_hsc_env DynFlags
dflags =
let mode :: SimplMode
mode =
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
#if MIN_VERSION_ghc(9,2,0)
, sm_uf_opts :: UnfoldingOpts
sm_uf_opts = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
, sm_pre_inline :: Bool
sm_pre_inline = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining DynFlags
dflags
, sm_logger :: Logger
sm_logger = HscEnv -> Logger
hsc_logger HscEnv
_hsc_env
#endif
#if MIN_VERSION_ghc(9,2,2)
, sm_cast_swizzle :: Bool
sm_cast_swizzle = Bool
True
#endif
#if MIN_VERSION_ghc(9,5,0)
, sm_float_enable = floatEnable dflags
#endif
}
in Int -> SimplMode -> CoreToDo
CoreDoSimplify
#if MIN_VERSION_ghc(9,5,0)
(CoreDoSimplifyOpts (maxSimplIterations dflags) mode)
#else
(DynFlags -> Int
maxSimplIterations DynFlags
dflags) SimplMode
mode
#endif
fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
mesg ReportMode
reportMode ModGuts
guts = do
String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mesg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
UniqFM Name [Fuse]
anns <- FMAP_SND getAnnotations deserializeWithData guts
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (([Fuse] -> Bool) -> UniqFM Name [Fuse] -> Bool
forall elt key. (elt -> Bool) -> UniqFM key 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 Name [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 Name [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns) ([CoreBind] -> CoreM ()) -> [CoreBind] -> CoreM ()
forall a b. (a -> b) -> a -> b
$ ModGuts -> [CoreBind]
mg_binds ModGuts
guts
ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
where
transformBind :: DynFlags -> UNIQ_FM -> CoreBind -> CoreM ()
transformBind :: DynFlags -> UniqFM Name [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns bind :: CoreBind
bind@(NonRec CoreBndr
b Expr CoreBndr
_) = do
let results :: [([CoreBind], Context)]
results = DynFlags
-> UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns DynFlags
dflags UniqFM Name [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. HasCallStack => [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, CoreBndr)
getConstrs (a, Context)
x =
case (a, Context)
x of
(a
bs, Constr CoreBndr
con) -> (a, CoreBndr) -> Maybe (a, CoreBndr)
forall a. a -> Maybe a
Just (a
bs, CoreBndr
con)
(a, Context)
_ -> Maybe (a, CoreBndr)
forall a. Maybe a
Nothing
let constrs :: [([CoreBind], CoreBndr)]
constrs = (([CoreBind], Context) -> Maybe ([CoreBind], CoreBndr))
-> [([CoreBind], Context)] -> [([CoreBind], CoreBndr)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([CoreBind], Context) -> Maybe ([CoreBind], CoreBndr)
forall {a}. (a, Context) -> Maybe (a, CoreBndr)
getConstrs [([CoreBind], Context)]
results
let uniqConstr :: [CoreBndr]
uniqConstr = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], CoreBndr) -> CoreBndr)
-> [([CoreBind], CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder(CoreBind -> CoreBndr)
-> (([CoreBind], CoreBndr) -> CoreBind)
-> ([CoreBind], CoreBndr)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. HasCallStack => [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], CoreBndr) -> [CoreBind])
-> ([CoreBind], CoreBndr)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst) [([CoreBind], CoreBndr)]
constrs)
case ReportMode
reportMode of
ReportMode
ReportSilent -> () -> CoreM ()
forall a. a -> CoreM a
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], CoreBndr) -> [CoreBind])
-> [([CoreBind], CoreBndr)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], CoreBndr)]
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 a. [a] -> 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], CoreBndr)]
-> (DynFlags -> ReportMode -> ([CoreBind], 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
"CONSTRUCT"
[CoreBndr]
uniqConstr [([CoreBind], CoreBndr)]
constrs DynFlags -> ReportMode -> ([CoreBind], CoreBndr) -> String
showDetailsConstr
transformBind DynFlags
dflags UniqFM Name [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 Name [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr)) [(CoreBndr, Expr CoreBndr)]
bs
#if !MIN_VERSION_ghc(9,0,0)
chooseDumpFile :: DynFlags -> FilePath -> Maybe FilePath
chooseDumpFile dflags suffix
| Just prefix <- getPrefix
= Just $ setDir (prefix ++ suffix)
| otherwise
= Nothing
where getPrefix
| Just prefix <- dumpPrefixForce dflags
= Just prefix
| Just prefix <- dumpPrefix dflags
= Just prefix
| otherwise
= Nothing
setDir f = case dumpDir dflags of
Just d -> d </> f
Nothing -> f
withDumpFileHandle :: DynFlags -> FilePath -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle dflags suffix action = do
let mFile = chooseDumpFile dflags suffix
case mFile of
Just fileName -> do
let gdref = generatedDumps dflags
gd <- readIORef gdref
let append = Set.member fileName gd
mode = if append then AppendMode else WriteMode
unless append $
writeIORef gdref (Set.insert fileName gd)
createDirectoryIfMissing True (takeDirectory fileName)
withFile fileName mode $ \handle -> do
hSetEncoding handle utf8
action (Just handle)
Nothing -> action Nothing
dumpSDocWithStyle :: PprStyle -> DynFlags -> FilePath -> String -> SDoc -> IO ()
dumpSDocWithStyle sty dflags suffix hdr doc =
withDumpFileHandle dflags suffix writeDump
where
writeDump (Just handle) = do
doc' <- if null hdr
then return doc
else do t <- getCurrentTime
let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
then empty
else text (show t)
let d = timeStamp
$$ blankLine
$$ doc
return $ mkDumpDoc hdr d
defaultLogActionHPrintDoc dflags handle doc' sty
writeDump Nothing = do
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
putLogMsg dflags NoReason severity noSrcSpan sty doc'
dumpSDoc :: DynFlags -> PrintUnqualified -> FilePath -> String -> SDoc -> IO ()
dumpSDoc dflags print_unqual
= dumpSDocWithStyle dump_style dflags
where dump_style = mkDumpStyle dflags print_unqual
#endif
#if __GLASGOW_HASKELL__!=900
#if MIN_VERSION_ghc(9,2,0)
dumpPassResult ::
Logger
-> DynFlags
-> PrintUnqualified
-> SDoc
-> SDoc
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult :: Logger
-> DynFlags
-> PrintUnqualified
-> SDoc
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpPassResult Logger
logger DynFlags
dflags PrintUnqualified
unqual SDoc
hdr SDoc
extra_info [CoreBind]
binds [CoreRule]
rules = do
#if MIN_VERSION_ghc(9,3,0)
let flags :: LogFlags
flags = Logger -> LogFlags
logFlags Logger
logger
let getDumpAction :: Logger -> DumpAction
getDumpAction = Logger -> DumpAction
putDumpFile
#else
let flags = dflags
let getDumpAction = putDumpMsg
#endif
(Logger -> DumpAction
getDumpAction Logger
logger)
LogFlags
flags PprStyle
dump_style DumpFlag
Opt_D_dump_simpl String
title DumpFormat
forall a. HasCallStack => a
undefined SDoc
dump_doc
where
title :: String
title = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
hdr
dump_style :: PprStyle
dump_style = PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
unqual
#else
dumpPassResult :: DynFlags
-> PrintUnqualified
-> FilePath
-> SDoc
-> SDoc
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult dflags unqual suffix hdr extra_info binds rules = do
dumpSDoc dflags unqual suffix (showSDoc dflags hdr) dump_doc
where
#endif
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 a. [a] -> 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 :: forall a. (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
#if MIN_VERSION_ghc(9,2,0)
:: Logger
-> DynFlags
#else
:: DynFlags
#endif
-> PrintUnqualified
-> Int
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
#if MIN_VERSION_ghc(9,2,0)
dumpResult :: Logger
-> DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpResult Logger
logger DynFlags
dflags PrintUnqualified
print_unqual Int
counter SDoc
todo [CoreBind]
binds [CoreRule]
rules =
Logger
-> DynFlags
-> PrintUnqualified
-> SDoc
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpPassResult Logger
logger1 DynFlags
dflags PrintUnqualified
print_unqual SDoc
hdr (String -> SDoc
text String
"") [CoreBind]
binds [CoreRule]
rules
#else
dumpResult dflags print_unqual counter todo binds rules =
dumpPassResult
dflags print_unqual (_suffix ++ "dump-simpl") hdr (text "") binds rules
#endif
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isSpace Char
x then Char
'-' else Char
x)
(String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filterOutLast Char -> Bool
isSpace
(String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(')
(String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
todo)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
#if MIN_VERSION_ghc(9,4,0)
prefix :: String
prefix = LogFlags -> String
log_dump_prefix (Logger -> LogFlags
logFlags Logger
logger) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
_suffix
logger1 :: Logger
logger1 = Logger
logger {logFlags :: LogFlags
logFlags = (Logger -> LogFlags
logFlags Logger
logger) {log_dump_prefix :: String
log_dump_prefix = String
prefix}}
#elif MIN_VERSION_ghc(9,2,0)
logger1 = logger
#endif
#endif
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
counter SDoc
title ModGuts
guts = 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
counter String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
title
#if MIN_VERSION_ghc(9,2,0)
HscEnv
hscEnv <- CoreM HscEnv
getHscEnv
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hscEnv
let print_unqual :: PrintUnqualified
print_unqual =
UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hscEnv) (ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts)
IO () -> CoreM ()
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpResult Logger
logger DynFlags
dflags PrintUnqualified
print_unqual Int
counter
SDoc
title (ModGuts -> [CoreBind]
mg_binds ModGuts
guts) (ModGuts -> [CoreRule]
mg_rules ModGuts
guts)
#elif MIN_VERSION_ghc(9,0,0)
putMsgS $ "fusion-plugin: dump-core not supported on GHC 9.0 "
#else
let print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
liftIO $ dumpResult dflags print_unqual counter
title (mg_binds guts) (mg_rules guts)
#endif
ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
dumpCorePass :: Int -> SDoc -> CoreToDo
dumpCorePass :: Int -> SDoc -> CoreToDo
dumpCorePass Int
counter SDoc
title =
String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
"Fusion plugin dump core" (Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
counter SDoc
title)
_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 [] = []
#if MIN_VERSION_ghc(9,5,0)
go _ (todo@(CoreDoSimplify (CoreDoSimplifyOpts _ SimplMode
{ sm_phase = Phase 0
, sm_names = ["main"]
})):todos)
#else
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)
#endif
= 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 a. IO a -> CoreM a
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
HscEnv
hscEnv <- CoreM HscEnv
getHscEnv
[CoreToDo] -> CoreM [CoreToDo]
forall a. a -> CoreM a
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
[ Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
1 ReportMode
ReportSilent Bool
False Bool
True
, HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
, Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
2 ReportMode
ReportSilent Bool
False Bool
True
, HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
, Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
3 ReportMode
ReportSilent Bool
False Bool
True
, HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
, let mesg :: String
mesg = String
"Check unfused (post inlining)"
in String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
mesg (String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
mesg ReportMode
ReportSilent)
]
(let mesg :: String
mesg = String
"Check unfused (final)"
report :: ModGuts -> CoreM ModGuts
report = String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
mesg (Options -> ReportMode
optionsVerbosityLevel Options
options)
in String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
mesg 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
}