From: simonpj@microsoft.com <unknown>
Date: Thu, 23 Sep 2010 10:59:49 +0000 (+0000)
Subject: Add notSCCNote, and use it
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=66413c79385a5b30a668e91789b8a334f6977ca9;ds=sidebyside

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
--- 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
-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'
@@ -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 (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
@@ -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
 
-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}
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index ef5e75e..4db4c53 100644
--- 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 (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
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 05cc575..fb7865b 100644
--- 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,
+	notSccNote,
 
 	-- * 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
+
+notSccNote :: Note -> Bool
+notSccNote (SCC {}) = False
+notSccNote _        = True
 \end{code}
 
 
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 66d34b1..4139a2a 100644
--- 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 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
@@ -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.
 
-    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