-- |
-- 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)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State
import Data.Maybe (mapMaybe)
import Data.Generics.Schemes (everywhere)
import Data.Generics.Aliases (mkT)

#if MIN_VERSION_ghc(9,0,0)
-- import GHC.Utils.Error (Severity(..))
-- import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules)
#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

import qualified Data.List as DL
#endif

-- Implicit imports
#if MIN_VERSION_ghc(9,0,0)
import GHC.Plugins
#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)

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

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)

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
    }

#if !MIN_VERSION_ghc(9,0,0)
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 })
#endif

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
#if !MIN_VERSION_ghc(9,0,0)
            String
"dump-core" -> Bool -> StateT ([String], Options) m ()
forall (m :: * -> *).
Monad m =>
Bool -> StateT ([String], Options) m ()
setDumpCore Bool
True
#endif
            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

#if MIN_VERSION_ghc(9,0,0)
#define IS_ACTIVE isActive (Phase 0)
#define UNIQ_FM UniqFM Name [Fuse]
#define GET_NAME getName
#define FMAP_SND fmap snd $
#else
#define IS_ACTIVE isActiveIn 0
#define UNIQ_FM UniqFM [Fuse]
#define GET_NAME getUnique
#define FMAP_SND
#endif

hasInlineBinder :: CoreBndr -> Bool
hasInlineBinder :: CoreBndr -> Bool
hasInlineBinder CoreBndr
bndr =
    let inl :: InlinePragma
inl = IdInfo -> InlinePragma
inlinePragInfo (IdInfo -> InlinePragma) -> IdInfo -> InlinePragma
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
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,3,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 :: UNIQ_FM -> [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@(ALT_CONSTR(DataAlt dcon,_,_)):_) =
    case UniqFM [Fuse] -> Unique -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Fuse]
anns (GET_NAME $ dataConTyCon 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 ((ALT_CONSTR[CoreBndr]
(DEFAULT,_,_)):alts) = altsContainsAnn anns alts
altsContainsAnn UniqFM [Fuse]
_ [Alt CoreBndr]
_ = Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing

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

needInlineCaseAlt
    :: CoreBind -> UNIQ_FM -> [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
    :: UNIQ_FM
    -> 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
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents False 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
>>= (\(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?
                                    [([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 -> UNIQ_FM -> 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 (GET_NAME $ dataConTyCon 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 :: UNIQ_FM -> 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
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents 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 :: UNIQ_FM -> 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
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents 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 (GET_NAME $ dataConTyCon 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
-------------------------------------------------------------------------------

-- 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@(ALT_CONSTR(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 (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"

-- 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 :: CoreBndr
-> DynFlags
-> ReportMode
-> Bool
-> String
-> [CoreBndr]
-> [([CoreBind], a)]
-> (DynFlags -> ReportMode -> ([CoreBind], a) -> String)
-> CoreM ()
showInfo CoreBndr
parent DynFlags
dflags ReportMode
reportMode Bool
failIt
        String
tag [CoreBndr]
uniqBinders [([CoreBind], a)]
annotated DynFlags -> ReportMode -> ([CoreBind], a) -> String
showDetails =
    Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([CoreBndr]
uniqBinders [CoreBndr] -> [CoreBndr] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
        let mesg :: String
mesg = String
"In "
                  String -> 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
mesg
                String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
DL.unlines
                        ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
DL.nub
                        ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (([CoreBind], a) -> String) -> [([CoreBind], a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ReportMode -> ([CoreBind], a) -> String
showDetails DynFlags
dflags ReportMode
reportMode) [([CoreBind], a)]
annotated
        Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
failIt (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String -> CoreM ()
forall a. HasCallStack => String -> a
error String
"failing"

markInline :: 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 <- FMAP_SND getAnnotations deserializeWithData 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 Unique [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 :: HscEnv -> DynFlags -> CoreToDo
fusionSimplify :: HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
_hsc_env 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
#if MIN_VERSION_ghc(9,3,0)
            , sm_uf_opts = unfoldingOpts dflags
            , sm_pre_inline = gopt Opt_SimplPreInlining dflags
            , sm_logger = logger
#endif
            }

#if MIN_VERSION_ghc(9,3,0)
    where logger = hsc_logger _hsc_env
#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 (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
mesg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    UniqFM [Fuse]
anns <- FMAP_SND getAnnotations deserializeWithData 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 -> UNIQ_FM -> 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
-------------------------------------------------------------------------------

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

-- Copied from GHC.Utils.Logger
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
#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 [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
    HscEnv
hscEnv <- CoreM HscEnv
getHscEnv
    -- 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
#if !MIN_VERSION_ghc(9,0,0)
            [CoreToDo] -> [CoreToDo]
_insertDumpCore
#else
            id
#endif
         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
            , HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
            , ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
ReportSilent Bool
False Bool
True
            , HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
            , ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline ReportMode
ReportSilent Bool
False Bool
True
            , HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
            -- 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
    }