Super-monster patch implementing the new typechecker -- at last

[ghc-hetmet.git] / compiler / deSugar / DsBinds.lhs

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 3fe8d54..c886c8e 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,8 +11,8 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 

-                dsCoercion,
-                AutoScc(..)
+                dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
+                DsEvBind(..), AutoScc(..)

   ) where
 
 #include "HsVersions.h"
   ) where
 
 #include "HsVersions.h"

@@ -32,30 +32,34 @@ import CoreUtils
 import CoreArity ( etaExpand )
 import CoreUnfold
 import CoreFVs
 import CoreArity ( etaExpand )
 import CoreUnfold
 import CoreFVs

+import Digraph

 
 import TcType
 
 import TcType

+import Type

 import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
 import Id
 import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
 import Id

+import TyCon   ( tyConDataCons )
+import Class
+import DataCon ( dataConRepType )
+import Name    ( localiseName )

 import MkId    ( seqId )
 import MkId    ( seqId )

-import Var     ( Var, TyVar, tyVarKind )
-import IdInfo  ( vanillaIdInfo )
+import Var

 import VarSet
 import Rules
 import VarEnv
 import Outputable
 import SrcLoc
 import Maybes
 import VarSet
 import Rules
 import VarEnv
 import Outputable
 import SrcLoc
 import Maybes

+import OrdList

 import Bag
 import BasicTypes hiding ( TopLevel )
 import FastString
 import Bag
 import BasicTypes hiding ( TopLevel )
 import FastString

-import StaticFlags     ( opt_DsMultiTyVar )
-import Util            ( count, lengthExceeds )
+-- import StaticFlags  ( opt_DsMultiTyVar )
+import Util

 
 import MonadUtils
 
 import MonadUtils

-import Control.Monad
-import Data.List

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -66,31 +70,27 @@ import Data.List
 
 \begin{code}
 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
 
 \begin{code}
 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]

-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds
+                                  ; return (fromOL binds') }

 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]

-dsLHsBinds binds = ds_lhs_binds NoSccs binds
-
+dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
+                      ; return (fromOL binds') }

 
 ------------------------
 
 ------------------------

-ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))

 
         -- scc annotation policy (see below)
 
         -- scc annotation policy (see below)

-ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
+ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
+                                 ; return (foldBag appOL id nilOL ds_bs) }

 
 

-dsLHsBind :: AutoScc
-        -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
-        -> LHsBind Id
-        -> DsM [(Id,CoreExpr)] -- Result
-dsLHsBind auto_scc rest (L loc bind)
-  = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
+dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind auto_scc (L loc bind)
+  = putSrcSpanDs loc $ dsHsBind auto_scc bind

 
 

-dsHsBind :: AutoScc
-        -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
-        -> HsBind Id
-        -> DsM [(Id,CoreExpr)] -- Result
+dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))

 
 

-dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
+dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })

   = do { core_expr <- dsLExpr expr
 
                -- Dictionary bindings are always VarBinds,
   = do { core_expr <- dsLExpr expr
 
                -- Dictionary bindings are always VarBinds,

@@ -99,115 +99,62 @@ dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_reg
        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
                   | otherwise         = var
 
        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
                   | otherwise         = var
 

-       ; return ((var', core_expr') : rest) }
+       ; return (unitOL (var', core_expr')) }

 
 

-dsHsBind _ rest 
-        (FunBind { fun_id = L _ fun, fun_matches = matches, 
-                   fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) 
+dsHsBind _ (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
  = do  { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
        ; body'    <- mkOptTickBox tick body

-       ; wrap_fn' <- dsCoercion co_fn 
-       ; return ((fun, wrap_fn' (mkLams args body')) : rest) }
+       ; wrap_fn' <- dsHsWrapper co_fn 
+       ; return (unitOL (fun, wrap_fn' (mkLams args body'))) }

 
 

-dsHsBind _ rest 
-        (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+dsHsBind _ (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })

   = do { body_expr <- dsGuarded grhss ty
        ; sel_binds <- mkSelectorBinds pat body_expr
   = do { body_expr <- dsGuarded grhss ty
        ; sel_binds <- mkSelectorBinds pat body_expr

-       ; return (sel_binds ++ rest) }
-
-{-  Note [Rules and inlining]
-    ~~~~~~~~~~~~~~~~~~~~~~~~~
-    Common special case: no type or dictionary abstraction
-    This is a bit less trivial than you might suppose
-    The naive way woudl be to desguar to something like
-       f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
-       M.f = f_lcl             -- Generated from "exports"
-    But we don't want that, because if M.f isn't exported,
-    it'll be inlined unconditionally at every call site (its rhs is 
-    trivial).  That would be ok unless it has RULES, which would 
-    thereby be completely lost.  Bad, bad, bad.
-
-    Instead we want to generate
-       M.f = ...f_lcl...
-       f_lcl = M.f
-    Now all is cool. The RULES are attached to M.f (by SimplCore), 
-    and f_lcl is rapidly inlined away.
-
-    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 -}
-
-dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
-  = do { core_prs <- ds_lhs_binds NoSccs binds
-       ; let env = mkABEnv exports
-             ar_env = mkArityEnv binds
+       ; 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_one (lcl_id, rhs) 
                | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id

-               = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )     -- Not overloaded
-                  makeCorePair gbl_id (lookupArity ar_env lcl_id)
-                              (addAutoScc auto_scc gbl_id rhs)
+               = 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 = (lcl_id, rhs)
+               | otherwise = return [(lcl_id, rhs)]

 
              locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
                        -- Note [Rules and inlining]
 
              locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
                        -- Note [Rules and inlining]

-       ; return (map do_one core_prs ++ locals' ++ rest) }
+        ; 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
 
 
                -- No Rec needed here (contrast the other AbsBinds cases)
                -- because we can rely on the enclosing dsBind to wrap in Rec
 
 

-{- Note [Abstracting over tyvars only]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   When abstracting over type variable only (not dictionaries), we don't really need to
-   built a tuple and select from it, as we do in the general case. Instead we can take
-
-       AbsBinds [a,b] [ ([a,b], fg, fl, _),
-                        ([b],   gg, gl, _) ]
-               { fl = e1
-                 gl = e2
-                  h = e3 }
-
-   and desugar it to
-
-       fg = /\ab. let B in e1
-       gg = /\b. let a = () in let B in S(e2)
-       h  = /\ab. let B in e3
-
-  where B is the *non-recursive* binding
-       fl = fg a b
-       gl = gg b
-       h  = h a b    -- See (b); note shadowing!
-  
-  Notice (a) g has a different number of type variables to f, so we must
-            use the mkArbitraryType thing to fill in the gaps.  
-            We use a type-let to do that.
-
-        (b) The local variable h isn't in the exports, and rather than
-            clone a fresh copy we simply replace h by (h a b), where
-            the two h's have different types!  Shadowing happens here,
-            which looks confusing but works fine.
-
-        (c) The result is *still* quadratic-sized if there are a lot of
-            small bindings.  So if there are more than some small
-            number (10), we filter the binding set B by the free
-            variables of the particular RHS.  Tiresome.
-
-  Why got to this trouble?  It's a common case, and it removes the
-  quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
-  compilation, especially in a case where there are a *lot* of
-  bindings.
--}
-
-
-dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
+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
   | 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]
   =    -- Note [Abstracting over tyvars only]

-    do { core_prs <- ds_lhs_binds NoSccs binds
-       ; let arby_env = mkArbitraryTypeEnv tyvars exports
+    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
              bndrs = mkVarSet (map fst core_prs)
 
              add_lets | core_prs `lengthExceeds` 10 = add_some

@@ -217,9 +164,7 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
                where
                  fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 
                where
                  fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 

-             ar_env = mkArityEnv binds

              env = mkABEnv exports
              env = mkABEnv exports

-

              mk_lg_bind lcl_id gbl_id tyvars
                 = NonRec (setIdInfo lcl_id vanillaIdInfo)
                                -- Nuke the IdInfo so that no old unfoldings
              mk_lg_bind lcl_id gbl_id tyvars
                 = NonRec (setIdInfo lcl_id vanillaIdInfo)
                                -- Nuke the IdInfo so that no old unfoldings

@@ -229,82 +174,90 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 
              do_one lg_binds (lcl_id, rhs) 
                | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
 
              do_one lg_binds (lcl_id, rhs) 
                | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id

-               = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )     -- Not overloaded
-                  (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
-                 in return (mk_lg_bind lcl_id gbl_id id_tvs,
-                            makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs'))
+               = 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,
                | 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))) }
+                              [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }

                                                  
        ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
                                                  
        ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)

-       ; return (core_prs' ++ rest) }
+       ; return (concat core_prs' ++ rest) }
+-}

 
 

-       -- Another common case: one exported variable
+       -- A common case: one exported variable

        -- Non-recursive bindings come through this way
        -- So do self-recursive bindings, and recursive bindings
        -- that have been chopped up with type signatures
        -- Non-recursive bindings come through this way
        -- So do self-recursive bindings, and recursive bindings
        -- that have been chopped up with type signatures

-dsHsBind auto_scc rest
-     (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
+dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
+                                   , abs_exports = [(tyvars, global, local, prags)]
+                                   , abs_ev_binds = ev_binds, abs_binds = binds })

   = ASSERT( all (`elem` tyvars) all_tyvars )
   = ASSERT( all (`elem` tyvars) all_tyvars )

-    do { core_prs <- ds_lhs_binds NoSccs binds
+    do { bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds

 
 

-       ; let   -- Always treat the binds as recursive, because the typechecker
-               -- makes rather mixed-up dictionary bindings
-               core_bind = Rec core_prs
-               inl_arity = lookupArity (mkArityEnv binds) local
+       ; let   core_bind = Rec (fromOL bind_prs)
+               rhs       = addAutoScc auto_scc global $
+                           mkLams tyvars $ mkLams dicts $ 
+                           wrapDsEvBinds ds_ev_binds $
+                            Let core_bind $
+                            Var local

     
     

-       ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global 
-                                        local inl_arity core_bind prags
+       ; (spec_binds, rules) <- dsSpecs global rhs prags

 
        ; let   global'   = addIdSpecialisations global rules
 
        ; let   global'   = addIdSpecialisations global rules

-               rhs       = addAutoScc auto_scc global $
-                           mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
-               main_bind = makeCorePair global' (inl_arity + dictArity dicts) rhs
+               main_bind = makeCorePair global' (isDefaultMethod prags)
+                                         (dictArity dicts) rhs 

     
     

-       ; return (main_bind : spec_binds ++ rest) }
+       ; return (main_bind `consOL` spec_binds) }

 
 

-dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
-  = do { core_prs <- ds_lhs_binds NoSccs binds
+dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
+                            , 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 env = mkABEnv exports
        ; let env = mkABEnv exports

-             ar_env = mkArityEnv binds

              do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
                                  = (lcl_id, addAutoScc auto_scc gbl_id rhs)
                                  | otherwise = (lcl_id,rhs)
               
              do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
                                  = (lcl_id, addAutoScc auto_scc gbl_id rhs)
                                  | otherwise = (lcl_id,rhs)
               

-               -- Rec because of mixed-up dictionary bindings
-             core_bind = Rec (map do_one core_prs)
+             core_bind = Rec (map do_one (fromOL bind_prs))
+               -- Monomorphic recursion possible, hence Rec

 
 

-             tup_expr      = mkBigCoreVarTup locals
-             tup_ty        = exprType tup_expr
-             poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
-                             Let core_bind tup_expr
-             locals        = [local | (_, _, local, _) <- exports]
-             local_tys     = map idType locals
+             tup_expr     = mkBigCoreVarTup locals
+             tup_ty       = exprType tup_expr
+             poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
+                            wrapDsEvBinds ds_ev_binds $
+                            Let core_bind $
+                            tup_expr
+             locals       = [local | (_, _, local, _) <- exports]
+             local_tys    = map idType locals

 
 

-       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
+       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)

 
 

-       ; let mk_bind ((tyvars, global, local, spec_prags), n)  -- locals!!n == local
+       ; let mk_bind ((tyvars, global, _, spec_prags), n)  -- locals!!n == local

                =       -- Need to make fresh locals to bind in the selector,
                        -- because some of the tyvars will be bound to 'Any'
                  do { let ty_args = map mk_ty_arg all_tyvars
                           substitute = substTyWith all_tyvars ty_args
                     ; locals' <- newSysLocalsDs (map substitute local_tys)
                     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
                =       -- Need to make fresh locals to bind in the selector,
                        -- because some of the tyvars will be bound to 'Any'
                  do { let ty_args = map mk_ty_arg all_tyvars
                           substitute = substTyWith all_tyvars ty_args
                     ; locals' <- newSysLocalsDs (map substitute local_tys)
                     ; tup_id  <- newSysLocalDs  (substitute tup_ty)

-                    ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global local 
-                                                     (lookupArity ar_env local) core_bind 
-                                                     spec_prags
-                    ; let global' = addIdSpecialisations global rules
-                          rhs = mkLams tyvars $ mkLams dicts $
+                    ; let rhs = mkLams tyvars $ mkLams dicts $

                                 mkTupleSelector locals' (locals' !! n) tup_id $
                                 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
                                           dicts
                                 mkTupleSelector locals' (locals' !! n) tup_id $
                                 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
                                           dicts

-                    ; return ((global', rhs) : spec_binds) }
+                    ; (spec_binds, rules) <- dsSpecs global
+                                                     (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
+                                                     spec_prags
+                    ; let global' = addIdSpecialisations global rules
+                    ; return ((global', rhs) `consOL` spec_binds) }

                where
                  mk_ty_arg all_tyvar
                        | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
                where
                  mk_ty_arg all_tyvar
                        | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar

@@ -313,55 +266,209 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
        ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
             -- Don't scc (auto-)annotate the tuple itself.
 
        ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
             -- Don't scc (auto-)annotate the tuple itself.
 

-       ; return ((poly_tup_id, poly_tup_expr) : 
-                   (concat export_binds_s ++ rest)) }
+       ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
+                   concatOL export_binds_s) }
+
+--------------------------------------
+data DsEvBind 
+  = LetEvBind          -- Dictionary or coercion
+      CoreBind         -- recursive or non-recursive

 
 

+  | CaseEvBind         -- Coercion binding by superclass selection
+                       -- Desugars to case d of d { K _ g _ _ _ -> ... }                       
+      DictId              -- b   The dictionary
+      AltCon              -- K   Its constructor
+      [CoreBndr]          -- _ g _ _ _   The binders in the alternative
+
+wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
+wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
+  where
+    body_ty = exprType body
+    wrap_one (LetEvBind b)       body = Let b body
+    wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
+
+dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+
+dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
+dsEvBinds bs = return (map dsEvGroup sccs)
+  where
+    sccs :: [SCC EvBind]
+    sccs = stronglyConnCompFromEdgedVertices edges
+
+    edges :: [(EvBind, EvVar, [EvVar])]
+    edges = foldrBag ((:) . mk_node) [] bs 
+
+    mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
+    mk_node b@(EvBind var term) = (b, var, free_vars_of term)
+
+    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 (EvDFunApp _ _ vs) = vs
+    free_vars_of (EvSuperClass d _) = [d]
+
+dsEvGroup :: SCC EvBind -> DsEvBind
+dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
+  | isCoVar co_var      -- An equality superclass
+  = ASSERT( null other_data_cons )
+    CaseEvBind dict (DataAlt data_con) bndrs
+  where
+    (cls, tys) = getClassPredTys (evVarPred dict)
+    (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
+    (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
+    (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)) 
+                                      co_var
+                        | otherwise = mkWildEvBinder p
+    
+dsEvGroup (AcyclicSCC (EvBind v r))
+  = LetEvBind (NonRec v (dsEvTerm r))
+
+dsEvGroup (CyclicSCC bs)
+  = LetEvBind (Rec (map ds_pair bs))
+  where
+    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 (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
+dsEvTerm (EvCoercion co)         = Type co
+dsEvTerm (EvSuperClass d n)
+  = ASSERT( isClassPred (classSCTheta cls !! n) )
+           -- We can only select *dictionary* superclasses
+           -- in terms.  Equality superclasses are dealt with
+           -- in dsEvGroup, where they can generate a case expression
+    Var sc_sel_id `mkTyApps` tys `App` Var d
+  where
+    sc_sel_id  = classSCSelId cls n    -- Zero-indexed
+    (cls, tys) = getClassPredTys (evVarPred d)    
+    

 ------------------------
 ------------------------

-makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr)
-makeCorePair gbl_id arity rhs
-  | isInlinePragma (idInlinePragma gbl_id)
+makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
+makeCorePair gbl_id is_default_method dict_arity rhs
+  | is_default_method                -- Default methods are *always* inlined
+  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
+
+  | not (isInlinePragma inline_prag)
+  = (gbl_id, rhs)
+
+  | Just arity <- inlinePragmaSat inline_prag

        -- Add an Unfolding for an INLINE (but not for NOINLINE)
        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
        -- Add an Unfolding for an INLINE (but not for NOINLINE)
        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]

-  = (gbl_id `setIdUnfolding` mkInlineRule InlSat rhs arity,
-     etaExpand arity rhs)
+  , let real_arity = dict_arity + arity
+        -- NB: The arity in the InlineRule takes account of the dictionaries
+  = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just real_arity),
+     etaExpand real_arity rhs)
+

   | otherwise
   | otherwise

-  = (gbl_id, rhs)
+  = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
+  where
+    inline_prag = idInlinePragma gbl_id
+
+dictArity :: [Var] -> Arity
+-- Don't count coercion variables in arity
+dictArity dicts = count isId dicts
+

 
 ------------------------
 
 ------------------------

-type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag])
+type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)

        -- Maps the "lcl_id" for an AbsBind to
        -- its "gbl_id" and associated pragmas, if any
 
        -- Maps the "lcl_id" for an AbsBind to
        -- its "gbl_id" and associated pragmas, if any
 

-mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> AbsBindEnv
+mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv

 -- Takes the exports of a AbsBinds, and returns a mapping
 --     lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 -- Takes the exports of a AbsBinds, and returns a mapping
 --     lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]

+\end{code}

 
 

-mkArityEnv :: LHsBinds Id -> IdEnv Arity
-       -- Maps a local to the arity of its definition
-mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds
+Note [Rules and inlining]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Common special case: no type or dictionary abstraction
+This is a bit less trivial than you might suppose
+The naive way woudl be to desguar to something like
+       f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
+       M.f = f_lcl             -- Generated from "exports"
+But we don't want that, because if M.f isn't exported,
+it'll be inlined unconditionally at every call site (its rhs is 
+trivial).  That would be ok unless it has RULES, which would 
+thereby be completely lost.  Bad, bad, bad.
+
+Instead we want to generate
+       M.f = ...f_lcl...
+       f_lcl = M.f
+Now all is cool. The RULES are attached to M.f (by SimplCore), 
+and f_lcl is rapidly inlined away.
+
+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 -}
+
+Note [Specialising in no-dict case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even if there are no tyvars or dicts, we may have specialisation pragmas.
+Class methods can generate
+      AbsBinds [] [] [( ... spec-prag]
+         { AbsBinds [tvs] [dicts] ...blah }
+So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
+
+  class  (Real a, Fractional a) => RealFrac a  where
+    round :: (Integral b) => a -> b
+
+  instance  RealFrac Float  where
+    {-# SPECIALIZE round :: Float -> Int #-}
+
+The top-level AbsBinds for $cround has no tyvars or dicts (because the 
+instance does not).  But the method is locally overloaded!
+
+Note [Abstracting over tyvars only]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When abstracting over type variable only (not dictionaries), we don't really need to
+built a tuple and select from it, as we do in the general case. Instead we can take

 
 

-lhsBindArity :: LHsBind Id -> IdEnv Arity
-lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) 
-  = unitVarEnv (unLoc id) (matchGroupArity ms)
-lhsBindArity (L _ (AbsBinds { abs_exports = exports
-                            , abs_dicts = dicts
-                            , abs_binds = binds })) 
-  = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts) 
-             | (_, gbl, lcl, _) <- exports]
-  where             -- See Note [Nested arities] 
-    ar_env = mkArityEnv binds
-    n_val_dicts = dictArity dicts      
+       AbsBinds [a,b] [ ([a,b], fg, fl, _),
+                        ([b],   gg, gl, _) ]
+               { fl = e1
+                 gl = e2
+                  h = e3 }

 
 

-lhsBindArity _ = emptyVarEnv   -- PatBind/VarBind
+and desugar it to

 
 

-dictArity :: [Var] -> Arity
--- Don't count coercion variables in arity
-dictArity dicts = count isId dicts
+       fg = /\ab. let B in e1
+       gg = /\b. let a = () in let B in S(e2)
+       h  = /\ab. let B in e3
+
+where B is the *non-recursive* binding
+       fl = fg a b
+       gl = gg b
+       h  = h a b    -- See (b); note shadowing!
+
+Notice (a) g has a different number of type variables to f, so we must
+            use the mkArbitraryType thing to fill in the gaps.  
+            We use a type-let to do that.
+
+        (b) The local variable h isn't in the exports, and rather than
+            clone a fresh copy we simply replace h by (h a b), where
+            the two h's have different types!  Shadowing happens here,
+            which looks confusing but works fine.
+
+        (c) The result is *still* quadratic-sized if there are a lot of
+            small bindings.  So if there are more than some small
+            number (10), we filter the binding set B by the free
+            variables of the particular RHS.  Tiresome.
+
+Why got to this trouble?  It's a common case, and it removes the
+quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
+compilation, especially in a case where there are a *lot* of
+bindings.

 
 

-lookupArity :: IdEnv Arity -> Id -> Arity
-lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
-\end{code}

 
 Note [Eta-expanding INLINE things]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Eta-expanding INLINE things]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -397,66 +504,81 @@ gotten from the binding for fromT_1.
 It might be better to have just one level of AbsBinds, but that requires more
 thought!
 
 It might be better to have just one level of AbsBinds, but that requires more
 thought!
 

+Note [Implementing SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example:
+       f :: (Eq a, Ix b) => a -> b -> Bool
+       {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
+        f = <poly_rhs>
+
+From this the typechecker generates
+
+    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
+
+    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
+                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
+
+Note that wrap_fn can transform *any* function with the right type prefix 
+    forall ab. (Eq a, Ix b) => XXX
+regardless of XXX.  It's sort of polymorphic in XXX.  This is
+useful: we use the same wrapper to transform each of the class ops, as
+well as the dict.
+
+From these we generate:
+
+    Rule:      forall p, q, (dp:Ix p), (dq:Ix q). 
+                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
+
+    Spec bind: f_spec = wrap_fn <poly_rhs>
+
+Note that 
+
+  * The LHS of the rule may mention dictionary *expressions* (eg
+    $dfIxPair dp dq), and that is essential because the dp, dq are
+    needed on the RHS.
+
+  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
+    can fully specialise it.

 
 \begin{code}
 ------------------------
 
 \begin{code}
 ------------------------

-dsSpecs :: [TyVar] -> [DictId] -> [TyVar]
-        -> Id -> Id -> Arity           -- Global, local, arity of local
-        -> CoreBind -> [LSpecPrag]
-        -> DsM ( [(Id,CoreExpr)]       -- Binding for specialised Ids
+dsSpecs :: Id          -- The polymorphic Id
+        -> CoreExpr     -- Its rhs
+        -> TcSpecPrags
+        -> DsM ( OrdList (Id,CoreExpr)         -- Binding for specialised Ids

               , [CoreRule] )           -- Rules for the Global Ids
               , [CoreRule] )           -- Rules for the Global Ids

--- Example:
---     f :: (Eq a, Ix b) => a -> b -> b
---     {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
---
---     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
--- 
---     SpecPrag (/\b.\(d:Ix b). f Int b dInt d) 
---              (forall b. Ix b => Int -> b -> b)
---
--- Rule:       forall b,(d:Ix b). f Int b dInt d = f_spec b d
---
--- Spec bind:  f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono 
---                      /\b.\(d:Ix b). in f Int b dInt d
---             The idea is that f occurs just once, so it'll be 
---             inlined and specialised
---
--- Given SpecPrag (/\as.\ds. f es) t, we have
--- the defn            f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
---                                    in f es 
--- and the RULE                forall as, ds. f es = f_spec as ds
---
--- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
--- (a bit silly, because then the 
-
-dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
-  = do { pairs <- mapMaybeM spec_one prags
-       ; let (spec_binds_s, rules) = unzip pairs
-       ; return (concat spec_binds_s, rules) }
+-- 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 
  where 

-    spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
+    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
     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   <- dsCoercion spec_co
-           ; let ds_spec_expr = wrap_fn (Var poly_id)
-          ; case decomposeRuleLhs ds_spec_expr of {
+          ; 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 } ;
 
               Nothing -> do { warnDs (decomp_msg spec_co)
                              ; return Nothing } ;
 

-              Just (bndrs, _fn, args) ->
+              Just (_fn, args) ->

 
           -- Check for dead binders: Note [Unused spec binders]
 
           -- Check for dead binders: Note [Unused spec binders]

-            case filter isDeadBinder bndrs of {
-               bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
-                  | otherwise -> do
+             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 (idUnfolding poly_id)
+          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)

 
 

-          ; let f_body = fix_up (Let mono_bind (Var mono_id))
-                 spec_ty = exprType ds_spec_expr
-                spec_id  = mkLocalId spec_name spec_ty 
+          ; let spec_id  = mkLocalId spec_name spec_ty 

                            `setInlinePragma` inl_prag
                            `setIdUnfolding`  spec_unf
                 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
                            `setInlinePragma` inl_prag
                            `setIdUnfolding`  spec_unf
                 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id

@@ -464,31 +586,21 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
                      -- Get the INLINE pragma from SPECIALISE declaration, or,
                       -- failing that, from the original Id
 
                      -- Get the INLINE pragma from SPECIALISE declaration, or,
                       -- failing that, from the original Id
 

-                spec_id_arity = inl_arity + count isDictId bndrs
-
-                extra_dict_bndrs = [ localiseId d  -- See Note [Constant rule dicts]
-                                        | d <- varSetElems (exprFreeVars ds_spec_expr)
-                                        , isDictId d]
-                               -- Note [Const rule dicts]
+                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)
 
 
                 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 (mkLams (tvs ++ dicts) f_body)
-                 spec_pair = makeCorePair spec_id spec_id_arity spec_rhs
-
-           ; return (Just (spec_pair : unf_pairs, rule))
-           } } } }
+                 spec_rhs  = wrap_fn poly_rhs
+                 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs

 
 

-       -- Bind to Any any of all_ptvs that aren't 
-       -- relevant for this particular function 
-    fix_up body | null void_tvs = body
-               | otherwise     = mkTyApps (mkLams void_tvs body) $
-                                  map dsMkArbitraryType void_tvs
-
-    void_tvs = all_tvs \\ tvs
+           ; return (Just (spec_pair `consOL` unf_pairs, rule))
+           } } }

 
     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
                                 <+> ptext (sLit "in specialied type:"),
 
     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
                                 <+> ptext (sLit "in specialied type:"),

@@ -501,14 +613,16 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
             2 (pprHsWrapper (ppr poly_id) spec_co)
             
 
             2 (pprHsWrapper (ppr poly_id) spec_co)
             
 

-specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
-specUnfolding wrap_fn (DFunUnfolding con ops)
+specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
+              -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
+specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)

   = do { let spec_rhss = map wrap_fn ops
        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
   = do { let spec_rhss = map wrap_fn ops
        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss

-       ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
-specUnfolding _ _
-  = return (noUnfolding, [])
+       ; 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 :: [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

@@ -524,6 +638,7 @@ mkArbitraryTypeEnv tyvars exports
                                      , not (tv `elemVarEnv` env)]
 
     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
                                      , not (tv `elemVarEnv` env)]
 
     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)

+-}

 
 dsMkArbitraryType :: TcTyVar -> Type
 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 
 dsMkArbitraryType :: TcTyVar -> Type
 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)

@@ -544,7 +659,7 @@ 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.
 
 but it seems better to reject the program because it's almost certainly
 a mistake.  That's what the isDeadBinder call detects.
 

-Note [Const rule dicts]
+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 
 ~~~~~~~~~~~~~~~~~~~~~~~
 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 

@@ -565,8 +680,9 @@ And from that we want the rule
 
 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
 
 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. Hence the use of 'localiseId' to make it Internal.
-
+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.

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -575,37 +691,51 @@ confused. Hence the use of 'localiseId' to make it Internal.
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
+decomposeRuleLhs :: CoreExpr -> Maybe (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 
 -- 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 

-  = case collectArgs body of
-        (Var fn, args) -> Just (bndrs, fn, args)
+  =  -- Note [Simplifying the left-hand side of a RULE]
+    case collectArgs (simpleOptExpr lhs) of
+        (Var fn, args) -> Just (fn, args)

 
         (Case scrut bndr ty [(DEFAULT, _, body)], args)
                | isDeadBinder bndr     -- Note [Matching seqId]
 
         (Case scrut bndr ty [(DEFAULT, _, body)], args)
                | isDeadBinder bndr     -- Note [Matching seqId]

-               -> Just (bndrs, seqId, args' ++ args)
+               -> Just (seqId, args' ++ args)

                where
                   args' = [Type (idType bndr), Type ty, scrut, body]
           
        _other -> Nothing       -- Unexpected shape
                where
                   args' = [Type (idType bndr), Type ty, scrut, body]
           
        _other -> Nothing       -- Unexpected shape

-  where
-    (bndrs, body) = collectBinders (simpleOptExpr lhs)
-       -- simpleOptExpr occurrence-analyses and simplifies the lhs
-       -- and thereby
-       -- (a) identifies unused binders: Note [Unused spec binders]
-       -- (b) sorts dict bindings into NonRecs 
-       --      so they can be inlined by 'decomp'
-       -- (c) substitute trivial lets so that they don't get in the way
-       --     Note that we substitute the function too; we might 
-       --     have this as a LHS:  let f71 = M.f Int in f71
-        -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
-       --     dictionary expressions that we might have to match

 \end{code}
 
 \end{code}
 

+Note [Simplifying the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+simpleOptExpr occurrence-analyses and simplifies the lhs
+and thereby
+(a) sorts dict bindings into NonRecs and inlines them
+(b) substitute trivial lets so that they don't get in the way
+    Note that we substitute the function too; we might 
+    have this as a LHS:  let f71 = M.f Int in f71
+(c) does eta reduction
+
+For (c) consider the fold/build rule, which without simplification
+looked like:
+       fold k z (build (/\a. g a))  ==>  ...
+This doesn't match unless you do eta reduction on the build argument.
+Similarly for a LHS like
+       augment g (build h) 
+we do not want to get
+       augment (\a. g a) (build h)
+otherwise we don't match when given an argument like
+       augment (\a. h a a) (build h)
+
+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
 Note [Matching seqId]
 ~~~~~~~~~~~~~~~~~~~
 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack

@@ -623,6 +753,7 @@ See Note [Rules for seq] in MkId for the details.
 data AutoScc = NoSccs 
             | AddSccs Module (Id -> Bool)
 -- The (Id->Bool) says which Ids to add SCCs to 
 data AutoScc = NoSccs 
             | AddSccs Module (Id -> Bool)
 -- The (Id->Bool) says which Ids to add SCCs to 

+-- But we never add a SCC to function marked INLINE

 
 addAutoScc :: AutoScc  
           -> Id        -- Binder
 
 addAutoScc :: AutoScc  
           -> Id        -- Binder

@@ -631,6 +762,8 @@ addAutoScc :: AutoScc
 
 addAutoScc NoSccs _ rhs
   = rhs
 
 addAutoScc NoSccs _ rhs
   = rhs

+addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
+  = rhs

 addAutoScc (AddSccs mod add_scc) id rhs
   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
   | otherwise  = rhs
 addAutoScc (AddSccs mod add_scc) id rhs
   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
   | otherwise  = rhs

@@ -664,19 +797,16 @@ addDictScc _ rhs = return rhs
 
 
 \begin{code}
 
 
 \begin{code}

-dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
-dsCoercion WpHole           = return (\e -> e)
-dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1 
-                                  ; k2 <- dsCoercion c2
-                                  ; return (k1 . k2) }
-dsCoercion (WpCast co)       = return (\e -> Cast e co) 
-dsCoercion (WpLam id)        = return (\e -> Lam id e) 
-dsCoercion (WpTyLam tv)      = return (\e -> Lam tv e) 
-dsCoercion (WpApp v)         | isTyVar v   -- Probably a coercion var
-                             = return (\e -> App e (Type (mkTyVarTy v)))
-                            | otherwise
-                             = return (\e -> App e (Var v))
-dsCoercion (WpTyApp ty)      = return (\e -> App e (Type ty))
-dsCoercion (WpLet bs)        = do { prs <- dsLHsBinds bs
-                                 ; return (\e -> Let (Rec prs) e) }
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsHsWrapper WpHole           = return (\e -> e)
+dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
+dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+                                   ; return (wrapDsEvBinds ds_ev_binds) }
+dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
+                                   ; k2 <- dsHsWrapper c2
+                                   ; return (k1 . k2) }
+dsHsWrapper (WpCast co)       = return (\e -> Cast e co) 
+dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
+dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
+dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))

 \end{code}
 \end{code}