merge GHC HEAD

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

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 0bb7045..65cb815 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -10,9 +10,9 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
 lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}

-module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
-                dsCoercion,
-                AutoScc(..)
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
+                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 Coercion

 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 Util

 
 import MonadUtils
 
 import MonadUtils

-import Control.Monad
-import Data.List

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

@@ -65,33 +69,28 @@ import Data.List
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

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

 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
 
 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 })
-  = do { core_expr <- dsLExpr expr
+dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
+  = do  { core_expr <- dsLExpr expr

 
                -- Dictionary bindings are always VarBinds,
                -- so we only need do this here
 
                -- Dictionary bindings are always VarBinds,
                -- so we only need do this here

@@ -99,212 +98,92 @@ 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 (makeCorePair var' False 0 core_expr')) }

 
 

-dsHsBind _ rest 
-        (FunBind { fun_id = L _ fun, fun_matches = matches, 
-                   fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) 
+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
  = 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 
+       ; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
+       ; return (unitOL (makeCorePair fun False 0 rhs)) }

 
 

-dsHsBind _ rest 
-        (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
   = 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
-             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)
-
-               | otherwise = (lcl_id, rhs)
-
-             locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
-                       -- Note [Rules and inlining]
-       ; return (map do_one core_prs ++ locals' ++ rest) }
-               -- 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.
+         -- 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') }

 
 

-  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)
-  | 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
-  =    -- Note [Abstracting over tyvars only]
-    do { core_prs <- ds_lhs_binds NoSccs binds
-       ; let 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
-
-             ar_env = mkArityEnv binds
-             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
-               = 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'))
-               | 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 (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 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) }
+                           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
                  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 +192,217 @@ 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 (tyCoVarsOfCo co)
+    free_vars_of (EvCoercion co)    = varSetElems (tyCoVarsOfCo 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 `eqPred` (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)         = Coercion 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)
+
+  | otherwise
+  = case inlinePragmaSpec inline_prag of
+         EmptyInlineSpec -> (gbl_id, rhs)
+         NoInline        -> (gbl_id, rhs)
+         Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          Inline          -> inline_pair
+
+  where
+    inline_prag   = idInlinePragma gbl_id
+    inlinable_unf = mkInlinableUnfolding rhs
+    inline_pair
+       | 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)
-  | otherwise
-  = (gbl_id, rhs)
+       , let real_arity = dict_arity + arity
+        -- NB: The arity in the InlineRule takes account of the dictionaries
+       = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
+         , etaExpand real_arity rhs)
+
+       | otherwise
+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
+         (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
+
+
+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,138 +438,205 @@ 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 :: 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
+-- See Note [Implementing SPECIALISE pragmas]
+dsSpecs _ IsDefaultMethod = return (nilOL, [])
+dsSpecs poly_rhs (SpecPrags sps)
+  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps

        ; let (spec_binds_s, rules) = unzip pairs
        ; let (spec_binds_s, rules) = unzip pairs

-       ; return (concat spec_binds_s, rules) }
- where 
-    spec_one :: LSpecPrag -> DsM (Maybe ([(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   <- dsCoercion spec_co
-           ; let ds_spec_expr = wrap_fn (Var poly_id)
-          ; case decomposeRuleLhs ds_spec_expr of {
-              Nothing -> do { warnDs (decomp_msg spec_co)
-                             ; return Nothing } ;
-
-              Just (bndrs, _fn, args) ->
-
-          -- 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
-
-          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (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 
-                           `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
-
-                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]
-
-                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))
-           } } } }
-
-       -- 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
-
-    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)
-            
-
-specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
-specUnfolding wrap_fn (DFunUnfolding con ops)
+       ; 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
   = 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, [])
-
-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)
+       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
+-}
+specUnfolding _ _ _
+  = return (noUnfolding, nilOL)

 
 dsMkArbitraryType :: TcTyVar -> Type
 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 \end{code}
 
 
 dsMkArbitraryType :: TcTyVar -> Type
 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 \end{code}
 

+%************************************************************************
+%*                                                                     *
+\subsection{Adding inline pragmas}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+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 bndrs lhs 
+  =  -- Note [Simplifying the left-hand side of a RULE]
+    case collectArgs opt_lhs of
+        (Var fn, args) -> check_bndrs fn args
+
+        (Case scrut bndr ty [(DEFAULT, _, body)], args)
+               | isDeadBinder bndr     -- Note [Matching seqId]
+               -> check_bndrs seqId (args' ++ args)
+               where
+                  args' = [Type (idType bndr), Type ty, scrut, body]
+          
+       _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]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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
+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
 Note [Unused spec binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider

@@ -544,7 +652,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,52 +673,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.
-
-
-%************************************************************************
-%*                                                                     *
-\subsection{Adding inline pragmas}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-decomposeRuleLhs :: CoreExpr -> Maybe ([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 
-  = case collectArgs body of
-        (Var fn, args) -> Just (bndrs, fn, args)
-
-        (Case scrut bndr ty [(DEFAULT, _, body)], args)
-               | isDeadBinder bndr     -- Note [Matching seqId]
-               -> Just (bndrs, seqId, args' ++ args)
-               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}
-
-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.
+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.

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

@@ -623,6 +688,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 +697,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 +732,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}