X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=0f6cf733a4697e104d4a620c11f814094d92be65;hb=c3fe0f3699fa59261a340686bba648c981b3511d;hp=84506d85cdeade446579af1b0ccd5f6b6cced86a;hpb=2fb8e343ac2b9dcb5c2476648cf3e30ec6637afd;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 84506d8..0f6cf73 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -308,17 +308,17 @@ interestingCallContext :: SimplCont -> CallCtxt
 interestingCallContext cont
   = interesting cont
   where
-    interestingCtxt = ArgCtxt False 2	-- Give *some* incentive!
-
     interesting (Select _ bndr _ _ _)
-	| isDeadBinder bndr       = CaseCtxt
-	| otherwise	          = interestingCtxt
+	| isDeadBinder bndr = CaseCtxt
+	| otherwise	    = ArgCtxt False 2	-- If the binder is used, this
+						-- is like a strict let
 		
-    interesting (ApplyTo {})      = interestingCtxt
-				-- Can happen if we have (coerce t (f x)) y
-				-- Perhaps interestingCtxt is a bit over-keen, but I've
-				-- seen (coerce f) x, where f has an INLINE prag,
-				-- So we have to give some motivation for inlining it
+    interesting (ApplyTo _ arg _ cont)
+	| isTypeArg arg = interesting cont
+	| otherwise     = ValAppCtxt 	-- Can happen if we have (f Int |> co) y
+					-- If f has an INLINE prag we need to give it some
+					-- motivation to inline. See Note [Cast then apply]
+					-- in CoreUnfold
 
     interesting (StrictArg _ cci _ _)	= cci
     interesting (StrictBind {})	  	= BoringCtxt
@@ -758,11 +758,11 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 --	in \y. ....case f of {...} ....
 -- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
 -- But
--- * We can't preInlineUnconditionally because that woud invalidate
---   the occ info for b.  
--- * We can't postInlineUnconditionally because the RHS is big, and
---   that risks exponential behaviour
--- * We can't call-site inline, because the rhs is big
+--  - We can't preInlineUnconditionally because that woud invalidate
+--    the occ info for b.
+--  - We can't postInlineUnconditionally because the RHS is big, and
+--    that risks exponential behaviour
+--  - We can't call-site inline, because the rhs is big
 -- Alas!
 
   where
@@ -797,7 +797,7 @@ activeInline env id
 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all
 activeRule dflags env
-  | not (dopt Opt_RewriteRules dflags)
+  | not (dopt Opt_EnableRewriteRules dflags)
   = Nothing	-- Rewriting is off
   | otherwise
   = case getMode env of
@@ -934,10 +934,16 @@ There are some particularly delicate points here:
 
   So it's important to to the right thing.
 
-* We need to be careful if we just look at f's arity. Currently (Dec07),
-  f's arity is visible in its own RHS (see Note [Arity robustness] in 
-  SimplEnv) so we must *not* trust the arity when checking that 'f' is
-  a value.  Instead, look at the unfolding. 
+* Note [Arity care]: we need to be careful if we just look at f's
+  arity. Currently (Dec07), f's arity is visible in its own RHS (see
+  Note [Arity robustness] in SimplEnv) so we must *not* trust the
+  arity when checking that 'f' is a value.  Otherwise we will
+  eta-reduce
+      f = \x. f x
+  to
+      f = f
+  Which might change a terminiating program (think (f `seq` e)) to a 
+  non-terminating one.  So we check for being a loop breaker first.
 
   However for GlobalIds we can look at the arity; and for primops we
   must, since they have no unfolding.  
@@ -950,6 +956,11 @@ There are some particularly delicate points here:
   with both type and dictionary lambdas; hence the slightly 
   ad-hoc isDictId
 
+* Never *reduce* arity. For example
+      f = \xy. g x y
+  Then if h has arity 1 we don't want to eta-reduce because then
+  f's arity would decrease, and that is bad
+
 These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
 Alas.
 
@@ -958,6 +969,8 @@ tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
 tryEtaReduce bndrs body 
   = go (reverse bndrs) body
   where
+    incoming_arity = count isId bndrs
+
     go (b : bs) (App fun arg) | ok_arg b arg = go bs fun	-- Loop round
     go []       fun           | ok_fun fun   = Just fun		-- Success!
     go _        _			     = Nothing		-- Failure!
@@ -971,11 +984,11 @@ tryEtaReduce bndrs body
 	&& (ok_fun_id fun_id || all ok_lam bndrs)
     ok_fun _fun = False
 
-    ok_fun_id fun
-	| isLocalId fun       = isEvaldUnfolding (idUnfolding fun)
-	| isDataConWorkId fun = True
-	| isGlobalId fun      = idArity fun > 0
-        | otherwise           = panic "tryEtaReduce/ok_fun_id"
+    ok_fun_id fun = fun_arity fun >= incoming_arity
+
+    fun_arity fun 	      -- See Note [Arity care]
+       | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
+       | otherwise = idArity fun   	      
 
     ok_lam v = isTyVar v || isDictId v
 
@@ -1425,9 +1438,9 @@ prepareDefault _ _ case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rh
 
 	_ -> return [(DEFAULT, [], deflt_rhs)]
 
-  | debugIsOn, isAlgTyCon tycon, [] <- tyConDataCons tycon
+  | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon)
+	-- This can legitimately happen for type families, so don't report that
   = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
-	-- This can legitimately happen for type families
         $ return [(DEFAULT, [], deflt_rhs)]
 
 --------- Catch-all cases -----------