Use OPTIONS rather than OPTIONS_GHC for pragmas

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

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 3832f54..649dd1b 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/CodingStyle#Warnings
+-- for details
+
 module SimplEnv (
        InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
        OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
@@ -32,9 +39,9 @@ module SimplEnv (
        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"
@@ -44,14 +51,12 @@ import IdInfo
 import CoreSyn
 import Rules
 import CoreUtils
-import CoreFVs
 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 )
@@ -59,8 +64,9 @@ import Coercion
 import BasicTypes      
 import DynFlags
 import Util
-import UniqFM
 import Outputable
+
+import Data.List
 \end{code}
 
 %************************************************************************
@@ -104,9 +110,6 @@ data SimplEnv
        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
@@ -210,11 +213,11 @@ seIdSubst:
 
 
 \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, 
-              seExtRules = rules, seFloats = emptyFloats,
+              seFloats = emptyFloats,
               seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
        -- The top level "enclosing CC" is "SUBSUMED".
 
@@ -292,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
-
----------------------
-getRules :: SimplEnv -> RuleBase
-getRules = seExtRules
 \end{code}
 
 
@@ -312,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 +# 3)   FltOkSpec
+
+  NonRec x# (y +# 3)   FltOkSpec       -- Unboxed, but ok-for-spec'n
+
   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
@@ -359,14 +360,15 @@ classifyFF (NonRec bndr rhs)
   | 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}
 
 
@@ -387,6 +389,16 @@ addNonRec env id rhs
   = 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 
@@ -629,8 +641,8 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old
              = 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