Fix LiberateCase

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

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 2fedf87..d1fd65f 100644 (file)
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -4,6 +4,13 @@
 \section[SimplMonad]{The simplifier Monad}
 
 \begin{code}
 \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,
 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 DynFlags
 import Util
 import Outputable

+
+import Data.List

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -101,9 +110,6 @@ data SimplEnv
        seChkr      :: SwitchChecker,
        seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 
        seChkr      :: SwitchChecker,
        seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 

-       -- Rules from other modules
-       seExtRules  :: RuleBase,
-

        -- The current set of in-scope variables
        -- They are all OutVars, and all bound in this module
        seInScope   :: InScopeSet,      -- OutVars only
        -- The current set of in-scope variables
        -- They are all OutVars, and all bound in this module
        seInScope   :: InScopeSet,      -- OutVars only

@@ -207,11 +213,11 @@ seIdSubst:
 
 
 \begin{code}
 
 
 \begin{code}

-mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
-mkSimplEnv mode switches rules
+mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv
+mkSimplEnv mode switches

   = SimplEnv { seChkr = switches, seCC = subsumedCCS, 
               seMode = mode, seInScope = emptyInScopeSet, 
   = SimplEnv { seChkr = switches, seCC = subsumedCCS, 
               seMode = mode, seInScope = emptyInScopeSet, 

-              seExtRules = rules, seFloats = emptyFloats,
+              seFloats = emptyFloats,

               seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
        -- The top level "enclosing CC" is "SUBSUMED".
 
               seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
        -- The top level "enclosing CC" is "SUBSUMED".
 

@@ -289,10 +295,6 @@ mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
 isEmptySimplSubst :: SimplEnv -> Bool
 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
   = isEmptyVarEnv tvs && isEmptyVarEnv ids
 isEmptySimplSubst :: SimplEnv -> Bool
 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
   = isEmptyVarEnv tvs && isEmptyVarEnv ids

-
----------------------
-getRules :: SimplEnv -> RuleBase
-getRules = seExtRules

 \end{code}
 
 
 \end{code}
 
 

@@ -605,29 +607,26 @@ simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
        ; seqIds ids1 `seq` return env1 }
 
 ---------------
        ; 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
               -> (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
   = (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,
     new_id = zapFragileIdInfo id2
 
        -- Extend the substitution if the unique has changed,

@@ -639,8 +638,8 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old
              = delVarEnv id_subst old_id
 \end{code}
 
              = delVarEnv id_subst old_id
 \end{code}
 

-Add IdInfo back onto a let-bound Id
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Add IdInfo back onto a let-bound Id]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 We must transfer the IdInfo of the original binder to the new binder.
 This is crucial, to preserve
        strictness
 We must transfer the IdInfo of the original binder to the new binder.
 This is crucial, to preserve
        strictness

@@ -697,14 +696,13 @@ when substituting in h's RULE.
 \begin{code}
 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
 addLetIdInfo env in_id out_id
 \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
   where

-    final_id = out_id `setIdInfo` new_info

     subst = mkCoreSubst env
     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 
 
 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 -- Substitute the