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

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

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

    -- * Implementation Details
    -- $impl

    -- * Results
    -- $results
      plugin
    )
where

#if MIN_VERSION_ghc(8,6,0)
-- Imports for all compiler versions
import Control.Monad (mzero, when)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.State (StateT, evalStateT, get, put)
import Data.Maybe (mapMaybe)
import Data.Generics.Schemes (everywhere)
import Data.Generics.Aliases (mkT)
import Debug.Trace (trace)
import qualified Data.List as DL

-- Imports for specific compiler versions
#if MIN_VERSION_ghc(9,2,0)
import Data.Char (isSpace)
import Text.Printf (printf)
import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules)
import GHC.Types.Name.Ppr (mkPrintUnqualified)
import GHC.Utils.Logger (Logger)
#endif

-- dump-core option related imports
#if MIN_VERSION_ghc(9,3,0)
import GHC.Utils.Logger (putDumpFile, logFlags, LogFlags(..))
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Utils.Logger (putDumpMsg)
#elif MIN_VERSION_ghc(9,0,0)
-- dump core option not supported
#else
import Control.Monad (unless)
import Data.Char (isSpace)
import Data.IORef (readIORef, writeIORef)
import Data.Time (getCurrentTime)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory)
import System.IO (Handle, IOMode(..), withFile, hSetEncoding, utf8)
import Text.Printf (printf)
import ErrUtils (mkDumpDoc, Severity(..))
import PprCore (pprCoreBindingsWithSize, pprRules)
import qualified Data.Set as Set
#endif
#endif

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

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

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

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

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

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

#if MIN_VERSION_ghc(8,6,0)

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

-- XXX Can use the debugLevel from dflags
-- Increase this level to see debug output
dbgLevel :: Int
dbgLevel :: Int
dbgLevel = Int
0

debug :: Int -> String -> a -> a
debug :: forall a. Int -> String -> a -> a
debug Int
level String
str a
x =
    if Int
dbgLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
level
    then String -> a -> a
forall a. String -> a -> a
trace String
str a
x
    else a
x

showBndr :: Outputable a => DynFlags -> a -> String
showBndr :: forall a. Outputable a => DynFlags -> a -> String
showBndr DynFlags
dflags a
bndr = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
bndr

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

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

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

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

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

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

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

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

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

-- 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 a b.
(a -> b)
-> StateT ([String], Options) (MaybeT IO) a
-> StateT ([String], Options) (MaybeT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String], Options) -> Options
forall a b. (a, b) -> b
snd StateT ([String], Options) (MaybeT IO) ([String], Options)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Options -> IO Options
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Options -> IO Options) -> Options -> IO Options
forall a b. (a -> b) -> a -> b
$ Options -> (Options -> Options) -> Maybe Options -> Options
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Options
defaultOptions Options -> Options
forall a. a -> a
id Maybe Options
maybeOptions

    where

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

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

-------------------------------------------------------------------------------
-- 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 :: DynFlags -> CoreBndr -> CoreBndr
setAlwaysInlineOnBndr :: DynFlags -> CoreBndr -> CoreBndr
setAlwaysInlineOnBndr DynFlags
dflags CoreBndr
n =
    let info :: IdInfo
info =
            case IdInfo -> Maybe IdInfo
zapUsageInfo (IdInfo -> Maybe IdInfo) -> IdInfo -> Maybe IdInfo
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
n of
                Just IdInfo
i -> IdInfo
i
                Maybe IdInfo
Nothing ->
                    String -> IdInfo
forall a. HasCallStack => String -> a
error String
"The impossible happened!! Or GHC changed their api."
        unf :: Unfolding
unf = IdInfo -> Unfolding
unfoldingInfo IdInfo
info
        info' :: IdInfo
info' =
            IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo
                (IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo IdInfo
info InlinePragma
alwaysInlinePragma)
                (Int -> Unfolding -> Unfolding
unfoldCompulsory (IdInfo -> Int
arityInfo IdInfo
info) Unfolding
unf)
     in Int -> String -> CoreBndr -> CoreBndr
forall a. Int -> String -> a -> a
debug Int
1
            (String
"Forcing inline on: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> CoreBndr -> String
forall a. (Outputable a, Uniquable a) => DynFlags -> a -> String
showWithUnique DynFlags
dflags CoreBndr
n)
            (CoreBndr -> IdInfo -> CoreBndr
lazySetIdInfo CoreBndr
n IdInfo
info')

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

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

hasInlineBinder :: CoreBndr -> Bool
hasInlineBinder :: CoreBndr -> Bool
hasInlineBinder CoreBndr
bndr =
    let inl :: InlinePragma
inl = IdInfo -> InlinePragma
inlinePragInfo (IdInfo -> InlinePragma) -> IdInfo -> InlinePragma
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
bndr
    in InlinePragma -> Bool
isInlinePragma InlinePragma
inl Bool -> Bool -> Bool
&& IS_ACTIVE (inlinePragmaActivation inl)

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

#if MIN_VERSION_ghc(9,2,0)
#define ALT_CONSTR(x,y,z) Alt (x) y z
#else
#define ALT_CONSTR(x,y,z) (x, y, z)
#endif

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

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

needInlineCaseAlt
    :: DynFlags
    -> [CoreBind]
    -> UNIQ_FM
    -> [Alt CoreBndr]
    -> Maybe (Alt CoreBndr)
needInlineCaseAlt :: DynFlags
-> [CoreBind]
-> UniqFM Name [Fuse]
-> [Alt CoreBndr]
-> Maybe (Alt CoreBndr)
needInlineCaseAlt DynFlags
dflags [CoreBind]
parents UniqFM Name [Fuse]
anns [Alt CoreBndr]
bndr =
    let mesg :: String
mesg = String
"Binder: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
parents
    in if Bool -> Bool
not (CoreBndr -> Bool
hasInlineBinder (CoreBndr -> Bool) -> CoreBndr -> Bool
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder ([CoreBind] -> CoreBind
forall a. HasCallStack => [a] -> a
head [CoreBind]
parents))
       then
            Int -> String -> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a. Int -> String -> a -> a
debug Int
2
                (String
mesg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not inlined")
                (Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr))
-> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a b. (a -> b) -> a -> b
$ case DynFlags
-> UniqFM Name [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn DynFlags
dflags UniqFM Name [Fuse]
anns [Alt CoreBndr]
bndr of
                    Just Alt CoreBndr
alt -> Alt CoreBndr -> Maybe (Alt CoreBndr)
forall a. a -> Maybe a
Just Alt CoreBndr
alt
                    Maybe (Alt CoreBndr)
_ -> Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing
       else Int -> String -> Maybe (Alt CoreBndr) -> Maybe (Alt CoreBndr)
forall a. Int -> String -> a -> a
debug Int
2 (String
mesg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" already inlined") Maybe (Alt CoreBndr)
forall a. Maybe a
Nothing

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

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

    -- Match and record the case alternative if it contains a constructor
    -- annotated with "Fuse" and traverse the Alt expressions to discover more
    -- let bindings.
    go :: [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
True (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
        let binders :: [([CoreBind], Alt CoreBndr)]
binders = [Alt CoreBndr]
alts [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], Alt CoreBndr)])
-> [([CoreBind], Alt CoreBndr)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents False expr1)
        in case DynFlags
-> [CoreBind]
-> UniqFM Name [Fuse]
-> [Alt CoreBndr]
-> Maybe (Alt CoreBndr)
needInlineCaseAlt DynFlags
dflags [CoreBind]
parents UniqFM Name [Fuse]
anns [Alt CoreBndr]
alts of
            Just Alt CoreBndr
x -> ([CoreBind]
parents, Alt CoreBndr
x) ([CoreBind], Alt CoreBndr)
-> [([CoreBind], Alt CoreBndr)] -> [([CoreBind], Alt CoreBndr)]
forall a. a -> [a] -> [a]
: [([CoreBind], Alt CoreBndr)]
binders
            Maybe (Alt CoreBndr)
Nothing -> [([CoreBind], Alt CoreBndr)]
binders

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

    -- 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 CoercionR
_) = [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go [CoreBind]
parents Bool
False Expr CoreBndr
expr1

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

    goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
    -- Here we pass the second argument to "go" as "True" i.e. we are now
    -- looking to match the case alternatives for annotated constructors.
    goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [CoreBind]
parents bndr :: CoreBind
bndr@(NonRec CoreBndr
_ Expr CoreBndr
expr1) = [CoreBind] -> Bool -> Expr CoreBndr -> [([CoreBind], Alt CoreBndr)]
go (CoreBind
bndr CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
parents) Bool
True Expr CoreBndr
expr1
    goLet [CoreBind]
parents (Rec [(CoreBndr, Expr CoreBndr)]
bs) =
        [(CoreBndr, Expr CoreBndr)]
bs [(CoreBndr, Expr CoreBndr)]
-> ((CoreBndr, Expr CoreBndr) -> [([CoreBind], Alt CoreBndr)])
-> [([CoreBind], Alt CoreBndr)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CoreBndr
b, Expr CoreBndr
expr1) -> [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
goLet [CoreBind]
parents (CoreBind -> [([CoreBind], Alt CoreBndr)])
-> CoreBind -> [([CoreBind], Alt CoreBndr)]
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
expr1)

needInlineTyCon :: CoreBind -> UNIQ_FM -> TyCon -> Bool
needInlineTyCon :: CoreBind -> UniqFM Name [Fuse] -> TyCon -> Bool
needInlineTyCon CoreBind
parent UniqFM Name [Fuse]
anns TyCon
tycon =
    case UniqFM Name [Fuse] -> Name -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Name [Fuse]
anns (GET_NAME tycon) of
        Just [Fuse]
_ | Bool -> Bool
not (CoreBndr -> Bool
hasInlineBinder (CoreBndr -> Bool) -> CoreBndr -> Bool
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreBndr
getNonRecBinder CoreBind
parent) -> Bool
True
        Maybe [Fuse]
_ -> Bool
False

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

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

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

    -- Check if the Var is a data constructor of interest
    go [CoreBind]
parents (Var CoreBndr
i) =
        let needInline :: TyCon -> Bool
needInline = CoreBind -> UniqFM Name [Fuse] -> TyCon -> Bool
needInlineTyCon ([CoreBind] -> CoreBind
forall a. HasCallStack => [a] -> a
head [CoreBind]
parents) UniqFM Name [Fuse]
anns
        in case Type -> Maybe TyCon
tyConAppTyConPicky_maybe (CoreBndr -> Type
varType CoreBndr
i) of
            Just TyCon
tycon | TyCon -> Bool
needInline TyCon
tycon -> [([CoreBind]
parents, CoreBndr
i)]
            Maybe TyCon
_ -> []

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

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

data Context = CaseAlt (Alt CoreBndr) | Constr Id

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

    -- Match and record the case alternative if it contains a constructor
    -- annotated with "Fuse" and traverse the Alt expressions to discover more
    -- let bindings.
    go :: [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents (Case Expr CoreBndr
_ CoreBndr
_ Type
_ [Alt CoreBndr]
alts) =
        let binders :: [([CoreBind], Context)]
binders = [Alt CoreBndr]
alts [Alt CoreBndr]
-> (Alt CoreBndr -> [([CoreBind], Context)])
-> [([CoreBind], Context)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1)
        in case DynFlags
-> UniqFM Name [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)
altsContainsAnn DynFlags
dflags UniqFM Name [Fuse]
anns [Alt CoreBndr]
alts of
            Just Alt CoreBndr
x -> ([CoreBind]
parents, Alt CoreBndr -> Context
CaseAlt Alt CoreBndr
x) ([CoreBind], Context)
-> [([CoreBind], Context)] -> [([CoreBind], Context)]
forall a. a -> [a] -> [a]
: [([CoreBind], Context)]
binders
            Maybe (Alt CoreBndr)
Nothing -> [([CoreBind], Context)]
binders

    -- 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 CoercionR
_) = [CoreBind] -> Expr CoreBndr -> [([CoreBind], Context)]
go [CoreBind]
parents Expr CoreBndr
expr1

    -- Check if the Var is of the type of a data constructor of interest
    go [CoreBind]
parents (Var CoreBndr
i) =
        case Type -> Maybe TyCon
tyConAppTyConPicky_maybe (CoreBndr -> Type
varType CoreBndr
i) of
            Just TyCon
tycon ->
                case UniqFM Name [Fuse] -> Name -> Maybe [Fuse]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Name [Fuse]
anns (GET_NAME tycon) of
                    Just [Fuse]
_ -> [([CoreBind]
parents, CoreBndr -> Context
Constr CoreBndr
i)]
                    Maybe [Fuse]
Nothing -> []
            Maybe TyCon
Nothing -> []

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

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

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

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

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

showDetailsConstr
    :: DynFlags
    -> ReportMode
    -> ([CoreBind], Id)
    -> String
showDetailsConstr :: DynFlags -> ReportMode -> ([CoreBind], CoreBndr) -> String
showDetailsConstr DynFlags
dflags ReportMode
reportMode ([CoreBind]
binds, CoreBndr
con) =
    let t :: Maybe TyCon
t = Type -> Maybe TyCon
tyConAppTyConPicky_maybe (CoreBndr -> Type
varType CoreBndr
con)
        vstr :: String
vstr =
            case ReportMode
reportMode of
                ReportMode
ReportVerbose -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
con)
                ReportMode
ReportVerbose1 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
con)
                ReportMode
ReportVerbose2 -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBind -> SDoc) -> CoreBind -> SDoc
forall a b. (a -> b) -> a -> b
$ [CoreBind] -> CoreBind
forall a. HasCallStack => [a] -> a
head [CoreBind]
binds)
                ReportMode
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"transformBind: unreachable"
        tstr :: String
tstr =
            case Maybe TyCon
t of
                Maybe TyCon
Nothing -> String
" :: Not a Type Constructor"
                Just TyCon
x -> String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
x)
    in DynFlags -> [CoreBind] -> String
listPath DynFlags
dflags [CoreBind]
binds String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vstr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tstr

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

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

markInline :: Int -> ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline :: Int -> ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts
markInline Int
pass ReportMode
reportMode Bool
failIt Bool
transform ModGuts
guts = do
    String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: Checking bindings to inline..."
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    UniqFM Name [Fuse]
anns <- FMAP_SND getAnnotations deserializeWithData guts
    if (([Fuse] -> Bool) -> UniqFM Name [Fuse] -> Bool
forall elt key. (elt -> Bool) -> UniqFM key elt -> Bool
anyUFM ((Fuse -> Bool) -> [Fuse] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Fuse -> Fuse -> Bool
forall a. Eq a => a -> a -> Bool
== Fuse
Fuse)) UniqFM Name [Fuse]
anns)
    then do
        ModGuts
r <- ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts
bindsOnlyPass ((CoreBind -> CoreM CoreBind) -> [CoreBind] -> CoreM [CoreBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (DynFlags -> UniqFM Name [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns)) ModGuts
guts
        if Int
dbgLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
0 (String -> SDoc
text (String
"Fusion-plugin-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
pass)) ModGuts
r
        else ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
r
    else ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
  where
    -- transformBind :: DynFlags -> UniqFM Unique [Fuse] -> CoreBind -> CoreM CoreBind
    transformBind :: DynFlags -> UniqFM Name [Fuse] -> CoreBind -> CoreM CoreBind
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns bind :: CoreBind
bind@(NonRec CoreBndr
b Expr CoreBndr
_) = do
        let patternMatches :: [([CoreBind], Alt CoreBndr)]
patternMatches = DynFlags
-> UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], Alt CoreBndr)]
letBndrsThatAreCases DynFlags
dflags UniqFM Name [Fuse]
anns CoreBind
bind
        let uniqPat :: [CoreBndr]
uniqPat = [CoreBndr] -> [CoreBndr]
forall a. Eq a => [a] -> [a]
DL.nub ((([CoreBind], Alt CoreBndr) -> CoreBndr)
-> [([CoreBind], Alt CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBind -> CoreBndr
getNonRecBinder(CoreBind -> CoreBndr)
-> (([CoreBind], Alt CoreBndr) -> CoreBind)
-> ([CoreBind], Alt CoreBndr)
-> CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> CoreBind
forall a. HasCallStack => [a] -> a
head ([CoreBind] -> CoreBind)
-> (([CoreBind], Alt CoreBndr) -> [CoreBind])
-> ([CoreBind], Alt CoreBndr)
-> CoreBind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBind], Alt CoreBndr) -> [CoreBind]
forall a b. (a, b) -> a
fst) [([CoreBind], Alt CoreBndr)]
patternMatches)

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

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

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

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

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

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

fusionSimplify :: HscEnv -> DynFlags -> CoreToDo
fusionSimplify :: HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
_hsc_env DynFlags
dflags =
    let mode :: SimplMode
mode =
            SimplMode
            { sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
            , sm_names :: [String]
sm_names = [String
"Fusion Plugin Inlining"]
            , sm_dflags :: DynFlags
sm_dflags = DynFlags
dflags
            , sm_rules :: Bool
sm_rules = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags
            , sm_eta_expand :: Bool
sm_eta_expand = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion DynFlags
dflags
            , sm_inline :: Bool
sm_inline = Bool
True
            , sm_case_case :: Bool
sm_case_case = Bool
True
#if MIN_VERSION_ghc(9,2,0)
            , sm_uf_opts :: UnfoldingOpts
sm_uf_opts = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
            , sm_pre_inline :: Bool
sm_pre_inline = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining DynFlags
dflags
            , sm_logger :: Logger
sm_logger = HscEnv -> Logger
hsc_logger HscEnv
_hsc_env
#endif
#if MIN_VERSION_ghc(9,2,2)
            , sm_cast_swizzle :: Bool
sm_cast_swizzle = Bool
True
#endif
#if MIN_VERSION_ghc(9,5,0)
            , sm_float_enable = floatEnable dflags
#endif
            }
    in Int -> SimplMode -> CoreToDo
CoreDoSimplify
#if MIN_VERSION_ghc(9,5,0)
        (CoreDoSimplifyOpts (maxSimplIterations dflags) mode)
#else
        (DynFlags -> Int
maxSimplIterations DynFlags
dflags) SimplMode
mode
#endif

-------------------------------------------------------------------------------
-- 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mesg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    UniqFM Name [Fuse]
anns <- FMAP_SND getAnnotations deserializeWithData guts
    Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (([Fuse] -> Bool) -> UniqFM Name [Fuse] -> Bool
forall elt key. (elt -> Bool) -> UniqFM key elt -> Bool
anyUFM ((Fuse -> Bool) -> [Fuse] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Fuse -> Fuse -> Bool
forall a. Eq a => a -> a -> Bool
== Fuse
Fuse)) UniqFM Name [Fuse]
anns) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
        (CoreBind -> CoreM ()) -> [CoreBind] -> CoreM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> UniqFM Name [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns) ([CoreBind] -> CoreM ()) -> [CoreBind] -> CoreM ()
forall a b. (a -> b) -> a -> b
$ ModGuts -> [CoreBind]
mg_binds ModGuts
guts
    ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
  where
    transformBind :: DynFlags -> UNIQ_FM -> CoreBind -> CoreM ()
    transformBind :: DynFlags -> UniqFM Name [Fuse] -> CoreBind -> CoreM ()
transformBind DynFlags
dflags UniqFM Name [Fuse]
anns bind :: CoreBind
bind@(NonRec CoreBndr
b Expr CoreBndr
_) = do
        let results :: [([CoreBind], Context)]
results = DynFlags
-> UniqFM Name [Fuse] -> CoreBind -> [([CoreBind], Context)]
containsAnns DynFlags
dflags UniqFM Name [Fuse]
anns CoreBind
bind

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

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

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

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

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

-- Only for GHC versions before 9.0.0
#if !MIN_VERSION_ghc(9,0,0)
chooseDumpFile :: DynFlags -> FilePath -> Maybe FilePath
chooseDumpFile dflags suffix
        | Just prefix <- getPrefix

        = Just $ setDir (prefix ++ suffix)

        | otherwise

        = Nothing

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

-- Copied from GHC.Utils.Logger
withDumpFileHandle :: DynFlags -> FilePath -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle dflags suffix action = do
    let mFile = chooseDumpFile dflags suffix
    case mFile of
      Just fileName -> do
        let gdref = generatedDumps dflags
        gd <- readIORef gdref
        let append = Set.member fileName gd
            mode = if append then AppendMode else WriteMode
        unless append $
            writeIORef gdref (Set.insert fileName gd)
        createDirectoryIfMissing True (takeDirectory fileName)
        withFile fileName mode $ \handle -> do
            -- We do not want the dump file to be affected by
            -- environment variables, but instead to always use
            -- UTF8. See:
            -- https://gitlab.haskell.org/ghc/ghc/issues/10762
            hSetEncoding handle utf8
            action (Just handle)
      Nothing -> action Nothing

dumpSDocWithStyle :: PprStyle -> DynFlags -> FilePath -> String -> SDoc -> IO ()
dumpSDocWithStyle sty dflags suffix hdr doc =
    withDumpFileHandle dflags suffix writeDump
  where
    -- write dump to file
    writeDump (Just handle) = do
        doc' <- if null hdr
                then return doc
                else do t <- getCurrentTime
                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
                                          then empty
                                          else text (show t)
                        let d = timeStamp
                                $$ blankLine
                                $$ doc
                        return $ mkDumpDoc hdr d
        defaultLogActionHPrintDoc dflags handle doc' sty

    -- write the dump to stdout
    writeDump Nothing = do
        let (doc', severity)
              | null hdr  = (doc, SevOutput)
              | otherwise = (mkDumpDoc hdr doc, SevDump)
        putLogMsg dflags NoReason severity noSrcSpan sty doc'

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

-- dump core not supported on 9.0.0, 9.0.0 does not export Logger
#if __GLASGOW_HASKELL__!=900
-- Only for GHC versions >= 9.2.0
#if MIN_VERSION_ghc(9,2,0)
dumpPassResult ::
      Logger
   -> DynFlags
   -> PrintUnqualified
   -> SDoc                  -- Header
   -> SDoc                  -- Extra info to appear after header
   -> CoreProgram -> [CoreRule]
   -> IO ()
dumpPassResult :: Logger
-> DynFlags
-> PrintUnqualified
-> SDoc
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpPassResult Logger
logger DynFlags
dflags PrintUnqualified
unqual SDoc
hdr SDoc
extra_info [CoreBind]
binds [CoreRule]
rules = do
#if MIN_VERSION_ghc(9,3,0)
    let flags :: LogFlags
flags = Logger -> LogFlags
logFlags Logger
logger
    let getDumpAction :: Logger -> DumpAction
getDumpAction = Logger -> DumpAction
putDumpFile
#else
    let flags = dflags
    let getDumpAction = putDumpMsg
#endif
    (Logger -> DumpAction
getDumpAction Logger
logger)
        LogFlags
flags PprStyle
dump_style DumpFlag
Opt_D_dump_simpl String
title DumpFormat
forall a. HasCallStack => a
undefined SDoc
dump_doc

    where

    title :: String
title = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
hdr

    dump_style :: PprStyle
dump_style = PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
unqual

#else

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

  where

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

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

dumpResult
#if MIN_VERSION_ghc(9,2,0)
    :: Logger
    -> DynFlags
#else
    :: DynFlags
#endif
    -> PrintUnqualified
    -> Int
    -> SDoc
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
#if MIN_VERSION_ghc(9,2,0)
dumpResult :: Logger
-> DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpResult Logger
logger DynFlags
dflags PrintUnqualified
print_unqual Int
counter SDoc
todo [CoreBind]
binds [CoreRule]
rules =
    Logger
-> DynFlags
-> PrintUnqualified
-> SDoc
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpPassResult Logger
logger1 DynFlags
dflags PrintUnqualified
print_unqual SDoc
hdr (String -> SDoc
text String
"") [CoreBind]
binds [CoreRule]
rules
#else
dumpResult dflags print_unqual counter todo binds rules =
    dumpPassResult
        dflags print_unqual (_suffix ++ "dump-simpl") hdr (text "") binds rules
#endif

    where

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

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

#if MIN_VERSION_ghc(9,4,0)
    prefix :: String
prefix = LogFlags -> String
log_dump_prefix (Logger -> LogFlags
logFlags Logger
logger) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
_suffix
    logger1 :: Logger
logger1 = Logger
logger {logFlags :: LogFlags
logFlags = (Logger -> LogFlags
logFlags Logger
logger) {log_dump_prefix :: String
log_dump_prefix = String
prefix}}
#elif MIN_VERSION_ghc(9,2,0)
    logger1 = logger
#endif
#endif

dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore Int
counter SDoc
title ModGuts
guts = do
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    String -> CoreM ()
putMsgS (String -> CoreM ()) -> String -> CoreM ()
forall a b. (a -> b) -> a -> b
$ String
"fusion-plugin: dumping core "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
counter String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
title

#if MIN_VERSION_ghc(9,2,0)
    HscEnv
hscEnv <- CoreM HscEnv
getHscEnv
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hscEnv
    let print_unqual :: PrintUnqualified
print_unqual =
            UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hscEnv) (ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts)
    IO () -> CoreM ()
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> PrintUnqualified
-> Int
-> SDoc
-> [CoreBind]
-> [CoreRule]
-> IO ()
dumpResult Logger
logger DynFlags
dflags PrintUnqualified
print_unqual Int
counter
                SDoc
title (ModGuts -> [CoreBind]
mg_binds ModGuts
guts) (ModGuts -> [CoreRule]
mg_rules ModGuts
guts)
#elif MIN_VERSION_ghc(9,0,0)
    putMsgS $ "fusion-plugin: dump-core not supported on GHC 9.0 "
#else
    let print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
    liftIO $ dumpResult dflags print_unqual counter
                title (mg_binds guts) (mg_rules guts)
#endif
    ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts

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

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

-------------------------------------------------------------------------------
-- 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 [] = []
#if MIN_VERSION_ghc(9,5,0)
    go _ (todo@(CoreDoSimplify (CoreDoSimplifyOpts _ SimplMode
            { sm_phase = Phase 0
            , sm_names = ["main"]
            })):todos)
#else
    go Bool
_ (todo :: CoreToDo
todo@(CoreDoSimplify Int
_ SimplMode
            { sm_phase :: SimplMode -> CompilerPhase
sm_phase = Phase Int
0
            , sm_names :: SimplMode -> [String]
sm_names = [String
"main"]
            }):[CoreToDo]
todos)
#endif
        = CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: [CoreToDo]
ourTodos [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ Bool -> [CoreToDo] -> [CoreToDo]
go Bool
True [CoreToDo]
todos
    go Bool
found (CoreToDo
todo:[CoreToDo]
todos) = CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: Bool -> [CoreToDo] -> [CoreToDo]
go Bool
found [CoreToDo]
todos

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: [String] -> [CoreToDo] -> CoreM [CoreToDo]
install [String]
args [CoreToDo]
todos = do
    Options
options <- IO Options -> CoreM Options
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Options -> CoreM Options) -> IO Options -> CoreM Options
forall a b. (a -> b) -> a -> b
$ [String] -> IO Options
parseOptions [String]
args
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    HscEnv
hscEnv <- CoreM HscEnv
getHscEnv
    -- 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 a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreToDo] -> CoreM [CoreToDo]) -> [CoreToDo] -> CoreM [CoreToDo]
forall a b. (a -> b) -> a -> b
$
        (if Options -> Bool
optionsDumpCore Options
options
         then [CoreToDo] -> [CoreToDo]
_insertDumpCore
         else [CoreToDo] -> [CoreToDo]
forall a. a -> a
id) ([CoreToDo] -> [CoreToDo]) -> [CoreToDo] -> [CoreToDo]
forall a b. (a -> b) -> a -> b
$
        [CoreToDo] -> [CoreToDo] -> CoreToDo -> [CoreToDo]
insertAfterSimplPhase0
            [CoreToDo]
todos
            [ Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
1 ReportMode
ReportSilent Bool
False Bool
True
            , HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
            , Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
2 ReportMode
ReportSilent Bool
False Bool
True
            , HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
            , Int -> ReportMode -> Bool -> Bool -> CoreToDo
fusionMarkInline Int
3 ReportMode
ReportSilent Bool
False Bool
True
            , HscEnv -> DynFlags -> CoreToDo
fusionSimplify HscEnv
hscEnv DynFlags
dflags
            -- 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
    }