From 28ca359b42fb5d62207f72270d20e386968eb1a9 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Mon, 7 Feb 2011 10:25:37 +0000
Subject: [PATCH] Fix Trac #4945: another SpecConstr infelicity

Well, more a plain bug really, which led to SpecConstr
missing some obvious opportunities for specialisation.

Thanks to Max Bolingbroke for spotting this.
---
 compiler/specialise/SpecConstr.lhs |   56 ++++++++++++++++++++++--------------
 1 file changed, 35 insertions(+), 21 deletions(-)

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 8235196..4fa4204 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -386,6 +386,18 @@ 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.
 
+In a case like the above we end up never calling the original un-specialised
+function.  (Although we still leave its code around just in case.)
+
+However, if we find any boring calls in the body, including *unsaturated*
+ones, such as
+      letrec foo x y = ....foo...
+      in map foo xs
+then we will end up calling the un-specialised function, so then we *should*
+use the calls in the un-specialised RHS as seeds.  We call these "boring 
+call patterns, and callsToPats reports if it finds any of these.
+
+
 Note [Do not specialise diverging functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Specialising a function that just diverges is a waste of code.
@@ -981,7 +993,7 @@ scExpr env e = scExpr' env e
 
 
 scExpr' env (Var v)     = case scSubstId env v of
-		            Var v' -> return (varUsage env v' UnkOcc, Var v')
+		            Var v' -> return (mkVarUsage env v' [], Var v')
 		            e'     -> scExpr (zapScSubst env) e'
 
 scExpr' env (Type t)    = return (nullUsage, Type (scSubstTy env t))
@@ -1118,7 +1130,7 @@ scApp env (Var fn, args)	-- Function is a variable
 	    fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
 			-- Do beta-reduction and try again
 
-	    Var fn' -> return (arg_usg `combineUsage` mk_fn_usg fn' args',
+	    Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',
                                mkApps (Var fn') args')
 
 	    other_fn' -> return (arg_usg, mkApps other_fn' args') }
@@ -1131,14 +1143,6 @@ scApp env (Var fn, args)	-- Function is a variable
     doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
     doBeta fn	           args	        = mkApps fn args
 
-    mk_fn_usg fn' args'
-      = case lookupHowBound env fn' of
-	  Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')]
-	  	                 , scu_occs  = emptyVarEnv }
-	  Just RecArg -> SCU { scu_calls = emptyVarEnv
-	                     , scu_occs  = unitVarEnv fn' evalScrutOcc }
-	  Nothing     -> nullUsage
-
 -- The function is almost always a variable, but not always.  
 -- In particular, if this pass follows float-in,
 -- which it may, we can get 
@@ -1149,6 +1153,20 @@ scApp env (other_fn, args)
 	; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
 
 ----------------------
+mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
+mkVarUsage env fn args
+  = case lookupHowBound env fn of
+	Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)]
+	                   , scu_occs  = emptyVarEnv }
+	Just RecArg -> SCU { scu_calls = emptyVarEnv
+	                   , scu_occs  = unitVarEnv fn arg_occ }
+        Nothing     -> nullUsage
+  where
+    -- I rather think we could use UnkOcc all the time
+    arg_occ | null args = UnkOcc
+            | otherwise = evalScrutOcc
+
+----------------------
 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
 scTopBind env (Rec prs)
   | Just threshold <- sc_size env
@@ -1206,13 +1224,6 @@ specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
     	      -- And now the original binding
   where
     rules = [r | OS _ r _ _ <- specs]
-
-----------------------
-varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
-varUsage env v use 
-  | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv 
-					      , scu_occs = unitVarEnv v use }
-  | otherwise		   	        = nullUsage
 \end{code}
 
 
@@ -1233,10 +1244,13 @@ data SpecInfo = SI [OneSpec]		-- The specialisations we have generated
 
 		   Int			-- Length of specs; used for numbering them
 
-		   (Maybe ScUsage)	-- Nothing => we have generated specialisations
-					--	      from calls in the *original* RHS
-					-- Just cs => we haven't, and this is the usage
-					--	      of the original RHS
+		   (Maybe ScUsage)	-- Just cs  => we have not yet used calls in the
+					--	       from calls in the *original* RHS as
+				 	--	       seeds for new specialisations;
+					--	       if you decide to do so, here is the
+					-- 	       RHS usage (which has not yet been
+					--	       unleashed)
+					-- Nothing => we have
 					-- See Note [Local recursive groups]
 
 	-- One specialisation: Rule plus definition
-- 
1.7.10.4