{-# LANGUAGE PatternSynonyms #-}
module GHC.Core.Opt.Simplify.Monad (
SimplM,
initSmpl, traceSmpl,
getSimplRules, getFamEnvs, getOptCoercionOpts,
MonadUnique(..), newId, newJoinId,
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, mkSysLocalOrCoVar )
import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo )
import GHC.Core.Type ( Type, Mult )
import GHC.Core.FamInstEnv ( FamInstEnv )
import GHC.Core ( RuleEnv(..), RuleBase)
import GHC.Core.Rules
import GHC.Core.Utils ( mkLamTypes )
import GHC.Core.Coercion.Opt
import GHC.Types.Unique.Supply
import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Core.Opt.Monad
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 Many )
import GHC.Exts( oneShot )
newtype SimplM result
= SM' { forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM :: SimplTopEnv
-> SimplCount
-> IO (result, SimplCount)}
pattern SM :: (SimplTopEnv -> SimplCount
-> IO (result, SimplCount))
-> SimplM result
pattern $mSM :: forall {r} {result}.
SimplM result
-> ((SimplTopEnv -> SimplCount -> IO (result, SimplCount)) -> r)
-> ((# #) -> r)
-> r
$bSM :: forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM m <- SM' m
where
SM SimplTopEnv -> SimplCount -> IO (result, SimplCount)
m = (SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM' ((SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
forall a b. (a -> b) -> a -> b
oneShot ((SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> (SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplTopEnv
-> SimplCount
-> IO (result, SimplCount)
forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
env -> (SimplCount -> IO (result, SimplCount))
-> SimplCount -> IO (result, SimplCount)
forall a b. (a -> b) -> a -> b
oneShot ((SimplCount -> IO (result, SimplCount))
-> SimplCount -> IO (result, SimplCount))
-> (SimplCount -> IO (result, SimplCount))
-> SimplCount
-> IO (result, SimplCount)
forall a b. (a -> b) -> a -> b
$ \SimplCount
ct -> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
m SimplTopEnv
env SimplCount
ct)
data SimplTopEnv
= STE { SimplTopEnv -> DynFlags
st_flags :: DynFlags
, SimplTopEnv -> Logger
st_logger :: !Logger
, SimplTopEnv -> IntWithInf
st_max_ticks :: IntWithInf
, SimplTopEnv -> IO RuleBase
st_query_rulebase :: IO RuleBase
, SimplTopEnv -> RuleEnv
st_mod_rules :: RuleEnv
, SimplTopEnv -> (FamInstEnv, FamInstEnv)
st_fams :: (FamInstEnv, FamInstEnv)
, SimplTopEnv -> OptCoercionOpts
st_co_opt_opts :: !OptCoercionOpts
}
initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv)
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl :: forall a.
Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (FamInstEnv, FamInstEnv)
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger DynFlags
dflags IO RuleBase
qrb RuleEnv
rules (FamInstEnv, FamInstEnv)
fam_envs Int
size SimplM a
m
= do
let simplCount :: SimplCount
simplCount = DynFlags -> SimplCount
zeroSimplCount DynFlags
dflags
(a
result, SimplCount
count) <- SimplM a -> SimplTopEnv -> SimplCount -> IO (a, SimplCount)
forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM SimplM a
m SimplTopEnv
env SimplCount
simplCount
(a, SimplCount) -> IO (a, SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SimplCount
count)
where
env :: SimplTopEnv
env = STE { st_flags :: DynFlags
st_flags = DynFlags
dflags
, st_logger :: Logger
st_logger = Logger
logger
, st_query_rulebase :: IO RuleBase
st_query_rulebase = IO RuleBase
qrb
, st_mod_rules :: RuleEnv
st_mod_rules = RuleEnv
rules
, st_max_ticks :: IntWithInf
st_max_ticks = DynFlags -> Int -> IntWithInf
computeMaxTicks DynFlags
dflags Int
size
, st_fams :: (FamInstEnv, FamInstEnv)
st_fams = (FamInstEnv, FamInstEnv)
fam_envs
, st_co_opt_opts :: OptCoercionOpts
st_co_opt_opts = DynFlags -> OptCoercionOpts
initOptCoercionOpts DynFlags
dflags
}
computeMaxTicks :: DynFlags -> Int -> IntWithInf
computeMaxTicks :: DynFlags -> Int -> IntWithInf
computeMaxTicks DynFlags
dflags Int
size
= Int -> IntWithInf
treatZeroAsInf (Int -> IntWithInf) -> Int -> IntWithInf
forall a b. (a -> b) -> a -> b
$
Integer -> Int
forall a. Num a => Integer -> a
fromInteger ((Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
base_size)
Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
tick_factor Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
magic_multiplier))
Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
100)
where
tick_factor :: Int
tick_factor = DynFlags -> Int
simplTickFactor DynFlags
dflags
base_size :: Int
base_size = Int
100
magic_multiplier :: Int
magic_multiplier = Int
40
{-# INLINE thenSmpl #-}
{-# INLINE thenSmpl_ #-}
{-# INLINE returnSmpl #-}
{-# INLINE mapSmpl #-}
instance Functor SimplM where
fmap :: forall a b. (a -> b) -> SimplM a -> SimplM b
fmap = (a -> b) -> SimplM a -> SimplM b
forall a b. (a -> b) -> SimplM a -> SimplM b
mapSmpl
instance Applicative SimplM where
pure :: forall a. a -> SimplM a
pure = a -> SimplM a
forall a. a -> SimplM a
returnSmpl
<*> :: forall a b. SimplM (a -> b) -> SimplM a -> SimplM 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
(*>) = 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
(>>) = SimplM a -> SimplM b -> SimplM b
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
(>>=) = 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 = SimplM a -> (a -> SimplM b) -> SimplM b
forall a b. SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl SimplM a
m (b -> SimplM b
forall a. a -> SimplM a
returnSmpl (b -> SimplM b) -> (a -> b) -> a -> SimplM b
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 = (SimplTopEnv -> SimplCount -> IO (a, SimplCount)) -> SimplM a
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env SimplCount
sc -> (a, SimplCount) -> IO (a, SimplCount)
forall a. a -> IO a
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
= (SimplTopEnv -> SimplCount -> IO (b, SimplCount)) -> SimplM b
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM ((SimplTopEnv -> SimplCount -> IO (b, SimplCount)) -> SimplM b)
-> (SimplTopEnv -> SimplCount -> IO (b, SimplCount)) -> SimplM b
forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
st_env SimplCount
sc0 -> do
(a
m_result, SimplCount
sc1) <- SimplM a -> SimplTopEnv -> SimplCount -> IO (a, SimplCount)
forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM SimplM a
m SimplTopEnv
st_env SimplCount
sc0
SimplM b -> SimplTopEnv -> SimplCount -> IO (b, SimplCount)
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
= (SimplTopEnv -> SimplCount -> IO (b, SimplCount)) -> SimplM b
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM ((SimplTopEnv -> SimplCount -> IO (b, SimplCount)) -> SimplM b)
-> (SimplTopEnv -> SimplCount -> IO (b, SimplCount)) -> SimplM b
forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
st_env SimplCount
sc0 -> do
(a
_, SimplCount
sc1) <- SimplM a -> SimplTopEnv -> SimplCount -> IO (a, SimplCount)
forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM SimplM a
m SimplTopEnv
st_env SimplCount
sc0
SimplM b -> SimplTopEnv -> SimplCount -> IO (b, SimplCount)
forall result.
SimplM result
-> SimplTopEnv -> SimplCount -> IO (result, SimplCount)
unSM SimplM b
k SimplTopEnv
st_env SimplCount
sc1
traceSmpl :: String -> SDoc -> SimplM ()
traceSmpl :: String -> SDoc -> SimplM ()
traceSmpl String
herald SDoc
doc
= do Logger
logger <- SimplM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> SimplM ()
forall a. IO a -> SimplM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SimplM ()) -> IO () -> SimplM ()
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 (String -> SDoc
text String
herald) Int
2 SDoc
doc)
{-# INLINE traceSmpl #-}
simplMask :: Char
simplMask :: Char
simplMask = Char
's'
instance MonadUnique SimplM where
getUniqueSupplyM :: SimplM UniqSupply
getUniqueSupplyM = IO UniqSupply -> SimplM UniqSupply
forall a. IO a -> SimplM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UniqSupply -> SimplM UniqSupply)
-> IO UniqSupply -> SimplM UniqSupply
forall a b. (a -> b) -> a -> b
$ Char -> IO UniqSupply
mkSplitUniqSupply Char
simplMask
getUniqueM :: SimplM Unique
getUniqueM = IO Unique -> SimplM Unique
forall a. IO a -> SimplM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Unique -> SimplM Unique) -> IO Unique -> SimplM Unique
forall a b. (a -> b) -> a -> b
$ Char -> IO Unique
uniqFromMask Char
simplMask
instance HasDynFlags SimplM where
getDynFlags :: SimplM DynFlags
getDynFlags = (SimplTopEnv -> SimplCount -> IO (DynFlags, SimplCount))
-> SimplM DynFlags
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc -> (DynFlags, SimplCount) -> IO (DynFlags, SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplTopEnv -> DynFlags
st_flags SimplTopEnv
st_env, SimplCount
sc))
instance HasLogger SimplM where
getLogger :: SimplM Logger
getLogger = (SimplTopEnv -> SimplCount -> IO (Logger, SimplCount))
-> SimplM Logger
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc -> (Logger, SimplCount) -> IO (Logger, SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplTopEnv -> Logger
st_logger SimplTopEnv
st_env, SimplCount
sc))
instance MonadIO SimplM where
liftIO :: forall a. IO a -> SimplM a
liftIO IO a
m = (SimplTopEnv -> SimplCount -> IO (a, SimplCount)) -> SimplM a
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM ((SimplTopEnv -> SimplCount -> IO (a, SimplCount)) -> SimplM a)
-> (SimplTopEnv -> SimplCount -> IO (a, SimplCount)) -> SimplM a
forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
_ SimplCount
sc -> do
a
x <- IO a
m
(a, SimplCount) -> IO (a, SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, SimplCount
sc)
getSimplRules :: SimplM RuleEnv
getSimplRules :: SimplM RuleEnv
getSimplRules = (SimplTopEnv -> SimplCount -> IO (RuleEnv, SimplCount))
-> SimplM RuleEnv
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc -> do
RuleBase
eps_rules <- SimplTopEnv -> IO RuleBase
st_query_rulebase SimplTopEnv
st_env
(RuleEnv, SimplCount) -> IO (RuleEnv, SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleEnv -> RuleBase -> RuleEnv
extendRuleEnv (SimplTopEnv -> RuleEnv
st_mod_rules SimplTopEnv
st_env) RuleBase
eps_rules, SimplCount
sc))
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
getFamEnvs = (SimplTopEnv
-> SimplCount -> IO ((FamInstEnv, FamInstEnv), SimplCount))
-> SimplM (FamInstEnv, FamInstEnv)
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc -> ((FamInstEnv, FamInstEnv), SimplCount)
-> IO ((FamInstEnv, FamInstEnv), SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplTopEnv -> (FamInstEnv, FamInstEnv)
st_fams SimplTopEnv
st_env, SimplCount
sc))
getOptCoercionOpts :: SimplM OptCoercionOpts
getOptCoercionOpts :: SimplM OptCoercionOpts
getOptCoercionOpts = (SimplTopEnv -> SimplCount -> IO (OptCoercionOpts, SimplCount))
-> SimplM OptCoercionOpts
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc -> (OptCoercionOpts, SimplCount) -> IO (OptCoercionOpts, SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplTopEnv -> OptCoercionOpts
st_co_opt_opts SimplTopEnv
st_env, SimplCount
sc))
newId :: FastString -> Mult -> Type -> SimplM Id
newId :: FastString -> Mult -> Mult -> SimplM Id
newId FastString
fs Mult
w Mult
ty = do Unique
uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
Id -> SimplM Id
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Mult -> Mult -> Id
mkSysLocalOrCoVar FastString
fs Unique
uniq Mult
w Mult
ty)
newJoinId :: [Var] -> Type -> SimplM Id
newJoinId :: [Id] -> Mult -> SimplM Id
newJoinId [Id]
bndrs Mult
body_ty
= do { Unique
uniq <- SimplM Unique
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
arity :: Int
arity = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
bndrs
join_arity :: Int
join_arity = [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bndrs
details :: IdDetails
details = Int -> Maybe [CbvMark] -> IdDetails
JoinId Int
join_arity Maybe [CbvMark]
forall a. Maybe a
Nothing
id_info :: IdInfo
id_info = IdInfo
vanillaIdInfo IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
; Id -> SimplM Id
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdDetails -> Name -> Mult -> Mult -> IdInfo -> Id
mkLocalVar IdDetails
details Name
name Mult
Many Mult
join_id_ty IdInfo
id_info) }
getSimplCount :: SimplM SimplCount
getSimplCount :: SimplM SimplCount
getSimplCount = (SimplTopEnv -> SimplCount -> IO (SimplCount, SimplCount))
-> SimplM SimplCount
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env SimplCount
sc -> (SimplCount, SimplCount) -> IO (SimplCount, SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplCount
sc, SimplCount
sc))
tick :: Tick -> SimplM ()
tick :: Tick -> SimplM ()
tick Tick
t = (SimplTopEnv -> SimplCount -> IO ((), SimplCount)) -> SimplM ()
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc -> let sc' :: SimplCount
sc' = DynFlags -> Tick -> SimplCount -> SimplCount
doSimplTick (SimplTopEnv -> DynFlags
st_flags SimplTopEnv
st_env) Tick
t SimplCount
sc
in SimplCount
sc' SimplCount -> IO ((), SimplCount) -> IO ((), SimplCount)
forall a b. a -> b -> b
`seq` ((), SimplCount) -> IO ((), SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), SimplCount
sc'))
checkedTick :: Tick -> SimplM ()
checkedTick :: Tick -> SimplM ()
checkedTick Tick
t
= (SimplTopEnv -> SimplCount -> IO ((), SimplCount)) -> SimplM ()
forall result.
(SimplTopEnv -> SimplCount -> IO (result, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env SimplCount
sc ->
if SimplTopEnv -> IntWithInf
st_max_ticks SimplTopEnv
st_env IntWithInf -> IntWithInf -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> IntWithInf
mkIntWithInf (SimplCount -> Int
simplCountN SimplCount
sc)
then GhcException -> IO ((), SimplCount)
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO ((), SimplCount))
-> GhcException -> IO ((), SimplCount)
forall a b. (a -> b) -> a -> b
$
String -> SDoc -> GhcException
PprProgramError String
"Simplifier ticks exhausted" (SimplCount -> SDoc
msg SimplCount
sc)
else let sc' :: SimplCount
sc' = DynFlags -> Tick -> SimplCount -> SimplCount
doSimplTick (SimplTopEnv -> DynFlags
st_flags SimplTopEnv
st_env) Tick
t SimplCount
sc
in SimplCount
sc' SimplCount -> IO ((), SimplCount) -> IO ((), SimplCount)
forall a b. a -> b -> b
`seq` ((), SimplCount) -> IO ((), SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), SimplCount
sc'))
where
msg :: SimplCount -> SDoc
msg SimplCount
sc = [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"When trying" SDoc -> SDoc -> SDoc
<+> Tick -> SDoc
forall a. Outputable a => a -> SDoc
ppr Tick
t
, String -> SDoc
text String
"To increase the limit, use -fsimpl-tick-factor=N (default 100)."
, SDoc
space
, String -> SDoc
text String
"In addition try adjusting -funfolding-case-threshold=N and"
, String -> SDoc
text String
"-funfolding-case-scaling=N for the module in question."
, String -> SDoc
text String
"Using threshold=1 and scaling=5 should break most inlining loops."
, SDoc
space
, String -> SDoc
text String
"If you need to increase the tick factor substantially, while also"
, String -> SDoc
text String
"adjusting unfolding parameters please file a bug report and"
, String -> SDoc
text String
"indicate the factor you needed."
, SDoc
space
, String -> SDoc
text String
"If GHC was unable to complete compilation even"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with a very large factor"
, String -> SDoc
text String
"(a thousand or more), please consult the"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (String -> SDoc
text String
"Known bugs or infelicities")
, String -> SDoc
text String
"section in the Users Guide before filing a report. There are a"
, String -> SDoc
text String
"few situations unlikely to occur in practical programs for which"
, String -> SDoc
text String
"simplifier non-termination has been judged acceptable."
, SDoc
space
, SimplCount -> SDoc
pp_details SimplCount
sc
, SimplCount -> SDoc
pprSimplCount SimplCount
sc ]
pp_details :: SimplCount -> SDoc
pp_details SimplCount
sc
| SimplCount -> Bool
hasDetailedCounts SimplCount
sc = SDoc
empty
| Bool
otherwise = String -> SDoc
text String
"To see detailed counts use -ddump-simpl-stats"
freeTick :: Tick -> SimplM ()
freeTick :: Tick -> SimplM ()
freeTick Tick
t
= (SimplTopEnv -> SimplCount -> IO ((), SimplCount)) -> SimplM ()
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' SimplCount -> IO ((), SimplCount) -> IO ((), SimplCount)
forall a b. a -> b -> b
`seq` ((), SimplCount) -> IO ((), SimplCount)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), SimplCount
sc'))