never executed always true always false
    1 {-# LANGUAGE PatternSynonyms #-}
    2 {-
    3 (c) The AQUA Project, Glasgow University, 1993-1998
    4 
    5 \section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}
    6 -}
    7 
    8 module GHC.Core.Opt.Simplify.Monad (
    9         -- The monad
   10         SimplM,
   11         initSmpl, traceSmpl,
   12         getSimplRules, getFamEnvs, getOptCoercionOpts,
   13 
   14         -- Unique supply
   15         MonadUnique(..), newId, newJoinId,
   16 
   17         -- Counting
   18         SimplCount, tick, freeTick, checkedTick,
   19         getSimplCount, zeroSimplCount, pprSimplCount,
   20         plusSimplCount, isZeroSimplCount
   21     ) where
   22 
   23 import GHC.Prelude
   24 
   25 import GHC.Types.Var       ( Var, isId, mkLocalVar )
   26 import GHC.Types.Name      ( mkSystemVarName )
   27 import GHC.Types.Id        ( Id, mkSysLocalOrCoVar )
   28 import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo )
   29 import GHC.Core.Type       ( Type, Mult )
   30 import GHC.Core.FamInstEnv ( FamInstEnv )
   31 import GHC.Core            ( RuleEnv(..) )
   32 import GHC.Core.Utils      ( mkLamTypes )
   33 import GHC.Core.Coercion.Opt
   34 import GHC.Types.Unique.Supply
   35 import GHC.Driver.Session
   36 import GHC.Driver.Config
   37 import GHC.Core.Opt.Monad
   38 import GHC.Utils.Outputable
   39 import GHC.Data.FastString
   40 import GHC.Utils.Monad
   41 import GHC.Utils.Logger as Logger
   42 import GHC.Utils.Misc      ( count )
   43 import GHC.Utils.Panic     (throwGhcExceptionIO, GhcException (..))
   44 import GHC.Types.Basic     ( IntWithInf, treatZeroAsInf, mkIntWithInf )
   45 import Control.Monad       ( ap )
   46 import GHC.Core.Multiplicity        ( pattern Many )
   47 import GHC.Exts( oneShot )
   48 
   49 {-
   50 ************************************************************************
   51 *                                                                      *
   52 \subsection{Monad plumbing}
   53 *                                                                      *
   54 ************************************************************************
   55 
   56 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
   57 (Command-line switches move around through the explicitly-passed SimplEnv.)
   58 -}
   59 
   60 newtype SimplM result
   61   =  SM'  { unSM :: SimplTopEnv  -- Envt that does not change much
   62                  -> SimplCount
   63                  -> IO (result, SimplCount)}
   64     -- We only need IO here for dump output, but since we already have it
   65     -- we might as well use it for uniques.
   66 
   67 pattern SM :: (SimplTopEnv -> SimplCount
   68                -> IO (result, SimplCount))
   69           -> SimplM result
   70 -- This pattern synonym makes the simplifier monad eta-expand,
   71 -- which as a very beneficial effect on compiler performance
   72 -- (worth a 1-2% reduction in bytes-allocated).  See #18202.
   73 -- See Note [The one-shot state monad trick] in GHC.Utils.Monad
   74 pattern SM m <- SM' m
   75   where
   76     SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct)
   77 
   78 data SimplTopEnv
   79   = STE { st_flags     :: DynFlags
   80         , st_logger    :: !Logger
   81         , st_max_ticks :: IntWithInf  -- ^ Max #ticks in this simplifier run
   82         , st_rules     :: RuleEnv
   83         , st_fams      :: (FamInstEnv, FamInstEnv)
   84 
   85         , st_co_opt_opts :: !OptCoercionOpts
   86             -- ^ Coercion optimiser options
   87         }
   88 
   89 initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
   90          -> Int                 -- Size of the bindings, used to limit
   91                                 -- the number of ticks we allow
   92          -> SimplM a
   93          -> IO (a, SimplCount)
   94 
   95 initSmpl logger dflags rules fam_envs size m
   96   = do -- No init count; set to 0
   97        let simplCount = zeroSimplCount dflags
   98        (result, count) <- unSM m env simplCount
   99        return (result, count)
  100   where
  101     env = STE { st_flags = dflags
  102               , st_logger = logger
  103               , st_rules = rules
  104               , st_max_ticks = computeMaxTicks dflags size
  105               , st_fams = fam_envs
  106               , st_co_opt_opts = initOptCoercionOpts dflags
  107               }
  108 
  109 computeMaxTicks :: DynFlags -> Int -> IntWithInf
  110 -- Compute the max simplifier ticks as
  111 --     (base-size + pgm-size) * magic-multiplier * tick-factor/100
  112 -- where
  113 --    magic-multiplier is a constant that gives reasonable results
  114 --    base-size is a constant to deal with size-zero programs
  115 computeMaxTicks dflags size
  116   = treatZeroAsInf $
  117     fromInteger ((toInteger (size + base_size)
  118                   * toInteger (tick_factor * magic_multiplier))
  119           `div` 100)
  120   where
  121     tick_factor      = simplTickFactor dflags
  122     base_size        = 100
  123     magic_multiplier = 40
  124         -- MAGIC NUMBER, multiplies the simplTickFactor
  125         -- We can afford to be generous; this is really
  126         -- just checking for loops, and shouldn't usually fire
  127         -- A figure of 20 was too small: see #5539.
  128 
  129 {-# INLINE thenSmpl #-}
  130 {-# INLINE thenSmpl_ #-}
  131 {-# INLINE returnSmpl #-}
  132 {-# INLINE mapSmpl #-}
  133 
  134 instance Functor SimplM where
  135   fmap = mapSmpl
  136 
  137 instance Applicative SimplM where
  138     pure  = returnSmpl
  139     (<*>) = ap
  140     (*>)  = thenSmpl_
  141 
  142 instance Monad SimplM where
  143    (>>)   = (*>)
  144    (>>=)  = thenSmpl
  145 
  146 mapSmpl :: (a -> b) -> SimplM a -> SimplM b
  147 mapSmpl f m = thenSmpl m (returnSmpl . f)
  148 
  149 returnSmpl :: a -> SimplM a
  150 returnSmpl e = SM (\_st_env sc -> return (e, sc))
  151 
  152 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
  153 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
  154 
  155 thenSmpl m k
  156   = SM $ \st_env sc0 -> do
  157       (m_result, sc1) <- unSM m st_env sc0
  158       unSM (k m_result) st_env sc1
  159 
  160 thenSmpl_ m k
  161   = SM $ \st_env sc0 -> do
  162       (_, sc1) <- unSM m st_env sc0
  163       unSM k st_env sc1
  164 
  165 -- TODO: this specializing is not allowed
  166 -- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
  167 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
  168 -- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
  169 
  170 traceSmpl :: String -> SDoc -> SimplM ()
  171 traceSmpl herald doc
  172   = do logger <- getLogger
  173        liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace"
  174          FormatText
  175          (hang (text herald) 2 doc)
  176 {-# INLINE traceSmpl #-}  -- see Note [INLINE conditional tracing utilities]
  177 
  178 {-
  179 ************************************************************************
  180 *                                                                      *
  181 \subsection{The unique supply}
  182 *                                                                      *
  183 ************************************************************************
  184 -}
  185 
  186 -- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques
  187 simplMask :: Char
  188 simplMask = 's'
  189 
  190 instance MonadUnique SimplM where
  191     getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask
  192     getUniqueM = liftIO $ uniqFromMask simplMask
  193 
  194 instance HasDynFlags SimplM where
  195     getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc))
  196 
  197 instance HasLogger SimplM where
  198     getLogger = SM (\st_env sc -> return (st_logger st_env, sc))
  199 
  200 instance MonadIO SimplM where
  201     liftIO m = SM $ \_ sc -> do
  202       x <- m
  203       return (x, sc)
  204 
  205 getSimplRules :: SimplM RuleEnv
  206 getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc))
  207 
  208 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
  209 getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc))
  210 
  211 getOptCoercionOpts :: SimplM OptCoercionOpts
  212 getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc))
  213 
  214 newId :: FastString -> Mult -> Type -> SimplM Id
  215 newId fs w ty = do uniq <- getUniqueM
  216                    return (mkSysLocalOrCoVar fs uniq w ty)
  217 
  218 newJoinId :: [Var] -> Type -> SimplM Id
  219 newJoinId bndrs body_ty
  220   = do { uniq <- getUniqueM
  221        ; let name       = mkSystemVarName uniq (fsLit "$j")
  222              join_id_ty = mkLamTypes bndrs body_ty  -- Note [Funky mkLamTypes]
  223              arity      = count isId bndrs
  224              -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core
  225              join_arity = length bndrs
  226              details    = JoinId join_arity
  227              id_info    = vanillaIdInfo `setArityInfo` arity
  228 --                                        `setOccInfo` strongLoopBreaker
  229 
  230        ; return (mkLocalVar details name Many join_id_ty id_info) }
  231 
  232 {-
  233 ************************************************************************
  234 *                                                                      *
  235 \subsection{Counting up what we've done}
  236 *                                                                      *
  237 ************************************************************************
  238 -}
  239 
  240 getSimplCount :: SimplM SimplCount
  241 getSimplCount = SM (\_st_env sc -> return (sc, sc))
  242 
  243 tick :: Tick -> SimplM ()
  244 tick t = SM (\st_env sc -> let sc' = doSimplTick (st_flags st_env) t sc
  245                               in sc' `seq` return ((), sc'))
  246 
  247 checkedTick :: Tick -> SimplM ()
  248 -- Try to take a tick, but fail if too many
  249 checkedTick t
  250   = SM (\st_env sc ->
  251            if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)
  252            then throwGhcExceptionIO $
  253                   PprProgramError "Simplifier ticks exhausted" (msg sc)
  254            else let sc' = doSimplTick (st_flags st_env) t sc
  255                 in sc' `seq` return ((), sc'))
  256   where
  257     msg sc = vcat
  258       [ text "When trying" <+> ppr t
  259       , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."
  260       , space
  261       , text "In addition try adjusting -funfolding-case-threshold=N and"
  262       , text "-funfolding-case-scaling=N for the module in question."
  263       , text "Using threshold=1 and scaling=5 should break most inlining loops."
  264       , space
  265       , text "If you need to increase the tick factor substantially, while also"
  266       , text "adjusting unfolding parameters please file a bug report and"
  267       , text "indicate the factor you needed."
  268       , space
  269       , text "If GHC was unable to complete compilation even"
  270                <+> text "with a very large factor"
  271       , text "(a thousand or more), please consult the"
  272                 <+> doubleQuotes (text "Known bugs or infelicities")
  273       , text "section in the Users Guide before filing a report. There are a"
  274       , text "few situations unlikely to occur in practical programs for which"
  275       , text "simplifier non-termination has been judged acceptable."
  276       , space
  277       , pp_details sc
  278       , pprSimplCount sc ]
  279     pp_details sc
  280       | hasDetailedCounts sc = empty
  281       | otherwise = text "To see detailed counts use -ddump-simpl-stats"
  282 
  283 
  284 freeTick :: Tick -> SimplM ()
  285 -- Record a tick, but don't add to the total tick count, which is
  286 -- used to decide when nothing further has happened
  287 freeTick t
  288    = SM (\_st_env sc -> let sc' = doFreeSimplTick t sc
  289                            in sc' `seq` return ((), sc'))