-- |
-- 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)
-- Explicit/qualified imports
import Control.Monad (mzero, when, unless)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State
import Data.Char (isSpace)
import Data.Maybe (mapMaybe)
import Data.Generics.Schemes (everywhere)
import Data.Generics.Aliases (mkT)
import Data.IORef (readIORef, writeIORef)
import Data.Time (getCurrentTime)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory)
import System.IO (Handle, IOMode(..), withFile, hSetEncoding, utf8)
import Text.Printf (printf)

import ErrUtils (mkDumpDoc, Severity(..))
import PprCore (pprCoreBindingsWithSize, pprRules)

import qualified Data.List as DL
import qualified Data.Set as Set
#endif

-- Implicit imports
import GhcPlugins

-- 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
-- @
--
-- 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)

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

data Options = Options
    { Options -> Bool
optionsDumpCore :: Bool
    , Options -> ReportMode
optionsVerbosityLevel :: ReportMode
    } deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show

defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: Bool -> ReportMode -> Options
Options
    { optionsDumpCore :: Bool
optionsDumpCore = Bool
False
    , optionsVerbosityLevel :: ReportMode
optionsVerbosityLevel = ReportMode
ReportSilent
    }

setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m ()
setDumpCore :: Bool -> StateT ([String], Options) m ()
setDumpCore Bool
val = do
    ([String]
args, Options
opts) <- StateT ([String], Options) m ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    ([String], Options) -> StateT ([String], Options) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([String]
args, Options
opts { optionsDumpCore :: Bool
optionsDumpCore = Bool
val })

setVerbosityLevel :: Monad m
    => ReportMode -> StateT ([CommandLineOption], Options) m ()
setVerbosityLevel :: ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
val = do
    ([String]
args, Options
opts) <- StateT ([String], Options) m ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    ([String], Options) -> StateT ([String], Options) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([String]
args, Options
opts { optionsVerbosityLevel :: ReportMode
optionsVerbosityLevel = ReportMode
val })

-- 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 <- StateT ([String], Options) (MaybeT IO) ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    case ([String], Options)
s of
        ([], Options
_) -> Maybe String
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        (String
x : [String]
xs, Options
opts) -> ([String], Options) -> StateT ([String], Options) (MaybeT IO) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([String]
xs, Options
opts) StateT ([String], Options) (MaybeT IO) ()
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String
-> StateT ([String], Options) (MaybeT IO) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
x)

-- totally imperative style option parsing
parseOptions :: [CommandLineOption] -> IO Options
parseOptions :: [String] -> IO Options
parseOptions [String]
args = do
    Maybe Options
maybeOptions <- MaybeT IO Options -> IO (Maybe Options)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
                        (MaybeT IO Options -> IO (Maybe Options))
-> MaybeT IO Options -> IO (Maybe Options)
forall a b. (a -> b) -> a -> b
$ (StateT ([String], Options) (MaybeT IO) Options
 -> ([String], Options) -> MaybeT IO Options)
-> ([String], Options)
-> StateT ([String], Options) (MaybeT IO) Options
-> MaybeT IO Options
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT ([String], Options) (MaybeT IO) Options
-> ([String], Options) -> MaybeT IO Options
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ([String]
args, Options
defaultOptions)
                        (StateT ([String], Options) (MaybeT IO) Options
 -> MaybeT IO Options)
-> StateT ([String], Options) (MaybeT IO) Options
-> MaybeT IO Options
forall a b. (a -> b) -> a -> b
$ do StateT ([String], Options) (MaybeT IO) ()
parseLoop
                             (([String], Options) -> Options)
-> StateT ([String], Options) (MaybeT IO) ([String], Options)
-> StateT ([String], Options) (MaybeT IO) Options
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String], Options) -> Options
forall a b. (a, b) -> b
snd StateT ([String], Options) (MaybeT IO) ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Options -> IO Options
forall (m :: * -> *) a. Monad m => a -> m a
return (Options -> IO Options) -> Options -> IO Options
forall a b. (a -> b) -> a -> b
$ Options -> (Options -> Options) -> Maybe Options -> Options
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Options
defaultOptions Options -> Options
forall a. a -> a
id Maybe Options
maybeOptions

    where

    parseOpt :: String -> StateT ([String], Options) m ()
parseOpt String
opt =
        case String
opt of
            String
"dump-core" -> Bool -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
Bool -> StateT ([String], Options) m ()
setDumpCore Bool
True
            String
"verbose=1" -> ReportMode -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportWarn
            String
"verbose=2" -> ReportMode -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose
            String
"verbose=3" -> ReportMode -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose1
            String
"verbose=4" -> ReportMode -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
ReportMode -> StateT ([String], Options) m ()
setVerbosityLevel ReportMode
ReportVerbose2
            String
str -> do
                IO () -> StateT ([String], Options) m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                    (IO () -> StateT ([String], Options) m ())
-> IO () -> StateT ([String], Options) m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn
                    (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: Unrecognized option - \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
                StateT ([String], Options) m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero

    parseLoop :: StateT ([String], Options) (MaybeT IO) ()
parseLoop = do
        Maybe String
next <- StateT ([String], Options) (MaybeT IO) (Maybe String)
shift
        case Maybe String
next of
            Just String
opt -> String -> StateT ([String], Options) (MaybeT IO) ()
forall (m :: * -> *).
(MonadIO m, MonadPlus m) =>
String -> StateT ([String], Options) m ()
parseOpt String
opt StateT ([String], Options) (MaybeT IO) ()
-> StateT ([String], Options) (MaybeT IO) ()
-> StateT ([String], Options) (MaybeT IO) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT ([String], Options) (MaybeT IO) ()
parseLoop
            Maybe String
Nothing -> () -> StateT ([String], Options) (MaybeT IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-------------------------------------------------------------------------------
-- 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=UnfoldingSource
InlineStable, 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 :: CoreBndr -> CoreBndr
setAlwaysInlineOnBndr :: CoreBndr -> CoreBndr
setAlwaysInlineOnBndr CoreBndr
n =
    let info :: IdInfo
info =
            case IdInfo -> Maybe IdInfo
zapUsageInfo (IdInfo -> Maybe IdInfo) -> IdInfo -> Maybe IdInfo
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
n of
                Just IdInfo
i -> IdInfo
i
                Maybe IdInfo
Nothing ->
                    String -> IdInfo
forall a. HasCallStack => String -> a
error String
"The impossible happened!! Or GHC changed their api."
        unf :: Unfolding
unf = IdInfo -> Unfolding
unfoldingInfo IdInfo
info
        info' :: IdInfo
info' =
            IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo
                (IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo IdInfo
info InlinePragma
alwaysInlinePragma)
                (Int -> Unfolding -> Unfolding
unfoldCompulsory (IdInfo -> Int
arityInfo IdInfo
info) Unfolding
unf)
     in CoreBndr -> IdInfo -> CoreBndr
lazySetIdInfo CoreBndr
n IdInfo
info'

--TODO: Replace self-recursive definitions with a loop breaker.
-- | Set inline on specific binders inside a given bind.
setInlineOnBndrs :: [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs :: [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs [CoreBndr]
bndrs = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((forall a. Data a => a -> a) -> forall a. Data a => a -> a)
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall a b. (a -> b) -> a -> b
$ (CoreBind -> CoreBind) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT CoreBind -> CoreBind
go
  where
    go :: CoreBind -> CoreBind
    go :: CoreBind -> CoreBind
go (NonRec CoreBndr
b Expr CoreBndr
expr) | (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CoreBndr
b CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
==) [CoreBndr]
bndrs =
        CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (CoreBndr -> CoreBndr
setAlwaysInlineOnBndr CoreBndr
b) Expr CoreBndr
expr
    go CoreBind
x = CoreBind
x

hasInlineBinder :: CoreBndr -> Bool
hasInlineBinder :: CoreBndr -> Bool
hasInlineBinder CoreBndr
bndr =
    let inl :: InlinePragma
inl = IdInfo -> InlinePragma
inlinePragInfo (IdInfo -> InlinePragma) -> IdInfo -> InlinePragma
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
bndr
    in InlinePragma -> Bool
isInlinePragma InlinePragma
inl Bool -> Bool -> Bool
&& Int -> Activation -> Bool
isActiveIn Int
0 (InlinePragma -> Activation
inlinePragmaActivation InlinePragma
inl)

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

-- 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 :: UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn :: UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn UniqFM [Fuse]
_ [] = Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
altsContainsAnn UniqFM [Fuse]
anns (bndr :: Alt CoreBndr
bndr@(DataAlt DataCon
dcon, [CoreBndr]
_, Expr CoreBndr
_):[Alt CoreBndr]
_) =
    case UniqFM [Fuse] -> Unique -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Fuse]
anns (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Unique) -> TyCon -> Unique
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dcon) of
        Maybe [Fuse]
Nothing -> Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
        Just [Fuse]
_ -> Alt CoreBndr -> Maybe (Alt CoreBndr)
forall a. a -> Maybe a
Just Alt CoreBndr
bndr
altsContainsAnn UniqFM [Fuse]
anns ((AltCon
DEFAULT, [CoreBndr]
_, Expr CoreBndr
_):[Alt CoreBndr]
alts) = UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn UniqFM [Fuse]
anns [Alt CoreBndr]
alts
altsContainsAnn UniqFM [Fuse]
_ [Alt CoreBndr]
_ = Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing

needInlineCaseAlt
    :: CoreBind -> UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
needInlineCaseAlt :: CoreBind -> UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
needInlineCaseAlt CoreBind
parent UniqFM [Fuse]
anns [Alt CoreBndr]
bndr =
    case UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn UniqFM [Fuse]
anns [Alt CoreBndr]
bndr of
        Just Alt CoreBndr
alt | Bool -> Bool
not (CoreBndr -> Bool
hasInlineBinder (CoreBndr -> Bool) -> CoreBndr -> Bool
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder CoreBind
parent) -> Alt CoreBndr -> Maybe (Alt CoreBndr)
forall a. a -> Maybe a
Just Alt CoreBndr
alt
        Maybe (Alt CoreBndr)
_ -> Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- 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
    :: UniqFM [Fuse]
    -> CoreBind
    -> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases UniqFM [Fuse]
anns CoreBind
bind = [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [] CoreBind
bind
  where
    -- 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 [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], Alt CoreBndr)])
-> [([CoreBind], Alt CoreBndr)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(AltCon
_, [CoreBndr]
_, Expr CoreBndr
expr1) -> [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1)
        in case CoreBind -> UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
needInlineCaseAlt ([CoreBind] -> CoreBind
forall a. [a] -> a
head [CoreBind]
parents) UniqFM [Fuse]
anns [Alt CoreBndr]
alts of
            Just Alt CoreBndr
x -> ([CoreBind]
parents, Alt CoreBndr
x) ([CoreBind], Alt CoreBndr)
-> [([CoreBind], Alt CoreBndr)] -> [([CoreBind], Alt CoreBndr)]
forall a. a -> [a] -> [a]
: [([CoreBind], Alt CoreBndr)]
binders
            Maybe (Alt CoreBndr)
Nothing -> [([CoreBind], Alt CoreBndr)]
binders

    -- 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 [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], Alt CoreBndr)])
-> [([CoreBind], Alt CoreBndr)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(AltCon
_, [CoreBndr]
_, Expr CoreBndr
expr1) -> [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1)

    -- 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?
                                    [([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

    -- 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
                                     [([CoreBind], Alt CoreBndr)]
-> [([CoreBind], Alt CoreBndr)] -> [([CoreBind], Alt CoreBndr)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr2
    go [CoreBind]
parents Bool
x (Lam CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
x Expr CoreBndr
expr1
    go [CoreBind]
parents Bool
_ (Cast Expr CoreBndr
expr1 Coercion
_) = [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1

    -- There are no let bindings in these.
    go [CoreBind]
_ Bool
_ (Var CoreBndr
_) = []
    go [CoreBind]
_ Bool
_ (Lit Literal
_) = []
    go [CoreBind]
_ Bool
_ (Tick Tickish CoreBndr
_ Expr CoreBndr
_) = []
    go [CoreBind]
_ Bool
_ (Type Type
_) = []
    go [CoreBind]
_ Bool
_ (Coercion Coercion
_) = []

    goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
    -- 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 CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
parents) Bool
True Expr CoreBndr
expr1
    goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
        [(CoreBndr, Expr CoreBndr)]
bs [(CoreBndr, Expr CoreBndr)]
-> ((CoreBndr, Expr CoreBndr) -> [([CoreBind], Alt CoreBndr)])
-> [([CoreBind], Alt CoreBndr)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CoreBndr
b, Expr CoreBndr
expr1) -> [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [CoreBind]
parents (CoreBind -> [([CoreBind], Alt CoreBndr)])
-> CoreBind -> [([CoreBind], Alt CoreBndr)]
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)

needInlineConstr :: CoreBind -> UniqFM [Fuse] -> DataCon -> Bool
needInlineConstr :: CoreBind -> UniqFM [Fuse] -> DataCon -> Bool
needInlineConstr CoreBind
parent UniqFM [Fuse]
anns DataCon
dcon =
    case UniqFM [Fuse] -> Unique -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Fuse]
anns (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Unique) -> TyCon -> Unique
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dcon) of
        Just [Fuse]
_ | Bool -> Bool
not (CoreBndr -> Bool
hasInlineBinder (CoreBndr -> Bool) -> CoreBndr -> Bool
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder CoreBind
parent) -> Bool
True
        Maybe [Fuse]
_ -> Bool
False

-- 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 :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], DataCon)]
constructingBinders :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], DataCon)]
constructingBinders UniqFM [Fuse]
anns CoreBind
bind = [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
goLet [] CoreBind
bind
  where
    -- 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], DataCon)]

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

    -- Traverse these to discover new let bindings
    go [CoreBind]
parents (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
        [Alt CoreBndr]
alts [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], DataCon)])
-> [([CoreBind], DataCon)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(AltCon
_, [CoreBndr]
_, Expr CoreBndr
expr1) -> [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1)
    go [CoreBind]
parents (App Expr CoreBndr
expr1 Expr CoreBndr
expr2) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1 [([CoreBind], DataCon)]
-> [([CoreBind], DataCon)] -> [([CoreBind], DataCon)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr2
    go [CoreBind]
parents (Lam CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1
    go [CoreBind]
parents (Cast Expr CoreBndr
expr1 Coercion
_) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go [CoreBind]
parents Expr CoreBndr
expr1

    -- Check if the Var is a data constructor of interest
    go [CoreBind]
parents (Var CoreBndr
i) =
        let needInline :: DataCon -> Bool
needInline = CoreBind -> UniqFM [Fuse] -> DataCon -> Bool
needInlineConstr ([CoreBind] -> CoreBind
forall a. [a] -> a
head [CoreBind]
parents) UniqFM [Fuse]
anns
        in case CoreBndr -> IdDetails
idDetails CoreBndr
i of
            DataConWorkId DataCon
dcon | DataCon -> Bool
needInline DataCon
dcon -> [([CoreBind]
parents, DataCon
dcon)]
            IdDetails
_ -> []

    go [CoreBind]
_ (Lit Literal
_) = []
    go [CoreBind]
_ (Tick Tickish CoreBndr
_ Expr CoreBndr
_) = []
    go [CoreBind]
_ (Type Type
_) = []
    go [CoreBind]
_ (Coercion Coercion
_) = []

    goLet :: [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
    goLet :: [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
goLet [CoreBind]
parents bndr :: CoreBind
bndr@(NonRec CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], DataCon)]
go (CoreBind
bndr CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
parents) Expr CoreBndr
expr1
    goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
        [(CoreBndr, Expr CoreBndr)]
bs [(CoreBndr, Expr CoreBndr)]
-> ((CoreBndr, Expr CoreBndr) -> [([CoreBind], DataCon)])
-> [([CoreBind], DataCon)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CoreBndr
b, Expr CoreBndr
expr1) -> [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]
goLet [CoreBind]
parents (CoreBind -> [([CoreBind], DataCon)])
-> CoreBind -> [([CoreBind], DataCon)]
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)

data Context = CaseAlt (Alt CoreBndr) | Constr DataCon

-- 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 :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns UniqFM [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 [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], Context)])
-> [([CoreBind], Context)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(AltCon
_, [CoreBndr]
_, Expr CoreBndr
expr1) -> [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1)
        in case UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn UniqFM [Fuse]
anns [Alt CoreBndr]
alts of
            Just Alt CoreBndr
x -> ([CoreBind]
parents, Alt CoreBndr -> Context
CaseAlt Alt CoreBndr
x) ([CoreBind], Context)
-> [([CoreBind], Context)] -> [([CoreBind], Context)]
forall a. a -> [a] -> [a]
: [([CoreBind], Context)]
binders
            Maybe (Alt CoreBndr)
Nothing -> [([CoreBind], Context)]
binders

    -- 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 [([CoreBind], Context)]
-> [([CoreBind], Context)] -> [([CoreBind], Context)]
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 [([CoreBind], Context)]
-> [([CoreBind], Context)] -> [([CoreBind], Context)]
forall a. [a] -> [a] -> [a]
++ [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr2
    go [CoreBind]
parents (Lam CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1
    go [CoreBind]
parents (Cast Expr CoreBndr
expr1 Coercion
_) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1

    -- Check if the Var is a data constructor of interest
    go [CoreBind]
parents (Var CoreBndr
i) =
        case CoreBndr -> IdDetails
idDetails CoreBndr
i of
            DataConWorkId DataCon
dcon ->
                case UniqFM [Fuse] -> Unique -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Fuse]
anns (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Unique) -> TyCon -> Unique
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dcon) of
                    Just [Fuse]
_ -> [([CoreBind]
parents, DataCon -> Context
Constr DataCon
dcon)]
                    Maybe [Fuse]
Nothing -> []
            IdDetails
_ -> []

    -- There are no let bindings in these.
    go [CoreBind]
_ (Lit Literal
_) = []
    go [CoreBind]
_ (Tick Tickish CoreBndr
_ Expr CoreBndr
_) = []
    go [CoreBind]
_ (Type Type
_) = []
    go [CoreBind]
_ (Coercion Coercion
_) = []

    goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Context)]
    goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet [CoreBind]
parents bndr :: CoreBind
bndr@(NonRec CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go (CoreBind
bndr CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
parents) Expr CoreBndr
expr1
    goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
        [(CoreBndr, Expr CoreBndr)]
bs [(CoreBndr, Expr CoreBndr)]
-> ((CoreBndr, Expr CoreBndr) -> [([CoreBind], Context)])
-> [([CoreBind], Context)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CoreBndr
b, Expr CoreBndr
expr1) -> [CoreBind] -> CoreBind -> [([CoreBind], Context)]
goLet [CoreBind]
parents (CoreBind -> [([CoreBind], Context)])
-> CoreBind -> [([CoreBind], Context)]
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)

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

data ReportMode =
      ReportSilent
    | ReportWarn
    | ReportVerbose
    | ReportVerbose1
    | ReportVerbose2
    deriving (Int -> ReportMode -> ShowS
[ReportMode] -> ShowS
ReportMode -> String
(Int -> ReportMode -> ShowS)
-> (ReportMode -> String)
-> ([ReportMode] -> ShowS)
-> Show ReportMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReportMode] -> ShowS
$cshowList :: [ReportMode] -> ShowS
show :: ReportMode -> String
$cshow :: ReportMode -> String
showsPrec :: Int -> ReportMode -> ShowS
$cshowsPrec :: Int -> ReportMode -> ShowS
Show)

getNonRecBinder :: CoreBind -> CoreBndr
getNonRecBinder :: CoreBind -> CoreBndr
getNonRecBinder (NonRec CoreBndr
b Expr CoreBndr
_) = CoreBndr
b
getNonRecBinder (Rec [(CoreBndr, Expr CoreBndr)]
_) = String -> CoreBndr
forall a. HasCallStack => String -> a
error String
"markInline: expecting only nonrec binders"

-- 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.

addMissingUnique :: (Outputable a, Uniquable a) => DynFlags -> a -> String
addMissingUnique :: DynFlags -> a -> String
addMissingUnique DynFlags
dflags a
bndr =
    let suffix :: String
suffix = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (a -> Unique
forall a. Uniquable a => a -> Unique
getUnique a
bndr)
        bndrName :: String
bndrName = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
bndr
    in if String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
DL.isSuffixOf String
suffix String
bndrName
       then String
bndrName
       else String
bndrName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix

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

showDetailsCaseMatch
    :: DynFlags
    -> ReportMode
    -> ([CoreBind], Alt CoreBndr)
    -> String
showDetailsCaseMatch :: DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String
showDetailsCaseMatch DynFlags
dflags ReportMode
reportMode ([CoreBind]
binds, c :: Alt CoreBndr
c@(AltCon
con,[CoreBndr]
_,Expr CoreBndr
_)) =
    DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        case ReportMode
reportMode of
            ReportMode
ReportVerbose -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con)
            ReportMode
ReportVerbose1 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Alt CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Alt CoreBndr
c)
            ReportMode
ReportVerbose2 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBind -> SDoc) -> CoreBind -> SDoc
forall a b. (a -> b) -> a -> b
$ [CoreBind] -> CoreBind
forall a. [a] -> a
head [CoreBind]
binds)
            ReportMode
_ -> ShowS
forall a. HasCallStack => String -> a
error String
"transformBind: unreachable"

showDetailsConstr
    :: DynFlags
    -> ReportMode
    -> ([CoreBind], DataCon)
    -> String
showDetailsConstr :: DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String
showDetailsConstr DynFlags
dflags ReportMode
reportMode ([CoreBind]
binds, DataCon
con) =
    DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        case ReportMode
reportMode of
            ReportMode
ReportVerbose -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con)
            ReportMode
ReportVerbose1 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con)
            ReportMode
ReportVerbose2 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBind -> SDoc) -> CoreBind -> SDoc
forall a b. (a -> b) -> a -> b
$ [CoreBind] -> CoreBind
forall a. [a] -> a
head [CoreBind]
binds)
            ReportMode
_ -> ShowS
forall a. HasCallStack => String -> a
error String
"transformBind: unreachable"

showInfo
    :: CoreBndr
    -> DynFlags
    -> ReportMode
    -> Bool
    -> String
    -> [CoreBndr]
    -> [([CoreBind], a)]
    -> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
    -> CoreM ()
showInfo :: CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
parent DynFlags
dflags ReportMode
reportMode Bool
failIt
        String
tag [CoreBndr]
uniqBinders [([CoreBind], a)]
annotated DynFlags -> ReportMode -> ([CoreBind], a) -> String
showDetails =
    Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([CoreBndr]
uniqBinders [CoreBndr] -> [CoreBndr] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
        let msg :: String
msg = String
"In "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> CoreBndr -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
addMissingUnique DynFlags
dflags CoreBndr
parent
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" binders "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((CoreBndr -> String) -> [CoreBndr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> CoreBndr -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
addMissingUnique DynFlags
dflags) ([CoreBndr]
uniqBinders))
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tag
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" data types annotated with "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Fuse -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fuse
Fuse)
        case ReportMode
reportMode of
            ReportMode
ReportSilent -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ReportMode
ReportWarn -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ReportMode
_ -> do
                String -> CoreM ()
putMsgS String
msg
                String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines
                        ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
DL.nub
                        ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (([CoreBind], a) -> String) -> [([CoreBind], a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ReportMode -> ([CoreBind], a) -> String
showDetails DynFlags
dflags ReportMode
reportMode) [([CoreBind], a)]
annotated
        Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
failIt (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String -> CoreM ()
forall a. HasCallStack => String -> a
error String
"failing"

markInline :: ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline :: ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline ReportMode
reportMode Bool
failIt Bool
transform ModGuts
guts = do
    String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: Checking bindings to inline..."
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    UniqFM [Fuse]
anns <- ([Word8] -> Fuse) -> ModGuts -> CoreM (UniqFM [Fuse])
forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
getAnnotations [Word8] -> Fuse
forall a. Data a => [Word8] -> a
deserializeWithData ModGuts
guts
    if (([Fuse] -> Bool) -> UniqFM [Fuse] -> Bool
forall elt. (elt -> Bool) -> UniqFM elt -> Bool
anyUFM ((Fuse -> Bool) -> [Fuse] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Fuse -> Fuse -> Bool
forall a. Eq a => a -> a -> Bool
== Fuse
Fuse)) UniqFM [Fuse]
anns)
    then ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts
bindsOnlyPass ((CoreBind -> CoreM CoreBind) -> [CoreBind] -> CoreM [CoreBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM [Fuse]
anns)) ModGuts
guts
    else ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
  where
    transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind
    transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM [Fuse]
anns bind :: CoreBind
bind@(NonRec CoreBndr
b Expr CoreBndr
_) = do
        let patternMatches :: [([CoreBind], Alt CoreBndr)]
patternMatches = UniqFM [Fuse] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases UniqFM [Fuse]
anns CoreBind
bind
        let uniqPat :: [CoreBndr]
uniqPat = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], Alt CoreBndr) -> CoreBndr)
-> [([CoreBind], Alt CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder(CoreBind -> CoreBndr)
-> (([CoreBind], Alt CoreBndr) -> CoreBind)
-> ([CoreBind], Alt CoreBndr)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> ([CoreBind], Alt CoreBndr)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst) [([CoreBind], Alt CoreBndr)]
patternMatches)

        let constrs :: [([CoreBind], DataCon)]
constrs = UniqFM [Fuse] -> CoreBind -> [([CoreBind], DataCon)]
constructingBinders UniqFM [Fuse]
anns CoreBind
bind
        let uniqConstr :: [CoreBndr]
uniqConstr = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], DataCon) -> CoreBndr)
-> [([CoreBind], DataCon)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder(CoreBind -> CoreBndr)
-> (([CoreBind], DataCon) -> CoreBind)
-> ([CoreBind], DataCon)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], DataCon) -> [CoreBind])
-> ([CoreBind], DataCon)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], DataCon) -> [CoreBind]
forall a b. (a, b) -> a
fst) [([CoreBind], DataCon)]
constrs)

        -- 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 -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ReportMode
ReportWarn -> do
                let allBinds :: [[CoreBind]]
allBinds = (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> [([CoreBind], Alt CoreBndr)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], Alt CoreBndr)]
patternMatches [[CoreBind]] -> [[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a] -> [a]
++ (([CoreBind], DataCon) -> [CoreBind])
-> [([CoreBind], DataCon)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], DataCon) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], DataCon)]
constrs
                Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [[CoreBind]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[CoreBind]]
allBinds) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
                    String -> CoreM ()
putMsgS String
"INLINE required on:"
                    String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
DL.nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([CoreBind] -> String) -> [[CoreBind]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags) [[CoreBind]]
allBinds
            ReportMode
_ -> do
                CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], Alt CoreBndr)]
-> (DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String)
-> CoreM ()
forall a.
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
b DynFlags
dflags ReportMode
reportMode Bool
failIt String
"SCRUTINIZE"
                    [CoreBndr]
uniqPat [([CoreBind], Alt CoreBndr)]
patternMatches DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String
showDetailsCaseMatch
                CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], DataCon)]
-> (DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String)
-> CoreM ()
forall a.
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
b DynFlags
dflags ReportMode
reportMode Bool
failIt String
"CONSTRUCT"
                    [CoreBndr]
uniqConstr [([CoreBind], DataCon)]
constrs DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String
showDetailsConstr

        let bind' :: CoreBind
bind' = do
                let allBinders :: [CoreBndr]
allBinders = [CoreBndr]
uniqPat [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
uniqConstr
                if Bool
transform Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
allBinders)
                then [CoreBndr] -> CoreBind -> CoreBind
setInlineOnBndrs [CoreBndr]
allBinders CoreBind
bind
                else CoreBind
bind
        CoreBind -> CoreM CoreBind
forall (m :: * -> *) a. Monad m => a -> m a
return CoreBind
bind'

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

-- | Core pass to mark functions scrutinizing constructors marked with Fuse
fusionMarkInline :: ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline :: ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
opt Bool
failIt Bool
transform =
    String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
"Mark for inlining" (ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline ReportMode
opt Bool
failIt Bool
transform)

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

fusionSimplify :: DynFlags -> CoreToDo
fusionSimplify :: DynFlags -> CoreToDo
fusionSimplify DynFlags
dflags =
    Int -> SimplMode -> CoreToDo
CoreDoSimplify
        (DynFlags -> Int
maxSimplIterations DynFlags
dflags)
        SimplMode :: [String]
-> CompilerPhase
-> DynFlags
-> Bool
-> Bool
-> Bool
-> Bool
-> SimplMode
SimplMode
            { sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
            , sm_names :: [String]
sm_names = [String
"Fusion Plugin Inlining"]
            , sm_dflags :: DynFlags
sm_dflags = DynFlags
dflags
            , sm_rules :: Bool
sm_rules = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags
            , sm_eta_expand :: Bool
sm_eta_expand = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion DynFlags
dflags
            , sm_inline :: Bool
sm_inline = Bool
True
            , sm_case_case :: Bool
sm_case_case = Bool
True
            }

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

fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
msg ReportMode
reportMode ModGuts
guts = do
    String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    UniqFM [Fuse]
anns <- ([Word8] -> Fuse) -> ModGuts -> CoreM (UniqFM [Fuse])
forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
getAnnotations [Word8] -> Fuse
forall a. Data a => [Word8] -> a
deserializeWithData ModGuts
guts
    Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (([Fuse] -> Bool) -> UniqFM [Fuse] -> Bool
forall elt. (elt -> Bool) -> UniqFM elt -> Bool
anyUFM ((Fuse -> Bool) -> [Fuse] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Fuse -> Fuse -> Bool
forall a. Eq a => a -> a -> Bool
== Fuse
Fuse)) UniqFM [Fuse]
anns) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
        (CoreBind -> CoreM ()) -> [CoreBind] -> CoreM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM [Fuse]
anns) ([CoreBind] -> CoreM ()) -> [CoreBind] -> CoreM ()
forall a b. (a -> b) -> a -> b
$ ModGuts -> [CoreBind]
mg_binds ModGuts
guts
    ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
  where
    transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM ()
    transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM [Fuse]
anns bind :: CoreBind
bind@(NonRec CoreBndr
b Expr CoreBndr
_) = do
        let results :: [([CoreBind], Context)]
results = UniqFM [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns UniqFM [Fuse]
anns CoreBind
bind

        let getAlts :: (a, Context) -> Maybe (a, Alt CoreBndr)
getAlts (a, Context)
x =
                case (a, Context)
x of
                    (a
bs, CaseAlt Alt CoreBndr
alt) -> (a, Alt CoreBndr) -> Maybe (a, Alt CoreBndr)
forall a. a -> Maybe a
Just (a
bs, Alt CoreBndr
alt)
                    (a, Context)
_ -> Maybe (a, Alt CoreBndr)
forall a. Maybe a
Nothing
        let patternMatches :: [([CoreBind], Alt CoreBndr)]
patternMatches = (([CoreBind], Context) -> Maybe ([CoreBind], Alt CoreBndr))
-> [([CoreBind], Context)] -> [([CoreBind], Alt CoreBndr)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([CoreBind], Context) -> Maybe ([CoreBind], Alt CoreBndr)
forall a. (a, Context) -> Maybe (a, Alt CoreBndr)
getAlts [([CoreBind], Context)]
results
        let uniqBinders :: [CoreBndr]
uniqBinders = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], Alt CoreBndr) -> CoreBndr)
-> [([CoreBind], Alt CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder (CoreBind -> CoreBndr)
-> (([CoreBind], Alt CoreBndr) -> CoreBind)
-> ([CoreBind], Alt CoreBndr)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> ([CoreBind], Alt CoreBndr)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst)
                                      [([CoreBind], Alt CoreBndr)]
patternMatches)

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

        -- 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 -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ReportMode
ReportWarn -> do
                let allBinds :: [[CoreBind]]
allBinds = (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> [([CoreBind], Alt CoreBndr)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], Alt CoreBndr)]
patternMatches [[CoreBind]] -> [[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a] -> [a]
++ (([CoreBind], DataCon) -> [CoreBind])
-> [([CoreBind], DataCon)] -> [[CoreBind]]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind], DataCon) -> [CoreBind]
forall a b. (a, b) -> a
fst [([CoreBind], DataCon)]
constrs
                Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [[CoreBind]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[CoreBind]]
allBinds) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
                    String -> CoreM ()
putMsgS String
"Unfused bindings:"
                    String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
DL.nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([CoreBind] -> String) -> [[CoreBind]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags) [[CoreBind]]
allBinds
            ReportMode
_ -> do
                CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], Alt CoreBndr)]
-> (DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String)
-> CoreM ()
forall a.
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
b DynFlags
dflags ReportMode
reportMode Bool
False String
"SCRUTINIZE"
                    [CoreBndr]
uniqBinders [([CoreBind], Alt CoreBndr)]
patternMatches DynFlags -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String
showDetailsCaseMatch
                CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], DataCon)]
-> (DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String)
-> CoreM ()
forall a.
CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
b DynFlags
dflags ReportMode
reportMode Bool
False String
"CONSTRUCT"
                    [CoreBndr]
uniqConstr [([CoreBind], DataCon)]
constrs DynFlags -> ReportMode -> ([CoreBind], DataCon) -> String
showDetailsConstr

    transformBind DynFlags
dflags UniqFM [Fuse]
anns (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
        ((CoreBndr, Expr CoreBndr) -> CoreM ())
-> [(CoreBndr, Expr CoreBndr)] -> CoreM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(CoreBndr
b, Expr CoreBndr
expr) -> DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM [Fuse]
anns (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr)) [(CoreBndr, Expr CoreBndr)]
bs

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

chooseDumpFile :: DynFlags -> FilePath -> Maybe FilePath
chooseDumpFile :: DynFlags -> String -> Maybe String
chooseDumpFile DynFlags
dflags String
suffix
        | Just String
prefix <- Maybe String
getPrefix

        = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ShowS
setDir (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix)

        | Bool
otherwise

        = Maybe String
forall a. Maybe a
Nothing

        where getPrefix :: Maybe String
getPrefix
                 -- dump file location is being forced
                 --      by the --ddump-file-prefix flag.
               | Just String
prefix <- DynFlags -> Maybe String
dumpPrefixForce DynFlags
dflags
                  = String -> Maybe String
forall a. a -> Maybe a
Just String
prefix
                 -- dump file location chosen by DriverPipeline.runPipeline
               | Just String
prefix <- DynFlags -> Maybe String
dumpPrefix DynFlags
dflags
                  = String -> Maybe String
forall a. a -> Maybe a
Just String
prefix
                 -- we haven't got a place to put a dump file.
               | Bool
otherwise
                  = Maybe String
forall a. Maybe a
Nothing
              setDir :: ShowS
setDir String
f = case DynFlags -> Maybe String
dumpDir DynFlags
dflags of
                         Just String
d  -> String
d String -> ShowS
</> String
f
                         Maybe String
Nothing ->       String
f

withDumpFileHandle :: DynFlags -> FilePath -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle :: DynFlags -> String -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DynFlags
dflags String
suffix Maybe Handle -> IO ()
action = do
    let mFile :: Maybe String
mFile = DynFlags -> String -> Maybe String
chooseDumpFile DynFlags
dflags String
suffix
    case Maybe String
mFile of
      Just String
fileName -> do
        let gdref :: IORef (Set String)
gdref = DynFlags -> IORef (Set String)
generatedDumps DynFlags
dflags
        Set String
gd <- IORef (Set String) -> IO (Set String)
forall a. IORef a -> IO a
readIORef IORef (Set String)
gdref
        let append :: Bool
append = String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
fileName Set String
gd
            mode :: IOMode
mode = if Bool
append then IOMode
AppendMode else IOMode
WriteMode
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
append (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            IORef (Set String) -> Set String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Set String)
gdref (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
fileName Set String
gd)
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
fileName)
        String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fileName IOMode
mode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
            -- 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
            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
utf8
            Maybe Handle -> IO ()
action (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle)
      Maybe String
Nothing -> Maybe Handle -> IO ()
action Maybe Handle
forall a. Maybe a
Nothing

dumpSDocWithStyle :: PprStyle -> DynFlags -> FilePath -> String -> SDoc -> IO ()
dumpSDocWithStyle :: PprStyle -> DynFlags -> String -> String -> SDoc -> IO ()
dumpSDocWithStyle PprStyle
sty DynFlags
dflags String
suffix String
hdr SDoc
doc =
    DynFlags -> String -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DynFlags
dflags String
suffix Maybe Handle -> IO ()
writeDump
  where
    -- write dump to file
    writeDump :: Maybe Handle -> IO ()
writeDump (Just Handle
handle) = do
        SDoc
doc' <- if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hdr
                then SDoc -> IO SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc
                else do UTCTime
t <- IO UTCTime
getCurrentTime
                        let timeStamp :: SDoc
timeStamp = if (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTimestamps DynFlags
dflags)
                                          then SDoc
empty
                                          else String -> SDoc
text (UTCTime -> String
forall a. Show a => a -> String
show UTCTime
t)
                        let d :: SDoc
d = SDoc
timeStamp
                                SDoc -> SDoc -> SDoc
$$ SDoc
blankLine
                                SDoc -> SDoc -> SDoc
$$ SDoc
doc
                        SDoc -> IO SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> IO SDoc) -> SDoc -> IO SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> SDoc
mkDumpDoc String
hdr SDoc
d
        DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPrintDoc DynFlags
dflags Handle
handle SDoc
doc' PprStyle
sty

    -- write the dump to stdout
    writeDump Maybe Handle
Nothing = do
        let (SDoc
doc', Severity
severity)
              | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hdr  = (SDoc
doc, Severity
SevOutput)
              | Bool
otherwise = (String -> SDoc -> SDoc
mkDumpDoc String
hdr SDoc
doc, Severity
SevDump)
        DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
severity SrcSpan
noSrcSpan PprStyle
sty SDoc
doc'

dumpSDoc :: DynFlags -> PrintUnqualified -> FilePath -> String -> SDoc -> IO ()
dumpSDoc :: DynFlags -> PrintUnqualified -> String -> String -> SDoc -> IO ()
dumpSDoc DynFlags
dflags PrintUnqualified
print_unqual
    = PprStyle -> DynFlags -> String -> String -> SDoc -> IO ()
dumpSDocWithStyle PprStyle
dump_style DynFlags
dflags
  where dump_style :: PprStyle
dump_style = DynFlags -> PrintUnqualified -> PprStyle
mkDumpStyle DynFlags
dflags PrintUnqualified
print_unqual

dumpPassResult :: DynFlags
               -> PrintUnqualified
               -> FilePath
               -> SDoc                  -- Header
               -> SDoc                  -- Extra info to appear after header
               -> CoreProgram -> [CoreRule]
               -> IO ()
dumpPassResult :: DynFlags
-> PrintUnqualified
-> String
-> SDoc
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpPassResult DynFlags
dflags PrintUnqualified
unqual String
suffix SDoc
hdr SDoc
extra_info [CoreBind]
binds [CoreRule]
rules = do
   DynFlags -> PrintUnqualified -> String -> String -> SDoc -> IO ()
dumpSDoc DynFlags
dflags PrintUnqualified
unqual String
suffix (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
hdr) SDoc
dump_doc

  where

    dump_doc :: SDoc
dump_doc  = [SDoc] -> SDoc
vcat [ Int -> SDoc -> SDoc
nest Int
2 SDoc
extra_info
                     , SDoc
blankLine
                     , [CoreBind] -> SDoc
pprCoreBindingsWithSize [CoreBind]
binds
                     , Bool -> SDoc -> SDoc
ppUnless ([CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules) SDoc
pp_rules ]
    pp_rules :: SDoc
pp_rules = [SDoc] -> SDoc
vcat [ SDoc
blankLine
                    , String -> SDoc
text String
"------ Local rules for imported ids --------"
                    , [CoreRule] -> SDoc
pprRules [CoreRule]
rules ]

filterOutLast :: (a -> Bool) -> [a] -> [a]
filterOutLast :: (a -> Bool) -> [a] -> [a]
filterOutLast a -> Bool
_ [] = []
filterOutLast a -> Bool
p [a
x]
    | a -> Bool
p a
x = []
    | Bool
otherwise = [a
x]
filterOutLast a -> Bool
p (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filterOutLast a -> Bool
p [a]
xs

dumpResult
    :: DynFlags
    -> PrintUnqualified
    -> Int
    -> SDoc
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
dumpResult :: DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpResult DynFlags
dflags PrintUnqualified
print_unqual Int
counter SDoc
todo [CoreBind]
binds [CoreRule]
rules =
    DynFlags
-> PrintUnqualified
-> String
-> SDoc
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpPassResult DynFlags
dflags PrintUnqualified
print_unqual String
suffix SDoc
hdr (String -> SDoc
text String
"") [CoreBind]
binds [CoreRule]
rules

    where

    hdr :: SDoc
hdr = String -> SDoc
text String
"["
        SDoc -> SDoc -> SDoc
GhcPlugins.<> Int -> SDoc
int Int
counter
        SDoc -> SDoc -> SDoc
GhcPlugins.<> String -> SDoc
text String
"] "
        SDoc -> SDoc -> SDoc
GhcPlugins.<> SDoc
todo

    suffix :: String
suffix = String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02d" Int
counter String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isSpace Char
x then Char
'-' else Char
x)
               ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filterOutLast Char -> Bool
isSpace
               ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(')
               ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
todo)

dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
counter SDoc
todo
    guts :: ModGuts
guts@(ModGuts
        { mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env
        , mg_binds :: ModGuts -> [CoreBind]
mg_binds = [CoreBind]
binds
        , mg_rules :: ModGuts -> [CoreRule]
mg_rules = [CoreRule]
rules
        }) = do
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: dumping core "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
counter String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
todo

    let print_unqual :: PrintUnqualified
print_unqual = DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
rdr_env
    IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpResult DynFlags
dflags PrintUnqualified
print_unqual Int
counter SDoc
todo [CoreBind]
binds [CoreRule]
rules
    ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts

dumpCorePass :: Int -> SDoc -> CoreToDo
dumpCorePass :: Int -> SDoc -> CoreToDo
dumpCorePass Int
counter SDoc
todo =
    String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
"Fusion plugin dump core" (Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
counter SDoc
todo)

_insertDumpCore :: [CoreToDo] -> [CoreToDo]
_insertDumpCore :: [CoreToDo] -> [CoreToDo]
_insertDumpCore [CoreToDo]
todos = Int -> SDoc -> CoreToDo
dumpCorePass Int
0 (String -> SDoc
text String
"Initial ") CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Int -> [CoreToDo] -> [CoreToDo]
go Int
1 [CoreToDo]
todos
  where
    go :: Int -> [CoreToDo] -> [CoreToDo]
go Int
_ [] = []
    go Int
counter (CoreToDo
todo:[CoreToDo]
rest) =
        CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Int -> SDoc -> CoreToDo
dumpCorePass Int
counter (String -> SDoc
text String
"After " SDoc -> SDoc -> SDoc
GhcPlugins.<> CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
todo)
             CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Int -> [CoreToDo] -> [CoreToDo]
go (Int
counter Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [CoreToDo]
rest

-------------------------------------------------------------------------------
-- 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 [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [CoreToDo
report]
  where
    go :: Bool -> [CoreToDo] -> [CoreToDo]
go Bool
False [] = String -> [CoreToDo]
forall a. HasCallStack => String -> a
error String
"Simplifier phase 0/\"main\" not found"
    go Bool
True [] = []
    go Bool
_ (todo :: CoreToDo
todo@(CoreDoSimplify Int
_ SimplMode
            { sm_phase :: SimplMode -> CompilerPhase
sm_phase = Phase Int
0
            , sm_names :: SimplMode -> [String]
sm_names = [String
"main"]
            }):[CoreToDo]
todos)
        = CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: [CoreToDo]
ourTodos [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ Bool -> [CoreToDo] -> [CoreToDo]
go Bool
True [CoreToDo]
todos
    go Bool
found (CoreToDo
todo:[CoreToDo]
todos) = CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Bool -> [CoreToDo] -> [CoreToDo]
go Bool
found [CoreToDo]
todos

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: [String] -> [CoreToDo] -> CoreM [CoreToDo]
install [String]
args [CoreToDo]
todos = do
    Options
options <- IO Options -> CoreM Options
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Options -> CoreM Options) -> IO Options -> CoreM Options
forall a b. (a -> b) -> a -> b
$ [String] -> IO Options
parseOptions [String]
args
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    -- 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.
    [CoreToDo] -> CoreM [CoreToDo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreToDo] -> CoreM [CoreToDo]) -> [CoreToDo] -> CoreM [CoreToDo]
forall a b. (a -> b) -> a -> b
$
        (if Options -> Bool
optionsDumpCore Options
options then [CoreToDo] -> [CoreToDo]
_insertDumpCore else [CoreToDo] -> [CoreToDo]
forall a. a -> a
id) ([CoreToDo] -> [CoreToDo]) -> [CoreToDo] -> [CoreToDo]
forall a b. (a -> b) -> a -> b
$
        [CoreToDo] -> [CoreToDo] -> CoreToDo -> [CoreToDo]
insertAfterSimplPhase0
            [CoreToDo]
todos
            [ ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
ReportSilent Bool
False Bool
True
            , DynFlags -> CoreToDo
fusionSimplify DynFlags
dflags
            , ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
ReportSilent Bool
False Bool
True
            , DynFlags -> CoreToDo
fusionSimplify DynFlags
dflags
            , ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
ReportSilent Bool
False Bool
True
            , DynFlags -> CoreToDo
fusionSimplify DynFlags
dflags
            -- This lets us know what was left unfused after all the inlining
            -- and case-of-case transformations.
            , let msg :: String
msg = String
"Check unfused (post inlining)"
              in String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
msg (String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
msg ReportMode
ReportSilent)
            ]
            (let msg :: String
msg = String
"Check unfused (final)"
                 report :: ModGuts -> CoreM ModGuts
report = String -> ReportMode -> ModGuts -> CoreM ModGuts
fusionReport String
msg (Options -> ReportMode
optionsVerbosityLevel Options
options)
            in String -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass String
msg ModGuts -> CoreM ModGuts
report)
#else
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todos = do
    putMsgS "Warning! fusion-plugin does nothing on ghc versions prior to 8.6"
    return todos
#endif

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
    { installCoreToDos :: [String] -> [CoreToDo] -> CoreM [CoreToDo]
installCoreToDos = [String] -> [CoreToDo] -> CoreM [CoreToDo]
install
#if MIN_VERSION_ghc(8,6,0)
    , pluginRecompile :: [String] -> IO PluginRecompile
pluginRecompile = [String] -> IO PluginRecompile
purePlugin
#endif
    }

-- Orphan instance for 'Fuse'
instance Outputable Fuse where
    ppr :: Fuse -> SDoc
ppr Fuse
_ = String -> SDoc
text String
"Fuse"