Fix LiberateCase

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

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 1d7d2e4..d1fd65f 100644 (file)
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -4,6 +4,13 @@
 \section[SimplMonad]{The simplifier Monad}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module SimplEnv (
        InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
        OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
@@ -58,6 +65,8 @@ import BasicTypes
 import DynFlags
 import Util
 import Outputable
+
+import Data.List
 \end{code}
 
 %************************************************************************
@@ -598,29 +607,26 @@ simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
        ; seqIds ids1 `seq` return env1 }
 
 ---------------
-substLetIdBndr :: SimplEnv -> InBndr   -- Env and binder to transform
+substLetIdBndr :: SimplEnv     
+              -> InBndr        -- Env and binder to transform
               -> (SimplEnv, OutBndr)
 -- C.f. substIdBndr above
 -- Clone Id if necessary, substitute its type
--- Return an Id with its fragile info zapped
---     namely, any info that depends on free variables
---     [addLetIdInfo, below, will restore its IdInfo]
---     We want to retain robust info, especially arity and demand info,
---     so that they are available to occurrences that occur in an
---     earlier binding of a letrec
--- Augment the subtitution 
---     if the unique changed, *or* 
---     if there's interesting occurrence info
-
-substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
+-- Return an Id with its 
+--     UnfoldingInfo zapped
+--     Rules, etc, substitutd with rec_subst
+--     Robust info, retained especially arity and demand info,
+--        so that they are available to occurrences that occur in an
+--        earlier binding of a letrec
+-- Augment the subtitution  if the unique changed
+
+substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) 
+              old_id
   = (env { seInScope = in_scope `extendInScopeSet` new_id, 
           seIdSubst = new_subst }, new_id)
   where
     id1           = uniqAway in_scope old_id
     id2    = substIdType env id1
-
-    -- We want to get rid of any info that's dependent on free variables,
-    -- but keep other info (like the arity).
     new_id = zapFragileIdInfo id2
 
        -- Extend the substitution if the unique has changed,
@@ -690,14 +696,13 @@ when substituting in h's RULE.
 \begin{code}
 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
 addLetIdInfo env in_id out_id
-  = (modifyInScope env out_id final_id, final_id)
+  = case substIdInfo subst (idInfo in_id) of
+       Nothing       -> (env, out_id)
+       Just new_info -> (modifyInScope env out_id final_id, final_id)
+                 where
+                     final_id = out_id `setIdInfo` new_info
   where
-    final_id = out_id `setIdInfo` new_info
     subst = mkCoreSubst env
-    old_info = idInfo in_id
-    new_info = case substIdInfo subst old_info of
-                 Nothing       -> old_info
-                 Just new_info -> new_info
 
 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 -- Substitute the