Add IO to the SimplM monad.

This is needed to turn the rule-firings traces into proper output.

2 files changed, 29 insertions, 38 deletions

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 4c51b304a9..d8c6732c34 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -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
diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index 3b18540e87..6883b6acde 100644
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -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}