{-# LANGUAGE PatternSynonyms #-}
{-
(c) The AQUA Project, Glasgow University, 1993-1998

\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}
-}

module GHC.Core.Opt.Simplify.Monad (
        -- The monad
        TopEnvConfig(..), SimplM,
        initSmpl, traceSmpl,
        getSimplRules,

        -- Unique supply
        MonadUnique(..), newId, newJoinId,

        -- Counting
        SimplCount, tick, freeTick, checkedTick,
        getSimplCount, zeroSimplCount, pprSimplCount,
        plusSimplCount, isZeroSimplCount
    ) where

import GHC.Prelude

import GHC.Types.Var       ( Var, isId, mkLocalVar )
import GHC.Types.Name      ( mkSystemVarName )
import GHC.Types.Id        ( Id, mkSysLocalOrCoVarM )
import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo )
import GHC.Core.Type       ( Type, Mult )
import GHC.Core.Opt.Stats
import GHC.Core.Rules
import GHC.Core.Utils      ( mkLamTypes )
import GHC.Types.Unique.Supply
import GHC.Driver.Flags
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Utils.Monad
import GHC.Utils.Logger as Logger
import GHC.Utils.Misc      ( count )
import GHC.Utils.Panic     (throwGhcExceptionIO, GhcException (..))
import GHC.Types.Basic     ( IntWithInf, treatZeroAsInf, mkIntWithInf )
import Control.Monad       ( ap )
import GHC.Core.Multiplicity        ( pattern ManyTy )
import GHC.Exts( oneShot )

{-
************************************************************************
*                                                                      *
\subsection{Monad plumbing}
*                                                                      *
************************************************************************
-}

newtype SimplM result
  =  SM'  { forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM :: SimplTopEnv
                 -> SimplCount
                 -> IO (result, SimplCount)}
    -- We only need IO here for dump output, but since we already have it
    -- we might as well use it for uniques.

pattern SM :: (SimplTopEnv -> SimplCount
               -> IO (result, SimplCount))
          -> SimplM result
-- This pattern synonym makes the simplifier monad eta-expand,
-- which as a very beneficial effect on compiler performance
-- (worth a 1-2% reduction in bytes-allocated).  See #18202.
-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
pattern $bSM :: forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
$mSM :: forall {r} {result}.
SimplM result
-> ((SimplTopEnv -> SimplCount -> IO (result, SimplCount)) -> r)
-> ((# #) -> r)
-> r
SM m <- SM' m
  where
    SM SimplTopEnv -> SimplCount -> IO (result, SimplCount)
m = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM' (oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
env -> oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \SimplCount
ct -> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
m SimplTopEnv
env SimplCount
ct)

-- See Note [The environments of the Simplify pass]
data TopEnvConfig = TopEnvConfig
  { TopEnvConfig -> Int
te_history_size :: !Int
  , TopEnvConfig -> Int
te_tick_factor :: !Int
  }

data SimplTopEnv
  = STE { -- See Note [The environments of the Simplify pass]
          SimplTopEnv -> TopEnvConfig
st_config :: !TopEnvConfig
        , SimplTopEnv -> Logger
st_logger    :: !Logger
        , SimplTopEnv -> IntWithInf
st_max_ticks :: !IntWithInf  -- ^ Max #ticks in this simplifier run
        , SimplTopEnv -> IO RuleEnv
st_read_ruleenv :: !(IO RuleEnv)
          -- ^ The action to retrieve an up-to-date EPS RuleEnv
          -- See Note [Overall plumbing for rules]
        }

initSmpl :: Logger
         -> IO RuleEnv
         -> TopEnvConfig
         -> Int -- ^ Size of the bindings, used to limit the number of ticks we allow
         -> SimplM a
         -> IO (a, SimplCount)

initSmpl :: forall a.
Logger
-> IO RuleEnv
-> TopEnvConfig
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger IO RuleEnv
read_ruleenv TopEnvConfig
cfg Int
size SimplM a
m
  = do -- No init count; set to 0
       let simplCount :: SimplCount
simplCount = Bool -> SimplCount
zeroSimplCount forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_simpl_stats
       forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM SimplM a
m SimplTopEnv
env SimplCount
simplCount
  where
    env :: SimplTopEnv
env = STE { st_config :: TopEnvConfig
st_config = TopEnvConfig
cfg
              , st_logger :: Logger
st_logger = Logger
logger
              , st_max_ticks :: IntWithInf
st_max_ticks = TopEnvConfig -> Int -> IntWithInf
computeMaxTicks TopEnvConfig
cfg Int
size
              , st_read_ruleenv :: IO RuleEnv
st_read_ruleenv = IO RuleEnv
read_ruleenv
              }

computeMaxTicks :: TopEnvConfig -> Int -> IntWithInf
-- Compute the max simplifier ticks as
--     (base-size + pgm-size) * magic-multiplier * tick-factor/100
-- where
--    magic-multiplier is a constant that gives reasonable results
--    base-size is a constant to deal with size-zero programs
computeMaxTicks :: TopEnvConfig -> Int -> IntWithInf
computeMaxTicks TopEnvConfig
cfg Int
size
  = Int -> IntWithInf
treatZeroAsInf forall a b. (a -> b) -> a -> b
$
    forall a. Num a => Integer -> a
fromInteger ((forall a. Integral a => a -> Integer
toInteger (Int
size forall a. Num a => a -> a -> a
+ Int
base_size)
                  forall a. Num a => a -> a -> a
* forall a. Integral a => a -> Integer
toInteger (Int
tick_factor forall a. Num a => a -> a -> a
* Int
magic_multiplier))
          forall a. Integral a => a -> a -> a
`div` Integer
100)
  where
    tick_factor :: Int
tick_factor      = TopEnvConfig -> Int
te_tick_factor TopEnvConfig
cfg
    base_size :: Int
base_size        = Int
100
    magic_multiplier :: Int
magic_multiplier = Int
40
        -- MAGIC NUMBER, multiplies the simplTickFactor
        -- We can afford to be generous; this is really
        -- just checking for loops, and shouldn't usually fire
        -- A figure of 20 was too small: see #5539.

{-# INLINE thenSmpl #-}
{-# INLINE thenSmpl_ #-}
{-# INLINE returnSmpl #-}
{-# INLINE mapSmpl #-}

instance Functor SimplM where
  fmap :: forall a b. (a -> b) -> SimplM a -> SimplM b
fmap = forall a b. (a -> b) -> SimplM a -> SimplM b
mapSmpl

instance Applicative SimplM where
    pure :: forall a. a -> SimplM a
pure  = forall a. a -> SimplM a
returnSmpl
    <*> :: forall a b. SimplM (a -> b) -> SimplM a -> SimplM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    *> :: forall a b. SimplM a -> SimplM b -> SimplM b
(*>)  = forall a b. SimplM a -> SimplM b -> SimplM b
thenSmpl_

instance Monad SimplM where
   >> :: forall a b. SimplM a -> SimplM b -> SimplM b
(>>)   = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
   >>= :: forall a b. SimplM a -> (a -> SimplM b) -> SimplM b
(>>=)  = forall a b. SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl

mapSmpl :: (a -> b) -> SimplM a -> SimplM b
mapSmpl :: forall a b. (a -> b) -> SimplM a -> SimplM b
mapSmpl a -> b
f SimplM a
m = forall a b. SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl SimplM a
m (forall a. a -> SimplM a
returnSmpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

returnSmpl :: a -> SimplM a
returnSmpl :: forall a. a -> SimplM a
returnSmpl a
e = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env SimplCount
sc -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
e, SimplCount
sc))

thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b

thenSmpl :: forall a b. SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl SimplM a
m a -> SimplM b
k
  = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
st_env SimplCount
sc0 -> do
      (a
m_result, SimplCount
sc1) <- forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM SimplM a
m SimplTopEnv
st_env SimplCount
sc0
      forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM (a -> SimplM b
k a
m_result) SimplTopEnv
st_env SimplCount
sc1

thenSmpl_ :: forall a b. SimplM a -> SimplM b -> SimplM b
thenSmpl_ SimplM a
m SimplM b
k
  = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
st_env SimplCount
sc0 -> do
      (a
_, SimplCount
sc1) <- forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM SimplM a
m SimplTopEnv
st_env SimplCount
sc0
      forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM SimplM b
k SimplTopEnv
st_env SimplCount
sc1

-- TODO: this specializing is not allowed
-- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
-- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}

traceSmpl :: String -> SDoc -> SimplM ()
traceSmpl :: String -> SDoc -> SimplM ()
traceSmpl String
herald SDoc
doc
  = do Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_simpl_trace String
"Simpl Trace"
         DumpFormat
FormatText
         (SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
herald) Int
2 SDoc
doc)
{-# INLINE traceSmpl #-}  -- see Note [INLINE conditional tracing utilities]

{-
************************************************************************
*                                                                      *
\subsection{The unique supply}
*                                                                      *
************************************************************************
-}

-- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques
simplMask :: Char
simplMask :: Char
simplMask = Char
's'

instance MonadUnique SimplM where
    getUniqueSupplyM :: SimplM UniqSupply
getUniqueSupplyM = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Char -> IO UniqSupply
mkSplitUniqSupply Char
simplMask
    getUniqueM :: SimplM Unique
getUniqueM = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Char -> IO Unique
uniqFromMask Char
simplMask

instance HasLogger SimplM where
    getLogger :: SimplM Logger
getLogger = forall a. (SimplTopEnv -> a) -> SimplM a
gets SimplTopEnv -> Logger
st_logger

instance MonadIO SimplM where
    liftIO :: forall a. IO a -> SimplM a
liftIO = forall a. (SimplTopEnv -> IO a) -> SimplM a
liftIOWithEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

getSimplRules :: SimplM RuleEnv
getSimplRules :: SimplM RuleEnv
getSimplRules = forall a. (SimplTopEnv -> IO a) -> SimplM a
liftIOWithEnv SimplTopEnv -> IO RuleEnv
st_read_ruleenv

liftIOWithEnv :: (SimplTopEnv -> IO a) -> SimplM a
liftIOWithEnv :: forall a. (SimplTopEnv -> IO a) -> SimplM a
liftIOWithEnv SimplTopEnv -> IO a
m = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc -> do
    a
x <- SimplTopEnv -> IO a
m SimplTopEnv
st_env
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, SimplCount
sc))

gets :: (SimplTopEnv -> a) -> SimplM a
gets :: forall a. (SimplTopEnv -> a) -> SimplM a
gets SimplTopEnv -> a
f = forall a. (SimplTopEnv -> IO a) -> SimplM a
liftIOWithEnv (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimplTopEnv -> a
f)

newId :: FastString -> Mult -> Type -> SimplM Id
newId :: FastString -> Mult -> Mult -> SimplM Id
newId FastString
fs Mult
w Mult
ty = forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m Id
mkSysLocalOrCoVarM FastString
fs Mult
w Mult
ty

-- | Make a join id with given type and arity but without call-by-value annotations.
newJoinId :: [Var] -> Type -> SimplM Id
newJoinId :: [Id] -> Mult -> SimplM Id
newJoinId [Id]
bndrs Mult
body_ty
  = do { Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
       ; let name :: Name
name       = Unique -> FastString -> Name
mkSystemVarName Unique
uniq (String -> FastString
fsLit String
"$j")
             join_id_ty :: Mult
join_id_ty = [Id] -> Mult -> Mult
mkLamTypes [Id]
bndrs Mult
body_ty  -- Note [Funky mkLamTypes]
             arity :: Int
arity      = forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
bndrs
             -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core
             join_arity :: Int
join_arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bndrs
             details :: IdDetails
details    = Int -> Maybe [CbvMark] -> IdDetails
JoinId Int
join_arity forall a. Maybe a
Nothing
             id_info :: IdInfo
id_info    = IdInfo
vanillaIdInfo IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
--                                        `setOccInfo` strongLoopBreaker

       ; forall (m :: * -> *) a. Monad m => a -> m a
return (IdDetails -> Name -> Mult -> Mult -> IdInfo -> Id
mkLocalVar IdDetails
details Name
name Mult
ManyTy Mult
join_id_ty IdInfo
id_info) }

{-
************************************************************************
*                                                                      *
\subsection{Counting up what we've done}
*                                                                      *
************************************************************************
-}

getSimplCount :: SimplM SimplCount
getSimplCount :: SimplM SimplCount
getSimplCount = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env SimplCount
sc -> forall (m :: * -> *) a. Monad m => a -> m a
return (SimplCount
sc, SimplCount
sc))

tick :: Tick -> SimplM ()
tick :: Tick -> SimplM ()
tick Tick
t = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc -> let
  history_size :: Int
history_size = TopEnvConfig -> Int
te_history_size (SimplTopEnv -> TopEnvConfig
st_config SimplTopEnv
st_env)
  sc' :: SimplCount
sc' = Int -> Tick -> SimplCount -> SimplCount
doSimplTick Int
history_size Tick
t SimplCount
sc
  in SimplCount
sc' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ((), SimplCount
sc'))

checkedTick :: Tick -> SimplM ()
-- Try to take a tick, but fail if too many
checkedTick :: Tick -> SimplM ()
checkedTick Tick
t
  = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc ->
           if SimplTopEnv -> IntWithInf
st_max_ticks SimplTopEnv
st_env forall a. Ord a => a -> a -> Bool
<= Int -> IntWithInf
mkIntWithInf (SimplCount -> Int
simplCountN SimplCount
sc)
           then forall a. GhcException -> IO a
throwGhcExceptionIO forall a b. (a -> b) -> a -> b
$
                  String -> SDoc -> GhcException
PprProgramError String
"Simplifier ticks exhausted" (SimplCount -> SDoc
msg SimplCount
sc)
           else let
             history_size :: Int
history_size = TopEnvConfig -> Int
te_history_size (SimplTopEnv -> TopEnvConfig
st_config SimplTopEnv
st_env)
             sc' :: SimplCount
sc' = Int -> Tick -> SimplCount -> SimplCount
doSimplTick Int
history_size Tick
t SimplCount
sc
             in SimplCount
sc' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ((), SimplCount
sc'))
  where
    msg :: SimplCount -> SDoc
msg SimplCount
sc = forall doc. IsDoc doc => [doc] -> doc
vcat
      [ forall doc. IsLine doc => String -> doc
text String
"When trying" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Tick
t
      , forall doc. IsLine doc => String -> doc
text String
"To increase the limit, use -fsimpl-tick-factor=N (default 100)."
      , forall doc. IsLine doc => doc
space
      , forall doc. IsLine doc => String -> doc
text String
"In addition try adjusting -funfolding-case-threshold=N and"
      , forall doc. IsLine doc => String -> doc
text String
"-funfolding-case-scaling=N for the module in question."
      , forall doc. IsLine doc => String -> doc
text String
"Using threshold=1 and scaling=5 should break most inlining loops."
      , forall doc. IsLine doc => doc
space
      , forall doc. IsLine doc => String -> doc
text String
"If you need to increase the tick factor substantially, while also"
      , forall doc. IsLine doc => String -> doc
text String
"adjusting unfolding parameters please file a bug report and"
      , forall doc. IsLine doc => String -> doc
text String
"indicate the factor you needed."
      , forall doc. IsLine doc => doc
space
      , forall doc. IsLine doc => String -> doc
text String
"If GHC was unable to complete compilation even"
               forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"with a very large factor"
      , forall doc. IsLine doc => String -> doc
text String
"(a thousand or more), please consult the"
                forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc -> doc
doubleQuotes (forall doc. IsLine doc => String -> doc
text String
"Known bugs or infelicities")
      , forall doc. IsLine doc => String -> doc
text String
"section in the Users Guide before filing a report. There are a"
      , forall doc. IsLine doc => String -> doc
text String
"few situations unlikely to occur in practical programs for which"
      , forall doc. IsLine doc => String -> doc
text String
"simplifier non-termination has been judged acceptable."
      , forall doc. IsLine doc => doc
space
      , forall {doc}. IsLine doc => SimplCount -> doc
pp_details SimplCount
sc
      , SimplCount -> SDoc
pprSimplCount SimplCount
sc ]
    pp_details :: SimplCount -> doc
pp_details SimplCount
sc
      | SimplCount -> Bool
hasDetailedCounts SimplCount
sc = forall doc. IsOutput doc => doc
empty
      | Bool
otherwise = forall doc. IsLine doc => String -> doc
text String
"To see detailed counts use -ddump-simpl-stats"


freeTick :: Tick -> SimplM ()
-- Record a tick, but don't add to the total tick count, which is
-- used to decide when nothing further has happened
freeTick :: Tick -> SimplM ()
freeTick Tick
t
   = forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env SimplCount
sc -> let sc' :: SimplCount
sc' = Tick -> SimplCount -> SimplCount
doFreeSimplTick Tick
t SimplCount
sc
                           in SimplCount
sc' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ((), SimplCount
sc'))