X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=5357a5353958c0b094ca3928e11985082ac2849e;hp=7eb3529d4e191930eaa03d86977c506d151d0fce;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=10f18550c3684368b9d8e5b7adcccc14994cf170

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 7eb3529..5357a53 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -20,22 +20,20 @@ import CoreSyn
 import CoreSubst
 import CoreUtils
 import CoreUnfold	( couldBeSmallEnoughToInline )
-import CoreLint		( showPass, endPass )
 import CoreFVs 		( exprsFreeVars )
 import WwLib		( mkWorkerArgs )
 import DataCon		( dataConRepArity, dataConUnivTyVars )
 import Coercion	
 import Rules
 import Type		hiding( substTy )
-import Id		( Id, idName, idType, isDataConWorkId_maybe, idArity,
-			  mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
+import Id
+import MkId		( mkImpossibleExpr )
 import Var
 import VarEnv
 import VarSet
 import Name
-import OccName		( mkSpecOcc )
-import ErrUtils		( dumpIfSet_dyn )
-import DynFlags		( DynFlags(..), DynFlag(..) )
+import DynFlags		( DynFlags(..) )
+import StaticFlags	( opt_PprStyle_Debug )
 import StaticFlags	( opt_SpecInlineJoinPoints )
 import BasicTypes	( Activation(..) )
 import Maybes		( orElse, catMaybes, isJust, isNothing )
@@ -367,6 +365,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
 -----------------------------------------------------
@@ -451,19 +462,8 @@ unbox the strict fields, becuase T is polymorphic!)
 %************************************************************************
 
 \begin{code}
-specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-specConstrProgram dflags us binds
-  = do
-	showPass dflags "SpecConstr"
-
-	let (binds', _) = initUs us (go (initScEnv dflags) binds)
-
-	endPass dflags "SpecConstr" Opt_D_dump_spec binds'
-
-	dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-		      (pprRulesForUser (rulesOfBinds binds'))
-
-	return binds'
+specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]
+specConstrProgram dflags us binds = fst $ initUs us (go (initScEnv dflags) binds)
   where
     go _   []	        = return []
     go env (bind:binds) = do (env', bind') <- scTopBind env bind
@@ -590,17 +590,28 @@ extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
 extendValEnv env _  Nothing   = env
 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
 
-extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
+extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
 -- When we encounter
 --	case scrut of b
 --	    C x y -> ...
--- we want to bind b, and perhaps scrut too, to (C x y)
--- NB: Extends only the sc_vals part of the envt
-extendCaseBndrs env scrut case_bndr con alt_bndrs
-  = case scrut of
-	Var v  -> extendValEnv env1 v cval
-	_other -> env1
+-- we want to bind b, to (C x y)
+-- NB1: Extends only the sc_vals part of the envt
+-- NB2: Kill the dead-ness info on the pattern binders x,y, since
+--      they are potentially made alive by the [b -> C x y] binding
+extendCaseBndrs env case_bndr con alt_bndrs
+  | isDeadBinder case_bndr
+  = (env, alt_bndrs)
+  | otherwise
+  = (env1, map zap alt_bndrs)
+	-- NB: We used to bind v too, if scrut = (Var v); but
+        --     the simplifer has already done this so it seems
+        --     redundant to do so here
+ 	-- case scrut of
+  	--	Var v  -> extendValEnv env1 v cval
+	--	_other -> env1
  where
+   zap v | isTyVar v = v		-- See NB2 above
+         | otherwise = zapIdOccInfo v
    env1 = extendValEnv env case_bndr cval
    cval = case con of
 		DEFAULT    -> Nothing
@@ -767,7 +778,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
@@ -787,15 +799,15 @@ scExpr' env (Case scrut b ty alts)
 	  ; return (alt_usg `combineUsage` scrut_usg',
 	  	    Case scrut' b' (scSubstTy env ty) alts') }
 
-    sc_alt env scrut' b' (con,bs,rhs)
-      = do { let (env1, bs') = extendBndrsWith RecArg env bs
-		 env2        = extendCaseBndrs env1 scrut' b' con bs'
+    sc_alt env _scrut' b' (con,bs,rhs)
+      = do { let (env1, bs1)  = extendBndrsWith RecArg env bs
+		 (env2, bs2) = extendCaseBndrs env1 b' con bs1
 	   ; (usg,rhs') <- scExpr env2 rhs
-	   ; let (usg', arg_occs) = lookupOccs usg bs'
+	   ; let (usg', arg_occs) = lookupOccs usg bs2
 		 scrut_occ = case con of
 				DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
 				_      	   -> ScrutOcc emptyUFM
-	   ; return (usg', scrut_occ, (con,bs',rhs')) }
+	   ; return (usg', scrut_occ, (con, bs2, rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
   | isTyVar bndr	-- Type-lets may be created by doBeta
@@ -1008,8 +1020,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,
@@ -1021,10 +1034,14 @@ specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
 	; let spec_count' = length pats + spec_count
 	; case sc_count env of
 	    Just max | spec_count' > max
-		-> pprTrace "SpecConstr: too many specialisations for one function (see -fspec-constr-count):" 
-			 (vcat [ptext (sLit "Function:") <+> ppr fn,
-				ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
-			 return (nullUsage, spec_info)
+		-> WARN( True, msg ) return (nullUsage, spec_info)
+		where
+		   msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
+		       	            , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
+			      , ptext (sLit "Use -fspec-constr-count=n to set the bound")
+			      , extra ]
+	           extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
+		   	 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
 
 	    _normal_case -> do {