Commit 9bf764be authored by pcapriotti's avatar pcapriotti

Add IO to the SimplM monad.

This is needed to turn the rule-firings traces into proper output.
parent 301b3725
......@@ -493,7 +493,8 @@ simplifyExpr dflags expr
; us <- mkSplitUniqSupply 's'
; let sz = exprSize expr
(expr', counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
simplExprGently (simplEnvForGHCi dflags) expr
; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
......@@ -629,18 +630,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
-- Simplify the program
-- We do this with a *case* not a *let* because lazy pattern
-- matching bit us with bad space leak!
-- With a let, we ended up with
-- let
-- t = initSmpl ...
-- counts1 = snd t
-- in
-- case t of {(_,counts1) -> if counts1=0 then ... }
-- So the conditional didn't force counts1, because the
-- selection got duplicated. Sigh!
case initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds of {
(env1, counts1) -> do {
(env1, counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds ;
let { binds1 = getFloatBinds env1
; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
......@@ -667,7 +657,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- Loop
do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
} } } }
} }
| otherwise = panic "do_iteration"
where
(us1, us2) = splitUniqSupply us
......
......@@ -52,7 +52,8 @@ newtype SimplM result
-> UniqSupply -- We thread the unique supply because
-- constantly splitting it is rather expensive
-> SimplCount
-> (result, UniqSupply, SimplCount)}
-> IO (result, UniqSupply, SimplCount)}
-- we only need IO here for dump output
data SimplTopEnv
= STE { st_flags :: DynFlags
......@@ -68,11 +69,11 @@ initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
-> Int -- Size of the bindings, used to limit
-- the number of ticks we allow
-> SimplM a
-> (a, SimplCount)
-> IO (a, SimplCount)
initSmpl dflags rules fam_envs us size m
= case unSM m env us (zeroSimplCount dflags) of
(result, _, count) -> (result, count)
= do (result, _, count) <- unSM m env us (zeroSimplCount dflags)
return (result, count)
where
env = STE { st_flags = dflags, st_rules = rules
, st_max_ticks = computeMaxTicks dflags size
......@@ -107,20 +108,20 @@ instance Monad SimplM where
return = returnSmpl
returnSmpl :: a -> SimplM a
returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
thenSmpl m k
= SM (\ st_env us0 sc0 ->
case (unSM m st_env us0 sc0) of
(m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
thenSmpl m k
= SM $ \st_env us0 sc0 -> do
(m_result, us1, sc1) <- unSM m st_env us0 sc0
unSM (k m_result) st_env us1 sc1
thenSmpl_ m k
= SM (\st_env us0 sc0 ->
case (unSM m st_env us0 sc0) of
(_, us1, sc1) -> unSM k st_env us1 sc1)
thenSmpl_ m k
= SM $ \st_env us0 sc0 -> do
(_, us1, sc1) <- unSM m st_env us0 sc0
unSM k st_env us1 sc1
-- TODO: this specializing is not allowed
-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
......@@ -139,24 +140,24 @@ thenSmpl_ m k
instance MonadUnique SimplM where
getUniqueSupplyM
= SM (\_st_env us sc -> case splitUniqSupply us of
(us1, us2) -> (us1, us2, sc))
(us1, us2) -> return (us1, us2, sc))
getUniqueM
= SM (\_st_env us sc -> case splitUniqSupply us of
(us1, us2) -> (uniqFromSupply us1, us2, sc))
(us1, us2) -> return (uniqFromSupply us1, us2, sc))
getUniquesM
= SM (\_st_env us sc -> case splitUniqSupply us of
(us1, us2) -> (uniqsFromSupply us1, us2, sc))
(us1, us2) -> return (uniqsFromSupply us1, us2, sc))
instance HasDynFlags SimplM where
getDynFlags = SM (\st_env us sc -> (st_flags st_env, us, sc))
getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))
getSimplRules :: SimplM RuleBase
getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
newId :: FastString -> Type -> SimplM Id
newId fs ty = do uniq <- getUniqueM
......@@ -172,11 +173,11 @@ newId fs ty = do uniq <- getUniqueM
\begin{code}
getSimplCount :: SimplM SimplCount
getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
tick :: Tick -> SimplM ()
tick t = SM (\_st_env us sc -> let sc' = doSimplTick t sc
in sc' `seq` ((), us, sc'))
tick t = SM (\_st_env us sc -> let sc' = doSimplTick t sc
in sc' `seq` return ((), us, sc'))
checkedTick :: Tick -> SimplM ()
-- Try to take a tick, but fail if too many
......@@ -184,7 +185,7 @@ checkedTick t
= SM (\st_env us sc -> if st_max_ticks st_env <= simplCountN sc
then pprPanic "Simplifier ticks exhausted" (msg sc)
else let sc' = doSimplTick t sc
in sc' `seq` ((), us, sc'))
in sc' `seq` return ((), us, sc'))
where
msg sc = vcat [ ptext (sLit "When trying") <+> ppr t
, ptext (sLit "To increase the limit, use -fsimpl-tick-factor=N (default 100)")
......@@ -201,5 +202,5 @@ freeTick :: Tick -> SimplM ()
-- used to decide when nothing further has happened
freeTick t
= SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
in sc' `seq` ((), us, sc'))
in sc' `seq` return ((), us, sc'))
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment