Tidy up the treatment of SPECIALISE pragmas

Remove the now-redundant "const-dicts" field in SpecPrag

In dsBinds, abstract over constant dictionaries in the RULE.
This avoids the creation of a redundant, duplicate, rule later
in the Specialise pass, which was happening before.

There should be no effect on performance either way, just less
duplicated code, and the compiler gets a little simpler.

4 files changed, 33 insertions, 28 deletions

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 5540dd806b..ca357c5b2d 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -34,6 +34,7 @@ import DsUtils
 import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
 import CoreUtils
+import CoreFVs
 
 import TcHsSyn		( mkArbitraryType )	-- Mis-placed?
 import TcType
@@ -42,6 +43,7 @@ import CostCentre
 import Module
 import Id
 import Var	( TyVar )
+import VarSet
 import Rules
 import VarEnv
 import Type
@@ -242,8 +244,9 @@ dsSpec :: [TyVar] -> [DictId] -> [TyVar]
 --		inlined and specialised
 --
 -- Given SpecPrag (/\as.\ds. f es) t, we have
--- the defn		f_spec as ds = f es 
--- and the RULE		f es = f_spec as ds
+-- the defn		f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
+--				       in f es 
+-- and the RULE		forall as, ds. f es = f_spec as ds
 --
 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
 -- (a bit silly, because then the 
@@ -251,8 +254,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (L _ (InlinePrag {}))
   = return Nothing
 
 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
-       (L loc (SpecPrag spec_expr spec_ty _const_dicts inl))
-	-- See Note [Const rule dicts]
+       (L loc (SpecPrag spec_expr spec_ty inl))
   = putSrcSpanDs loc $ 
     do	{ let poly_name = idName poly_id
 	; spec_name <- newLocalName poly_name
@@ -283,9 +285,12 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 		  spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 		  poly_f_body = mkLams (tvs ++ dicts) f_body
 			   	
+		  extra_dict_bndrs = filter isDictId (varSetElems (exprFreeVars ds_spec_expr))
+			-- Note [Const rule dicts]
+
 		  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 				AlwaysActive poly_name
-			        bndrs args
+			        (extra_dict_bndrs ++ bndrs) args
 				(mkVarApps (Var spec_id) bndrs)
 	; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
 	} } }
@@ -329,17 +334,23 @@ a mistake.  That's what the isDeadBinder call detects.
 
 Note [Const rule dicts]
 ~~~~~~~~~~~~~~~~~~~~~~~
-A SpecPrag has a field for "constant dicts" in the RULE, but I think
-it's pretty useless.  See the place where it's generated in TcBinds.
-TcSimplify will discharge a constraint by binding it to, say, 
-GHC.Base.$f2 :: Eq Int, withour putting anything in the LIE, so this 
-dict won't show up in the const-dicts field.  It probably doesn't matter,
-because the rule will end up being something like
-	f Int GHC.Base.$f2 = ...
-rather than
-	forall d. f Int d = ...
-The latter is more general, but in practice I think it won't make any
-difference.
+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
+which is presumably in scope at the function definition site, we can quantify 
+over it too.  *Any* dict with that type will do.
+
+So for example when you have
+	f :: Eq a => a -> a
+	f = <rhs>
+	{-# SPECIALISE f :: Int -> Int #-}
+
+Then we get the SpecPrag
+	SpecPrag (f Int dInt) Int
+
+And from that we want the rule
+	
+	RULE forall dInt. f Int dInt = f_spec
+	f_spec = let f = <rhs> in f Int dInt
+
 
 
 %************************************************************************
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 90442dfc99..211a3c1560 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -454,9 +454,6 @@ data Prag
   | SpecPrag   
 	(HsExpr Id)	-- An expression, of the given specialised type, which
 	PostTcType 	-- specialises the polymorphic function
-	[Id]		-- Dicts mentioned free in the expression
-			--   Apr07: I think this is pretty useless
-			--	    see Note [Const rule dicts] in DsBinds
 	InlineSpec 	-- Inlining spec for the specialised function
 
 isInlinePrag (InlinePrag _) = True
@@ -573,7 +570,7 @@ pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
 
 pprPrag :: Outputable id => id -> LPrag -> SDoc
-pprPrag var (L _ (InlinePrag inl))         = ppr inl <+> ppr var
-pprPrag var (L _ (SpecPrag expr ty _ inl)) = pprSpec var ty inl
+pprPrag var (L _ (InlinePrag inl))       = ppr inl <+> ppr var
+pprPrag var (L _ (SpecPrag expr ty inl)) = pprSpec var ty inl
 \end{code}
 
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index db1a37ab0d..9e60bbd47f 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -426,10 +426,8 @@ tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
 tcSpecPrag poly_id hs_ty inl
   = do	{ let name = idName poly_id
 	; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
-	; (co_fn, lie) <- getLIE (tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty)
-	; extendLIEs lie
-	; let const_dicts = map instToId lie
-	; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
+	; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
+	; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) }
 	-- Most of the work of specialisation is done by 
 	-- the desugarer, guided by the SpecPrag
   
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 205197a1a5..df6c50a6b2 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -313,11 +313,10 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
 	  mapM zonk_prag prags			`thenM` \ new_prags -> 
 	  returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
     zonk_prag prag@(L _ (InlinePrag {}))  = return prag
-    zonk_prag (L loc (SpecPrag expr ty ds inl))
+    zonk_prag (L loc (SpecPrag expr ty inl))
 	= do { expr' <- zonkExpr env expr 
 	     ; ty'   <- zonkTcTypeToType env ty
-	     ; let ds' = zonkIdOccs env ds
-	     ; return (L loc (SpecPrag expr' ty' ds' inl)) }
+	     ; return (L loc (SpecPrag expr' ty' inl)) }
 \end{code}
 
 %************************************************************************