X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=3a4b38291081acd41bb148564d7b5a74debb31ab;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hp=23127f440ff1fd759056e8cbc03a35e27389a7ed;hpb=9bcd95bad83ee937c178970e8b729732e680fe1e;p=ghc-hetmet.git

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 23127f4..3a4b382 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -27,6 +27,7 @@ import Coercion
 import Rules
 import Type		hiding( substTy )
 import Id
+import MkId		( mkImpossibleExpr )
 import Var
 import VarEnv
 import VarSet
@@ -365,6 +366,19 @@ specialising the loops arising from stream fusion, for example in NDP where
 we were getting literally hundreds of (mostly unused) specialisations of
 a local function.
 
+Note [Do not specialise diverging functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Specialising a function that just diverges is a waste of code.
+Furthermore, it broke GHC (simpl014) thus:
+   {-# STR Sb #-}
+   f = \x. case x of (a,b) -> f x
+If we specialise f we get
+   f = \x. case x of (a,b) -> fspec a b
+But fspec doesn't have decent strictnes info.  As it happened,
+(f x) :: IO t, so the state hack applied and we eta expanded fspec,
+and hence f.  But now f's strictness is less than its arity, which
+breaks an invariant.
+
 -----------------------------------------------------
 		Stuff not yet handled
 -----------------------------------------------------
@@ -765,7 +779,8 @@ scExpr' env (Case scrut b ty alts)
   where
     sc_con_app con args scrut' 	-- Known constructor; simplify
 	= do { let (_, bs, rhs) = findAlt con alts
-		   alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
+	       	   	          `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
+		   alt_env'  = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
 	     ; scExpr alt_env' rhs }
 				
     sc_vanilla scrut_usg scrut'	-- Normal case
@@ -1006,8 +1021,9 @@ specialise
 
 specialise env bind_calls (fn, arg_bndrs, body, arg_occs) 
 			  spec_info@(SI specs spec_count mb_unspec)
-  | notNull arg_bndrs,	-- Only specialise functions
-    Just all_calls <- lookupVarEnv bind_calls fn
+  | not (isBottomingId fn)      -- Note [Do not specialise diverging functions]
+  , notNull arg_bndrs		-- Only specialise functions
+  , Just all_calls <- lookupVarEnv bind_calls fn
   = do	{ (boring_call, pats) <- callsToPats env specs arg_occs all_calls
 --	; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
 --	  				text "calls" <+> ppr all_calls,