Make 'SPECIALISE instance' work again

This is a long-standing regression (Trac #7797), which meant that in
particular the Eq [Char] instance does not get specialised.
(The *methods* do, but the dictionary itself doesn't.)  So when you
call a function
     f :: Eq a => blah
on a string type (ie a=[Char]), 7.6 passes a dictionary of un-specialised
methods.

This only matters when calling an overloaded function from a
specialised context, but that does matter in some programs.  I
remember (though I cannot find the details) that Nick Frisby discovered
this to be the source of some pretty solid performanc regresisons.

Anyway it works now. The key change is that a DFunUnfolding now takes
a form that is both simpler than before (the DFunArg type is eliminated)
and more general:

data Unfolding
  = ...
  | DFunUnfolding {     -- The Unfolding of a DFunId
    			-- See Note [DFun unfoldings]
      		  	--     df = /\a1..am. \d1..dn. MkD t1 .. tk
                        --                                 (op1 a1..am d1..dn)
     		      	--     	    	      	       	   (op2 a1..am d1..dn)
        df_bndrs :: [Var],      -- The bound variables [a1..m],[d1..dn]
        df_con   :: DataCon,    -- The dictionary data constructor (never a newtype datacon)
        df_args  :: [CoreExpr]  -- Args of the data con: types, superclasses and methods,
    }                           -- in positional order

That in turn allowed me to re-enable the DFunUnfolding specialisation in
DsBinds.  Lots of details here in TcInstDcls:
	  Note [SPECIALISE instance pragmas]

I also did some refactoring, in particular to pass the InScopeSet to
exprIsConApp_maybe (which in turn means it has to go to a RuleFun).

NB: Interface file format has changed!

21 files changed, 316 insertions, 383 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 112664c1e2..f475ba8195 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -346,14 +346,13 @@ mkDictSelId dflags no_unf name clas
 				-- varToCoreExpr needed for equality superclass selectors
 				--   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
 
-dictSelRule :: Int -> Arity
-            -> DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+dictSelRule :: Int -> Arity -> RuleFun
 -- Tries to persuade the argument to look like a constructor
 -- application, using exprIsConApp_maybe, and then selects
 -- from it
 --       sel_i t1..tk (D t1..tk op1 ... opm) = opi
 --
-dictSelRule val_index n_ty_args _ _ id_unf args
+dictSelRule val_index n_ty_args _ id_unf _ args
   | (dict_arg : _) <- drop n_ty_args args
   , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
   = Just (getNth con_args val_index)
@@ -1082,8 +1081,7 @@ seqId = pcMiscPrelId seqName ty info
                                 , ru_try   = match_seq_of_cast
                                 }
 
-match_seq_of_cast :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr]
-                  -> Maybe CoreExpr
+match_seq_of_cast :: RuleFun
     -- See Note [Built-in RULES for seq]
 match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr]
   = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 2a11723fa9..636c049c42 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -104,8 +104,17 @@ type InterestingVarFun = Var -> Bool
 
 \begin{code}
 type FV = InterestingVarFun
-        -> VarSet               -- In scope
+        -> VarSet               -- Locally bound
         -> VarSet               -- Free vars
+ -- Return the vars that are both (a) interesting 
+ --                           and (b) not locally bound
+ -- See function keep_it
+
+keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
+keep_it fv_cand in_scope var
+  | var `elemVarSet` in_scope = False
+  | fv_cand var               = True
+  | otherwise                 = False
 
 union :: FV -> FV -> FV
 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
@@ -152,13 +161,6 @@ someVars :: VarSet -> FV
 someVars vars fv_cand in_scope
   = filterVarSet (keep_it fv_cand in_scope) vars
 
-keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
-keep_it fv_cand in_scope var
-  | var `elemVarSet` in_scope = False
-  | fv_cand var               = True
-  | otherwise                 = False
-
-
 addBndr :: CoreBndr -> FV -> FV
 addBndr bndr fv fv_cand in_scope
   = someVars (varTypeTyVars bndr) fv_cand in_scope
@@ -434,15 +436,18 @@ idUnfoldingVars :: Id -> VarSet
 -- and we'll get exponential behaviour if we look at both unf and rhs!
 -- But do look at the *real* unfolding, even for loop breakers, else
 -- we might get out-of-scope variables
-idUnfoldingVars id = stableUnfoldingVars isLocalId (realIdUnfolding id) `orElse` emptyVarSet
+idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet
 
-stableUnfoldingVars :: InterestingVarFun -> Unfolding -> Maybe VarSet
-stableUnfoldingVars fv_cand unf
+stableUnfoldingVars :: Unfolding -> Maybe VarSet
+stableUnfoldingVars unf
   = case unf of
       CoreUnfolding { uf_tmpl = rhs, uf_src = src }
-         | isStableSource src -> Just (exprSomeFreeVars fv_cand rhs)
-      DFunUnfolding _ _ args  -> Just (exprsSomeFreeVars fv_cand (dfunArgExprs args))
-      _other                  -> Nothing
+         | isStableSource src          
+         -> Just (exprFreeVars rhs)
+      DFunUnfolding { df_bndrs = bndrs, df_args = args } 
+         -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs))
+            -- DFuns are top level, so no fvs from types of bndrs
+      _other -> Nothing
 \end{code}
 
 
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 95cb7f8fbb..bc9c767d29 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -59,7 +59,6 @@ import Type     hiding ( substTy, extendTvSubst, extendTvSubstList
                        , isInScope, substTyVarBndr, cloneTyVarBndr )
 import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
 
-import TcType      ( tcSplitDFunTy )
 import TyCon       ( tyConArity )
 import DataCon
 import PrelNames   ( eqBoxDataConKey )
@@ -78,7 +77,6 @@ import Maybes
 import ErrUtils
 import DynFlags
 import BasicTypes ( isAlwaysActive )
-import ListSetOps
 import Util
 import Pair
 import Outputable
@@ -656,10 +654,11 @@ substUnfoldingSC subst unf 	 -- Short-cut version
   | isEmptySubst subst = unf
   | otherwise          = substUnfolding subst unf
 
-substUnfolding subst (DFunUnfolding ar con args)
-  = DFunUnfolding ar con (map subst_arg args)
+substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+  = df { df_bndrs = bndrs', df_args = args' }
   where
-    subst_arg = fmap (substExpr (text "dfun-unf") subst)
+    (subst',bndrs') = substBndrs subst bndrs
+    args'           = map (substExpr (text "subst-unf:dfun") subst') args
 
 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
 	-- Retain an InlineRule!
@@ -923,6 +922,8 @@ simple_opt_expr :: Subst -> InExpr -> OutExpr
 simple_opt_expr subst expr
   = go expr
   where
+    in_scope_env = (substInScope subst, simpleUnfoldingFun)
+
     go (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
     go (App e1 e2)      = simple_app subst e1 [go e2]
     go (Type ty)        = Type     (substTy subst ty)
@@ -942,7 +943,7 @@ simple_opt_expr subst expr
     go (Case e b ty as)
        -- See Note [Optimise coercion boxes agressively]
       | isDeadBinder b
-      , Just (con, _tys, es) <- expr_is_con_app e'
+      , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
       , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
       = case altcon of
           DEFAULT -> go rhs
@@ -1109,8 +1110,10 @@ add_info subst old_bndr new_bndr
  | otherwise        = maybeModifyIdInfo mb_new_info new_bndr
  where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
 
-expr_is_con_app :: OutExpr -> Maybe (DataCon, [Type], [OutExpr])
-expr_is_con_app = exprIsConApp_maybe (\id -> if isAlwaysActive (idInlineActivation id) then idUnfolding id else noUnfolding)
+simpleUnfoldingFun :: IdUnfoldingFun
+simpleUnfoldingFun id 
+  | isAlwaysActive (idInlineActivation id) = idUnfolding id
+  | otherwise                              = noUnfolding
 \end{code}
 
 Note [Inline prag in simplOpt]
@@ -1158,12 +1161,10 @@ data ConCont = CC [CoreExpr] Coercion
 -- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is 
 -- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
 -- where t1..tk are the *universally-qantified* type args of 'dc'
-exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
-exprIsConApp_maybe id_unf expr
+exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
+exprIsConApp_maybe (in_scope, id_unf) expr
   = go (Left in_scope) expr (CC [] (mkReflCo (exprType expr)))
   where
-    in_scope = mkInScopeSet (exprFreeVars expr)
-
     go :: Either InScopeSet Subst 
        -> CoreExpr -> ConCont 
        -> Maybe (DataCon, [Type], [CoreExpr])
@@ -1184,17 +1185,13 @@ exprIsConApp_maybe id_unf expr
     go (Left in_scope) (Var fun) cont@(CC args co)
         | Just con <- isDataConWorkId_maybe fun
         , count isValArg args == idArity fun
-        , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
-        = dealWithCoercion co (con, stripTypeArgs univ_ty_args, rest_args)
+        = dealWithCoercion co con args
 
         -- Look through dictionary functions; see Note [Unfolding DFuns]
-        | DFunUnfolding dfun_nargs con ops <- unfolding
-        , length args == dfun_nargs    -- See Note [DFun arity check]
-        , let (dfun_tvs, _theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
-              subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
-              mk_arg (DFunPolyArg e) = mkApps e args
-              mk_arg (DFunLamArg i)  = getNth args i
-        = dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops)
+        | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
+        , bndrs `equalLength` args    -- See Note [DFun arity check]
+        , let subst = mkOpenSubst in_scope (bndrs `zip` args)
+        = dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args)
 
         -- Look through unfoldings, but only arity-zero one; 
 	-- if arity > 0 we are effectively inlining a function call,
@@ -1217,17 +1214,17 @@ exprIsConApp_maybe id_unf expr
     subst_co (Right s) co = CoreSubst.substCo s co
 
     subst_arg (Left {}) e = e
-    subst_arg (Right s) e = substExpr (text "exprIsConApp") s e
+    subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e
 
     extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
     extend (Right s)       v e = Right (extendSubst s v e)
 
-dealWithCoercion :: Coercion
-                 -> (DataCon, [Type], [CoreExpr])
+dealWithCoercion :: Coercion -> DataCon -> [CoreExpr]
                  -> Maybe (DataCon, [Type], [CoreExpr])
-dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
+dealWithCoercion co dc dc_args
   | isReflCo co 
-  = Just stuff
+  , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
+  = Just (dc, stripTypeArgs univ_ty_args, rest_args)
 
   | Pair _from_ty to_ty <- coercionKind co
   , Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
@@ -1250,7 +1247,8 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
         dc_ex_tyvars   = dataConExTyVars dc
         arg_tys        = dataConRepArgTys dc
 
-        (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
+        non_univ_args  = dropList dc_univ_tyvars dc_args
+        (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args
 
         -- Make the "theta" from Fig 3 of the paper
         gammas = decomposeCo tc_arity co
@@ -1263,10 +1261,11 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
         cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty)
 
         dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
-                         ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
+                         ppr arg_tys, ppr dc_args,        
                          ppr ex_args, ppr val_args, ppr co, ppr _from_ty, ppr to_ty, ppr to_tc ]
     in
-    ASSERT2( eqType _from_ty (mkTyConApp to_tc _dc_univ_args), dump_doc )
+    ASSERT2( eqType _from_ty (mkTyConApp to_tc (stripTypeArgs $ takeList dc_univ_tyvars dc_args))
+           , dump_doc )
     ASSERT2( all isTypeArg ex_args, dump_doc )
     ASSERT2( equalLength val_args arg_tys, dump_doc )
     Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
@@ -1299,16 +1298,16 @@ type args) matches what the dfun is expecting.  This may be *less*
 than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
 
 \begin{code}
-exprIsLiteral_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe Literal
+exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
 -- Same deal as exprIsConApp_maybe, but much simpler
 -- Nevertheless we do need to look through unfoldings for
 -- Integer literals, which are vigorously hoisted to top level
 -- and not subsequently inlined
-exprIsLiteral_maybe id_unf e
+exprIsLiteral_maybe env@(_, id_unf) e
   = case e of
       Lit l     -> Just l
-      Tick _ e' -> exprIsLiteral_maybe id_unf e' -- dubious?
+      Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
       Var v     | Just rhs <- expandUnfolding_maybe (id_unf v)
-                -> exprIsLiteral_maybe id_unf rhs
+                -> exprIsLiteral_maybe env rhs
       _         -> Nothing
 \end{code}       
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 6bd25fdeae..ede3a4052b 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -49,7 +49,6 @@ module CoreSyn (
 
         -- * Unfolding data types
         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
-        DFunArg(..), dfunArgExprs,
 
 	-- ** Constructing 'Unfolding's
 	noUnfolding, evaldUnfolding, mkOtherCon,
@@ -78,7 +77,7 @@ module CoreSyn (
 
 	-- * Core rule data types
 	CoreRule(..),	-- CoreSubst, CoreTidy, CoreFVs, PprCore only
-	RuleName, IdUnfoldingFun,
+	RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
 	
 	-- ** Operations on 'CoreRule's 
 	seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
@@ -92,6 +91,7 @@ module CoreSyn (
 #include "HsVersions.h"
 
 import CostCentre
+import VarEnv( InScopeSet )
 import Var
 import Type
 import Coercion
@@ -577,13 +577,16 @@ data CoreRule
 	ru_fn    :: Name,       -- ^ As above
 	ru_nargs :: Int,	-- ^ Number of arguments that 'ru_try' consumes,
 				-- if it fires, including type arguments
-	ru_try  :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+	ru_try   :: RuleFun
 		-- ^ This function does the rewrite.  It given too many
 		-- arguments, it simply discards them; the returned 'CoreExpr'
 		-- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
     }
 		-- See Note [Extra args in rule matching] in Rules.lhs
 
+type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
+type InScopeEnv = (InScopeSet, IdUnfoldingFun)
+
 type IdUnfoldingFun = Id -> Unfolding
 -- A function that embodies how to unfold an Id if you need
 -- to do that in the Rule.  The reason we need to pass this info in
@@ -663,17 +666,15 @@ data Unfolding
 		       --
 		       -- Here, @f@ gets an @OtherCon []@ unfolding.
 
-  | DFunUnfolding       -- The Unfolding of a DFunId  
+  | DFunUnfolding {     -- The Unfolding of a DFunId  
     			-- See Note [DFun unfoldings]
-      		  	--     df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
+      		  	--     df = /\a1..am. \d1..dn. MkD t1 .. tk
+                        --                                 (op1 a1..am d1..dn)
      		      	--     	    	      	       	   (op2 a1..am d1..dn)
-
-        Arity 		-- Arity = m+n, the *total* number of args 
-			--   (unusually, both type and value) to the dfun
-
-        DataCon 	-- The dictionary data constructor (possibly a newtype datacon)
-
-        [DFunArg CoreExpr]  -- Specification of superclasses and methods, in positional order
+        df_bndrs :: [Var],      -- The bound variables [a1..m],[d1..dn]
+        df_con   :: DataCon,    -- The dictionary data constructor (never a newtype datacon)
+        df_args  :: [CoreExpr]  -- Args of the data con: types, superclasses and methods,
+    }                           -- in positional order
 
   | CoreUnfolding {		-- An unfolding for an Id with no pragma, 
                                 -- or perhaps a NOINLINE pragma
@@ -710,20 +711,6 @@ data Unfolding
   --
   --  uf_guidance:  Tells us about the /size/ of the unfolding template
 
-------------------------------------------------
-data DFunArg e   -- Given (df a b d1 d2 d3)
-  = DFunPolyArg  e      -- Arg is (e a b d1 d2 d3)
-  | DFunLamArg   Int    -- Arg is one of [a,b,d1,d2,d3], zero indexed
-  deriving( Functor )
-
-  -- 'e' is often CoreExpr, which are usually variables, but can
-  -- be trivial expressions instead (e.g. a type application).
-
-dfunArgExprs :: [DFunArg e] -> [e]
-dfunArgExprs []                    = []
-dfunArgExprs (DFunPolyArg  e : as) = e : dfunArgExprs as
-dfunArgExprs (DFunLamArg {}  : as) = dfunArgExprs as
-
 
 ------------------------------------------------
 data UnfoldingSource
diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index 77a85c241e..8d45fbb9b4 100644
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -206,8 +206,11 @@ tidyIdBndr env@(tidy_env, var_env) id
 
 ------------ Unfolding  --------------
 tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
-tidyUnfolding tidy_env (DFunUnfolding ar con args) _
-  = DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) args)
+tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _
+  = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
+  where
+    (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
+
 tidyUnfolding tidy_env 
               unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
               unf_from_rhs
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 513bb22166..0bff15ea9c 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -48,7 +48,6 @@ module CoreUnfold (
 import DynFlags
 import CoreSyn
 import PprCore		()	-- Instances
-import TcType           ( tcSplitDFunTy )
 import OccurAnal        ( occurAnalyseExpr )
 import CoreSubst hiding( substTy )
 import CoreArity       ( manifestArity, exprBotStrictness_maybe )
@@ -98,13 +97,9 @@ mkImplicitUnfolding dflags expr
 mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding
 mkSimpleUnfolding dflags = mkUnfolding dflags InlineRhs False False
 
-mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
-mkDFunUnfolding dfun_ty ops 
-  = DFunUnfolding dfun_nargs data_con ops
-  where
-    (tvs, theta, cls, _) = tcSplitDFunTy dfun_ty
-    dfun_nargs = length tvs + length theta
-    data_con   = classDataCon cls
+mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
+mkDFunUnfolding bndrs con ops 
+  = DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = ops }
 
 mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
 mkWwInlineRule id expr arity
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 0ead297eb8..0a6914e0b8 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -429,8 +429,10 @@ instance Outputable UnfoldingSource where
 instance Outputable Unfolding where
   ppr NoUnfolding                = ptext (sLit "No unfolding")
   ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
-  ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
-                                   <+> ppr con <+> brackets (pprWithCommas ppr ops)
+  ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
+       = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\") 
+                <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
+            2 (ppr con <+> sep (map ppr args))
   ppr (CoreUnfolding { uf_src = src
                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
                      , uf_is_conlike=conlike, uf_is_work_free=wf
@@ -451,10 +453,6 @@ instance Outputable Unfolding where
              | otherwise          = empty
             -- Don't print the RHS or we get a quadratic
             -- blowup in the size of the printout!
-
-instance Outputable e => Outputable (DFunArg e) where
-  ppr (DFunPolyArg e) = braces (ppr e)
-  ppr (DFunLamArg i)  = char '<' <> int i <> char '>'
 \end{code}
 
 -----------------------------------------------------
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 62793acfd3..66022f970e 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -447,24 +447,24 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
   = putSrcSpanDs loc $ 
     do { uniq <- newUnique
        ; let poly_name = idName poly_id
-             spec_name = mkClonedInternalName uniq poly_name
+             spec_occ  = mkSpecOcc (getOccName poly_name)
+             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
        ; (bndrs, ds_lhs) <- liftM collectBinders
                                   (dsHsWrapper spec_co (Var poly_id))
        ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
        ; case decomposeRuleLhs bndrs ds_lhs of {
            Left msg -> do { warnDs msg; return Nothing } ;
-           Right (final_bndrs, _fn, args) -> do
+           Right (rule_bndrs, _fn, args) -> do
 
-       { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
-
-       ; dflags <- getDynFlags
-       ; let spec_id  = mkLocalId spec_name spec_ty 
+       { dflags <- getDynFlags
+       ; let spec_unf = specUnfolding bndrs args (realIdUnfolding poly_id)
+             spec_id  = mkLocalId spec_name spec_ty 
          	            `setInlinePragma` inl_prag
          	 	    `setIdUnfolding`  spec_unf
              rule =  mkRule False {- Not auto -} is_local_id
                         (mkFastString ("SPEC " ++ showPpr dflags poly_name))
        			rule_act poly_name
-       		        final_bndrs args
+       		        rule_bndrs args
        			(mkVarApps (Var spec_id) bndrs)
 
        ; spec_rhs <- dsHsWrapper spec_co poly_rhs
@@ -472,7 +472,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
 
        ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
               (warnDs (specOnInline poly_name))
-       ; return (Just (spec_pair `consOL` unf_pairs, rule))
+       ; return (Just (unitOL spec_pair, rule))
        } } }
   where
     is_local_id = isJust mb_poly_rhs
@@ -509,18 +509,15 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
              | otherwise   = spec_prag_act                   -- Specified by user
 
 
-specUnfolding :: HsWrapper -> Type 
-              -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
-{-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
-              generate unfoldings for specialised DFuns
+specUnfolding :: [Var] -> [CoreExpr] -> Unfolding -> Unfolding
+specUnfolding new_bndrs new_args df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+  = ASSERT2( equalLength new_args bndrs, ppr df $$ ppr new_args $$ ppr new_bndrs )
+    df { df_bndrs = new_bndrs, df_args = map (substExpr (text "specUnfolding") subst) args }
+  where
+    subst = mkOpenSubst (mkInScopeSet fvs) (bndrs `zip` new_args)
+    fvs = (exprsFreeVars args `delVarSetList` bndrs) `extendVarSetList` new_bndrs
 
-specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
-  = do { let spec_rhss = map wrap_fn ops
-       ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
-       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
--}
-specUnfolding _ _ _
-  = return (noUnfolding, nilOL)
+specUnfolding _ _ _ = noUnfolding
 
 specOnInline :: Name -> MsgDoc
 specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") 
@@ -598,8 +595,8 @@ decomposeRuleLhs bndrs lhs
    opt_lhs = simpleOptExpr lhs
 
    check_bndrs fn args
-     | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
-     | otherwise         = Left (vcat (map dead_msg dead_bndrs))
+     | null dead_bndrs = Right (extra_dict_bndrs ++ bndrs, fn, args)
+     | otherwise       = Left (vcat (map dead_msg dead_bndrs))
      where
        arg_fvs = exprsFreeVars args
 
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 5a751f7243..9390ee4377 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -24,7 +24,6 @@ import TyCon
 import DataCon    (dataConName, dataConWorkId, dataConTyCon)
 import PrelInfo   (wiredInThings, basicKnownKeyNames)
 import Id         (idName, isDataConWorkId_maybe)
-import CoreSyn    (DFunArg(..))
 import Coercion   (LeftOrRight(..))
 import TysWiredIn
 import IfaceEnv
@@ -1110,14 +1109,6 @@ instance Binary IfaceIdDetails where
             1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
             _ -> do { n <- get bh; return (IfDFunId n) }
 
-instance Binary (DFunArg IfaceExpr) where
-    put_ bh (DFunPolyArg  e) = putByte bh 0 >> put_ bh e
-    put_ bh (DFunLamArg i)   = putByte bh 1 >> put_ bh i
-    get bh = do { h <- getByte bh
-                ; case h of
-                    0 -> do { a <- get bh; return (DFunPolyArg a) }
-                    _ -> do { a <- get bh; return (DFunLamArg a) } }
-
 instance Binary IfaceIdInfo where
     put_ bh NoInfo      = putByte bh 0
     put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
@@ -1164,9 +1155,10 @@ instance Binary IfaceUnfolding where
         putByte bh 3
         put_ bh a
         put_ bh n
-    put_ bh (IfDFunUnfold as) = do
+    put_ bh (IfDFunUnfold as bs) = do
         putByte bh 4
         put_ bh as
+        put_ bh bs
     put_ bh (IfCompulsory e) = do
         putByte bh 5
         put_ bh e
@@ -1188,7 +1180,8 @@ instance Binary IfaceUnfolding where
                     n <- get bh
                     return (IfExtWrapper a n)
             4 -> do as <- get bh
-                    return (IfDFunUnfold as)
+                    bs <- get bh
+                    return (IfDFunUnfold as bs)
             _ -> do e <- get bh
                     return (IfCompulsory e)
 
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index e20269b35a..7632b38d81 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -38,7 +38,6 @@ module IfaceSyn (
 
 import TyCon( SynTyConRhs(..) )
 import IfaceType
-import CoreSyn( DFunArg, dfunArgExprs )
 import PprCore()            -- Printing DFunArgs
 import Demand
 import Annotations
@@ -255,7 +254,7 @@ data IfaceUnfolding
   | IfLclWrapper Arity IfLclName  --     because the worker can simplify to a function in
                                   --     another module.
 
-  | IfDFunUnfold [DFunArg IfaceExpr]
+  | IfDFunUnfold [IfaceBndr] [IfaceExpr]
 
 --------------------------------
 data IfaceExpr
@@ -769,8 +768,8 @@ instance Outputable IfaceUnfolding where
                              <+> parens (ptext (sLit "arity") <+> int a)
   ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext):") <+> ppr wkr
                              <+> parens (ptext (sLit "arity") <+> int a)
-  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:")
-                             <+> brackets (pprWithCommas ppr ns)
+  ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot)
+                                2 (sep (map pprParendIfaceExpr es))
 
 -- -----------------------------------------------------------------------------
 -- | Finding the Names in IfaceSyn
@@ -899,7 +898,7 @@ freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
 freeNamesIfUnfold (IfExtWrapper _ v)     = unitNameSet v
 freeNamesIfUnfold (IfLclWrapper {})      = emptyNameSet
-freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr (dfunArgExprs vs)
+freeNamesIfUnfold (IfDFunUnfold bs es)   = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)      = unitNameSet v
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index e9676aca7f..13b64cdb25 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1746,8 +1746,8 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
   where
     if_rhs = toIfaceExpr rhs
 
-toIfUnfolding lb (DFunUnfolding _ar _con ops)
-  = Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops)))
+toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
+  = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
       -- No need to serialise the data constructor; 
       -- we can recover it from the type of the dfun
 
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 7f0ad075a3..89d9807a37 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -1244,15 +1244,15 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
                                                  (UnfWhen unsat_ok boring_ok))
     }
 
-tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
-  = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
+tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
+  = bindIfaceBndrs bs $ \ bs' ->
+    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
        ; return (case mb_ops1 of
                     Nothing   -> noUnfolding
-                    Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
+                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
   where
     doc = text "Class ops for dfun" <+> ppr name
-    tc_arg (DFunPolyArg  e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
-    tc_arg (DFunLamArg i)   = return (DFunLamArg i)
+    (_, _, cls, _) = tcSplitDFunTy dfun_ty
 
 tcUnfolding name ty info (IfExtWrapper arity wkr)
   = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 1c6bb397ea..4608a21e8c 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -822,7 +822,8 @@ dffvLetBndr vanilla_unfold id
             -- but I've seen cases where we had a wrapper id $w but a
             -- rhs where $w had been inlined; see Trac #3922
 
-    go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr (dfunArgExprs args)
+    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) 
+             = extendScopeList bndrs $ mapM_ dffvExpr args
     go_unf _ = return ()
 
     go_rule (BuiltinRule {}) = return ()
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 079ab0cc98..05e58e40ce 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -512,10 +512,10 @@ mkBasicRule op_name n_args rm
   = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
                   ru_fn = op_name,
                   ru_nargs = n_args,
-                  ru_try = \dflags _ -> runRuleM rm dflags }
+                  ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
 
 newtype RuleM r = RuleM
-  { runRuleM :: DynFlags -> IdUnfoldingFun -> [CoreExpr] -> Maybe r }
+  { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
 
 instance Monad RuleM where
   return x = RuleM $ \_ _ _ -> Just x
@@ -557,8 +557,8 @@ removeOp32 = mzero
 getArgs :: RuleM [CoreExpr]
 getArgs = RuleM $ \_ _ args -> Just args
 
-getIdUnfoldingFun :: RuleM IdUnfoldingFun
-getIdUnfoldingFun = RuleM $ \_ iu _ -> Just iu
+getInScopeEnv :: RuleM InScopeEnv
+getInScopeEnv = RuleM $ \_ iu _ -> Just iu
 
 -- return the n-th argument of this rule, if it is a literal
 -- argument indices start from 0
@@ -745,8 +745,8 @@ dataToTagRule = a `mplus` b
     b = do
       dflags <- getDynFlags
       [_, val_arg] <- getArgs
-      id_unf <- getIdUnfoldingFun
-      (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg
+      in_scope <- getInScopeEnv
+      (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
       ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
       return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
 \end{code}
@@ -812,11 +812,11 @@ builtinRules :: [CoreRule]
 builtinRules
   = [BuiltinRule { ru_name = fsLit "AppendLitString",
                    ru_fn = unpackCStringFoldrName,
-                   ru_nargs = 4, ru_try = \_ _ -> match_append_lit },
+                   ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
-                   ru_nargs = 2, ru_try = \_ _ -> match_eq_string },
+                   ru_nargs = 2, ru_try = \_ _ _ -> match_eq_string },
      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
-                   ru_nargs = 2, ru_try = \_ _ -> match_inline }]
+                   ru_nargs = 2, ru_try = \_ _ _ -> match_inline }]
  ++ builtinIntegerRules
 
 builtinIntegerRules :: [CoreRule]
@@ -929,8 +929,8 @@ builtinIntegerRules =
 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
 --      =  unpackFoldrCString# "foobaz" c n
 
-match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_append_lit _ [Type ty1,
+match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_append_lit [Type ty1,
                     Lit (MachStr s1),
                     c1,
                     Var unpk `App` Type ty2
@@ -946,20 +946,20 @@ match_append_lit _ [Type ty1,
                    `App` c1
                    `App` n)
 
-match_append_lit _ _ = Nothing
+match_append_lit _ = Nothing
 
 ---------------------------------------------------
 -- The rule is this:
 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 
-match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
+match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_eq_string [Var unpk1 `App` Lit (MachStr s1),
                    Var unpk2 `App` Lit (MachStr s2)]
   | unpk1 `hasKey` unpackCStringIdKey,
     unpk2 `hasKey` unpackCStringIdKey
   = Just (if s1 == s2 then trueVal else falseVal)
 
-match_eq_string _ _ = Nothing
+match_eq_string _ = Nothing
 
 
 ---------------------------------------------------
@@ -975,14 +975,14 @@ match_eq_string _ _ = Nothing
 --     programmer can't avoid
 --
 -- Also, don't forget about 'inline's type argument!
-match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_inline _ (Type _ : e : _)
+match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_inline (Type _ : e : _)
   | (Var f, args1) <- collectArgs e,
     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
              -- Ignore the IdUnfoldingFun here!
   = Just (mkApps unf args1)
 
-match_inline _ _ = Nothing
+match_inline _ = Nothing
 
 -------------------------------------------------
 -- Integer rules
@@ -990,26 +990,18 @@ match_inline _ _ = Nothing
 --   wordToInteger (79::Word#) = 79::Integer   
 -- Similarly Int64, Word64
 
-match_IntToInteger :: DynFlags
-                   -> Id
-                   -> IdUnfoldingFun
-                   -> [Expr CoreBndr]
-                   -> Maybe (Expr CoreBndr)
-match_IntToInteger _ id id_unf [xl]
+match_IntToInteger :: RuleFun
+match_IntToInteger _ id_unf fn [xl]
   | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
-  = case idType id of
+  = case idType fn of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_IntToInteger: Id has the wrong type"
 match_IntToInteger _ _ _ _ = Nothing
 
-match_WordToInteger :: DynFlags
-                    -> Id
-                    -> IdUnfoldingFun
-                    -> [Expr CoreBndr]
-                    -> Maybe (Expr CoreBndr)
-match_WordToInteger _ id id_unf [xl]
+match_WordToInteger :: RuleFun
+match_WordToInteger _ id_unf id [xl]
   | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
@@ -1018,12 +1010,8 @@ match_WordToInteger _ id id_unf [xl]
         panic "match_WordToInteger: Id has the wrong type"
 match_WordToInteger _ _ _ _ = Nothing
 
-match_Int64ToInteger :: DynFlags
-                     -> Id
-                     -> IdUnfoldingFun
-                     -> [Expr CoreBndr]
-                     -> Maybe (Expr CoreBndr)
-match_Int64ToInteger _ id id_unf [xl]
+match_Int64ToInteger :: RuleFun
+match_Int64ToInteger _ id_unf id [xl]
   | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
@@ -1032,12 +1020,8 @@ match_Int64ToInteger _ id id_unf [xl]
         panic "match_Int64ToInteger: Id has the wrong type"
 match_Int64ToInteger _ _ _ _ = Nothing
 
-match_Word64ToInteger :: DynFlags
-                      -> Id
-                      -> IdUnfoldingFun
-                      -> [Expr CoreBndr]
-                      -> Maybe (Expr CoreBndr)
-match_Word64ToInteger _ id id_unf [xl]
+match_Word64ToInteger :: RuleFun
+match_Word64ToInteger _ id_unf id [xl]
   | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
@@ -1049,47 +1033,29 @@ match_Word64ToInteger _ _ _ _ = Nothing
 -------------------------------------------------
 match_Integer_convert :: Num a
                       => (DynFlags -> a -> Expr CoreBndr)
-                      -> DynFlags
-                      -> Id
-                      -> IdUnfoldingFun
-                      -> [Expr CoreBndr]
-                      -> Maybe (Expr CoreBndr)
-match_Integer_convert convert dflags _ id_unf [xl]
+                      -> RuleFun
+match_Integer_convert convert dflags id_unf _ [xl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   = Just (convert dflags (fromInteger x))
 match_Integer_convert _ _ _ _ _ = Nothing
 
-match_Integer_unop :: (Integer -> Integer)
-                   -> DynFlags
-                   -> Id
-                   -> IdUnfoldingFun
-                   -> [Expr CoreBndr]
-                   -> Maybe (Expr CoreBndr)
-match_Integer_unop unop _ _ id_unf [xl]
+match_Integer_unop :: (Integer -> Integer) -> RuleFun
+match_Integer_unop unop _ id_unf _ [xl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   = Just (Lit (LitInteger (unop x) i))
 match_Integer_unop _ _ _ _ _ = Nothing
 
-match_Integer_binop :: (Integer -> Integer -> Integer)
-                    -> DynFlags
-                    -> Id
-                    -> IdUnfoldingFun
-                    -> [Expr CoreBndr]
-                    -> Maybe (Expr CoreBndr)
-match_Integer_binop binop _ _ id_unf [xl,yl]
+match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
+match_Integer_binop binop _ id_unf _ [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (Lit (LitInteger (x `binop` y) i))
 match_Integer_binop _ _ _ _ _ = Nothing
 
 -- This helper is used for the quotRem and divMod functions
-match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
-                         -> DynFlags
-                         -> Id
-                         -> IdUnfoldingFun
-                         -> [Expr CoreBndr]
-                         -> Maybe (Expr CoreBndr)
-match_Integer_divop_both divop _ _ id_unf [xl,yl]
+match_Integer_divop_both 
+   :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
+match_Integer_divop_both divop _ id_unf _ [xl,yl]
   | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
@@ -1102,50 +1068,30 @@ match_Integer_divop_both divop _ _ id_unf [xl,yl]
 match_Integer_divop_both _ _ _ _ _ = Nothing
 
 -- This helper is used for the quotRem and divMod functions
-match_Integer_divop_one :: (Integer -> Integer -> Integer)
-                        -> DynFlags
-                        -> Id
-                        -> IdUnfoldingFun
-                        -> [Expr CoreBndr]
-                        -> Maybe (Expr CoreBndr)
-match_Integer_divop_one divop _ _ id_unf [xl,yl]
+match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
+match_Integer_divop_one divop _ id_unf _ [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   = Just (Lit (LitInteger (x `divop` y) i))
 match_Integer_divop_one _ _ _ _ _ = Nothing
 
-match_Integer_Int_binop :: (Integer -> Int -> Integer)
-                        -> DynFlags
-                        -> Id
-                        -> IdUnfoldingFun
-                        -> [Expr CoreBndr]
-                        -> Maybe (Expr CoreBndr)
-match_Integer_Int_binop binop _ _ id_unf [xl,yl]
+match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
+match_Integer_Int_binop binop _ id_unf _ [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
 match_Integer_Int_binop _ _ _ _ _ = Nothing
 
-match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
-                         -> DynFlags
-                         -> Id
-                         -> IdUnfoldingFun
-                         -> [Expr CoreBndr]
-                         -> Maybe (Expr CoreBndr)
-match_Integer_binop_Bool binop _ _ id_unf [xl, yl]
+match_Integer_binop_Bool :: (Integer -> Integer -> Bool) -> RuleFun
+match_Integer_binop_Bool binop _ id_unf _ [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (if x `binop` y then trueVal else falseVal)
 match_Integer_binop_Bool _ _ _ _ _ = Nothing
 
-match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
-                             -> DynFlags
-                             -> Id
-                             -> IdUnfoldingFun
-                             -> [Expr CoreBndr]
-                             -> Maybe (Expr CoreBndr)
-match_Integer_binop_Ordering binop _ _ id_unf [xl, yl]
+match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
+match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just $ case x `binop` y of
@@ -1156,12 +1102,8 @@ match_Integer_binop_Ordering _ _ _ _ _ = Nothing
 
 match_Integer_Int_encodeFloat :: RealFloat a
                               => (a -> Expr CoreBndr)
-                              -> DynFlags
-                              -> Id
-                              -> IdUnfoldingFun
-                              -> [Expr CoreBndr]
-                              -> Maybe (Expr CoreBndr)
-match_Integer_Int_encodeFloat mkLit _ _ id_unf [xl,yl]
+                              -> RuleFun
+match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (mkLit $ encodeFloat x (fromInteger y))
@@ -1179,24 +1121,16 @@ match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
 -- NaN or +-Inf
 match_rationalTo :: RealFloat a
                  => (a -> Expr CoreBndr)
-                 -> DynFlags
-                 -> Id
-                 -> IdUnfoldingFun
-                 -> [Expr CoreBndr]
-                 -> Maybe (Expr CoreBndr)
-match_rationalTo mkLit _ _ id_unf [xl, yl]
+                 -> RuleFun
+match_rationalTo mkLit _ id_unf _ [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   = Just (mkLit (fromRational (x % y)))
 match_rationalTo _ _ _ _ _ = Nothing
 
-match_decodeDouble :: DynFlags
-                   -> Id
-                   -> IdUnfoldingFun
-                   -> [Expr CoreBndr]
-                   -> Maybe (Expr CoreBndr)
-match_decodeDouble _ fn id_unf [xl]
+match_decodeDouble :: RuleFun
+match_decodeDouble _ id_unf fn [xl]
   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
   = case idType fn of
     FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
@@ -1211,23 +1145,13 @@ match_decodeDouble _ fn id_unf [xl]
         panic "match_decodeDouble: Id has the wrong type"
 match_decodeDouble _ _ _ _ = Nothing
 
-match_XToIntegerToX :: Name
-                    -> DynFlags
-                    -> Id
-                    -> IdUnfoldingFun
-                    -> [Expr CoreBndr]
-                    -> Maybe (Expr CoreBndr)
+match_XToIntegerToX :: Name -> RuleFun
 match_XToIntegerToX n _ _ _ [App (Var x) y]
   | idName x == n
   = Just y
 match_XToIntegerToX _ _ _ _ _ = Nothing
 
-match_smallIntegerTo :: PrimOp
-                     -> DynFlags
-                     -> Id
-                     -> IdUnfoldingFun
-                     -> [Expr CoreBndr]
-                     -> Maybe (Expr CoreBndr)
+match_smallIntegerTo :: PrimOp -> RuleFun
 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
   | idName x == smallIntegerName
   = Just $ App (Var (mkPrimOpId primOp)) y
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 2c27070166..42dd672844 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -692,7 +692,7 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs)
 
     -- Finding the free variables of the INLINE pragma (if any)
     unf        = realIdUnfolding bndr     -- Ignore any current loop-breaker flag
-    mb_unf_fvs = stableUnfoldingVars isLocalId unf
+    mb_unf_fvs = stableUnfoldingVars unf
 
     -- Find the "nd_inl" free vars; for the loop-breaker phase
     inl_fvs = case mb_unf_fvs of
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7bc10de43f..17da9be32e 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -641,19 +641,21 @@ activeUnfolding env
   where
     mode = getMode env
 
-getUnfoldingInRuleMatch :: SimplEnv -> IdUnfoldingFun
+getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
 -- When matching in RULE, we want to "look through" an unfolding
 -- (to see a constructor) if *rules* are on, even if *inlinings*
 -- are not.  A notable example is DFuns, which really we want to
 -- match in rules like (op dfun) in gentle mode. Another example
 -- is 'otherwise' which we want exprIsConApp_maybe to be able to
 -- see very early on
-getUnfoldingInRuleMatch env id
-  | unf_is_active = idUnfolding id
-  | otherwise     = NoUnfolding
+getUnfoldingInRuleMatch env
+  = (in_scope, id_unf)
   where
+    in_scope = seInScope env
     mode = getMode env
-    unf_is_active
+    id_unf id | unf_is_active id = idUnfolding id
+              | otherwise        = NoUnfolding
+    unf_is_active id
      | not (sm_rules mode) = active_unfolding_minimal id
      | otherwise           = isActive (sm_phase mode) (idInlineActivation id)
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index d30e826f93..0bc05f3985 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -723,10 +723,10 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
                -> OutExpr
                -> Unfolding -> SimplM Unfolding
 -- Note [Setting the new unfolding]
-simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
-  = return (DFunUnfolding ar con ops')
-  where
-    ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
+simplUnfolding env _ _ _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+  = do { (env', bndrs') <- simplBinders env bndrs
+       ; args' <- mapM (simplExpr env') args
+       ; return (df { df_bndrs = bndrs', df_args  = args' }) }
 
 simplUnfolding env top_lvl id _
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
@@ -1559,8 +1559,8 @@ tryRules env rules fn args call_cont
   = return Nothing
   | otherwise
   = do { dflags <- getDynFlags
-       ; case lookupRule dflags (activeRule env) (getUnfoldingInRuleMatch env)
-                         (getInScope env) fn args rules of {
+       ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env) 
+                         fn args rules of {
            Nothing               -> return Nothing ;   -- No rule matches
            Just (rule, rule_rhs) ->
 
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 9c473e5a3a..cc2cc19f98 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -47,8 +47,8 @@ import Name             ( Name, NamedThing(..) )
 import NameEnv
 import Unify            ( ruleMatchTyX, MatchEnv(..) )
 import BasicTypes       ( Activation, CompilerPhase, isActive )
-import DynFlags         ( DynFlags )
 import StaticFlags      ( opt_PprStyle_Debug )
+import DynFlags         ( DynFlags )
 import Outputable
 import FastString
 import Maybes
@@ -351,16 +351,14 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
 -- supplied rules to this instance of an application in a given
 -- context, returning the rule applied and the resulting expression if
 -- successful.
-lookupRule :: DynFlags
-            -> (Activation -> Bool)      -- When rule is active
-            -> IdUnfoldingFun           -- When Id can be unfolded
-            -> InScopeSet
-            -> Id -> [CoreExpr]
-            -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
+lookupRule :: DynFlags -> InScopeEnv
+           -> (Activation -> Bool)      -- When rule is active
+           -> Id -> [CoreExpr]
+           -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
 
 -- See Note [Extra args in rule matching]
 -- See comments on matchRule
-lookupRule dflags is_active id_unf in_scope fn args rules
+lookupRule dflags in_scope is_active fn args rules
   = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
     case go [] rules of
         []     -> Nothing
@@ -370,7 +368,7 @@ lookupRule dflags is_active id_unf in_scope fn args rules
 
     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
     go ms []           = ms
-    go ms (r:rs) = case (matchRule dflags fn is_active id_unf in_scope args rough_args r) of
+    go ms (r:rs) = case (matchRule dflags in_scope is_active fn args rough_args r) of
                         Just e  -> go ((r,e):ms) rs
                         Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
                                    --   ppr [ (arg_id, unfoldingTemplate unf)
@@ -418,7 +416,7 @@ isMoreSpecific (BuiltinRule {}) _                = False
 isMoreSpecific (Rule {})        (BuiltinRule {}) = True
 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
                (Rule { ru_bndrs = bndrs2, ru_args = args2 })
-  = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)
+  = isJust (matchN (in_scope, id_unfolding_fun) bndrs2 args2 args1)
   where
    id_unfolding_fun _ = NoUnfolding     -- Don't expand in templates
    in_scope = mkInScopeSet (mkVarSet bndrs1)
@@ -447,9 +445,8 @@ to lookupRule are the result of a lazy substitution
 
 \begin{code}
 ------------------------------------
-matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun
-          -> InScopeSet
-          -> [CoreExpr] -> [Maybe Name]
+matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
+          -> Id -> [CoreExpr] -> [Maybe Name]
           -> CoreRule -> Maybe CoreExpr
 
 -- If (matchRule rule args) returns Just (name,rhs)
@@ -474,21 +471,21 @@ matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun
 -- Any 'surplus' arguments in the input are simply put on the end
 -- of the output.
 
-matchRule dflags fn _is_active id_unf _in_scope args _rough_args
+matchRule dflags rule_env _is_active fn args _rough_args
           (BuiltinRule { ru_try = match_fn })
 -- Built-in rules can't be switched off, it seems
-  = case match_fn dflags fn id_unf args of
+  = case match_fn dflags rule_env fn args of
         Just expr -> Just expr
         Nothing   -> Nothing
 
-matchRule _ _ is_active id_unf in_scope args rough_args
-          (Rule { ru_act = act, ru_rough = tpl_tops,
-                  ru_bndrs = tpl_vars, ru_args = tpl_args,
-                  ru_rhs = rhs })
+matchRule _ in_scope is_active _ args rough_args
+          (Rule { ru_act = act, ru_rough = tpl_tops
+                , ru_bndrs = tpl_vars, ru_args = tpl_args
+                , ru_rhs = rhs })
   | not (is_active act)               = Nothing
   | ruleCantMatch tpl_tops rough_args = Nothing
   | otherwise
-  = case matchN id_unf in_scope tpl_vars tpl_args args of
+  = case matchN in_scope tpl_vars tpl_args args of
         Nothing                        -> Nothing
         Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $
                                                rule_fn `mkApps` tpl_vals)
@@ -497,8 +494,7 @@ matchRule _ _ is_active id_unf in_scope args rough_args
         -- We could do this when putting things into the rulebase, I guess
 
 ---------------------------------------
-matchN  :: IdUnfoldingFun
-        -> InScopeSet           -- ^ In-scope variables
+matchN  :: InScopeEnv
         -> [Var]                -- ^ Match template type variables
         -> [CoreExpr]           -- ^ Match template
         -> [CoreExpr]           -- ^ Target; can have more elements than the template
@@ -508,7 +504,7 @@ matchN  :: IdUnfoldingFun
 -- the entire result and what should be substituted for each template variable.
 -- Fail if there are two few actual arguments from the target to match the template
 
-matchN id_unf in_scope tmpl_vars tmpl_es target_es
+matchN (in_scope, id_unf) tmpl_vars tmpl_es target_es
   = do  { subst <- go init_menv emptyRuleSubst tmpl_es target_es
         ; return (rs_binds subst,
                   map (lookup_tmpl subst) tmpl_vars') }
@@ -572,14 +568,15 @@ necessary; the renamed ones are the tmpl_vars'
 -- * The BindWrapper in a RuleSubst are the bindings floated out
 --   from nested matches; see the Let case of match, below
 --
-data RuleEnv = RV { rv_tmpls :: VarSet          -- Template variables
-                  , rv_lcl   :: RnEnv2          -- Renamings for *local bindings*
-                                                --   (lambda/case)
-                  , rv_fltR  :: Subst           -- Renamings for floated let-bindings
-                                                --   domain disjoint from envR of rv_lcl
-                                                -- See Note [Matching lets]
-                  , rv_unf :: IdUnfoldingFun
-                  }
+data RuleMatchEnv 
+  = RV { rv_tmpls :: VarSet          -- Template variables
+       , rv_lcl   :: RnEnv2          -- Renamings for *local bindings*
+                                     --   (lambda/case)
+       , rv_fltR  :: Subst           -- Renamings for floated let-bindings
+                                     --   domain disjoint from envR of rv_lcl
+                                     -- See Note [Matching lets]
+       , rv_unf :: IdUnfoldingFun
+       }
 
 data RuleSubst = RS { rs_tv_subst :: TvSubstEnv   -- Range is the
                     , rs_id_subst :: IdSubstEnv   --   template variables
@@ -604,7 +601,7 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
 --      SLPJ July 99
 
 
-match :: RuleEnv
+match :: RuleMatchEnv
       -> RuleSubst
       -> CoreExpr               -- Template
       -> CoreExpr               -- Target
@@ -720,7 +717,7 @@ match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text
                     Nothing
 
 -------------
-match_co :: RuleEnv
+match_co :: RuleMatchEnv
          -> RuleSubst
          -> Coercion
          -> Coercion
@@ -736,7 +733,7 @@ match_co _ _ co1 _
     -- Currently just deals with CoVarCo and Refl
 
 -------------
-rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
+rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv
 rnMatchBndr2 renv subst x1 x2
   = renv { rv_lcl  = rnBndr2 rn_env x1 x2
          , rv_fltR = delBndr (rv_fltR renv) x2 }
@@ -746,7 +743,7 @@ rnMatchBndr2 renv subst x1 x2
     -- there are some floated let-bindings
 
 ------------------------------------------
-match_alts :: RuleEnv
+match_alts :: RuleMatchEnv
            -> RuleSubst
            -> [CoreAlt]         -- Template
            -> [CoreAlt]         -- Target
@@ -772,7 +769,7 @@ okToFloat rn_env bind_fvs
     not_captured fv = not (inRnEnvR rn_env fv)
 
 ------------------------------------------
-match_var :: RuleEnv
+match_var :: RuleMatchEnv
           -> RuleSubst
           -> Var                -- Template
           -> CoreExpr        -- Target
@@ -801,7 +798,7 @@ match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })
         -- template x, so we must rename first!
 
 ------------------------------------------
-match_tmpl_var :: RuleEnv
+match_tmpl_var :: RuleMatchEnv
                -> RuleSubst
                -> Var                -- Template
                -> CoreExpr              -- Target
@@ -842,7 +839,7 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
          -- because no free var of e2' is in the rnEnvR of the envt
 
 ------------------------------------------
-match_ty :: RuleEnv
+match_ty :: RuleMatchEnv
          -> RuleSubst
          -> Type                -- Template
          -> Type                -- Target
@@ -1096,7 +1093,8 @@ ruleAppCheck_help env fn args rules
         = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
 
     rule_info dflags rule
-        | Just _ <- matchRule dflags fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
+        | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) 
+                              noBlackList fn args rough_args rule
         = text "matches (which is very peculiar!)"
 
     rule_info _ (BuiltinRule {}) = text "does not match"
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index e6e4c48092..212a7fedb2 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -1044,7 +1044,8 @@ specCalls env rules_for_me calls_for_me fn rhs
        ; return (spec_rules, spec_defns, plusUDList spec_uds) }
 
   | otherwise   -- No calls or RHS doesn't fit our preconceptions
-  = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for")
+  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, 
+          ptext (sLit "Missed specialisation opportunity for")
                                  <+> ppr fn $$ _trace_doc )
           -- Note [Specialisation shape]
     -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
@@ -1077,8 +1078,9 @@ specCalls env rules_for_me calls_for_me fn rhs
 
     already_covered :: DynFlags -> [CoreExpr] -> Bool
     already_covered dflags args      -- Note [Specialisations already covered]
-       = isJust (lookupRule dflags (const True) realIdUnfolding
-                            (CoreSubst.substInScope (se_subst env))
+       = isJust (lookupRule dflags 
+                            (CoreSubst.substInScope (se_subst env), realIdUnfolding)
+                            (const True) 
                             fn args rules_for_me)
 
     mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]
@@ -1429,6 +1431,18 @@ It's a silly exapmle, but we get
 where choose doesn't have any dict arguments.  Thus far I have not
 tried to fix this (wait till there's a real example).
 
+Mind you, then 'choose' will be inlined (since RHS is trivial) so 
+it doesn't matter.  This comes up with single-method classes
+
+   class C a where { op :: a -> a }
+   instance C a => C [a] where ....
+==>
+   $fCList :: C a => C [a]
+   $fCList = $copList |> (...coercion>...)
+   ....(uses of $fCList at particular types)...
+
+So we suppress the WARN if the rhs is trivial.
+
 Note [Inline specialisations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Here is what we do with the InlinePragma of the original function
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 9f6b571be4..a6f6b3e33c 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -42,7 +42,6 @@ import TcEnv
 import TcHsType
 import TcUnify
 import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
-import CoreSyn    ( DFunArg(..) )
 import Type
 import TcEvidence
 import TyCon
@@ -54,7 +53,7 @@ import VarEnv
 import VarSet     ( mkVarSet, subVarSet, varSetElems )
 import Pair
 import CoreUnfold ( mkDFunUnfolding )
-import CoreSyn    ( Expr(Var), CoreExpr )
+import CoreSyn    ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps )
 import PrelNames  ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
 
 import Bag
@@ -190,9 +189,9 @@ Instead we use a cunning trick.
    a suitable constructor application -- inlining df "on the fly" as it
    were.
 
- * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
-   iff its argument satisfies exprIsConApp_maybe.  This is done in
-   MkId mkDictSelId
+ * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that
+   extracts the right piece iff its argument satisfies
+   exprIsConApp_maybe.  This is done in MkId mkDictSelId
 
  * We make 'df' CONLIKE, so that shared uses still match; eg
       let d = df d1 d2
@@ -796,12 +795,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
 
        ; dfun_ev_vars <- newEvVars dfun_theta
 
-       ; (sc_binds, sc_ev_vars, sc_dfun_args) 
-            <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta'
+       ; (sc_binds, sc_ev_vars) <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta'
 
        -- Deal with 'SPECIALISE instance' pragmas
        -- See Note [SPECIALISE instance pragmas]
-       ; spec_inst_info <- tcSpecInstPrags dfun_id ibinds
+       ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
 
         -- Typecheck the methods
        ; (meth_ids, meth_binds)
@@ -831,11 +829,10 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
              con_app_tys  = wrapId (mkWpTyApps inst_tys)
                                    (dataConWrapId dict_constr)
              con_app_scs  = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys
-             con_app_args = foldl mk_app con_app_scs $
-                            map (wrapId arg_wrapper) meth_ids
+             con_app_args = foldl app_to_meth con_app_scs meth_ids
 
-             mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id
-             mk_app fun arg = HsApp (L loc fun) (L loc arg)
+             app_to_meth :: HsExpr Id -> Id -> HsExpr Id
+             app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)
 
              inst_tv_tys = mkTyVarTys inst_tyvars
              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
@@ -843,19 +840,26 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                 -- Do not inline the dfun; instead give it a magic DFunFunfolding
                 -- See Note [ClassOp/DFun selection]
                 -- See also note [Single-method classes]
-             dfun_id_w_fun
+             (dfun_id_w_fun, dfun_spec_prags)
                 | isNewTyCon class_tc
-                = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+                = ( dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+                  , SpecPrags [] )   -- Newtype dfuns just inline unconditionally,
+                                     -- so don't attempt to specialise them
                 | otherwise
-                = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty dfun_args
-                          `setInlinePragma` dfunInlinePragma
+                = ( dfun_id `setIdUnfolding`  mkDFunUnfolding (inst_tyvars ++ dfun_ev_vars)
+                                                              dict_constr dfun_args
+                            `setInlinePragma` dfunInlinePragma
+                  , SpecPrags spec_inst_prags )
 
-             dfun_args :: [DFunArg CoreExpr]
-             dfun_args = sc_dfun_args ++ map (DFunPolyArg . Var) meth_ids
+             dfun_args :: [CoreExpr]
+             dfun_args = map Type inst_tys        ++
+                         map Var  sc_ev_vars      ++ 
+                         map mk_meth_app meth_ids
+             mk_meth_app meth_id = Var meth_id `mkTyApps` inst_tv_tys `mkVarApps` dfun_ev_vars 
 
              export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
-                          , abe_mono = self_dict, abe_prags = noSpecPrags }
-                          -- NB: noSpecPrags, see Note [SPECIALISE instance pragmas]
+                          , abe_mono = self_dict, abe_prags = dfun_spec_prags }
+                          -- NB: see Note [SPECIALISE instance pragmas]
              main_bind = AbsBinds { abs_tvs = inst_tyvars
                                   , abs_ev_vars = dfun_ev_vars
                                   , abs_exports = [export]
@@ -866,13 +870,12 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                  listToBag meth_binds)
        }
  where
-   dfun_ty   = idType dfun_id
-   dfun_id   = instanceDFunId ispec
-   loc       = getSrcSpan dfun_id
+   dfun_id = instanceDFunId ispec
+   loc     = getSrcSpan dfun_id
 
 ------------------------------
 tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType
-               -> TcM (TcEvBinds, [EvVar], [DFunArg CoreExpr])
+               -> TcM (TcEvBinds, [EvVar])
 -- See Note [Silent superclass arguments]
 tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
   = do {   -- Check that all superclasses can be deduced from
@@ -881,19 +884,18 @@ tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
                                emitWanteds ScOrigin sc_theta
 
        ; if null inst_tyvars && null dfun_ev_vars 
-         then return (sc_binds,       sc_evs,      map (DFunPolyArg . Var) sc_evs)
-         else return (emptyTcEvBinds, sc_lam_args, sc_dfun_args) }
+         then return (sc_binds,       sc_evs)
+         else return (emptyTcEvBinds, sc_lam_args) }
   where
     n_silent     = dfunNSilent dfun_id
-    n_tv_args    = length inst_tyvars
     orig_ev_vars = drop n_silent dfun_ev_vars
 
-    (sc_lam_args, sc_dfun_args) = unzip (map (find n_tv_args dfun_ev_vars) sc_theta)
-    find _ [] pred 
+    sc_lam_args = map (find dfun_ev_vars) sc_theta
+    find [] pred 
       = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred)
-    find i (ev:evs) pred 
-      | pred `eqPred` evVarPred ev = (ev, DFunLamArg i)
-      | otherwise                  = find (i+1) evs pred
+    find (ev:evs) pred 
+      | pred `eqPred` evVarPred ev = ev
+      | otherwise                  = find evs pred
 
 ----------------------
 mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] 
@@ -1056,35 +1058,56 @@ Consider
      {-# SPECIALISE instance Ix (Int,Int) #-}
      range (x,y) = ...
 
-We do *not* want to make a specialised version of the dictionary
-function.  Rather, we want specialised versions of each *method*.
-Thus we should generate something like this:
+We make a specialised version of the dictionary function, AND
+specialised versions of each *method*.  Thus we should generate
+something like this:
 
   $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
-  {- DFUN [$crangePair, ...] -}
+  {-# DFUN [$crangePair, ...] #-}
+  {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
   $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
 
   $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
   {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
   $crange da db = <blah>
 
-  {-# RULE  range ($dfIx da db) = $crange da db #-}
+The SPECIALISE pragmas are acted upon by the desugarer, which generate
 
+  dii :: Ix Int
+  dii = ...
+
+  $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
+  {-# DFUN [$crangePair di di, ...] #-}
+  $s$dfIxPair = Ix ($crangePair di di) (...)
+
+  {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
+
+  $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
+  $c$crangePair = ...specialised RHS of $crangePair...
+
+  {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
+ 
 Note that
 
-  * The RULE is unaffected by the specialisation.  We don't want to
-    specialise $dfIx, because then it would need a specialised RULE
-    which is a pain.  The single RULE works fine at all specialisations.
-    See Note [How instance declarations are translated] above
+  * The specialised dictionary $s$dfIxPair is very much needed, in case we
+    call a function that takes a dictionary, but in a context where the 
+    specialised dictionary can be used.  See Trac #7797.
 
-  * Instead, we want to specialise the *method*, $crange
+  * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
+    it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]
+
+  * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
+       --> {ClassOp rule for range}     $crangePair Int Int d1 d2
+       --> {SPEC rule for $crangePair}  $s$crangePair
+    or thus:
+       --> {SPEC rule for $dfIxPair}    range $s$dfIxPair
+       --> {ClassOpRule for range}      $s$crangePair
+    It doesn't matter which way.
+
+  * We want to specialise the RHS of both $dfIxPair and $crangePair,
+    but the SAME HsWrapper will do for both!  We can call tcSpecPrag
+    just once, and pass the result (in spec_inst_info) to tcInstanceMethods.
 
-In practice, rather than faking up a SPECIALISE pragama for each
-method (which is painful, since we'd have to figure out its
-specialised type), we call tcSpecPrag *as if* were going to specialise
-$dfIx -- you can see that in the call to tcSpecInst.  That generates a
-SpecPrag which, as it turns out, can be used unchanged for each method.
-The "it turns out" bit is delicate, but it works fine!
 
 \begin{code}
 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
@@ -1437,7 +1460,6 @@ That is, just as if you'd written
 
 So for the above example we generate:
 
-
   {-# INLINE $dmop1 #-}
   -- $dmop1 has an InlineCompulsory unfolding
   $dmop1 d b x = op2 d (not b) x
diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs
index f70e796daa..7e70f2dd11 100644
--- a/compiler/vectorise/Vectorise/Generic/PADict.hs
+++ b/compiler/vectorise/Vectorise/Generic/PADict.hs
@@ -68,37 +68,35 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr
                              ; pr_cls <- builtin prClass
                              ; return $ mkClassPred pr_cls [r]
                              }
-      ; super_tys <- sequence [mk_super_ty | not (null tvs)]
+      ; super_tys  <- sequence [mk_super_ty | not (null tvs)]
       ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys
-      ; let all_args = super_args ++ args
+      ; let val_args = super_args ++ args
+            all_args = tvs ++ val_args
      
           -- ...it is constant otherwise
       ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs]
 
           -- Get ids for each of the methods in the dictionary, including superclass
       ; paMethodBuilders <- buildPAScAndMethods
-      ; method_ids       <- mapM (method all_args dfun_name) paMethodBuilders
+      ; method_ids       <- mapM (method val_args dfun_name) paMethodBuilders
 
           -- Expression to build the dictionary.
       ; pa_dc  <- builtin paDataCon
-      ; let dict = mkLams (tvs ++ all_args)
-                 $ mkConApp pa_dc
-                 $ Type inst_ty
-                 : map Var super_args ++ super_consts -- the superclass dictionary is either lambda-bound or constant
-                   ++ map (method_call all_args) method_ids
+      ; let dict = mkLams all_args (mkConApp pa_dc con_args)
+            con_args = Type inst_ty
+                     : map Var super_args  -- the superclass dictionary is either 
+                    ++ super_consts        -- lambda-bound or constant
+                    ++ map (method_call val_args) method_ids
 
           -- Build the type of the dictionary function.
       ; pa_cls <- builtin paClass
       ; let dfun_ty = mkForAllTys tvs
-                    $ mkFunTys (map varType all_args)
+                    $ mkFunTys (map varType val_args)
                                (mkClassPred pa_cls [inst_ty])
 
           -- Set the unfolding for the inliner.
       ; raw_dfun <- newExportedVar dfun_name dfun_ty
-      ; let dfun_unf = mkDFunUnfolding dfun_ty $
-                       map (const $ DFunLamArg 0) super_args
-                       ++ map DFunPolyArg super_consts
-                       ++ map (DFunPolyArg . Var) method_ids
+      ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args
             dfun = raw_dfun `setIdUnfolding`  dfun_unf
                             `setInlinePragma` dfunInlinePragma