Make the loop-breaking algorithm a bit more liberal, where RULES are involved

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

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 599c509..8be8dd6 100644 (file)
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -46,7 +46,7 @@
 -- 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
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module SetLevels (
@@ -72,7 +72,7 @@ import Id             ( Id, idType, mkSysLocal, isOneShotLambda,
                          idSpecialisation, idWorkerInfo, setIdInfo
                        )
 import IdInfo          ( workerExists, vanillaIdInfo, isEmptySpecInfo )
-import Var             ( Var )
+import Var
 import VarSet
 import VarEnv
 import Name            ( getOccName )
@@ -126,8 +126,8 @@ allocation becomes static instead of dynamic.  We always start with
 context @Level 0 0@.  
 
 
-InlineCtxt
-~~~~~~~~~~
+Note [FloatOut inside INLINE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 @InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
 to say "don't float anything out of here".  That's exactly what we
 want for the body of an INLINE, where we don't want to float anything
@@ -669,8 +669,8 @@ type LevelEnv = (FloatOutSwitches,
        -- We also use these envs when making a variable polymorphic
        -- because we want to float it out past a big lambda.
        --
-       -- The SubstEnv and IdEnv always implement the same mapping, but the
-       -- SubstEnv maps to CoreExpr and the IdEnv to LevelledExpr
+       -- The Subst and IdEnv always implement the same mapping, but the
+       -- Subst maps to CoreExpr and the IdEnv to LevelledExpr
        -- Since the range is always a variable or type application,
        -- there is never any difference between the two, but sadly
        -- the types differ.  The SubstEnv is used when substituting in
@@ -772,44 +772,33 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
        -- Find the variables in fvs, free vars of the target expresion,
        -- whose level is greater than the destination level
        -- These are the ones we are going to abstract out
-abstractVars dest_lvl env fvs
-  = uniq (sortLe le [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
+abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
+  = map zap $ uniq $ sortLe le 
+       [var | fv <- varSetElems fvs
+            , var <- absVarsOf id_env fv
+            , abstract_me var ]
+       -- NB: it's important to call abstract_me only on the OutIds the
+       -- come from absVarsOf (not on fv, which is an InId)
   where
-       -- Sort the variables so we don't get 
-       -- mixed-up tyvars and Ids; it's just messy
-    v1 `le` v2 = case (isId v1, isId v2) of
-                  (True, False) -> False
-                  (False, True) -> True
+       -- Sort the variables so the true type variables come first;
+       -- the tyvars scope over Ids and coercion vars
+    v1 `le` v2 = case (is_tv v1, is_tv v2) of
+                  (True, False) -> True
+                  (False, True) -> False
                   other         -> v1 <= v2    -- Same family
 
+    is_tv v = isTyVar v && not (isCoVar v)
+
     uniq :: [Var] -> [Var]
        -- Remove adjacent duplicates; the sort will have brought them together
     uniq (v1:v2:vs) | v1 == v2  = uniq (v2:vs)
                    | otherwise = v1 : uniq (v2:vs)
     uniq vs = vs
 
-absVarsOf :: Level -> LevelEnv -> Var -> [Var]
-       -- If f is free in the expression, and f maps to poly_f a b c in the
-       -- current substitution, then we must report a b c as candidate type
-       -- variables
-absVarsOf dest_lvl (_, lvl_env, _, id_env) v 
-  | isId v
-  = [zap av2 | av1 <- lookup_avs v, av2 <- add_tyvars av1, abstract_me av2]
-
-  | otherwise
-  = if abstract_me v then [v] else []
-
-  where
     abstract_me v = case lookupVarEnv lvl_env v of
                        Just lvl -> dest_lvl `ltLvl` lvl
                        Nothing  -> False
 
-    lookup_avs v = case lookupVarEnv id_env v of
-                       Just (abs_vars, _) -> abs_vars
-                       Nothing            -> [v]
-
-    add_tyvars v = v : varSetElems (varTypeTyVars v)
-
        -- We are going to lambda-abstract, so nuke any IdInfo,
        -- and add the tyvars of the Id (if necessary)
     zap v | isId v = WARN( workerExists (idWorkerInfo v) ||
@@ -817,6 +806,27 @@ absVarsOf dest_lvl (_, lvl_env, _, id_env) v
                           text "absVarsOf: discarding info on" <+> ppr v )
                     setIdInfo v vanillaIdInfo
          | otherwise = v
+
+absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var]
+       -- If f is free in the expression, and f maps to poly_f a b c in the
+       -- current substitution, then we must report a b c as candidate type
+       -- variables
+       --
+       -- Also, if x::a is an abstracted variable, then so is a; that is,
+       --      we must look in x's type
+       -- And similarly if x is a coercion variable.
+absVarsOf id_env v 
+  | isId v    = [av2 | av1 <- lookup_avs v
+                    , av2 <- add_tyvars av1]
+  | isCoVar v = add_tyvars v
+  | otherwise = [v]
+
+  where
+    lookup_avs v = case lookupVarEnv id_env v of
+                       Just (abs_vars, _) -> abs_vars
+                       Nothing            -> [v]
+
+    add_tyvars v = v : varSetElems (varTypeTyVars v)
 \end{code}
 
 \begin{code}