Merge remote-tracking branch 'origin/master' into type-nats
[ghc.git] / compiler / deSugar / DsBinds.lhs
index 3fe8d54..8fc6bd9 100644 (file)
@@ -10,9 +10,15 @@ 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(..)
+{-# OPTIONS -fno-warn-tabs #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and
+-- detab the module (please do the detabbing in a separate patch). See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+-- for details
+
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
+                 dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion
   ) where
 
 #include "HsVersions.h"
   ) where
 
 #include "HsVersions.h"
@@ -26,36 +32,45 @@ import DsUtils
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
+import HscTypes         ( MonadThings )
+import Literal          ( Literal(MachStr) )
 import CoreSubst
 import MkCore
 import CoreUtils
 import CoreArity ( etaExpand )
 import CoreUnfold
 import CoreFVs
 import CoreSubst
 import MkCore
 import CoreUtils
 import CoreArity ( etaExpand )
 import CoreUnfold
 import CoreFVs
+import Digraph
 
 
+
+import TyCon      ( isTupleTyCon, tyConDataCons_maybe )
+import TcEvidence
 import TcType
 import TcType
-import TysPrim  ( anyTypeOfKind )
-import CostCentre
-import Module
+import Type
+import Coercion hiding (substCo)
+import TysWiredIn ( eqBoxDataCon, tupleCon )
 import Id
 import Id
+import Class
+import DataCon ( dataConWorkId )
+import Name    ( 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 Bag
 import BasicTypes hiding ( TopLevel )
+import DynFlags
 import FastString
 import FastString
-import StaticFlags     ( opt_DsMultiTyVar )
-import Util            ( count, lengthExceeds )
-
+import ErrUtils( MsgDoc )
+import Util
+import Control.Monad( when )
 import MonadUtils
 import MonadUtils
-import Control.Monad
-import Data.List
+import Control.Monad(liftM)
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -65,122 +80,240 @@ import Data.List
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
+dsTopLHsBinds binds = ds_lhs_binds 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 binds
+                      ; return (fromOL binds') }
 
 ------------------------
 
 ------------------------
-ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 
 
-        -- scc annotation policy (see below)
-ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
+ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind 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 :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind (L loc bind)
+  = putSrcSpanDs loc $ dsHsBind bind
 
 
-dsHsBind :: AutoScc
-        -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
-        -> HsBind Id
-        -> DsM [(Id,CoreExpr)] -- Result
+dsHsBind :: 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
-       ; core_expr' <- addDictScc var core_expr
-       ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
+        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
                   | otherwise         = var
 
                   | 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 (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
  = 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) }
+        ; let body' = mkOptTickBox tick body
+        ; rhs <- dsHsWrapper co_fn (mkLams args body')
+        ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
+           return (unitOL (makeCorePair fun False 0 rhs)) }
 
 
-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
+                  , pat_ticks = (rhs_tick, var_ticks) })
   = do { body_expr <- dsGuarded grhss ty
   = 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
+        ; let body' = mkOptTickBox rhs_tick body_expr
+        ; sel_binds <- mkSelectorBinds var_ticks pat body'
+         -- We silently ignore inline pragmas; no makeCorePair
+         -- Not so cool, but really doesn't matter
+    ; return (toOL sel_binds) }
+
+       -- 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
+dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+                   , abs_exports = [export]
+                   , abs_ev_binds = ev_binds, abs_binds = binds })
+  | ABE { abe_wrap = wrap, abe_poly = global
+        , abe_mono = local, abe_prags = prags } <- export
+  = do  { bind_prs    <- ds_lhs_binds binds
+       ; let   core_bind = Rec (fromOL bind_prs)
+        ; ds_binds <- dsTcEvBinds ev_binds
+        ; rhs <- dsHsWrapper wrap $  -- Usually the identity
+                           mkLams tyvars $ mkLams dicts $ 
+                           mkCoreLets ds_binds $
+                            Let core_bind $
+                            Var local
+    
+       ; (spec_binds, rules) <- dsSpecs rhs prags
+
+       ; let   global'   = addIdSpecialisations global rules
+               main_bind = makeCorePair global' (isDefaultMethod prags)
+                                         (dictArity dicts) rhs 
+    
+       ; return (main_bind `consOL` spec_binds) }
+
+dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+                   , abs_exports = exports, abs_ev_binds = ev_binds
+                   , abs_binds = binds })
+         -- See Note [Desugaring AbsBinds]
+  = do  { bind_prs    <- ds_lhs_binds binds
+        ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs
+                              | (lcl_id, rhs) <- fromOL bind_prs ]
+               -- Monomorphic recursion possible, hence Rec
+
+             locals       = map abe_mono exports
+             tup_expr     = mkBigCoreVarTup locals
+             tup_ty       = exprType tup_expr
+        ; ds_binds <- dsTcEvBinds ev_binds
+       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+                            mkCoreLets ds_binds $
+                            Let core_bind $
+                            tup_expr
+
+       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+
+       ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
+                           , abe_mono = local, abe_prags = spec_prags })
+               = do { tup_id  <- newSysLocalDs tup_ty
+                    ; rhs <- dsHsWrapper wrap $ 
+                                 mkLams tyvars $ mkLams dicts $
+                                mkTupleSelector locals local tup_id $
+                                mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
+                     ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
+                    ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
+                    ; let global' = (global `setInlinePragma` defaultInlinePragma)
+                                             `addIdSpecialisations` rules
+                           -- Kill the INLINE pragma because it applies to
+                           -- the user written (local) function.  The global
+                           -- Id is just the selector.  Hmm.  
+                    ; return ((global', rhs) `consOL` spec_binds) }
+
+        ; export_binds_s <- mapM mk_bind exports
+
+       ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
+                   concatOL export_binds_s) }
+  where
+    inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with
+                             -- the inline pragma from the source
+                             -- The type checker put the inline pragma
+                             -- on the *global* Id, so we need to transfer it
+    inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
+                          | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
+                          , let prag = idInlinePragma gbl_id ]
+
+    add_inline :: Id -> Id    -- tran
+    add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_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]
+       , 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
+\end{code}
+
+[Desugaring AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~
+In the general AbsBinds case we desugar the binding to this:
+
+       tup a (d:Num a) = let fm = ...gm...
+                             gm = ...fm...
+                         in (fm,gm)
+       f a d = case tup a d of { (fm,gm) -> fm }
+       g a d = case tup a d of { (fm,gm) -> fm }
+
+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
 
        AbsBinds [a,b] [ ([a,b], fg, fl, _),
 
        AbsBinds [a,b] [ ([a,b], fg, fl, _),
-                        ([b],   gg, gl, _) ]
+                        ([b],   gg, gl, _) ]
                { fl = e1
                  gl = e2
                   h = e3 }
 
                { fl = e1
                  gl = e2
                   h = e3 }
 
-   and desugar it to
+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
 
 
        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
+where B is the *non-recursive* binding
        fl = fg a b
        gl = gg b
        h  = h a b    -- See (b); note shadowing!
        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
+
+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.
 
             use the mkArbitraryType thing to fill in the gaps.  
             We use a type-let to do that.
 
@@ -194,174 +327,11 @@ dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
             number (10), we filter the binding set B by the free
             variables of the particular RHS.  Tiresome.
 
             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)
-  | 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
-       -- 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)
-  = ASSERT( all (`elem` tyvars) all_tyvars )
-    do { core_prs <- ds_lhs_binds NoSccs 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
-    
-       ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global 
-                                        local inl_arity core_bind prags
-
-       ; 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
-    
-       ; return (main_bind : spec_binds ++ rest) }
-
-dsHsBind auto_scc rest (AbsBinds all_tyvars dicts 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, _, _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)
-
-             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
-
-       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
-
-       ; let mk_bind ((tyvars, global, local, 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)
-                    ; (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 $
-                                mkTupleSelector locals' (locals' !! n) tup_id $
-                                mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
-                                          dicts
-                    ; return ((global', rhs) : spec_binds) }
-               where
-                 mk_ty_arg all_tyvar
-                       | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
-                       | otherwise               = dsMkArbitraryType all_tyvar
-
-       ; 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)) }
+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.
 
 
-------------------------
-makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr)
-makeCorePair gbl_id arity rhs
-  | isInlinePragma (idInlinePragma gbl_id)
-       -- 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)
-
-------------------------
-type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag])
-       -- Maps the "lcl_id" for an AbsBind to
-       -- its "gbl_id" and associated pragmas, if any
-
-mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> 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]
-
-mkArityEnv :: LHsBinds Id -> IdEnv Arity
-       -- Maps a local to the arity of its definition
-mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds
-
-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      
-
-lhsBindArity _ = emptyVarEnv   -- PatBind/VarBind
-
-dictArity :: [Var] -> Arity
--- Don't count coercion variables in arity
-dictArity dicts = count isId dicts
-
-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 +367,285 @@ 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 (idUnfolding 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))
+  | isJust (isClassOpId_maybe poly_id)
+  = putSrcSpanDs loc $ 
+    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") 
+                 <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- There is no point in trying to specialise a class op
+                                   -- Moreover, classops don't (currently) have an inl_sat arity set
+                           -- (it would be Just 0) and that in turn makes makeCorePair bleat
+
+  | no_act_spec && isNeverActive rule_act 
+  = putSrcSpanDs loc $ 
+    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
+                 <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that
+                                   -- See Note [Activation pragmas for SPECIALISE]
+
+  | otherwise
+  = putSrcSpanDs loc $ 
+    do { let poly_name = idName poly_id
+       ; spec_name <- newLocalName poly_name
+       ; (bndrs, ds_lhs) <- liftM collectBinders
+                                  (dsHsWrapper spec_co (Var poly_id))
+       ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
+       ; case decomposeRuleLhs bndrs ds_lhs of {
+           Left msg -> do { warnDs msg; return Nothing } ;
+           Right (final_bndrs, _fn, args) -> do
+
+       { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
+
+       ; let spec_id  = mkLocalId spec_name spec_ty 
+                           `setInlinePragma` inl_prag
+                           `setIdUnfolding`  spec_unf
+             rule =  mkRule False {- Not auto -} is_local_id
+                        (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
+                               rule_act poly_name
+                               final_bndrs args
+                               (mkVarApps (Var spec_id) bndrs)
+
+       ; spec_rhs <- dsHsWrapper spec_co poly_rhs
+       ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
+
+       ; dflags <- getDynFlags
+       ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
+              (warnDs (specOnInline poly_name))
+       ; 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
+
+    id_inl = idInlinePragma poly_id
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
+             | not is_local_id  -- See Note [Specialising imported functions]
+                                -- in OccurAnal
+             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
+             | otherwise                               = id_inl
+     -- Get the INLINE pragma from SPECIALISE declaration, or,
+     -- failing that, from the original Id
+
+    spec_prag_act = inlinePragmaActivation spec_inl
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    -- no_act_spec is True if the user didn't write an explicit
+    -- phase specification in the SPECIALISE pragma
+    no_act_spec = case inlinePragmaSpec spec_inl of
+                    NoInline -> isNeverActive  spec_prag_act
+                    _        -> isAlwaysActive spec_prag_act
+    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
+             | otherwise   = spec_prag_act                   -- Specified by user
+
+
+specUnfolding :: HsWrapper -> Type 
+              -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
+{-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
+              generate unfoldings for specialised DFuns
+
+specUnfolding 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)
-
-dsMkArbitraryType :: TcTyVar -> Type
-dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
+       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
+-}
+specUnfolding _ _ _
+  = return (noUnfolding, nilOL)
+
+specOnInline :: Name -> MsgDoc
+specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") 
+                 <+> quotes (ppr f)
+\end{code}
+
+
+Note [Activation pragmas for SPECIALISE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+From a user SPECIALISE pragma for f, we generate
+  a) A top-level binding    spec_fn = rhs
+  b) A RULE                 f dOrd = spec_fn
+
+We need two pragma-like things:
+
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring 
+                           activation on SPEC), unless overriden by SPEC INLINE
+
+* Activation of RULE: from SPECIALISE pragma (if activation given)
+                      otherwise from f's inline pragma
+
+This is not obvious (see Trac #5237)!
+
+Examples      Rule activation   Inline prag on spec'd fn
+---------------------------------------------------------------------
+SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
+                                  copy f's prag
+
+NOINLINE f
+SPEC [n] f :: ty            [n]   NOINLINE
+                                  copy f's prag
+
+NOINLINE [k] f
+SPEC [n] f :: ty            [n]   NOINLINE [k]
+                                  copy f's prag
+
+INLINE [k] f
+SPEC [n] f :: ty            [n]   INLINE [k] 
+                                  copy f's prag
+
+SPEC INLINE [n] f :: ty     [n]   INLINE [n]
+                                  (ignore INLINE prag on f,
+                                  same activation for rule and spec'd fn)
+
+NOINLINE [k] f
+SPEC f :: ty                [n]   INLINE [k]
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Adding inline pragmas}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
+-- Take apart the LHS of a RULE.  It's supposed 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)
+    | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
+    | otherwise                         = ptext (sLit "variable") <+> quotes (ppr bndr)
 \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
+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 +661,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,118 +682,158 @@ 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.
 
 
 %************************************************************************
 %*                                                                     *
 
 
 %************************************************************************
 %*                                                                     *
-\subsection{Adding inline pragmas}
+               Desugaring evidence
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
-\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
+\begin{code}
+dsHsWrapper :: MonadThings m => HsWrapper -> CoreExpr -> m CoreExpr
+dsHsWrapper WpHole           e = return e
+dsHsWrapper (WpTyApp ty)      e = return $ App e (Type ty)
+dsHsWrapper (WpLet ev_binds)  e = do bs <- dsTcEvBinds ev_binds
+                                     return (mkCoreLets bs e)
+dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
+dsHsWrapper (WpCast co)       e = return $ dsTcCoercion co (mkCast e) 
+dsHsWrapper (WpEvLam ev)      e = return $ Lam ev e 
+dsHsWrapper (WpTyLam tv)      e = return $ Lam tv e 
+dsHsWrapper (WpEvApp evtrm)   e = liftM (App e) (dsEvTerm evtrm)
+
+--------------------------------------
+dsTcEvBinds :: MonadThings m => TcEvBinds -> m [CoreBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+
+dsEvBinds :: MonadThings m => Bag EvBind -> m [CoreBind]
+dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
   where
   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}
+    ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
+    ds_scc (CyclicSCC bs)            = liftM Rec (mapM ds_pair bs)
 
 
-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.
+    ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)
 
 
+sccEvBinds :: Bag EvBind -> [SCC EvBind]
+sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
+  where
+    edges :: [(EvBind, EvVar, [EvVar])]
+    edges = foldrBag ((:) . mk_node) [] bs 
 
 
-%************************************************************************
-%*                                                                     *
-\subsection[addAutoScc]{Adding automatic sccs}
-%*                                                                     *
-%************************************************************************
+    mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
+    mk_node b@(EvBind var term) = (b, var, evVarsOfTerm term)
 
 
-\begin{code}
-data AutoScc = NoSccs 
-            | AddSccs Module (Id -> Bool)
--- The (Id->Bool) says which Ids to add SCCs to 
-
-addAutoScc :: AutoScc  
-          -> Id        -- Binder
-          -> CoreExpr  -- Rhs
-          -> CoreExpr  -- Scc'd Rhs
-
-addAutoScc NoSccs _ rhs
-  = rhs
-addAutoScc (AddSccs mod add_scc) id rhs
-  | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
-  | otherwise  = rhs
-\end{code}
 
 
-If profiling and dealing with a dict binding,
-wrap the dict in @_scc_ DICT <dict>@:
+---------------------------------------
+dsEvTerm :: MonadThings m => EvTerm -> m CoreExpr
+dsEvTerm (EvId v) = return (Var v)
 
 
-\begin{code}
-addDictScc :: Id -> CoreExpr -> DsM CoreExpr
-addDictScc _ rhs = return rhs
+dsEvTerm (EvCast v co) 
+  = return $ dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
+                                     -- unnecessary to call varToCoreExpr v here.
+dsEvTerm (EvKindCast v co)
+  = return $ dsTcCoercion co $ (\_ -> Var v)
 
 
-{- DISABLED for now (need to somehow make up a name for the scc) -- SDM
-  | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
-    || not (isDictId var)
-  = return rhs                         -- That's easy: do nothing
+dsEvTerm (EvDFunApp df tys vars) = return (Var df `mkTyApps` tys `mkVarApps` vars)
+dsEvTerm (EvCoercion co)         = return $ dsTcCoercion co mkEqBox
+dsEvTerm (EvTupleSel v n)
+   = ASSERT( isTupleTyCon tc )
+     return $
+     Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
+  where
+    (tc, tys) = splitTyConApp (evVarPred v)
+    Just [dc] = tyConDataCons_maybe tc
+    v' = v `setVarType` ty_want
+    xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
+    (tys_before, ty_want:tys_after) = splitAt n tys
+dsEvTerm (EvTupleMk vs) = return $ Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
+  where dc = tupleCon ConstraintTuple (length vs)
+        tys = map varType vs
+dsEvTerm (EvSuperClass d n)
+  = return $ Var sc_sel_id `mkTyApps` tys `App` Var d
+  where
+    sc_sel_id  = classSCSelId cls n    -- Zero-indexed
+    (cls, tys) = getClassPredTys (evVarPred d)   
+dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
+  where 
+    errorId = rUNTIME_ERROR_ID
+    litMsg  = Lit (MachStr msg)
+
+dsEvTerm (EvLit l) =
+  case l of
+    EvNum n -> mkIntegerExpr n
+    EvStr s -> mkStringExprFS s
+
+---------------------------------------
+dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
+-- This is the crucial function that moves 
+-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
+-- e.g.  dsTcCoercion (trans g1 g2) k
+--       = case g1 of EqBox g1# ->
+--         case g2 of EqBox g2# ->
+--         k (trans g1# g2#)
+dsTcCoercion co thing_inside
+  = foldr wrap_in_case result_expr eqvs_covs
+  where
+    result_expr = thing_inside (ds_tc_coercion subst co)
+    result_ty   = exprType result_expr
 
 
-  | otherwise
-  = do (mod, grp) <- getModuleAndGroupDs
-       -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
-       return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
--}
-\end{code}
+    -- We use the same uniques for the EqVars and the CoVars, and just change
+    -- the type. So the CoVars shadow the EqVars
 
 
+    eqvs_covs :: [(EqVar,CoVar)]
+    eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
+                | eqv <- varSetElems (coVarsOfTcCo co)
+                , let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
 
 
-%************************************************************************
-%*                                                                     *
-               Desugaring coercions
-%*                                                                     *
-%************************************************************************
+    subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
 
 
+    wrap_in_case (eqv, cov) body 
+      = Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
 
 
-\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) }
+ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
+-- If the incoming TcCoercion if of type (a ~ b), 
+--                 the result is of type (a ~# b)
+-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b)
+-- No need for InScope set etc because the 
+ds_tc_coercion subst tc_co
+  = go tc_co
+  where
+    go (TcRefl ty)            = Refl (Coercion.substTy subst ty)
+    go (TcTyConAppCo tc cos)  = mkTyConAppCo tc (map go cos)
+    go (TcAppCo co1 co2)      = mkAppCo (go co1) (go co2)
+    go (TcForAllCo tv co)     = mkForAllCo tv' (ds_tc_coercion subst' co)
+                              where
+                                (subst', tv') = Coercion.substTyVarBndr subst tv
+    go (TcAxiomInstCo ax tys) = mkAxInstCo ax (map (Coercion.substTy subst) tys)
+    go (TcSymCo co)           = mkSymCo (go co)
+    go (TcTransCo co1 co2)    = mkTransCo (go co1) (go co2)
+    go (TcNthCo n co)         = mkNthCo n (go co)
+    go (TcInstCo co ty)       = mkInstCo (go co) ty
+    go (TcLetCo bs co)        = ds_tc_coercion (ds_co_binds bs) co
+    go (TcCoVarCo v)          = ds_ev_id subst v
+
+    ds_co_binds :: TcEvBinds -> CvSubst
+    ds_co_binds (EvBinds bs)      = foldl ds_scc subst (sccEvBinds bs)
+    ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
+
+    ds_scc :: CvSubst -> SCC EvBind -> CvSubst
+    ds_scc subst (AcyclicSCC (EvBind v ev_term))
+      = extendCvSubstAndInScope subst v (ds_ev_term subst ev_term)
+    ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
+
+    ds_ev_term :: CvSubst -> EvTerm -> Coercion
+    ds_ev_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
+    ds_ev_term subst (EvId v)           = ds_ev_id subst v
+    ds_ev_term _ other = pprPanic "ds_ev_term" (ppr other $$ ppr tc_co)
+
+    ds_ev_id :: CvSubst -> EqVar -> Coercion
+    ds_ev_id subst v
+     | Just co <- Coercion.lookupCoVar subst v = co
+     | otherwise  = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)
 \end{code}
 \end{code}