-- |
-- Module      : Fusion.Plugin
-- Copyright   : (c) 2019 Composewell Technologies
-- License     : Apache-2.0
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
-- Stream fusion depends on the GHC case-of-case transformations eliminating
-- intermediate constructors.  Case-of-case transformation in turn depends on
-- inlining. During core-to-core transformations GHC may create several
-- internal bindings (e.g. join points) which may not get inlined because their
-- size is bigger than GHC's inlining threshold. Even though we know that after
-- fusion the resulting code would be smaller and more efficient. The
-- programmer cannot force inlining of these bindings as there is no way for
-- the programmer to address these bindings at the source level because they
-- are internal, generated during core-to-core transformations. As a result
-- stream fusion fails unpredictably depending on whether GHC was able to
-- inline the internal bindings or not.
--
-- [See GHC ticket #17075](https://gitlab.haskell.org/ghc/ghc/issues/17075) for
-- more details.
--
-- This plugin provides the programmer with a way to annotate certain types
-- using a custom 'Fuse' annotation. The programmer would annotate the
-- types that are to be eliminated by fusion via case-of-case transformations.
-- During the simplifier phase the plugin goes through the relevant bindings
-- and if one of these types are found inside a binding then that binding is
-- marked to be inlined irrespective of the size.
--
-- At the right places, fusion can provide dramatic performance improvements
-- (e.g. 10x) to the code.

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}

module Fusion.Plugin
    (
    -- * Using the Plugin
    -- $using

    -- * Implementation Details
    -- $impl

    -- * Results
    -- $results
      plugin
    )
where

#if MIN_VERSION_ghc(8,6,0)
-- Imports for all compiler versions
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

-- Imports for specific compiler versions
#if MIN_VERSION_ghc(9,6,0)
import GHC.Core.Lint.Interactive (interactiveInScope)
import GHC.Core.Opt.Simplify.Env (SimplMode(..))
import GHC.Core.Opt.Simplify (SimplifyOpts(..))
import GHC.Driver.Config.Core.Opt.Simplify (initSimplMode, initSimplifyOpts)
#endif

#if MIN_VERSION_ghc(9,6,0)
#elif 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

-- dump-core option related imports
#if MIN_VERSION_ghc(9,6,0)
#elif 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)
-- dump core option not supported
#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

-- Implicit imports
#if MIN_VERSION_ghc(9,6,0)
import GHC.Plugins
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Plugins
import qualified GHC.Plugins as GhcPlugins
#else
import GhcPlugins
#endif

-- Imports from this package
import Fusion.Plugin.Types (Fuse(..))

-- $using
--
-- This plugin was primarily motivated by fusion issues discovered in
-- [streamly](https://github.com/composewell/streamly) but it can be used in
-- general.
--
-- To use this plugin, add this package to your @build-depends@
-- and pass the following to your ghc-options:
--
-- @
-- ghc-options: -O2 -fplugin=Fusion.Plugin
-- @
--
-- The following currently works only for GHC versions less than 9.0.
--
-- To dump the core after each core to core transformation, pass the
-- following to your ghc-options:
--
-- @
-- ghc-options: -O2 -fplugin=Fusion.Plugin -fplugin-opt=Fusion.Plugin:dump-core
-- @
-- Output from each transformation is then printed in a different file.

-- $impl
--
-- The plugin runs after the simplifier phase 0. It finds all non recursive
-- join point bindings whose definition begins with a case match on a type that
-- is annotated with 'Fuse'. It then sets AlwaysInlinePragma on those
-- bindings. This is followed by two runs of a gentle simplify pass that does
-- both inlining and case-of-case. This is followed by the rest of CoreToDos.

-- TODO:
--
-- This inlining could further create a recursive join point that does an
-- explicit case match on a type that would benefit again from inlining, so in
-- the second run we should create a loop breaker and transform the recursive
-- join point to a non-recursive join point and inline. This is not currently
-- done, the machinery is already available, just create a loop breaker for Let
-- Rec in `setInlineOnBndrs`.

-- $results
--
-- This plugin has been used extensively in the streaming library
-- [streamly](https://github.com/composewell/streamly).  Several file IO
-- benchmarks have shown 2x-6x improvements. With the use of this plugin stream
-- fusion in streamly has become much more predictable which has been verified
-- by inspecting the core generated by GHC and by inspection testing for the
-- presence of the stream state constructors.

#if MIN_VERSION_ghc(8,6,0)

-------------------------------------------------------------------------------
-- Debug stuff
-------------------------------------------------------------------------------

-- XXX Can use the debugLevel from dflags
-- Increase this level to see debug output
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 forall a. Ord a => a -> a -> Bool
>= Int
level
    then 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr (forall a. Uniquable a => a -> Unique
getUnique a
bndr)
        bndrName :: String
bndrName = forall a. Outputable a => DynFlags -> a -> String
showBndr DynFlags
dflags a
bndr
    in if forall a. Eq a => [a] -> [a] -> Bool
DL.isSuffixOf String
suffix String
bndrName
       then String
bndrName
       else String
bndrName forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ String
suffix

listPath :: DynFlags -> [CoreBind] -> [Char]
listPath :: DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds =
      forall a. [a] -> [[a]] -> [a]
DL.intercalate String
"/"
    forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse
    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags)
    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map CoreBind -> CoreBndr
getNonRecBinder [CoreBind]
binds

-------------------------------------------------------------------------------
-- Commandline parsing lifted from streamly/benchmark/Chart.hs
-------------------------------------------------------------------------------

data ReportMode =
      ReportSilent
    | ReportWarn
    | ReportVerbose
    | ReportVerbose1
    | ReportVerbose2
    deriving (Int -> ReportMode -> ShowS
[ReportMode] -> ShowS
ReportMode -> String
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)

data Options = Options
    { Options -> Bool
optionsDumpCore :: Bool
    , Options -> ReportMode
optionsVerbosityLevel :: ReportMode
    } deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
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
    { 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) <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    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) <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([String]
args, Options
opts { optionsVerbosityLevel :: ReportMode
optionsVerbosityLevel = ReportMode
val })

-- Like the shell "shift" to shift the command line arguments
shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
shift = do
    ([String], Options)
s <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    case ([String], Options)
s of
        ([], Options
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        (String
x : [String]
xs, Options
opts) -> forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([String]
xs, Options
opts) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
x)

-- totally imperative style option parsing
parseOptions :: [CommandLineOption] -> IO Options
parseOptions :: [String] -> IO Options
parseOptions [String]
args = do
    Maybe Options
maybeOptions <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
                        forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ([String]
args, Options
defaultOptions)
                        forall a b. (a -> b) -> a -> b
$ do StateT ([String], Options) (MaybeT IO) ()
parseLoop
                             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall (m :: * -> *) s. Monad m => StateT s m s
get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Options
defaultOptions 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" -> forall (m :: * -> *).
Monad m =>
Bool -> StateT ([String], Options) m ()
setDumpCore Bool
True
            String
"verbose=1" -> forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportWarn
            String
"verbose=2" -> forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose
            String
"verbose=3" -> forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose1
            String
"verbose=4" -> forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose2
            String
str -> do
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                    forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn
                    forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: Unrecognized option - \"" forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ String
"\""
                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 -> forall {m :: * -> *}.
(MonadIO m, MonadPlus m) =>
String -> StateT ([String], Options) m ()
parseOpt String
opt forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT ([String], Options) (MaybeT IO) ()
parseLoop
            Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-------------------------------------------------------------------------------
-- Set always INLINE on a binder
-------------------------------------------------------------------------------

unfoldCompulsory :: Arity -> Unfolding -> Unfolding
unfoldCompulsory :: Int -> Unfolding -> Unfolding
unfoldCompulsory Int
arity cuf :: Unfolding
cuf@CoreUnfolding{} =
    Unfolding
cuf
        { uf_src :: UnfoldingSource
uf_src=
#if MIN_VERSION_ghc(9,6,0)
            StableSystemSrc
#else
            UnfoldingSource
InlineStable
#endif
        , uf_guidance :: UnfoldingGuidance
uf_guidance = Int -> Bool -> Bool -> UnfoldingGuidance
UnfWhen Int
arity Bool
True Bool
True
        }
unfoldCompulsory Int
_ Unfolding
x = Unfolding
x -- NoUnfolding

-- Sets the inline pragma on a bndr, and forgets the unfolding.
setAlwaysInlineOnBndr :: DynFlags -> CoreBndr -> CoreBndr
setAlwaysInlineOnBndr :: DynFlags -> CoreBndr -> CoreBndr
setAlwaysInlineOnBndr DynFlags
dflags CoreBndr
n =
    let info :: IdInfo
info =
            case IdInfo -> Maybe IdInfo
zapUsageInfo forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
idInfo CoreBndr
n of
                Just IdInfo
i -> IdInfo
i
                Maybe IdInfo
Nothing ->
                    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 forall a. Int -> String -> a -> a
debug Int
1
            (String
"Forcing inline on: " forall a. [a] -> [a] -> [a]
++ forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags CoreBndr
n)
            (CoreBndr -> IdInfo -> CoreBndr
lazySetIdInfo CoreBndr
n IdInfo
info')

--TODO: Replace self-recursive definitions with a loop breaker.
-- | Set inline on specific binders inside a given bind.
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 b. (a -> b) -> a -> b
$ 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) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CoreBndr
b forall a. Eq a => a -> a -> Bool
==) [CoreBndr]
bndrs =
        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 forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
idInfo CoreBndr
bndr
    in InlinePragma -> Bool
isInlinePragma InlinePragma
inl Bool -> Bool -> Bool
&& IS_ACTIVE (inlinePragmaActivation inl)

-------------------------------------------------------------------------------
-- Inspect case alternatives for interesting constructor matches
-------------------------------------------------------------------------------

#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

-- Checks whether a case alternative contains a type with the
-- annotation.  Only checks the first typed element in the list, so
-- only pass alternatives from one case expression.
altsContainsAnn ::
    DynFlags -> UNIQ_FM -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn :: DynFlags
-> UniqFM Name [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn DynFlags
_ UniqFM Name [Fuse]
_ [] = forall a. Maybe a
Nothing
altsContainsAnn DynFlags
_ UniqFM Name [Fuse]
_ ((ALT_CONSTR(DEFAULT,_,_)):[]) =
    forall a. Int -> String -> a -> a
debug Int
2 String
"Case trivial default" 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 " forall a. [a] -> [a] -> [a]
++ forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags Name
name
    in case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Name [Fuse]
anns Name
name of
            Maybe [Fuse]
Nothing -> forall a. Int -> String -> a -> a
debug Int
2 (String
mesg forall a. [a] -> [a] -> [a]
++ String
" not annotated") forall a. Maybe a
Nothing
            Just [Fuse]
_ -> forall a. Int -> String -> a -> a
debug Int
2 (String
mesg forall a. [a] -> [a] -> [a]
++ String
" annotated") (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]
_,_)):_) =
    forall a. Int -> String -> a -> a
debug Int
2 String
"Case LitAlt" forall a. Maybe a
Nothing

getNonRecBinder :: CoreBind -> CoreBndr
getNonRecBinder :: CoreBind -> CoreBndr
getNonRecBinder (NonRec CoreBndr
b Expr CoreBndr
_) = CoreBndr
b
getNonRecBinder (Rec [(CoreBndr, Expr 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: " forall a. [a] -> [a] -> [a]
++ DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
parents
    in if Bool -> Bool
not (CoreBndr -> Bool
hasInlineBinder forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder (forall a. [a] -> a
head [CoreBind]
parents))
       then
            forall a. Int -> String -> a -> a
debug Int
2
                (String
mesg forall a. [a] -> [a] -> [a]
++ String
" not inlined")
                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 -> forall a. a -> Maybe a
Just Alt CoreBndr
alt
                    Maybe (Alt CoreBndr)
_ -> forall a. Maybe a
Nothing
       else forall a. Int -> String -> a -> a
debug Int
2 (String
mesg forall a. [a] -> [a] -> [a]
++ String
" already inlined") forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- Determine if a let binder contains a case match on an annotated type
-------------------------------------------------------------------------------

-- XXX Can check the call site and return only those that would enable
-- case-of-known constructor to kick in. Or is that not relevant?
--
-- | Discover binders that start with a pattern match on constructors that are
-- annotated with Fuse. For example, for the following code:
--
-- @
-- joinrec { $w$g0 x y z = case y of predicateAlt -> ... } -> returns [$w$go]
-- join { $j1_sGH1 x y z = case y of predicateAlt -> ... } -> returns [$j1_sGH1]
-- @
--
-- It will return @$w$go@ and @$j1_sGH1@ if they are matching on fusible
-- constructors.
--
-- Returns all the binds in the hierarchy from the parent to the bind
-- containing the case alternative. Along with the binders it also returns the
-- case alternative scrutinizing the annotated type for better errors with
-- context.
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
    -- The first argument is current binder and its parent chain. We add a new
    -- element to this path when we enter a let statement.
    --
    -- When second argument is "False" it means we do not examine the case
    -- alternatives for annotated constructors when we encounter a case
    -- statement. We pass the second arg as "True" in recursive calls to "go"
    -- after we encounter a let binder. We reset it to "False" when we do not
    -- want to consider inlining the current binder.
    --
    go :: [CoreBind] -> Bool -> CoreExpr -> [([CoreBind], Alt CoreBndr)]

    -- Match and record the case alternative if it contains a constructor
    -- annotated with "Fuse" and traverse the Alt expressions to discover more
    -- let bindings.
    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 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) forall a. a -> [a] -> [a]
: [([CoreBind], Alt CoreBndr)]
binders
            Maybe (Alt CoreBndr)
Nothing -> [([CoreBind], Alt CoreBndr)]
binders

    -- Only traverse the Alt expressions of the case to discover new let
    -- bindings. Do not match for annotated constructors in the Alts.
    go [CoreBind]
parents Bool
False (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
        [Alt CoreBndr]
alts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents False expr1)

    -- Enter a new let binding inside the current expression and traverse the
    -- let expression as well.
    go [CoreBind]
parents Bool
_ (Let CoreBind
bndr Expr CoreBndr
expr1) =    [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [CoreBind]
parents CoreBind
bndr
    -- If the binding starts with a "let" expression we ignore the case matches
    -- in its expression. Can inlining such lets be useful in some cases?
                                    forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1

    -- Traverse these to discover new let bindings. We ignore any case matches
    -- directly in the application expr. There should not be any harm in
    -- chasing expr1 with True here?
    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
                                     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

    -- There are no let bindings in these.
    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)]
    -- Here we pass the second argument to "go" as "True" i.e. we are now
    -- looking to match the case alternatives for annotated constructors.
    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 forall a. a -> [a] -> [a]
: [CoreBind]
parents) Bool
True Expr CoreBndr
expr1
    goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
        [(CoreBndr, Expr CoreBndr)]
bs 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 forall a b. (a -> b) -> a -> b
$ 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 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 forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder CoreBind
parent) -> Bool
True
        Maybe [Fuse]
_ -> Bool
False

-- XXX Currently this function and containsAnns are equivalent. So containsAnns
-- can be used in place of this. But we may want to restrict this to certain
-- cases and keep containsAnns unrestricted so it is kept separate for now.
--
-- | Discover binders whose return type is a fusible constructor and the
-- constructor is directly used in the binder definition rather than through an
-- identifier.
--
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
    -- The first argument is current binder and its parent chain. We add a new
    -- element to this path when we enter a let statement.
    --
    go :: [CoreBind] -> CoreExpr -> [([CoreBind], Id)]

    -- Enter a new let binding inside the current expression and traverse the
    -- let expression as well.
    go :: [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
go [CoreBind]
parents (Let CoreBind
bndr Expr CoreBndr
expr1) = [CoreBind] -> CoreBind -> [([CoreBind], CoreBndr)]
goLet [CoreBind]
parents CoreBind
bndr forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], CoreBndr)]
go [CoreBind]
parents Expr CoreBndr
expr1

    -- Traverse these to discover new let bindings
    go [CoreBind]
parents (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
        [Alt CoreBndr]
alts 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 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

    -- Check if the Var is a data constructor of interest
    go [CoreBind]
parents (Var CoreBndr
i) =
        let needInline :: TyCon -> Bool
needInline = CoreBind -> UniqFM Name [Fuse] -> TyCon -> Bool
needInlineTyCon (forall a. [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 forall a. a -> [a] -> [a]
: [CoreBind]
parents) Expr CoreBndr
expr1
    goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
        [(CoreBndr, Expr CoreBndr)]
bs 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 forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)

data Context = CaseAlt (Alt CoreBndr) | Constr Id

-- letBndrsThatAreCases restricts itself to only case matches right on
-- entry to a let. This one looks for case matches anywhere.
--
-- | Report whether data constructors of interest are case matched or returned
-- anywhere in the binders, not just case match on entry or construction on
-- return.
--
containsAnns :: DynFlags -> UNIQ_FM -> CoreBind -> [([CoreBind], Context)]
containsAnns :: DynFlags
-> UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns DynFlags
dflags UniqFM Name [Fuse]
anns CoreBind
bind =
    -- The first argument is current binder and its parent chain. We add a new
    -- element to this path when we enter a let statement.
    [CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet [] CoreBind
bind
  where
    go :: [CoreBind] -> CoreExpr -> [([CoreBind], Context)]

    -- Match and record the case alternative if it contains a constructor
    -- annotated with "Fuse" and traverse the Alt expressions to discover more
    -- let bindings.
    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 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) forall a. a -> [a] -> [a]
: [([CoreBind], Context)]
binders
            Maybe (Alt CoreBndr)
Nothing -> [([CoreBind], Context)]
binders

    -- Enter a new let binding inside the current expression and traverse the
    -- let expression as well.
    go [CoreBind]
parents (Let CoreBind
bndr Expr CoreBndr
expr1) = [CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet [CoreBind]
parents CoreBind
bndr forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1

    -- Traverse these to discover new let bindings
    go [CoreBind]
parents (App Expr CoreBndr
expr1 Expr CoreBndr
expr2) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1 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

    -- Check if the Var is of the type of a data constructor of interest
    go [CoreBind]
parents (Var CoreBndr
i) =
        case Type -> Maybe TyCon
tyConAppTyConPicky_maybe (CoreBndr -> Type
varType CoreBndr
i) of
            Just TyCon
tycon ->
                case 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 -> []

    -- There are no let bindings in these.
    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 forall a. a -> [a] -> [a]
: [CoreBind]
parents) Expr CoreBndr
expr1
    goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
        [(CoreBndr, Expr CoreBndr)]
bs 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 forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)

-------------------------------------------------------------------------------
-- Core-to-core pass to mark interesting binders to be always inlined
-------------------------------------------------------------------------------

-- XXX we can possibly have a FUSE_DEBUG annotation to print verbose
-- messages only for a given type.
--
-- XXX we mark certain functions (e.g. toStreamK) with a NOFUSION
-- annotation so that we do not report them.

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 forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++
        case ReportMode
reportMode of
            ReportMode
ReportVerbose -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr AltCon
con)
            ReportMode
ReportVerbose1 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr Alt CoreBndr
c)
            ReportMode
ReportVerbose2 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [CoreBind]
binds)
            ReportMode
_ -> 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 (forall a. Outputable a => a -> SDoc
ppr CoreBndr
con)
                ReportMode
ReportVerbose1 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr CoreBndr
con)
                ReportMode
ReportVerbose2 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [CoreBind]
binds)
                ReportMode
_ -> 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
" :: " forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr TyCon
x)
    in DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
vstr forall a. [a] -> [a] -> [a]
++ String
tstr

-- Orphan instance for 'Fuse'
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 =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([CoreBndr]
uniqBinders forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$ do
        let mesg :: String
mesg = String
"In "
                  forall a. [a] -> [a] -> [a]
++ forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags CoreBndr
parent
                  forall a. [a] -> [a] -> [a]
++ String
" binders "
                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags) ([CoreBndr]
uniqBinders))
                  forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
tag
                  forall a. [a] -> [a] -> [a]
++ String
" data types annotated with "
                  forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr Fuse
Fuse)
        case ReportMode
reportMode of
            ReportMode
ReportSilent -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ReportMode
ReportWarn -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ReportMode
_ -> do
                String -> CoreM ()
putMsgS String
mesg
                String -> CoreM ()
putMsgS forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines
                        forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
DL.nub
                        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ReportMode -> ([CoreBind], a) -> String
showDetails DynFlags
dflags ReportMode
reportMode) [([CoreBind], a)]
annotated
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
failIt forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: Checking bindings to inline..."
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    UniqFM Name [Fuse]
anns <- FMAP_SND getAnnotations deserializeWithData guts
    if (forall elt key. (elt -> Bool) -> UniqFM key elt -> Bool
anyUFM (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Fuse
Fuse)) UniqFM Name [Fuse]
anns)
    then do
        ModGuts
r <- ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts
bindsOnlyPass (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> UniqFM Name [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns)) ModGuts
guts
        if Int
dbgLevel forall a. Ord a => a -> a -> Bool
> Int
0
        then Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
0 (String -> SDoc
text (String
"Fusion-plugin-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
pass)) ModGuts
r
        else forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
r
    else forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
  where
    -- transformBind :: DynFlags -> UniqFM Unique [Fuse] -> CoreBind -> CoreM CoreBind
    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 = forall a. Eq a => [a] -> [a]
DL.nub (forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinderforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Eq a => [a] -> [a]
DL.nub (forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinderforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([CoreBind], CoreBndr)]
constrs)

        -- TBD: For ReportWarn level prepare a single consolidated list of
        -- paths with one entry for each binder and giving one example of what
        -- it scrutinizes and/or constructs, for example:
        --
        -- \$sconcat_s8wu/step5_s8M4: Scrutinizes ConcatOuter, Constructs Yield
        --
        case ReportMode
reportMode of
            ReportMode
ReportSilent -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ReportMode
ReportWarn -> do
                let allBinds :: [[CoreBind]]
allBinds = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([CoreBind], Alt CoreBndr)]
patternMatches forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([CoreBind], CoreBndr)]
constrs
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[CoreBind]]
allBinds) forall a b. (a -> b) -> a -> b
$ do
                    String -> CoreM ()
putMsgS String
"INLINE required on:"
                    String -> CoreM ()
putMsgS forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
DL.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags) [[CoreBind]]
allBinds
            ReportMode
_ -> do
                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
                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 forall a. [a] -> [a] -> [a]
++ [CoreBndr]
uniqConstr
                if Bool
transform Bool -> Bool -> Bool
&& (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ 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
        forall (m :: * -> *) a. Monad m => a -> m a
return CoreBind
bind'

    transformBind DynFlags
dflags UniqFM Name [Fuse]
anns (Rec [(CoreBndr, Expr CoreBndr)]
bs) = do
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b. [(b, Expr b)] -> Bind b
Rec (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 Name [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns (forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr)
            case CoreBind
r of
                NonRec CoreBndr
b1 Expr CoreBndr
expr1 -> forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr
b1, Expr CoreBndr
expr1)
                CoreBind
_ -> forall a. HasCallStack => String -> a
error String
"Bug: expecting NonRec binder"

-- | Core pass to mark functions scrutinizing constructors marked with Fuse
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)

-------------------------------------------------------------------------------
-- Simplification pass after marking inline
-------------------------------------------------------------------------------

#if MIN_VERSION_ghc(9,6,0)
fusionSimplify :: RuleBase -> HscEnv -> DynFlags -> CoreToDo
fusionSimplify hpt_rules hsc_env dflags =
    let mode = initSimplMode dflags InitialPhase "Fusion Plugin Inlining"
        extra_vars = interactiveInScope (hsc_IC hsc_env)
     in CoreDoSimplify
            (initSimplifyOpts
                dflags extra_vars (maxSimplIterations dflags) mode hpt_rules)
#else
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
#endif

-------------------------------------------------------------------------------
-- Report unfused constructors
-------------------------------------------------------------------------------

fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
mesg ReportMode
reportMode ModGuts
guts = do
    String -> CoreM ()
putMsgS forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: " forall a. [a] -> [a] -> [a]
++ String
mesg forall a. [a] -> [a] -> [a]
++ String
"..."
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    UniqFM Name [Fuse]
anns <- FMAP_SND getAnnotations deserializeWithData guts
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall elt key. (elt -> Bool) -> UniqFM key elt -> Bool
anyUFM (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Fuse
Fuse)) UniqFM Name [Fuse]
anns) forall a b. (a -> b) -> a -> b
$
        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) forall a b. (a -> b) -> a -> b
$ ModGuts -> [CoreBind]
mg_binds ModGuts
guts
    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) -> forall a. a -> Maybe a
Just (a
bs, Alt CoreBndr
alt)
                    (a, Context)
_ -> forall a. Maybe a
Nothing
        let patternMatches :: [([CoreBind], Alt CoreBndr)]
patternMatches = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. (a, Context) -> Maybe (a, Alt CoreBndr)
getAlts [([CoreBind], Context)]
results
        let uniqBinders :: [CoreBndr]
uniqBinders = forall a. Eq a => [a] -> [a]
DL.nub (forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                                      [([CoreBind], Alt CoreBndr)]
patternMatches)

        -- let constrs = constructingBinders anns bind
        let getConstrs :: (a, Context) -> Maybe (a, CoreBndr)
getConstrs (a, Context)
x =
                case (a, Context)
x of
                    (a
bs, Constr CoreBndr
con) -> forall a. a -> Maybe a
Just (a
bs, CoreBndr
con)
                    (a, Context)
_ -> forall a. Maybe a
Nothing
        let constrs :: [([CoreBind], CoreBndr)]
constrs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. (a, Context) -> Maybe (a, CoreBndr)
getConstrs [([CoreBind], Context)]
results
        let uniqConstr :: [CoreBndr]
uniqConstr = forall a. Eq a => [a] -> [a]
DL.nub (forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinderforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([CoreBind], CoreBndr)]
constrs)

        -- TBD: For ReportWarn level prepare a single consolidated list of
        -- paths with one entry for each binder and giving one example of what
        -- it scrutinizes and/or constructs, for example:
        --
        -- \$sconcat_s8wu/step5_s8M4: Scrutinizes ConcatOuter, Constructs Yield
        --
        case ReportMode
reportMode of
            ReportMode
ReportSilent -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ReportMode
ReportWarn -> do
                let allBinds :: [[CoreBind]]
allBinds = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([CoreBind], Alt CoreBndr)]
patternMatches forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([CoreBind], CoreBndr)]
constrs
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[CoreBind]]
allBinds) forall a b. (a -> b) -> a -> b
$ do
                    String -> CoreM ()
putMsgS String
"Unfused bindings:"
                    String -> CoreM ()
putMsgS forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
DL.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags) [[CoreBind]]
allBinds
            ReportMode
_ -> do
                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
                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) =
        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 (forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr)) [(CoreBndr, Expr CoreBndr)]
bs

-------------------------------------------------------------------------------
-- Dump core passes
-------------------------------------------------------------------------------

-- Only for GHC versions before 9.0.0
#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
                 -- dump file location is being forced
                 --      by the --ddump-file-prefix flag.
               | Just prefix <- dumpPrefixForce dflags
                  = Just prefix
                 -- dump file location chosen by DriverPipeline.runPipeline
               | Just prefix <- dumpPrefix dflags
                  = Just prefix
                 -- we haven't got a place to put a dump file.
               | otherwise
                  = Nothing
              setDir f = case dumpDir dflags of
                         Just d  -> d </> f
                         Nothing ->       f

-- Copied from GHC.Utils.Logger
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
            -- We do not want the dump file to be affected by
            -- environment variables, but instead to always use
            -- UTF8. See:
            -- https://gitlab.haskell.org/ghc/ghc/issues/10762
            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
    -- write dump to file
    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

    -- write the dump to stdout
    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

-- XXX Need to fix for GHC-9.6 and above
-- dump core not supported on 9.0.0, 9.0.0 does not export Logger
#if __GLASGOW_HASKELL__!=900 && !MIN_VERSION_ghc(9,6,0)
-- Only for GHC versions >= 9.2.0
#if MIN_VERSION_ghc(9,2,0)
dumpPassResult ::
      Logger
   -> DynFlags
   -> PrintUnqualified
   -> SDoc                  -- Header
   -> SDoc                  -- Extra info to appear after header
   -> 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 logger
    let getDumpAction = putDumpFile
#else
    let flags :: DynFlags
flags = DynFlags
dflags
    let getDumpAction :: Logger -> DumpAction
getDumpAction = Logger -> DumpAction
putDumpMsg
#endif
    (Logger -> DumpAction
getDumpAction Logger
logger)
        DynFlags
flags PprStyle
dump_style DumpFlag
Opt_D_dump_simpl String
title 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                  -- Header
               -> SDoc                  -- Extra info to appear after header
               -> 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 (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 forall a. a -> [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 = forall r. PrintfType r => String -> r
printf String
"%02d" Int
counter forall a. [a] -> [a] -> [a]
++ String
"-"
        forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isSpace Char
x then Char
'-' else Char
x)
               forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filterOutLast Char -> Bool
isSpace
               forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'(')
               forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
todo)
        forall a. [a] -> [a] -> [a]
++ String
"."

#if MIN_VERSION_ghc(9,4,0)
    prefix = log_dump_prefix (logFlags logger) ++ _suffix
    logger1 = logger {logFlags = (logFlags logger) {log_dump_prefix = prefix}}
#elif MIN_VERSION_ghc(9,2,0)
    logger1 :: Logger
logger1 = Logger
logger
#endif
#endif

#if !MIN_VERSION_ghc(9,6,0)
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
counter SDoc
title ModGuts
guts = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    String -> CoreM ()
putMsgS forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: dumping core "
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
counter forall a. [a] -> [a] -> [a]
++ 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)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
    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 ") 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 forall a. a -> [a] -> [a]
: Int -> SDoc -> CoreToDo
dumpCorePass Int
counter (String -> SDoc
text String
"After " SDoc -> SDoc -> SDoc
GhcPlugins.<> forall a. Outputable a => a -> SDoc
ppr CoreToDo
todo)
             forall a. a -> [a] -> [a]
: Int -> [CoreToDo] -> [CoreToDo]
go (Int
counter forall a. Num a => a -> a -> a
+ Int
1) [CoreToDo]
rest
#else
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore _counter _title guts = return guts

_insertDumpCore :: [CoreToDo] -> [CoreToDo]
_insertDumpCore = id
#endif

-------------------------------------------------------------------------------
-- Install our plugin core pass
-------------------------------------------------------------------------------

-- | Inserts the given list of 'CoreToDo' after the simplifier phase 0.
-- A final 'CoreToDo' (for reporting) passed is executed after all the phases.
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 forall a. [a] -> [a] -> [a]
++ [CoreToDo
report]
  where
    go :: Bool -> [CoreToDo] -> [CoreToDo]
go Bool
False [] = forall a. HasCallStack => String -> a
error String
"Simplifier phase 0/\"main\" not found"
    go Bool
True [] = []
#if MIN_VERSION_ghc(9,6,0)
    go _ (todo@(CoreDoSimplify
        (SimplifyOpts
            { so_mode =
                (SimplMode
                    { sm_phase = Phase 0
                    , sm_names = ["main"]
                    }
                )
            }
        )):todos)
#elif 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 forall a. a -> [a] -> [a]
: [CoreToDo]
ourTodos forall a. [a] -> [a] -> [a]
++ Bool -> [CoreToDo] -> [CoreToDo]
go Bool
True [CoreToDo]
todos
    go Bool
found (CoreToDo
todo:[CoreToDo]
todos) = CoreToDo
todo 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [String] -> IO Options
parseOptions [String]
args
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    HscEnv
hscEnv <- CoreM HscEnv
getHscEnv
#if MIN_VERSION_ghc(9,6,0)
    m <- getModule
    let
        home_pkg_rules =
            hptRules
                hscEnv
                (moduleUnitId m)
                (GWIB
                    { gwib_mod = moduleName m
                    , gwib_isBoot = NotBoot
                    }
                )
        hpt_rule_base = mkRuleBase home_pkg_rules
        -- XXX GHC should export getHomeRuleBase
        -- hpt_rule_base <- getHomeRuleBase
        simplify = fusionSimplify hpt_rule_base hscEnv dflags
#else
    let simplify :: CoreToDo
simplify = HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
#endif

    -- We run our plugin once the simplifier finishes phase 0,
    -- followed by a gentle simplifier which inlines and case-cases
    -- twice.
    --
    -- TODO: The gentle simplifier runs on the whole program,
    -- however it might be better to call `simplifyExpr` on the
    -- expression directly.
    --
    -- TODO do not run simplify if we did not do anything in markInline phase.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        (if Options -> Bool
optionsDumpCore Options
options
         then [CoreToDo] -> [CoreToDo]
_insertDumpCore
         else forall a. a -> a
id) 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
            , CoreToDo
simplify
            , Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
2 ReportMode
ReportSilent Bool
False Bool
True
            , CoreToDo
simplify
            , Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
3 ReportMode
ReportSilent Bool
False Bool
True
            , CoreToDo
simplify
            -- This lets us know what was left unfused after all the inlining
            -- and case-of-case transformations.
            , 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
    }