Monadify simplCore/Simplify: use do and return

[ghc-hetmet.git] / compiler / simplCore / Simplify.lhs

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 9723dfb..693f1a2 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -742,7 +742,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType
        -- Kept monadic just so we can do the seqType
 simplType env ty
   = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
-    seqType new_ty   `seq`   returnSmpl new_ty
+    seqType new_ty   `seq`   return new_ty
   where
     new_ty = substTy env ty
 \end{code}
@@ -939,8 +939,8 @@ simplNote env InlineMe e cont
                -- (even a type application -- anything except Stop)
   = simplExprF env e cont
 
-simplNote env (CoreNote s) e cont
-  = simplExpr env e    `thenSmpl` \ e' ->
+simplNote env (CoreNote s) e cont = do
+    e' <- simplExpr env e
     rebuild env (Note (CoreNote s) e') cont
 \end{code}
 
@@ -1009,8 +1009,8 @@ completeCall env var cont
                                Just act_fn -> lookupRule act_fn in_scope 
                                                          rules var args 
        ; case maybe_rule of {
-           Just (rule, rule_rhs) -> 
-               tick (RuleFired (ru_name rule))                 `thenSmpl_`
+           Just (rule, rule_rhs) -> do
+               tick (RuleFired (ru_name rule))
                (if dopt Opt_D_dump_rule_firings dflags then
                   pprTrace "Rule fired" (vcat [
                        text "Rule:" <+> ftext (ru_name rule),
@@ -1019,8 +1019,8 @@ completeCall env var cont
                        text "Cont:  " <+> ppr call_cont])
                 else
                        id)             $
-               simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
-               -- The ruleArity says how many args the rule consumed
+                simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
+                -- The ruleArity says how many args the rule consumed
        
          ; Nothing -> do       -- No rules
 
@@ -1572,19 +1572,19 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
 
 simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
   = do {       -- Deal with the pattern-bound variables
-         (env, vs') <- simplBinders env (add_evals con vs)
-
                -- Mark the ones that are in ! positions in the
                -- data constructor as certainly-evaluated.
-       ; let vs'' = add_evals con vs'
+               -- NB: simplLamBinders preserves this eval info
+         let vs_with_evals = add_evals vs (dataConRepStrictness con)
+       ; (env, vs') <- simplLamBndrs env vs_with_evals
 
                -- Bind the case-binder to (con args)
        ; let inst_tys' = tyConAppArgs (idType case_bndr')
-             con_args  = map Type inst_tys' ++ varsToCoreExprs vs'' 
+             con_args  = map Type inst_tys' ++ varsToCoreExprs vs' 
              env'      = addBinderUnfolding env case_bndr' (mkConApp con con_args)
 
        ; rhs' <- simplExprC env' rhs cont'
-       ; return (DataAlt con, vs'', rhs') }
+       ; return (DataAlt con, vs', rhs') }
   where
        -- add_evals records the evaluated-ness of the bound variables of
        -- a case pattern.  This is *important*.  Consider
@@ -1595,9 +1595,7 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
        -- We really must record that b is already evaluated so that we don't
        -- go and re-evaluate it when constructing the result.
        -- See Note [Data-con worker strictness] in MkId.lhs
-    add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
-
-    cat_evals dc vs strs
+    add_evals vs strs
        = go vs strs
        where
          go [] [] = []
@@ -1608,12 +1606,15 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
            where
              zapped_v = zap_occ_info v
              evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
-         go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
+         go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr strs)
 
-       -- If the case binder is alive, then we add the unfolding
+       -- zap_occ_info: if the case binder is alive, then we add the unfolding
        --      case_bndr = C vs
        -- to the envt; so vs are now very much alive
-       -- Note [Aug06] I can't see why this actually matters
+       -- Note [Aug06] I can't see why this actually matters, but it's neater
+       --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
+       --   ==>  case e of t { (a,b) -> ...(a)... }
+       -- Look, Ma, a is alive now.
     zap_occ_info | isDeadBinder case_bndr' = \id -> id
                 | otherwise               = zapOccInfo
 
@@ -1739,7 +1740,7 @@ mkDupableCont :: SimplEnv -> SimplCont
 
 mkDupableCont env cont
   | contIsDupable cont
-  = returnSmpl (env, cont, mkBoringStop (contResultType cont))
+  = return (env, cont, mkBoringStop (contResultType cont))
 
 mkDupableCont env (Stop {}) = panic "mkDupableCont"    -- Handled by previous eqn