Substantial improvement to the interaction of RULES and inlining

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

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index f9e0484..d1fd65f 100644 (file)
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -4,13 +4,18 @@
 \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,
         InCoercion, OutCoercion,
 
 module SimplEnv (
        InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
        OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
         InCoercion, OutCoercion,
 

-       isStrictBndr,
-

        -- The simplifier mode
        setMode, getMode, 
 
        -- The simplifier mode
        setMode, getMode, 
 

@@ -21,7 +26,7 @@ module SimplEnv (
        setEnclosingCC, getEnclosingCC,
 
        -- Environments
        setEnclosingCC, getEnclosingCC,
 
        -- Environments

-       SimplEnv(..),   -- Temp not abstract
+       SimplEnv(..), pprSimplEnv,      -- Temp not abstract

        mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 
        zapSubstEnv, setSubstEnv, 
        getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
        mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 
        zapSubstEnv, setSubstEnv, 
        getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,

@@ -34,9 +39,9 @@ module SimplEnv (
        substExpr, substTy, 
 
        -- Floats
        substExpr, substTy, 
 
        -- Floats

-       Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, 
-       wrapFloats, floatBinds, setFloats, canFloat, zapFloats, addRecFloats,
-       getFloats
+       Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
+       wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
+       doFloatFromRhs, getFloats

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -46,14 +51,12 @@ import IdInfo
 import CoreSyn
 import Rules
 import CoreUtils
 import CoreSyn
 import Rules
 import CoreUtils

-import CoreFVs

 import CostCentre
 import Var
 import VarEnv
 import VarSet
 import OrdList
 import Id
 import CostCentre
 import Var
 import VarEnv
 import VarSet
 import OrdList
 import Id

-import NewDemand

 import qualified CoreSubst     ( Subst, mkSubst, substExpr, substSpec, substWorker )
 import qualified Type          ( substTy, substTyVarBndr )
 import Type hiding             ( substTy, substTyVarBndr )
 import qualified CoreSubst     ( Subst, mkSubst, substExpr, substSpec, substWorker )
 import qualified Type          ( substTy, substTyVarBndr )
 import Type hiding             ( substTy, substTyVarBndr )

@@ -61,8 +64,9 @@ import Coercion
 import BasicTypes      
 import DynFlags
 import Util
 import BasicTypes      
 import DynFlags
 import Util

-import UniqFM

 import Outputable
 import Outputable

+
+import Data.List

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

@@ -92,13 +96,6 @@ type OutAlt   = CoreAlt
 type OutArg     = CoreArg
 \end{code}
 
 type OutArg     = CoreArg
 \end{code}
 

-\begin{code}
-isStrictBndr :: Id -> Bool
-isStrictBndr bndr
-  = ASSERT2( isId bndr, ppr bndr )
-    isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr)
-\end{code}
-

 %************************************************************************
 %*                                                                     *
 \subsubsection{The @SimplEnv@ type}
 %************************************************************************
 %*                                                                     *
 \subsubsection{The @SimplEnv@ type}

@@ -113,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

@@ -129,7 +123,14 @@ data SimplEnv
 
     }
 
 
     }
 

+pprSimplEnv :: SimplEnv -> SDoc
+-- Used for debugging; selective
+pprSimplEnv env
+  = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env),
+         ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ]
+

 type SimplIdSubst = IdEnv SimplSR      -- IdId |--> OutExpr
 type SimplIdSubst = IdEnv SimplSR      -- IdId |--> OutExpr

+       -- See Note [Extending the Subst] in CoreSubst

 
 data SimplSR
   = DoneEx OutExpr             -- Completed term
 
 data SimplSR
   = DoneEx OutExpr             -- Completed term

@@ -137,15 +138,16 @@ data SimplSR
   | ContEx TvSubstEnv          -- A suspended substitution
           SimplIdSubst
           InExpr        
   | ContEx TvSubstEnv          -- A suspended substitution
           SimplIdSubst
           InExpr        

+

 instance Outputable SimplSR where
   ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
   ppr (DoneId v) = ptext SLIT("DoneId") <+> ppr v
   ppr (ContEx tv id e) = vcat [ptext SLIT("ContEx") <+> ppr e {-,
                                ppr (filter_env tv), ppr (filter_env id) -}]
 instance Outputable SimplSR where
   ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
   ppr (DoneId v) = ptext SLIT("DoneId") <+> ppr v
   ppr (ContEx tv id e) = vcat [ptext SLIT("ContEx") <+> ppr e {-,
                                ppr (filter_env tv), ppr (filter_env id) -}]

-       where
-         fvs = exprFreeVars e
-         filter_env env = filterVarEnv_Directly keep env
-         keep uniq _ = uniq `elemUFM_Directly` fvs
+       -- where
+       -- fvs = exprFreeVars e
+       -- filter_env env = filterVarEnv_Directly keep env
+       -- keep uniq _ = uniq `elemUFM_Directly` fvs

 \end{code}
 
 
 \end{code}
 
 

@@ -211,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".
 

@@ -293,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}
 
 

@@ -313,11 +311,13 @@ The Floats is a bunch of bindings, classified by a FloatFlag.
 
   NonRec x (y:ys)      FltLifted
   Rec [(x,rhs)]                FltLifted
 
   NonRec x (y:ys)      FltLifted
   Rec [(x,rhs)]                FltLifted

-  NonRec x# (y +# 3)   FltOkSpec
+
+  NonRec x# (y +# 3)   FltOkSpec       -- Unboxed, but ok-for-spec'n
+

   NonRec x# (a /# b)   FltCareful
   NonRec x# (a /# b)   FltCareful

-  NonRec x* (f y)      FltCareful      -- Might fail or diverge
-  NonRec x# (f y)      FltCareful      -- Might fail or diverge
-                         (where f :: Int -> Int#)
+  NonRec x* (f y)      FltCareful      -- Strict binding; might fail or diverge
+  NonRec x# (f y)      FltCareful      -- Unboxed binding: might fail or diverge
+                                       --        (where f :: Int -> Int#)

 
 \begin{code}
 data Floats = Floats (OrdList OutBind) FloatFlag
 
 \begin{code}
 data Floats = Floats (OrdList OutBind) FloatFlag

@@ -356,18 +356,19 @@ andFF FltLifted  flt          = flt
 classifyFF :: CoreBind -> FloatFlag
 classifyFF (Rec _) = FltLifted
 classifyFF (NonRec bndr rhs) 
 classifyFF :: CoreBind -> FloatFlag
 classifyFF (Rec _) = FltLifted
 classifyFF (NonRec bndr rhs) 

-  | not (isStrictBndr bndr)  = FltLifted
+  | not (isStrictId bndr)    = FltLifted

   | exprOkForSpeculation rhs = FltOkSpec
   | otherwise               = FltCareful
 
   | exprOkForSpeculation rhs = FltOkSpec
   | otherwise               = FltCareful
 

-canFloat :: TopLevelFlag -> RecFlag -> Bool -> SimplEnv -> Bool
-canFloat lvl rec str (SimplEnv {seFloats = Floats _ ff}) 
-  = canFloatFlt lvl rec str ff
-
-canFloatFlt :: TopLevelFlag -> RecFlag -> Bool -> FloatFlag -> Bool
-canFloatFlt lvl rec str FltLifted  = True
-canFloatFlt lvl rec str FltOkSpec  = isNotTopLevel lvl && isNonRec rec
-canFloatFlt lvl rec str FltCareful = str && isNotTopLevel lvl && isNonRec rec
+doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
+doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) 
+  =  not (isNilOL fs) && want_to_float && can_float
+  where
+     want_to_float = isTopLevel lvl || exprIsCheap rhs
+     can_float = case ff of
+                  FltLifted  -> True
+                  FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
+                  FltCareful -> isNotTopLevel lvl && isNonRec rec && str

 \end{code}
 
 
 \end{code}
 
 

@@ -388,6 +389,16 @@ addNonRec env id rhs
   = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
          seInScope = extendInScopeSet (seInScope env) id }
 
   = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
          seInScope = extendInScopeSet (seInScope env) id }
 

+extendFloats :: SimplEnv -> [OutBind] -> SimplEnv
+-- Add these bindings to the floats, and extend the in-scope env too
+extendFloats env binds
+  = env { seFloats  = seFloats env `addFlts` new_floats,
+         seInScope = extendInScopeSetList (seInScope env) bndrs }
+  where
+    bndrs = bindersOfBinds binds
+    new_floats = Floats (toOL binds) 
+                       (foldr (andFF . classifyFF) FltLifted binds)
+

 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
 -- Add the floats for env2 to env1; 
 -- *plus* the in-scope set for env2, which is bigger 
 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
 -- Add the floats for env2 to env1; 
 -- *plus* the in-scope set for env2, which is bigger 

@@ -531,6 +542,8 @@ substIdBndr :: SimplEnv -> Id       -- Substitition and Id to transform
 --     * The substitution extended with a DoneId if unique changed
 --       In this case, the var in the DoneId is the same as the
 --       var returned
 --     * The substitution extended with a DoneId if unique changed
 --       In this case, the var in the DoneId is the same as the
 --       var returned

+--
+-- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs

 
 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
            old_id
 
 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
            old_id

@@ -549,6 +562,7 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
 
        -- Extend the substitution if the unique has changed
        -- See the notes with substTyVarBndr for the delSubstEnv
 
        -- Extend the substitution if the unique has changed
        -- See the notes with substTyVarBndr for the delSubstEnv

+       -- Also see Note [Extending the Subst] in CoreSubst

     new_subst | new_id /= old_id
              = extendVarEnv id_subst old_id (DoneId new_id)
              | otherwise 
     new_subst | new_id /= old_id
              = extendVarEnv id_subst old_id (DoneId new_id)
              | otherwise 

@@ -593,23 +607,27 @@ 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 completely zapped IdInfo
---     [addLetIdInfo, below, will restore its IdInfo]
--- 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

-    new_id = setIdInfo id2 vanillaIdInfo
+    new_id = zapFragileIdInfo id2

 
        -- Extend the substitution if the unique has changed,
        -- or there's some useful occurrence information
 
        -- Extend the substitution if the unique has changed,
        -- or there's some useful occurrence information

@@ -620,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

@@ -678,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