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

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index d697fb3..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
@@ -1438,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 -----------