Add notSCCNote, and use it

The point here is that SCCs get in the way of eta
expansion and we must treat them uniformly.

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index f0f6c75..d0092b2 100644 (file)
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -95,11 +95,11 @@ in exprArity.  That is a less local change, so I'm going to leave it for today!
 \begin{code}
 manifestArity :: CoreExpr -> Arity
 -- ^ manifestArity sees how many leading value lambdas there are
 \begin{code}
 manifestArity :: CoreExpr -> Arity
 -- ^ manifestArity sees how many leading value lambdas there are

-manifestArity (Lam v e) | isId v    = 1 + manifestArity e
-                       | otherwise = manifestArity e
-manifestArity (Note _ e)           = manifestArity e
-manifestArity (Cast e _)            = manifestArity e
-manifestArity _                     = 0
+manifestArity (Lam v e) | isId v       = 1 + manifestArity e
+                       | otherwise     = manifestArity e
+manifestArity (Note n e) | notSccNote n        = manifestArity e
+manifestArity (Cast e _)               = manifestArity e
+manifestArity _                        = 0

 
 exprArity :: CoreExpr -> Arity
 -- ^ An approximate, fast, version of 'exprEtaExpandArity'
 
 exprArity :: CoreExpr -> Arity
 -- ^ An approximate, fast, version of 'exprEtaExpandArity'

@@ -108,7 +108,7 @@ exprArity e = go e
     go (Var v)                            = idArity v
     go (Lam x e) | isId x         = go e + 1
                 | otherwise       = go e
     go (Var v)                            = idArity v
     go (Lam x e) | isId x         = go e + 1
                 | otherwise       = go e

-    go (Note _ e)                  = go e
+    go (Note n e) | notSccNote n   = go e

     go (Cast e co)                 = go e `min` length (typeArity (snd (coercionKind co)))
                                                -- Note [exprArity invariant]
     go (App e (Type _))            = go e
     go (Cast e co)                 = go e `min` length (typeArity (snd (coercionKind co)))
                                                -- Note [exprArity invariant]
     go (App e (Type _))            = go e

@@ -554,7 +554,8 @@ arityType dicts_cheap (Let b e)
        -- See Note [Dictionary-like types] in TcType.lhs for why we use
        -- isDictLikeTy here rather than isDictTy
 
        -- See Note [Dictionary-like types] in TcType.lhs for why we use
        -- isDictLikeTy here rather than isDictTy
 

-arityType dicts_cheap (Note _ e) = arityType dicts_cheap e
+arityType dicts_cheap (Note n e) 
+  | notSccNote n                 = arityType dicts_cheap e

 arityType dicts_cheap (Cast e _) = arityType dicts_cheap e
 arityType _           _          = vanillaArityType
 \end{code}
 arityType dicts_cheap (Cast e _) = arityType dicts_cheap e
 arityType _           _          = vanillaArityType
 \end{code}

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index ef5e75e..4db4c53 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -688,8 +688,7 @@ cpe_ExprIsTrivial (Var _)                  = True
 cpe_ExprIsTrivial (Type _)                 = True
 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Type _)                 = True
 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e

-cpe_ExprIsTrivial (Note (SCC _) _)         = False
-cpe_ExprIsTrivial (Note _ e)               = cpe_ExprIsTrivial e
+cpe_ExprIsTrivial (Note n e)               = notSccNote n  && cpe_ExprIsTrivial e

 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 05cc575..fb7865b 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -34,6 +34,7 @@ module CoreSyn (
        collectArgs, coreExprCc, flattenBinds, 
 
        isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
        collectArgs, coreExprCc, flattenBinds, 
 
        isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,

+       notSccNote,

 
        -- * Unfolding data types
        Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
 
        -- * Unfolding data types
        Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),

@@ -1046,6 +1047,10 @@ valBndrCount = count isId
 -- | The number of argument expressions that are values rather than types at their top level
 valArgCount :: [Arg b] -> Int
 valArgCount = count isValArg
 -- | The number of argument expressions that are values rather than types at their top level
 valArgCount :: [Arg b] -> Int
 valArgCount = count isValArg

+
+notSccNote :: Note -> Bool
+notSccNote (SCC {}) = False
+notSccNote _        = True

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 66d34b1..4139a2a 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1396,11 +1396,9 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs
   is_static :: Bool    -- True <=> in a constructor argument; must be atomic
          -> CoreExpr -> Bool
   
   is_static :: Bool    -- True <=> in a constructor argument; must be atomic
          -> CoreExpr -> Bool
   

-  is_static False (Lam b e) = isRuntimeVar b || is_static False e
-  
-  is_static _      (Note (SCC _) _) = False
-  is_static in_arg (Note _ e)       = is_static in_arg e
-  is_static in_arg (Cast e _)       = is_static in_arg e
+  is_static False (Lam b e)   = isRuntimeVar b || is_static False e
+  is_static in_arg (Note n e) = notSccNote n && is_static in_arg e
+  is_static in_arg (Cast e _) = is_static in_arg e

   
   is_static _      (Lit lit)
     = case lit of
   
   is_static _      (Lit lit)
     = case lit of

@@ -1441,11 +1439,9 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs
         --   x = D# (1.0## /## 2.0##)
         -- can't float because /## can fail.
 
         --   x = D# (1.0## /## 2.0##)
         -- can't float because /## can fail.
 

-    go (Note (SCC _) _) _          = False
-    go (Note _ f)       n_val_args = go f n_val_args
-    go (Cast e _)       n_val_args = go e n_val_args
-
-    go _                _          = False
+    go (Note n f) n_val_args = notSccNote n && go f n_val_args
+    go (Cast e _) n_val_args = go e n_val_args
+    go _          _          = False

 
     saturated_data_con f n_val_args
        = case isDataConWorkId_maybe f of
 
     saturated_data_con f n_val_args
        = case isDataConWorkId_maybe f of