{-
(c) The AQUA Project, Glasgow University, 1993-1998

\section[SimplMonad]{The simplifier Monad}
-}

{-# LANGUAGE DeriveFunctor #-}
module SimplMonad (
        -- The monad
        SimplM,
        initSmpl, traceSmpl,
        getSimplRules, getFamEnvs,

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

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

import GhcPrelude

import Var              ( Var, isId, mkLocalVar )
import Name             ( mkSystemVarName )
import Id               ( Id, mkSysLocalOrCoVar )
import IdInfo           ( IdDetails(..), vanillaIdInfo, setArityInfo )
import Type             ( Type, mkLamTypes )
import FamInstEnv       ( FamInstEnv )
import CoreSyn          ( RuleEnv(..) )
import UniqSupply
import DynFlags
import CoreMonad
import Outputable
import FastString
import MonadUtils
import ErrUtils as Err
import Util                ( count )
import Panic               (throwGhcExceptionIO, GhcException (..))
import BasicTypes          ( IntWithInf, treatZeroAsInf, mkIntWithInf )
import Control.Monad       ( ap )

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

For the simplifier monad, we want to {\em thread} a unique supply and a counter.
(Command-line switches move around through the explicitly-passed SimplEnv.)
-}

newtype SimplM result
  =  SM  { SimplM result
-> SimplTopEnv
-> UniqSupply
-> SimplCount
-> IO (result, UniqSupply, SimplCount)
unSM :: SimplTopEnv  -- Envt that does not change much
                -> UniqSupply   -- We thread the unique supply because
                                -- constantly splitting it is rather expensive
                -> SimplCount
                -> IO (result, UniqSupply, SimplCount)}
  -- we only need IO here for dump output
    deriving (a -> SimplM b -> SimplM a
(a -> b) -> SimplM a -> SimplM b
(forall a b. (a -> b) -> SimplM a -> SimplM b)
-> (forall a b. a -> SimplM b -> SimplM a) -> Functor SimplM
forall a b. a -> SimplM b -> SimplM a
forall a b. (a -> b) -> SimplM a -> SimplM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SimplM b -> SimplM a
$c<$ :: forall a b. a -> SimplM b -> SimplM a
fmap :: (a -> b) -> SimplM a -> SimplM b
$cfmap :: forall a b. (a -> b) -> SimplM a -> SimplM b
Functor)

data SimplTopEnv
  = STE { SimplTopEnv -> DynFlags
st_flags     :: DynFlags
        , SimplTopEnv -> IntWithInf
st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run
        , SimplTopEnv -> RuleEnv
st_rules     :: RuleEnv
        , SimplTopEnv -> (FamInstEnv, FamInstEnv)
st_fams      :: (FamInstEnv, FamInstEnv) }

initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
         -> UniqSupply          -- No init count; set to 0
         -> Int                 -- Size of the bindings, used to limit
                                -- the number of ticks we allow
         -> SimplM a
         -> IO (a, SimplCount)

initSmpl :: DynFlags
-> RuleEnv
-> (FamInstEnv, FamInstEnv)
-> UniqSupply
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl DynFlags
dflags RuleEnv
rules (FamInstEnv, FamInstEnv)
fam_envs UniqSupply
us Int
size SimplM a
m
  = do (a
result, UniqSupply
_, SimplCount
count) <- SimplM a
-> SimplTopEnv
-> UniqSupply
-> SimplCount
-> IO (a, UniqSupply, SimplCount)
forall result.
SimplM result
-> SimplTopEnv
-> UniqSupply
-> SimplCount
-> IO (result, UniqSupply, SimplCount)
unSM SimplM a
m SimplTopEnv
env UniqSupply
us (DynFlags -> SimplCount
zeroSimplCount DynFlags
dflags)
       (a, SimplCount) -> IO (a, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SimplCount
count)
  where
    env :: SimplTopEnv
env = STE :: DynFlags
-> IntWithInf -> RuleEnv -> (FamInstEnv, FamInstEnv) -> SimplTopEnv
STE { st_flags :: DynFlags
st_flags = DynFlags
dflags, st_rules :: RuleEnv
st_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 }

computeMaxTicks :: DynFlags -> 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 :: 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
        -- 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 #-}


instance Applicative SimplM where
    pure :: a -> SimplM a
pure  = a -> SimplM a
forall a. a -> SimplM a
returnSmpl
    <*> :: 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
    *> :: 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
   >> :: SimplM a -> SimplM b -> SimplM b
(>>)   = SimplM a -> SimplM b -> SimplM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f 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

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

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

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

thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
thenSmpl_ SimplM a
m SimplM b
k
  = (SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (b, UniqSupply, SimplCount))
-> SimplM b
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM ((SimplTopEnv
  -> UniqSupply -> SimplCount -> IO (b, UniqSupply, SimplCount))
 -> SimplM b)
-> (SimplTopEnv
    -> UniqSupply -> SimplCount -> IO (b, UniqSupply, SimplCount))
-> SimplM b
forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
st_env UniqSupply
us0 SimplCount
sc0 -> do
      (a
_, UniqSupply
us1, SimplCount
sc1) <- SimplM a
-> SimplTopEnv
-> UniqSupply
-> SimplCount
-> IO (a, UniqSupply, SimplCount)
forall result.
SimplM result
-> SimplTopEnv
-> UniqSupply
-> SimplCount
-> IO (result, UniqSupply, SimplCount)
unSM SimplM a
m SimplTopEnv
st_env UniqSupply
us0 SimplCount
sc0
      SimplM b
-> SimplTopEnv
-> UniqSupply
-> SimplCount
-> IO (b, UniqSupply, SimplCount)
forall result.
SimplM result
-> SimplTopEnv
-> UniqSupply
-> SimplCount
-> IO (result, UniqSupply, SimplCount)
unSM SimplM b
k SimplTopEnv
st_env UniqSupply
us1 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 { DynFlags
dflags <- SimplM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; IO () -> SimplM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SimplM ()) -> IO () -> SimplM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
Err.dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_simpl_trace String
"Simpl Trace"
           (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
herald) Int
2 SDoc
doc) }

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

instance MonadUnique SimplM where
    getUniqueSupplyM :: SimplM UniqSupply
getUniqueSupplyM
       = (SimplTopEnv
 -> UniqSupply
 -> SimplCount
 -> IO (UniqSupply, UniqSupply, SimplCount))
-> SimplM UniqSupply
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env UniqSupply
us SimplCount
sc -> case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us of
                                (UniqSupply
us1, UniqSupply
us2) -> (UniqSupply, UniqSupply, SimplCount)
-> IO (UniqSupply, UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply
us1, UniqSupply
us2, SimplCount
sc))

    getUniqueM :: SimplM Unique
getUniqueM
       = (SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (Unique, UniqSupply, SimplCount))
-> SimplM Unique
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env UniqSupply
us SimplCount
sc -> case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us of
                                (Unique
u, UniqSupply
us') -> (Unique, UniqSupply, SimplCount)
-> IO (Unique, UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique
u, UniqSupply
us', SimplCount
sc))

    getUniquesM :: SimplM [Unique]
getUniquesM
        = (SimplTopEnv
 -> UniqSupply
 -> SimplCount
 -> IO ([Unique], UniqSupply, SimplCount))
-> SimplM [Unique]
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env UniqSupply
us SimplCount
sc -> case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us of
                                (UniqSupply
us1, UniqSupply
us2) -> ([Unique], UniqSupply, SimplCount)
-> IO ([Unique], UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us1, UniqSupply
us2, SimplCount
sc))

instance HasDynFlags SimplM where
    getDynFlags :: SimplM DynFlags
getDynFlags = (SimplTopEnv
 -> UniqSupply
 -> SimplCount
 -> IO (DynFlags, UniqSupply, SimplCount))
-> SimplM DynFlags
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env UniqSupply
us SimplCount
sc -> (DynFlags, UniqSupply, SimplCount)
-> IO (DynFlags, UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplTopEnv -> DynFlags
st_flags SimplTopEnv
st_env, UniqSupply
us, SimplCount
sc))

instance MonadIO SimplM where
    liftIO :: IO a -> SimplM a
liftIO IO a
m = (SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (a, UniqSupply, SimplCount))
-> SimplM a
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM ((SimplTopEnv
  -> UniqSupply -> SimplCount -> IO (a, UniqSupply, SimplCount))
 -> SimplM a)
-> (SimplTopEnv
    -> UniqSupply -> SimplCount -> IO (a, UniqSupply, SimplCount))
-> SimplM a
forall a b. (a -> b) -> a -> b
$ \SimplTopEnv
_ UniqSupply
us SimplCount
sc -> do
      a
x <- IO a
m
      (a, UniqSupply, SimplCount) -> IO (a, UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, UniqSupply
us, SimplCount
sc)

getSimplRules :: SimplM RuleEnv
getSimplRules :: SimplM RuleEnv
getSimplRules = (SimplTopEnv
 -> UniqSupply
 -> SimplCount
 -> IO (RuleEnv, UniqSupply, SimplCount))
-> SimplM RuleEnv
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env UniqSupply
us SimplCount
sc -> (RuleEnv, UniqSupply, SimplCount)
-> IO (RuleEnv, UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplTopEnv -> RuleEnv
st_rules SimplTopEnv
st_env, UniqSupply
us, SimplCount
sc))

getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
getFamEnvs = (SimplTopEnv
 -> UniqSupply
 -> SimplCount
 -> IO ((FamInstEnv, FamInstEnv), UniqSupply, SimplCount))
-> SimplM (FamInstEnv, FamInstEnv)
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env UniqSupply
us SimplCount
sc -> ((FamInstEnv, FamInstEnv), UniqSupply, SimplCount)
-> IO ((FamInstEnv, FamInstEnv), UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplTopEnv -> (FamInstEnv, FamInstEnv)
st_fams SimplTopEnv
st_env, UniqSupply
us, SimplCount
sc))

newId :: FastString -> Type -> SimplM Id
newId :: FastString -> Type -> SimplM Id
newId FastString
fs Type
ty = do Unique
uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
                 Id -> SimplM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Type -> Id
mkSysLocalOrCoVar FastString
fs Unique
uniq Type
ty)

newJoinId :: [Var] -> Type -> SimplM Id
newJoinId :: [Id] -> Type -> SimplM Id
newJoinId [Id]
bndrs Type
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 :: Type
join_id_ty = [Id] -> Type -> Type
mkLamTypes [Id]
bndrs Type
body_ty  -- Note [Funky mkLamTypes]
             arity :: Int
arity      = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
bndrs
             -- arity: See Note [Invariants on join points] invariant 2b, in CoreSyn
             join_arity :: Int
join_arity = [Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bndrs
             details :: IdDetails
details    = Int -> IdDetails
JoinId Int
join_arity
             id_info :: IdInfo
id_info    = IdInfo
vanillaIdInfo IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
--                                        `setOccInfo` strongLoopBreaker

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

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

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

tick :: Tick -> SimplM ()
tick :: Tick -> SimplM ()
tick Tick
t = (SimplTopEnv
 -> UniqSupply -> SimplCount -> IO ((), UniqSupply, SimplCount))
-> SimplM ()
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env UniqSupply
us 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 ((), UniqSupply, SimplCount)
-> IO ((), UniqSupply, SimplCount)
`seq` ((), UniqSupply, SimplCount) -> IO ((), UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), UniqSupply
us, SimplCount
sc'))

checkedTick :: Tick -> SimplM ()
-- Try to take a tick, but fail if too many
checkedTick :: Tick -> SimplM ()
checkedTick Tick
t
  = (SimplTopEnv
 -> UniqSupply -> SimplCount -> IO ((), UniqSupply, SimplCount))
-> SimplM ()
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
st_env UniqSupply
us 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 ((), UniqSupply, SimplCount)
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO ((), UniqSupply, SimplCount))
-> GhcException -> IO ((), UniqSupply, 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 ((), UniqSupply, SimplCount)
-> IO ((), UniqSupply, SimplCount)
`seq` ((), UniqSupply, SimplCount) -> IO ((), UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), UniqSupply
us, 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
"If you need to increase the limit substantially, please file a"
      , String -> SDoc
text String
"bug report and 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 ()
-- 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
   = (SimplTopEnv
 -> UniqSupply -> SimplCount -> IO ((), UniqSupply, SimplCount))
-> SimplM ()
forall result.
(SimplTopEnv
 -> UniqSupply -> SimplCount -> IO (result, UniqSupply, SimplCount))
-> SimplM result
SM (\SimplTopEnv
_st_env UniqSupply
us SimplCount
sc -> let sc' :: SimplCount
sc' = Tick -> SimplCount -> SimplCount
doFreeSimplTick Tick
t SimplCount
sc
                           in SimplCount
sc' SimplCount
-> IO ((), UniqSupply, SimplCount)
-> IO ((), UniqSupply, SimplCount)
`seq` ((), UniqSupply, SimplCount) -> IO ((), UniqSupply, SimplCount)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), UniqSupply
us, SimplCount
sc'))