Make SpecConstr work again

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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index d05e4a1..a27aa47 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -39,6 +39,7 @@ import PrelInfo               ( realWorldPrimId )
 import BasicTypes      ( TopLevelFlag(..), isTopLevel, 
                          RecFlag(..), isNonRuleLoopBreaker )
 import Maybes          ( orElse )
+import Data.List       ( mapAccumL )
 import Outputable
 import Util
 \end{code}
@@ -234,8 +235,10 @@ simplTopBinds env binds
     trace True  bind = pprTrace "SimplBind" (ppr (bindersOf bind))
     trace False bind = \x -> x
 
-    simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r
-    simpl_bind env (Rec pairs)  = simplRecBind      env TopLevel pairs
+    simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
+    simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
+       where
+         (env', b') = addBndrRules env b (lookupRecBndr env b)
 \end{code}
 
 
@@ -253,15 +256,22 @@ simplRecBind :: SimplEnv -> TopLevelFlag
             -> [(InId, InExpr)]
             -> SimplM SimplEnv
 simplRecBind env top_lvl pairs
-  = do { env' <- go (zapFloats env) pairs
+  = do { let (env_with_info, triples) = mapAccumL add_rules env pairs
+       ; env' <- go (zapFloats env_with_info) triples
        ; return (env `addRecFloats` env') }
        -- addFloats adds the floats from env', 
        -- *and* updates env with the in-scope set from env'
   where
+    add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
+       -- Add the (substituted) rules to the binder
+    add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
+       where
+         (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
+
     go env [] = return env
        
-    go env ((bndr, rhs) : pairs)
-       = do { env <- simplRecOrTopPair env top_lvl bndr rhs
+    go env ((old_bndr, new_bndr, rhs) : pairs)
+       = do { env <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
             ; go env pairs }
 \end{code}
 
@@ -274,18 +284,16 @@ It assumes the binder has already been simplified, but not its IdInfo.
 \begin{code}
 simplRecOrTopPair :: SimplEnv
                  -> TopLevelFlag
-                 -> InId -> InExpr     -- Binder and rhs
+                 -> InId -> OutBndr -> InExpr  -- Binder and rhs
                  -> SimplM SimplEnv    -- Returns an env that includes the binding
 
-simplRecOrTopPair env top_lvl bndr rhs
-  | preInlineUnconditionally env top_lvl bndr rhs      -- Check for unconditional inline
-  = do { tick (PreInlineUnconditionally bndr)
-       ; return (extendIdSubst env bndr (mkContEx env rhs)) }
+simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+  | preInlineUnconditionally env top_lvl old_bndr rhs          -- Check for unconditional inline
+  = do { tick (PreInlineUnconditionally old_bndr)
+       ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
 
   | otherwise
-  = do { let bndr' = lookupRecBndr env bndr
-             (env', bndr'') = addLetIdInfo env bndr bndr'
-       ; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' }
+  = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env 
        -- May not actually be recursive, but it doesn't matter
 \end{code}
 
@@ -578,6 +586,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
        -- (for example) be no longer strictly demanded.
        -- The solution here is a bit ad hoc...
        info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+                                  `setWorkerInfo`    worker_info
+
         final_info | loop_breaker              = new_bndr_info
                   | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
                   | otherwise                  = info_w_unf
@@ -591,6 +601,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
     return (addNonRec env final_id new_rhs)
   where 
     unfolding    = mkUnfolding (isTopLevel top_lvl) new_rhs
+    worker_info  = substWorker env (workerInfo old_info)
     loop_breaker = isNonRuleLoopBreaker occ_info
     old_info     = idInfo old_bndr
     occ_info     = occInfo old_info
@@ -896,9 +907,10 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
                     (StrictBind bndr bndrs body env cont) }
 
   | otherwise
-  = do { (env, bndr') <- simplNonRecBndr env bndr
-       ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
-       ; simplLam env bndrs body cont }
+  = do { (env1, bndr1) <- simplNonRecBndr env bndr
+       ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
+       ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
+       ; simplLam env3 bndrs body cont }
 \end{code}
 
 
@@ -977,8 +989,8 @@ completeCall env var cont
        -- the wrapper didn't occur for things that have specialisations till a 
        -- later phase, so but now we just try RULES first
        --
-       -- Note [Self-recursive rules]
-       -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+       -- Note [Rules for recursive functions]
+       -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        -- You might think that we shouldn't apply rules for a loop breaker: 
        -- doing so might give rise to an infinite loop, because a RULE is
        -- rather like an extra equation for the function:
@@ -1025,7 +1037,7 @@ completeCall env var cont
            Just unfolding      -- There is an inlining!
              ->  do { tick (UnfoldingDone var)
                     ; (if dopt Opt_D_dump_inlinings dflags then
-                          pprTrace "Inlining done" (vcat [
+                          pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
                                text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
                                text "Inlined fn: " <+> nest 2 (ppr unfolding),
                                text "Cont:  " <+> ppr call_cont])
@@ -1455,7 +1467,7 @@ simplCaseBinder env scrut case_bndr alts
                -- See Note [no-case-of-case]
        = (env, case_bndr)
 
-       | otherwise     -- Failed try [see Note 2 above]
+       | otherwise     -- Failed try; see Note [Suppressing the case binder-swap]
                        --     not (isEvaldUnfolding (idUnfolding v))
        = case scrut of
            Var v -> (modifyInScope env1 v case_bndr', case_bndr')
@@ -1533,7 +1545,7 @@ simplAlts env scrut case_bndr alts cont'
     do { let alt_env = zapFloats env
        ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
 
-       ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts
+       ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts
 
        ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
        ; return (scrut', case_bndr', alts') }