X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=2599f4abef847c2af0980ed9bf1e3c668a5dfc47;hp=8b0eda2b27f22bf7a342e82441d05c550111f884;hb=8d6bc9bf51829ea04da5f599b84114ef220f0a19;hpb=dcd9c637398c22ebf791e92ce490359ee8cf3e0b

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 8b0eda2..2599f4a 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -34,7 +34,7 @@ module CoreUtils (
 	exprEtaExpandArity, etaExpand, 
 
 	-- Size
-	coreBindsSize,
+	coreBindsSize, exprSize,
 
 	-- Hashing
 	hashExpr,
@@ -1204,6 +1204,7 @@ eta_expand n us expr ty
 	-- This *can* legitmately happen: e.g. 	coerce Int (\x. x)
 	-- Essentially the programmer is playing fast and loose with types
 	-- (Happy does this a lot).  So we simply decline to eta-expand.
+	-- Otherwise we'd end up with an explicit lambda having a non-function type
 	expr
     	}}}
 \end{code}
@@ -1232,23 +1233,51 @@ And in any case it seems more robust to have exprArity be a bit more intelligent
 But note that 	(\x y z -> f x y z)
 should have arity 3, regardless of f's arity.
 
+Note [exprArity invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+exprArity has the following invariant:
+	(exprArity e) = n, then manifestArity (etaExpand e n) = n
+
+That is, if exprArity says "the arity is n" then etaExpand really can get
+"n" manifest lambdas to the top.
+
+Why is this important?  Because 
+  - In TidyPgm we use exprArity to fix the *final arity* of 
+    each top-level Id, and in
+  - In CorePrep we use etaExpand on each rhs, so that the visible lambdas
+    actually match that arity, which in turn means
+    that the StgRhs has the right number of lambdas
+
+An alternative would be to do the eta-expansion in TidyPgm, at least
+for top-level bindings, in which case we would not need the trim_arity
+in exprArity.  That is a less local change, so I'm going to leave it for today!
+
+
 \begin{code}
 exprArity :: CoreExpr -> Arity
 exprArity e = go e
-	    where
-	      go (Var v) 	       	   = idArity v
-	      go (Lam x e) | isId x    	   = go e + 1
-			   | otherwise 	   = go e
-              go (Note _ e)                = go e
-              go (Cast e _)                = go e
-              go (App e (Type _))          = go e
-	      go (App f a) | exprIsCheap a = (go f - 1) `max` 0
-		-- NB: exprIsCheap a!  
-		--	f (fac x) does not have arity 2, 
-		-- 	even if f has arity 3!
-		-- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
-		--		 unknown, hence arity 0
-	      go _		       	   = 0
+  where
+    go (Var v) 	       	         = idArity v
+    go (Lam x e) | isId x    	 = go e + 1
+    		 | otherwise 	 = go e
+    go (Note _ e)                = go e
+    go (Cast e co)               = trim_arity (go e) 0 (snd (coercionKind co))
+    go (App e (Type _))          = go e
+    go (App f a) | exprIsCheap a = (go f - 1) `max` 0
+    	-- NB: exprIsCheap a!  
+    	--	f (fac x) does not have arity 2, 
+    	-- 	even if f has arity 3!
+    	-- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
+    	--		 unknown, hence arity 0
+    go _		       	   = 0
+
+	-- Note [exprArity invariant]
+    trim_arity n a ty
+	| n==a					      = a
+	| Just (_, ty') <- splitForAllTy_maybe ty     = trim_arity n a     ty'
+	| Just (_, ty') <- splitFunTy_maybe ty        = trim_arity n (a+1) ty'
+	| Just (ty',_)  <- splitNewTypeRepCo_maybe ty = trim_arity n a     ty'
+	| otherwise				      = a
 \end{code}
 
 %************************************************************************
@@ -1271,6 +1300,9 @@ cheapEqExpr (Type t1)  (Type t2)  = t1 `coreEqType` t2
 cheapEqExpr (App f1 a1) (App f2 a2)
   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 
+cheapEqExpr (Cast e1 t1) (Cast e2 t2)
+  = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2
+
 cheapEqExpr _ _ = False
 
 exprIsBig :: Expr b -> Bool
@@ -1466,8 +1498,9 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool
 -- no thunks involved at all.
 --
 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
--- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
--- update flag on it.
+-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
+-- update flag on it and (iii) in DsExpr to decide how to expand
+-- list literals
 --
 -- The basic idea is that rhsIsStatic returns True only if the RHS is
 --	(a) a value lambda
@@ -1517,11 +1550,8 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool
 --	   dynamic
 -- 
 --    c) don't look through unfolding of f in (f x).
---
--- When opt_RuntimeTypes is on, we keep type lambdas and treat
--- them as making the RHS re-entrant (non-updatable).
 
-rhsIsStatic this_pkg rhs = is_static False rhs
+rhsIsStatic _this_pkg rhs = is_static False rhs
   where
   is_static :: Bool	-- True <=> in a constructor argument; must be atomic
   	  -> CoreExpr -> Bool
@@ -1549,7 +1579,7 @@ rhsIsStatic this_pkg rhs = is_static False rhs
    where
     go (Var f) n_val_args
 #if mingw32_TARGET_OS
-        | not (isDllName this_pkg (idName f))
+        | not (isDllName _this_pkg (idName f))
 #endif
 	=  saturated_data_con f n_val_args
 	|| (in_arg && n_val_args == 0)