merge GHC HEAD
[ghc-hetmet.git] / compiler / deSugar / DsBinds.lhs
index 17333af..65cb815 100644 (file)
@@ -10,7 +10,7 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
 lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
-module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
                 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
                 DsEvBind(..), AutoScc(..)
   ) where
@@ -36,6 +36,7 @@ import Digraph
 
 import TcType
 import Type
+import Coercion
 import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
@@ -56,7 +57,6 @@ import OrdList
 import Bag
 import BasicTypes hiding ( TopLevel )
 import FastString
--- import StaticFlags  ( opt_DsMultiTyVar )
 import Util
 
 import MonadUtils
@@ -69,9 +69,8 @@ import MonadUtils
 %************************************************************************
 
 \begin{code}
-dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds
-                                  ; return (fromOL binds') }
+dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
+dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
 dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
@@ -91,7 +90,7 @@ dsLHsBind auto_scc (L loc bind)
 dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
 
 dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
-  = do { core_expr <- dsLExpr expr
+  = do  { core_expr <- dsLExpr expr
 
                -- Dictionary bindings are always VarBinds,
                -- so we only need do this here
@@ -99,98 +98,25 @@ dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardle
        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
                   | otherwise         = var
 
-       ; return (unitOL (var', core_expr')) }
+       ; return (unitOL (makeCorePair var' False 0 core_expr')) }
 
-dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches 
+dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches
                    , fun_co_fn = co_fn, fun_tick = tick 
                     , fun_infix = inf }) 
  = do  { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
        ; body'    <- mkOptTickBox tick body
        ; wrap_fn' <- dsHsWrapper co_fn 
-       ; return (unitOL (fun, wrap_fn' (mkLams args body'))) }
+       ; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
+       ; return (unitOL (makeCorePair fun False 0 rhs)) }
 
-dsHsBind _ (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
   = do { body_expr <- dsGuarded grhss ty
        ; sel_binds <- mkSelectorBinds pat body_expr
-       ; return (toOL sel_binds) }
-
-{-
-dsHsBind auto_scc (AbsBinds { abs_tvs = [], abs_ev_vars = []
-                                   , abs_exports = exports, abs_ev_binds = ev_binds
-                                   , abs_binds = binds })
-  = do { bind_prs    <- ds_lhs_binds NoSccs binds
-        ; ds_ev_binds <- dsTcEvBinds ev_binds
-
-       ; let core_prs = addEvPairs ds_ev_binds bind_prs
-              env = mkABEnv exports
-             do_one (lcl_id, rhs) 
-               | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
-               = do { let rhs' = addAutoScc auto_scc gbl_id rhs
-                    ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
-                                   -- See Note [Specialising in no-dict case]
-                     ; let   gbl_id'   = addIdSpecialisations gbl_id rules
-                             main_bind = makeCorePair gbl_id' False 0 rhs'
-                    ; return (main_bind : spec_binds) }
-
-               | otherwise = return [(lcl_id, rhs)]
-
-             locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
-                       -- Note [Rules and inlining]
-        ; export_binds <- mapM do_one core_prs
-       ; return (concat export_binds ++ locals' ++ rest) }
-               -- No Rec needed here (contrast the other AbsBinds cases)
-               -- because we can rely on the enclosing dsBind to wrap in Rec
-
-
-dsHsBind auto_scc rest (AbsBinds { abs_tvs = tyvars, abs_ev_vars = []
-                                        , abs_exports = exports, abs_ev_binds = ev_binds
-                                        , abs_binds = binds })
-  | opt_DsMultiTyVar   -- This (static) debug flag just lets us
-                       -- switch on and off this optimisation to
-                       -- see if it has any impact; it is on by default
-  , allOL isLazyEvBind ev_binds
-  =    -- Note [Abstracting over tyvars only]
-    do { bind_prs    <- ds_lhs_binds NoSccs binds
-        ; ds_ev_binds <- dsTcEvBinds ev_binds
-
-       ; let core_prs = addEvPairs ds_ev_binds bind_prs
-              arby_env = mkArbitraryTypeEnv tyvars exports
-             bndrs = mkVarSet (map fst core_prs)
-
-             add_lets | core_prs `lengthExceeds` 10 = add_some
-                      | otherwise                   = mkLets
-             add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
-                                                         , b `elemVarSet` fvs] rhs
-               where
-                 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
-
-             env = mkABEnv exports
-             mk_lg_bind lcl_id gbl_id tyvars
-                = NonRec (setIdInfo lcl_id vanillaIdInfo)
-                               -- Nuke the IdInfo so that no old unfoldings
-                               -- confuse use (it might mention something not
-                               -- even in scope at the new site
-                         (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
-
-             do_one lg_binds (lcl_id, rhs) 
-               | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
-               = do { let rhs' = addAutoScc auto_scc gbl_id  $
-                                 mkLams id_tvs $
-                                 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
-                                        | tv <- tyvars, not (tv `elem` id_tvs)] $
-                                 add_lets lg_binds rhs
-                    ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
-                     ; let   gbl_id'   = addIdSpecialisations gbl_id rules
-                             main_bind = makeCorePair gbl_id' False 0 rhs'
-                    ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }
-               | otherwise
-               = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
-                    ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
-                              [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }
-                                                 
-       ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
-       ; return (concat core_prs' ++ rest) }
--}
+         -- We silently ignore inline pragmas; no makeCorePair
+         -- Not so cool, but really doesn't matter
+    ; let sel_binds' = [ (v, addAutoScc auto_scc v expr)
+                       | (v, expr) <- sel_binds ]
+       ; return (toOL sel_binds') }
 
        -- A common case: one exported variable
        -- Non-recursive bindings come through this way
@@ -210,7 +136,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
                             Let core_bind $
                             Var local
     
-       ; (spec_binds, rules) <- dsSpecs global rhs prags
+       ; (spec_binds, rules) <- dsSpecs rhs prags
 
        ; let   global'   = addIdSpecialisations global rules
                main_bind = makeCorePair global' (isDefaultMethod prags)
@@ -253,9 +179,9 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
                                 mkTupleSelector locals' (locals' !! n) tup_id $
                                 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
                                           dicts
-                    ; (spec_binds, rules) <- dsSpecs global
-                                                     (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
-                                                     spec_prags
+                           full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
+                    ; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
+                                                     
                     ; let global' = addIdSpecialisations global rules
                     ; return ((global', rhs) `consOL` spec_binds) }
                where
@@ -305,8 +231,8 @@ dsEvBinds bs = return (map dsEvGroup sccs)
 
     free_vars_of :: EvTerm -> [EvVar]
     free_vars_of (EvId v)           = [v]
-    free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
-    free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
+    free_vars_of (EvCast v co)      = v : varSetElems (tyCoVarsOfCo co)
+    free_vars_of (EvCoercion co)    = varSetElems (tyCoVarsOfCo co)
     free_vars_of (EvDFunApp _ _ vs) = vs
     free_vars_of (EvSuperClass d _) = [d]
 
@@ -322,7 +248,7 @@ dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
     (arg_tys, _) = splitFunTys rho
     bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
                    ++ map mkWildValBinder arg_tys
-    mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
+    mk_wild_pred (p, i) | i==n      = ASSERT( p `eqPred` (coVarPred co_var)) 
                                       co_var
                         | otherwise = mkWildEvBinder p
     
@@ -335,10 +261,10 @@ dsEvGroup (CyclicSCC bs)
     ds_pair (EvBind v r) = (v, dsEvTerm r)
 
 dsEvTerm :: EvTerm -> CoreExpr
-dsEvTerm (EvId v)                       = Var v
-dsEvTerm (EvCast v co)                  = Cast (Var v) co 
+dsEvTerm (EvId v)                = Var v
+dsEvTerm (EvCast v co)           = Cast (Var v) co
 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co)         = Type co
+dsEvTerm (EvCoercion co)         = Coercion co
 dsEvTerm (EvSuperClass d n)
   = ASSERT( isClassPred (classSCTheta cls !! n) )
            -- We can only select *dictionary* superclasses
@@ -417,7 +343,7 @@ This does not happen in the same way to polymorphic binds,
 because they desugar to
        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 Although I'm a bit worried about whether full laziness might
-float the f_lcl binding out and then inline M.f at its call site -}
+float the f_lcl binding out and then inline M.f at its call site
 
 Note [Specialising in no-dict case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -550,148 +476,83 @@ Note that
 
 \begin{code}
 ------------------------
-dsSpecs :: Id          -- The polymorphic Id
-        -> CoreExpr     -- Its rhs
+dsSpecs :: CoreExpr     -- Its rhs
         -> TcSpecPrags
         -> DsM ( OrdList (Id,CoreExpr)         -- Binding for specialised Ids
               , [CoreRule] )           -- Rules for the Global Ids
 -- See Note [Implementing SPECIALISE pragmas]
-dsSpecs poly_id poly_rhs prags
-  = case prags of
-      IsDefaultMethod      -> return (nilOL, [])
-      SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
-                          ; let (spec_binds_s, rules) = unzip pairs
-                          ; return (concatOL spec_binds_s, rules) }
- where 
-    spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-    spec_one (L loc (SpecPrag spec_co spec_inl))
-      = putSrcSpanDs loc $ 
-        do { let poly_name = idName poly_id
-          ; spec_name <- newLocalName poly_name
-          ; wrap_fn   <- dsHsWrapper spec_co
-           ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
-                 spec_ty = mkPiTypes bndrs (exprType ds_lhs)
-          ; case decomposeRuleLhs ds_lhs of {
-              Nothing -> do { warnDs (decomp_msg spec_co)
-                             ; return Nothing } ;
-
-              Just (_fn, args) ->
-
-          -- Check for dead binders: Note [Unused spec binders]
-             let arg_fvs = exprsFreeVars args
-                 bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
-            in if not (null bad_bndrs)
-                then do { warnDs (dead_msg bad_bndrs); return Nothing } 
-               else do
-
-          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
-
-          ; let spec_id  = mkLocalId spec_name spec_ty 
-                           `setInlinePragma` inl_prag
-                           `setIdUnfolding`  spec_unf
-                inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
-                         | otherwise                      = spec_inl
-                     -- Get the INLINE pragma from SPECIALISE declaration, or,
-                      -- failing that, from the original Id
-
-                extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
-                                            -- See Note [Constant rule dicts]
-                                   | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
-                                   , isDictId d]
-
-                rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
-                               AlwaysActive poly_name
-                               (extra_dict_bndrs ++ bndrs) args
-                               (mkVarApps (Var spec_id) bndrs)
-
-                 spec_rhs  = wrap_fn poly_rhs
-                 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
-
-           ; return (Just (spec_pair `consOL` unf_pairs, rule))
-           } } }
-
-    dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
-                                <+> ptext (sLit "in specialied type:"),
-                            nest 2 (pprTheta (map get_pred bs))]
-                      , ptext (sLit "SPECIALISE pragma ignored")]
-    get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
-
-    decomp_msg spec_co 
-        = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
-            2 (pprHsWrapper (ppr poly_id) spec_co)
-            
+dsSpecs _ IsDefaultMethod = return (nilOL, [])
+dsSpecs poly_rhs (SpecPrags sps)
+  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
+       ; let (spec_binds_s, rules) = unzip pairs
+       ; return (concatOL spec_binds_s, rules) }
+
+dsSpec :: Maybe CoreExpr       -- Just rhs => RULE is for a local binding
+                                       -- Nothing => RULE is for an imported Id
+                               --            rhs is in the Id's unfolding
+       -> Located TcSpecPrag
+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
+  = putSrcSpanDs loc $ 
+    do { let poly_name = idName poly_id
+       ; spec_name <- newLocalName poly_name
+       ; wrap_fn   <- dsHsWrapper spec_co
+       ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
+             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
+
+       { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
+
+       ; let spec_id  = mkLocalId spec_name spec_ty 
+                           `setInlinePragma` inl_prag
+                           `setIdUnfolding`  spec_unf
+             inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
+                     | otherwise                      = spec_inl
+                     -- Get the INLINE pragma from SPECIALISE declaration, or,
+              -- failing that, from the original Id
+
+             rule =  mkRule False {- Not auto -} is_local_id
+                        (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
+                               AlwaysActive poly_name
+                               final_bndrs args
+                               (mkVarApps (Var spec_id) bndrs)
+
+             spec_rhs  = wrap_fn poly_rhs
+             spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
+
+       ; return (Just (spec_pair `consOL` unf_pairs, rule))
+       } } }
+  where
+    is_local_id = isJust mb_poly_rhs
+    poly_rhs | Just rhs <-  mb_poly_rhs
+             = rhs         -- Local Id; this is its rhs
+             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+             = unfolding    -- Imported Id; this is its unfolding
+                           -- Use realIdUnfolding so we get the unfolding 
+                           -- even when it is a loop breaker. 
+                           -- We want to specialise recursive functions!
+             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+                           -- The type checker has checked that it *has* an unfolding
 
 specUnfolding :: (CoreExpr -> CoreExpr) -> 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 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)
 
-{-
-mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
--- If any of the tyvars is missing from any of the lists in 
--- the second arg, return a binding in the result
-mkArbitraryTypeEnv tyvars exports
-  = go emptyVarEnv exports
-  where
-    go env [] = env
-    go env ((ltvs, _, _, _) : exports)
-       = go env' exports
-        where
-          env' = foldl extend env [tv | tv <- tyvars
-                                     , not (tv `elem` ltvs)
-                                     , not (tv `elemVarEnv` env)]
-
-    extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
--}
-
 dsMkArbitraryType :: TcTyVar -> Type
 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 \end{code}
 
-Note [Unused spec binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-       f :: a -> a
-       {-# SPECIALISE f :: Eq a => a -> a #-}
-It's true that this *is* a more specialised type, but the rule
-we get is something like this:
-       f_spec d = f
-       RULE: f = f_spec d
-Note that the rule is bogus, becuase it mentions a 'd' that is
-not bound on the LHS!  But it's a silly specialisation anyway, becuase
-the constraint is unused.  We could bind 'd' to (error "unused")
-but it seems better to reject the program because it's almost certainly
-a mistake.  That's what the isDeadBinder call detects.
-
-Note [Constant rule dicts]
-~~~~~~~~~~~~~~~~~~~~~~~
-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) 
-
-And from that we want the rule
-       
-       RULE forall dInt. f Int dInt = f_spec
-       f_spec = let f = <rhs> in f Int dInt
-
-But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
-Name, and you can't bind them in a lambda or forall without getting things
-confused.   Likewise it might have an InlineRule or something, which would be
-utterly bogus. So we really make a fresh Id, with the same unique and type
-as the old one, but with an Internal name and no IdInfo.
-
 %************************************************************************
 %*                                                                     *
 \subsection{Adding inline pragmas}
@@ -699,24 +560,51 @@ as the old one, but with an Internal name and no IdInfo.
 %************************************************************************
 
 \begin{code}
-decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
+decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
 -- Take apart the LHS of a RULE.  It's suuposed to look like
 --     /\a. f a Int dOrdInt
 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 -- That is, the RULE binders are lambda-bound
 -- Returns Nothing if the LHS isn't of the expected shape
-decomposeRuleLhs lhs 
+decomposeRuleLhs bndrs lhs 
   =  -- Note [Simplifying the left-hand side of a RULE]
-    case collectArgs (simpleOptExpr lhs) of
-        (Var fn, args) -> Just (fn, args)
+    case collectArgs opt_lhs of
+        (Var fn, args) -> check_bndrs fn args
 
         (Case scrut bndr ty [(DEFAULT, _, body)], args)
                | isDeadBinder bndr     -- Note [Matching seqId]
-               -> Just (seqId, args' ++ args)
+               -> check_bndrs seqId (args' ++ args)
                where
                   args' = [Type (idType bndr), Type ty, scrut, body]
           
-       _other -> Nothing       -- Unexpected shape
+       _other -> Left bad_shape_msg
+ where
+   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))
+     where
+       arg_fvs = exprsFreeVars args
+
+            -- Check for dead binders: Note [Unused spec binders]
+       dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
+
+            -- Add extra dict binders: Note [Constant rule dicts]
+       extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
+                          | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
+                         , isDictId d]
+
+
+   bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
+                      2 (ppr opt_lhs)
+   dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
+                            , ptext (sLit "is not bound in RULE lhs")])
+                      2 (ppr opt_lhs)
+   pp_bndr bndr
+    | isTyVar bndr  = ptext (sLit "type variable") <+> quotes (ppr bndr)
+    | isEvVar bndr  = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr))
+    | otherwise     = ptext (sLit "variable") <+> quotes (ppr bndr)
 \end{code}
 
 Note [Simplifying the left-hand side of a RULE]
@@ -743,13 +631,52 @@ otherwise we don't match when given an argument like
 NB: tcSimplifyRuleLhs is very careful not to generate complicated
     dictionary expressions that we might have to match
 
-
 Note [Matching seqId]
 ~~~~~~~~~~~~~~~~~~~
 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
 and this code turns it back into an application of seq!  
 See Note [Rules for seq] in MkId for the details.
 
+Note [Unused spec binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+       f :: a -> a
+       {-# SPECIALISE f :: Eq a => a -> a #-}
+It's true that this *is* a more specialised type, but the rule
+we get is something like this:
+       f_spec d = f
+       RULE: f = f_spec d
+Note that the rule is bogus, becuase it mentions a 'd' that is
+not bound on the LHS!  But it's a silly specialisation anyway, becuase
+the constraint is unused.  We could bind 'd' to (error "unused")
+but it seems better to reject the program because it's almost certainly
+a mistake.  That's what the isDeadBinder call detects.
+
+Note [Constant rule dicts]
+~~~~~~~~~~~~~~~~~~~~~~~
+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) 
+
+And from that we want the rule
+       
+       RULE forall dInt. f Int dInt = f_spec
+       f_spec = let f = <rhs> in f Int dInt
+
+But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
+Name, and you can't bind them in a lambda or forall without getting things
+confused.   Likewise it might have an InlineRule or something, which would be
+utterly bogus. So we really make a fresh Id, with the same unique and type
+as the old one, but with an Internal name and no IdInfo.
+
 
 %************************************************************************
 %*                                                                     *