Trim redundant import
[ghc-hetmet.git] / compiler / specialise / Specialise.lhs
index b3bd6a2..4d8efdd 100644 (file)
@@ -4,55 +4,50 @@
 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
 
 \begin{code}
 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
 
 \begin{code}
-{-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
 
 -- for details
 
 module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
 
-import DynFlags        ( DynFlags, DynFlag(..) )
-import Id              ( Id, idName, idType, mkUserLocal, 
-                         idInlinePragma, setInlinePragma ) 
+import Id              ( Id, idName, idType, mkUserLocal, idCoreRules,
+                         idInlinePragma, setInlinePragma, setIdUnfolding,
+                         isLocalId ) 
 import TcType          ( Type, mkTyVarTy, tcSplitSigmaTy, 
                          tyVarsOfTypes, tyVarsOfTheta, isClassPred,
                          tcCmpType, isUnLiftedType
                        )
 import CoreSubst       ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
                          substBndr, substBndrs, substTy, substInScope,
 import TcType          ( Type, mkTyVarTy, tcSplitSigmaTy, 
                          tyVarsOfTypes, tyVarsOfTheta, isClassPred,
                          tcCmpType, isUnLiftedType
                        )
 import CoreSubst       ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
                          substBndr, substBndrs, substTy, substInScope,
-                         cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
+                         cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
+                         extendIdSubst
                        ) 
                        ) 
+import CoreUnfold      ( mkUnfolding )
+import SimplUtils      ( interestingArg )
+import Var             ( DictId )
 import VarSet
 import VarEnv
 import CoreSyn
 import VarSet
 import VarEnv
 import CoreSyn
-import CoreUtils       ( applyTypeToArgs, mkPiTypes )
+import Rules
+import CoreUtils       ( exprIsTrivial, applyTypeToArgs, mkPiTypes )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, idFreeVars )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, idFreeVars )
-import CoreTidy                ( tidyRules )
-import CoreLint                ( showPass, endPass )
-import Rules           ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
-import PprCore         ( pprRules )
 import UniqSupply      ( UniqSupply,
 import UniqSupply      ( UniqSupply,
-                         UniqSM, initUs_, thenUs, returnUs, getUniqueUs, 
-                         getUs, mapUs
+                         UniqSM, initUs_,
+                         MonadUnique(..)
                        )
 import Name
 import MkId            ( voidArgId, realWorldPrimId )
 import FiniteMap
                        )
 import Name
 import MkId            ( voidArgId, realWorldPrimId )
 import FiniteMap
-import Maybes          ( catMaybes, maybeToBool )
-import ErrUtils                ( dumpIfSet_dyn )
-import BasicTypes      ( Activation( AlwaysActive ) )
+import Maybes          ( catMaybes, isJust )
 import Bag
 import Bag
-import List            ( partition )
-import Util            ( zipEqual, zipWithEqual, cmpList, lengthIs,
-                         equalLength, lengthAtLeast, notNull )
+import Util
 import Outputable
 import FastString
 
 import Outputable
 import FastString
 
-infixr 9 `thenSM`
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -493,8 +488,6 @@ of this is permanently ruled out.
 Still, this is no great hardship, because we intend to eliminate
 overloading altogether anyway!
 
 Still, this is no great hardship, because we intend to eliminate
 overloading altogether anyway!
 
-
-
 A note about non-tyvar dictionaries
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Some Ids have types like
 A note about non-tyvar dictionaries
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Some Ids have types like
@@ -519,7 +512,7 @@ Should we specialise wrt this compound-type dictionary?  We used to say
 But it is simpler and more uniform to specialise wrt these dicts too;
 and in future GHC is likely to support full fledged type signatures 
 like
 But it is simpler and more uniform to specialise wrt these dicts too;
 and in future GHC is likely to support full fledged type signatures 
 like
-       f ;: Eq [(a,b)] => ...
+       f :: Eq [(a,b)] => ...
 
 
 %************************************************************************
 
 
 %************************************************************************
@@ -582,32 +575,21 @@ Hence, the invariant is this:
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-specProgram dflags us binds
-  = do
-       showPass dflags "Specialise"
-
-       let binds' = initSM us (go binds        `thenSM` \ (binds', uds') ->
-                               returnSM (dumpAllDictBinds uds' binds'))
-
-       endPass dflags "Specialise" Opt_D_dump_spec binds'
-
-       dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-                 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
-
-       return binds'
+specProgram :: UniqSupply -> [CoreBind] -> [CoreBind]
+specProgram us binds = initSM us (do (binds', uds') <- go binds
+                                    return (dumpAllDictBinds uds' binds'))
   where
        -- We need to start with a Subst that knows all the things
        -- that are in scope, so that the substitution engine doesn't
        -- accidentally re-use a unique that's already in use
        -- Easiest thing is to do it all at once, as if all the top-level
        -- decls were mutually recursive
   where
        -- We need to start with a Subst that knows all the things
        -- that are in scope, so that the substitution engine doesn't
        -- accidentally re-use a unique that's already in use
        -- Easiest thing is to do it all at once, as if all the top-level
        -- decls were mutually recursive
-    top_subst      = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
+    top_subst       = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
 
 
-    go []          = returnSM ([], emptyUDs)
-    go (bind:binds) = go binds                                 `thenSM` \ (binds', uds) ->
-                     specBind top_subst bind uds       `thenSM` \ (bind', uds') ->
-                     returnSM (bind' ++ binds', uds')
+    go []           = return ([], emptyUDs)
+    go (bind:binds) = do (binds', uds) <- go binds
+                         (bind', uds') <- specBind top_subst bind uds
+                         return (bind' ++ binds', uds')
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -622,82 +604,79 @@ specVar subst v = lookupIdSubst subst v
 
 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 -- We carry a substitution down:
 
 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 -- We carry a substitution down:
---     a) we must clone any binding that might flaot outwards,
+--     a) we must clone any binding that might float outwards,
 --        to avoid name clashes
 --     b) we carry a type substitution to use when analysing
 --        the RHS of specialised bindings (no type-let!)
 
 ---------------- First the easy cases --------------------
 --        to avoid name clashes
 --     b) we carry a type substitution to use when analysing
 --        the RHS of specialised bindings (no type-let!)
 
 ---------------- First the easy cases --------------------
-specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
-specExpr subst (Var v)   = returnSM (specVar subst v,         emptyUDs)
-specExpr subst (Lit lit) = returnSM (Lit lit,                emptyUDs)
-specExpr subst (Cast e co) =
-  specExpr subst e              `thenSM` \ (e', uds) ->
-  returnSM ((Cast e' (substTy subst co)), uds)
-specExpr subst (Note note body)
-  = specExpr subst body        `thenSM` \ (body', uds) ->
-    returnSM (Note (specNote subst note) body', uds)
+specExpr subst (Type ty) = return (Type (substTy subst ty), emptyUDs)
+specExpr subst (Var v)   = return (specVar subst v,         emptyUDs)
+specExpr _     (Lit lit) = return (Lit lit,                 emptyUDs)
+specExpr subst (Cast e co) = do
+    (e', uds) <- specExpr subst e
+    return ((Cast e' (substTy subst co)), uds)
+specExpr subst (Note note body) = do
+    (body', uds) <- specExpr subst body
+    return (Note (specNote subst note) body', uds)
 
 
 ---------------- Applications might generate a call instance --------------------
 
 
 ---------------- Applications might generate a call instance --------------------
-specExpr subst expr@(App fun arg)
+specExpr subst expr@(App {})
   = go expr []
   where
   = go expr []
   where
-    go (App fun arg) args = specExpr subst arg `thenSM` \ (arg', uds_arg) ->
-                           go fun (arg':args)  `thenSM` \ (fun', uds_app) ->
-                           returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
+    go (App fun arg) args = do (arg', uds_arg) <- specExpr subst arg
+                               (fun', uds_app) <- go fun (arg':args)
+                               return (App fun' arg', uds_arg `plusUDs` uds_app)
 
     go (Var f)       args = case specVar subst f of
 
     go (Var f)       args = case specVar subst f of
-                               Var f' -> returnSM (Var f', mkCallUDs subst f' args)
-                               e'     -> returnSM (e', emptyUDs)       -- I don't expect this!
-    go other        args = specExpr subst other
+                                Var f' -> return (Var f', mkCallUDs f' args)
+                                e'     -> return (e', emptyUDs)        -- I don't expect this!
+    go other        _    = specExpr subst other
 
 ---------------- Lambda/case require dumping of usage details --------------------
 
 ---------------- Lambda/case require dumping of usage details --------------------
-specExpr subst e@(Lam _ _)
-  = specExpr subst' body       `thenSM` \ (body', uds) ->
-    let
-       (filtered_uds, body'') = dumpUDs bndrs' uds body'
-    in
-    returnSM (mkLams bndrs' body'', filtered_uds)
+specExpr subst e@(Lam _ _) = do
+    (body', uds) <- specExpr subst' body
+    let (filtered_uds, body'') = dumpUDs bndrs' uds body'
+    return (mkLams bndrs' body'', filtered_uds)
   where
     (bndrs, body) = collectBinders e
     (subst', bndrs') = substBndrs subst bndrs
        -- More efficient to collect a group of binders together all at once
        -- and we don't want to split a lambda group with dumped bindings
 
   where
     (bndrs, body) = collectBinders e
     (subst', bndrs') = substBndrs subst bndrs
        -- More efficient to collect a group of binders together all at once
        -- and we don't want to split a lambda group with dumped bindings
 
-specExpr subst (Case scrut case_bndr ty alts)
-  = specExpr subst scrut               `thenSM` \ (scrut', uds_scrut) ->
-    mapAndCombineSM spec_alt alts      `thenSM` \ (alts', uds_alts) ->
-    returnSM (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
+specExpr subst (Case scrut case_bndr ty alts) = do
+    (scrut', uds_scrut) <- specExpr subst scrut
+    (alts', uds_alts) <- mapAndCombineSM spec_alt alts
+    return (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
   where
     (subst_alt, case_bndr') = substBndr subst case_bndr
        -- No need to clone case binder; it can't float like a let(rec)
 
   where
     (subst_alt, case_bndr') = substBndr subst case_bndr
        -- No need to clone case binder; it can't float like a let(rec)
 
-    spec_alt (con, args, rhs)
-       = specExpr subst_rhs rhs                `thenSM` \ (rhs', uds) ->
-         let
-            (uds', rhs'') = dumpUDs args uds rhs'
-         in
-         returnSM ((con, args', rhs''), uds')
-       where
-         (subst_rhs, args') = substBndrs subst_alt args
+    spec_alt (con, args, rhs) = do
+          (rhs', uds) <- specExpr subst_rhs rhs
+          let (uds', rhs'') = dumpUDs args uds rhs'
+          return ((con, args', rhs''), uds')
+        where
+          (subst_rhs, args') = substBndrs subst_alt args
 
 ---------------- Finally, let is the interesting case --------------------
 
 ---------------- Finally, let is the interesting case --------------------
-specExpr subst (Let bind body)
-  =    -- Clone binders
-    cloneBindSM subst bind                     `thenSM` \ (rhs_subst, body_subst, bind') ->
-       
-       -- Deal with the body
-    specExpr body_subst body                   `thenSM` \ (body', body_uds) ->
+specExpr subst (Let bind body) = do
+       -- Clone binders
+    (rhs_subst, body_subst, bind') <- cloneBindSM subst bind
+
+        -- Deal with the body
+    (body', body_uds) <- specExpr body_subst body
 
 
-       -- Deal with the bindings
-    specBind rhs_subst bind' body_uds          `thenSM` \ (binds', uds) ->
+        -- Deal with the bindings
+    (binds', uds) <- specBind rhs_subst bind' body_uds
 
 
-       -- All done
-    returnSM (foldr Let body' binds', uds)
+        -- All done
+    return (foldr Let body' binds', uds)
 
 -- Must apply the type substitution to coerceions
 
 -- Must apply the type substitution to coerceions
-specNote subst note          = note
+specNote :: Subst -> Note -> Note
+specNote _ note = note
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -714,81 +693,117 @@ specBind :: Subst                        -- Use this for RHSs
                   UsageDetails)        -- And info to pass upstream
 
 specBind rhs_subst bind body_uds
                   UsageDetails)        -- And info to pass upstream
 
 specBind rhs_subst bind body_uds
-  = specBindItself rhs_subst bind (calls body_uds)     `thenSM` \ (bind', bind_uds) ->
-    let
-       bndrs   = bindersOf bind
-       all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds)
-                       -- It's important that the `plusUDs` is this way round,
+  = do { (bind', bind_uds) <- specBindItself rhs_subst bind (calls body_uds)
+       ; return (finishSpecBind bind' bind_uds body_uds) }
+
+finishSpecBind :: CoreBind -> UsageDetails -> UsageDetails -> ([CoreBind], UsageDetails)
+finishSpecBind bind 
+       (MkUD { dict_binds = rhs_dbs,  calls = rhs_calls,  ud_fvs = rhs_fvs })
+       (MkUD { dict_binds = body_dbs, calls = body_calls, ud_fvs = body_fvs })
+  | not (mkVarSet bndrs `intersectsVarSet` all_fvs)
+               -- Common case 1: the bound variables are not
+               --                mentioned in the dictionary bindings
+  = ([bind], MkUD { dict_binds = body_dbs `unionBags` rhs_dbs
+                       -- It's important that the `unionBags` is this way round,
                        -- because body_uds may bind dictionaries that are
                        -- used in the calls passed to specDefn.  So the
                        -- because body_uds may bind dictionaries that are
                        -- used in the calls passed to specDefn.  So the
-                       -- dictionary bindings in bind_uds may mention 
+                       -- dictionary bindings in rhs_uds may mention 
                        -- dictionaries bound in body_uds.
                        -- dictionaries bound in body_uds.
-    in
-    case splitUDs bndrs all_uds of
-
-       (_, ([],[]))    -- This binding doesn't bind anything needed
-                       -- in the UDs, so put the binding here
-                       -- This is the case for most non-dict bindings, except
-                       -- for the few that are mentioned in a dict binding
-                       -- that is floating upwards in body_uds
-               -> returnSM ([bind'], all_uds)
-
-       (float_uds, (dict_binds, calls))        -- This binding is needed in the UDs, so float it out
-               -> returnSM ([], float_uds `plusUDs` mkBigUD bind' dict_binds calls)
-   
-
--- A truly gruesome function
-mkBigUD bind@(NonRec _ _) dbs calls
-  =    -- Common case: non-recursive and no specialisations
-       -- (if there were any specialistions it would have been made recursive)
-    MkUD { dict_binds = listToBag (mkDB bind : dbs),
-          calls = listToCallDetails calls }
-
-mkBigUD bind dbs calls
-  =    -- General case
-    MkUD { dict_binds = unitBag (mkDB (Rec (bind_prs bind ++ dbsToPairs dbs))),
-                       -- Make a huge Rec
-          calls = listToCallDetails calls }
+                 , calls  = all_calls
+                 , ud_fvs = all_fvs })
+
+  | case bind of { NonRec {} -> True; Rec {} -> False }
+               -- Common case 2: no specialisation happened, and binding
+               --                is non-recursive.  But the binding may be
+               --                mentioned in body_dbs, so we should put it first
+  = ([], MkUD { dict_binds = rhs_dbs `unionBags` ((bind, b_fvs) `consBag` body_dbs)
+             , calls      = all_calls
+             , ud_fvs     = all_fvs `unionVarSet` b_fvs })
+
+  | otherwise  -- General case: make a huge Rec (sigh)
+  = ([], MkUD { dict_binds = unitBag (Rec all_db_prs, all_db_fvs)
+             , calls      = all_calls
+             , ud_fvs     = all_fvs `unionVarSet` b_fvs })
   where
   where
-    bind_prs (NonRec b r) = [(b,r)]
-    bind_prs (Rec prs)    = prs
+    all_fvs = rhs_fvs `unionVarSet` body_fvs
+    all_calls = zapCalls bndrs (rhs_calls `unionCalls` body_calls)
+
+    bndrs   = bindersOf bind
+    b_fvs   = bind_fvs bind
 
 
-    dbsToPairs []             = []
-    dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
+    (all_db_prs, all_db_fvs) = add (bind, b_fvs) $ 
+                              foldrBag add ([], emptyVarSet) $
+                              rhs_dbs `unionBags` body_dbs
+    add (NonRec b r, b_fvs) (prs, fvs) = ((b,r)  : prs, b_fvs `unionVarSet` fvs)
+    add (Rec b_prs,  b_fvs) (prs, fvs) = (b_prs ++ prs, b_fvs `unionVarSet` fvs)
+
+---------------------------
+specBindItself :: Subst -> CoreBind -> CallDetails -> SpecM (CoreBind, UsageDetails)
 
 -- specBindItself deals with the RHS, specialising it according
 -- to the calls found in the body (if any)
 
 -- specBindItself deals with the RHS, specialising it according
 -- to the calls found in the body (if any)
-specBindItself rhs_subst (NonRec bndr rhs) call_info
-  = specDefn rhs_subst call_info (bndr,rhs)    `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
-    let
-        new_bind | null spec_defns = NonRec bndr' rhs'
-                 | otherwise       = Rec ((bndr',rhs'):spec_defns)
+specBindItself rhs_subst (NonRec fn rhs) call_info
+  = do { (rhs', rhs_uds) <- specExpr rhs_subst rhs          -- Do RHS of original fn
+       ; (fn', spec_defns, spec_uds) <- specDefn rhs_subst call_info fn rhs
+       ; if null spec_defns then
+                   return (NonRec fn rhs', rhs_uds)
+        else 
+           return (Rec ((fn',rhs') : spec_defns), rhs_uds `plusUDs` spec_uds) }
                -- bndr' mentions the spec_defns in its SpecEnv
                -- Not sure why we couln't just put the spec_defns first
                -- bndr' mentions the spec_defns in its SpecEnv
                -- Not sure why we couln't just put the spec_defns first
-    in
-    returnSM (new_bind, spec_uds)
-
+                 
 specBindItself rhs_subst (Rec pairs) call_info
 specBindItself rhs_subst (Rec pairs) call_info
-  = mapSM (specDefn rhs_subst call_info) pairs `thenSM` \ stuff ->
-    let
-       (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
-       spec_defns = concat spec_defns_s
-       spec_uds   = plusUDList spec_uds_s
-        new_bind   = Rec (spec_defns ++ pairs')
-    in
-    returnSM (new_bind, spec_uds)
-    
-
-specDefn :: Subst                      -- Subst to use for RHS
+       -- Note [Specialising a recursive group]
+  = do { let (bndrs,rhss) = unzip pairs
+       ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_subst) rhss
+       ; let all_calls = call_info `unionCalls` calls rhs_uds
+       ; (bndrs1, spec_defns1, spec_uds1) <- specDefns rhs_subst all_calls pairs
+
+       ; if null spec_defns1 then   -- Common case: no specialisation
+                   return (Rec (bndrs `zip` rhss'), rhs_uds)
+        else do                     -- Specialisation occurred; do it again
+       { (bndrs2, spec_defns2, spec_uds2) <- 
+                         -- pprTrace "specB" (ppr bndrs $$ ppr rhs_uds) $
+                         specDefns rhs_subst (calls spec_uds1) (bndrs1 `zip` rhss)
+
+       ; let all_defns = spec_defns1 ++ spec_defns2 ++ zip bndrs2 rhss'
+             
+       ; return (Rec all_defns, rhs_uds `plusUDs` spec_uds1 `plusUDs` spec_uds2) } }
+
+
+---------------------------
+specDefns :: Subst
+        -> CallDetails                 -- Info on how it is used in its scope
+        -> [(Id,CoreExpr)]             -- The things being bound and their un-processed RHS
+        -> SpecM ([Id],                -- Original Ids with RULES added
+                  [(Id,CoreExpr)],     -- Extra, specialised bindings
+                  UsageDetails)        -- Stuff to fling upwards from the specialised versions
+
+-- Specialise a list of bindings (the contents of a Rec), but flowing usages
+-- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }
+-- Then if the input CallDetails has a specialised call for 'g', whose specialisation
+-- in turn generates a specialised call for 'f', we catch that in this one sweep.
+-- But not vice versa (it's a fixpoint problem).
+
+specDefns _subst _call_info []
+  = return ([], [], emptyUDs)
+specDefns subst call_info ((bndr,rhs):pairs)
+  = do { (bndrs', spec_defns, spec_uds) <- specDefns subst call_info pairs
+       ; let all_calls = call_info `unionCalls` calls spec_uds
+       ; (bndr', spec_defns1, spec_uds1) <- specDefn subst all_calls bndr rhs
+       ; return (bndr' : bndrs',
+                        spec_defns1 ++ spec_defns, 
+                spec_uds1 `plusUDs` spec_uds) }
+
+---------------------------
+specDefn :: Subst
         -> CallDetails                 -- Info on how it is used in its scope
         -> CallDetails                 -- Info on how it is used in its scope
-        -> (Id, CoreExpr)              -- The thing being bound and its un-processed RHS
-        -> SpecM ((Id, CoreExpr),      -- The thing and its processed RHS
-                                       --      the Id may now have specialisations attached
+        -> Id -> CoreExpr              -- The thing being bound and its un-processed RHS
+        -> SpecM (Id,                  -- Original Id with added RULES
                   [(Id,CoreExpr)],     -- Extra, specialised bindings
                   [(Id,CoreExpr)],     -- Extra, specialised bindings
-                  UsageDetails         -- Stuff to fling upwards from the RHS and its
-           )                           --      specialised versions
+                  UsageDetails)        -- Stuff to fling upwards from the specialised versions
 
 
-specDefn subst calls (fn, rhs)
+specDefn subst calls fn rhs
        -- The first case is the interesting one
   |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
   && rhs_ids    `lengthAtLeast` n_dicts        -- and enough dict args
        -- The first case is the interesting one
   |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
   && rhs_ids    `lengthAtLeast` n_dicts        -- and enough dict args
@@ -798,25 +813,16 @@ specDefn subst calls (fn, rhs)
 --     See Note [Inline specialisation] for why we do not 
 --     switch off specialisation for inline functions
 
 --     See Note [Inline specialisation] for why we do not 
 --     switch off specialisation for inline functions
 
-  =   -- Specialise the body of the function
-    specExpr subst rhs                                 `thenSM` \ (rhs', rhs_uds) ->
-
-      -- Make a specialised version for each call in calls_for_me
-    mapSM spec_call calls_for_me               `thenSM` \ stuff ->
-    let
-       (spec_defns, spec_uds, spec_rules) = unzip3 stuff
-
-       fn' = addIdSpecialisations fn spec_rules
-    in
-    returnSM ((fn',rhs'), 
-             spec_defns, 
-             rhs_uds `plusUDs` plusUDList spec_uds)
+  = do {       -- Make a specialised version for each call in calls_for_me
+         stuff <- mapM spec_call calls_for_me
+       ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff)
+             fn' = addIdSpecialisations fn spec_rules
+       ; return (fn', spec_defns, plusUDList spec_uds) }
 
   | otherwise  -- No calls or RHS doesn't fit our preconceptions
 
   | otherwise  -- No calls or RHS doesn't fit our preconceptions
-  = WARN( notNull calls_for_me, ptext SLIT("Missed specialisation opportunity for") <+> ppr fn )
+  = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn )
          -- Note [Specialisation shape]
          -- Note [Specialisation shape]
-    specExpr subst rhs                 `thenSM` \ (rhs', rhs_uds) ->
-    returnSM ((fn, rhs'), [], rhs_uds)
+    return (fn, [], emptyUDs)
   
   where
     fn_type           = idType fn
   
   where
     fn_type           = idType fn
@@ -830,94 +836,209 @@ specDefn subst calls (fn, rhs)
     (inline_rhs, rhs_inside) = dropInline rhs
     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside
 
     (inline_rhs, rhs_inside) = dropInline rhs
     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside
 
-    rhs_dicts = take n_dicts rhs_ids
-    rhs_bndrs = rhs_tyvars ++ rhs_dicts
-    body      = mkLams (drop n_dicts rhs_ids) rhs_body
+    rhs_dict_ids = take n_dicts rhs_ids
+    body         = mkLams (drop n_dicts rhs_ids) rhs_body
                -- Glue back on the non-dict lambdas
 
     calls_for_me = case lookupFM calls fn of
                        Nothing -> []
                        Just cs -> fmToList cs
 
                -- Glue back on the non-dict lambdas
 
     calls_for_me = case lookupFM calls fn of
                        Nothing -> []
                        Just cs -> fmToList cs
 
+    already_covered :: [CoreExpr] -> Bool
+    already_covered args         -- Note [Specialisations already covered]
+       = isJust (lookupRule (const True) (substInScope subst) 
+                                   fn args (idCoreRules fn))
+
+    mk_ty_args :: [Maybe Type] -> [CoreExpr]
+    mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
+              where
+                 mk_ty_arg rhs_tyvar Nothing   = Type (mkTyVarTy rhs_tyvar)
+                 mk_ty_arg _         (Just ty) = Type ty
+
     ----------------------------------------------------------
        -- Specialise to one particular call pattern
     ----------------------------------------------------------
        -- Specialise to one particular call pattern
-    spec_call :: (CallKey, ([DictExpr], VarSet))       -- Call instance
-              -> SpecM ((Id,CoreExpr),                 -- Specialised definition
-                       UsageDetails,                   -- Usage details from specialised body
-                       CoreRule)                       -- Info for the Id's SpecEnv
-    spec_call (CallKey call_ts, (call_ds, call_fvs))
+    spec_call :: (CallKey, ([DictExpr], VarSet))  -- Call instance
+              -> SpecM (Maybe ((Id,CoreExpr),    -- Specialised definition
+                              UsageDetails,      -- Usage details from specialised body
+                              CoreRule))         -- Info for the Id's SpecEnv
+    spec_call (CallKey call_ts, (call_ds, _))
       = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
       = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
-               -- Calls are only recorded for properly-saturated applications
        
        
-       -- Suppose f's defn is  f = /\ a b c d -> \ d1 d2 -> rhs        
-        -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [dx1, dx2]
+       -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs  
+        -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]
 
        -- Construct the new binding
 
        -- Construct the new binding
-       --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b d -> rhs)
+       --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)
        -- PLUS the usage-details
        --      { d1' = dx1; d2' = dx2 }
        -- PLUS the usage-details
        --      { d1' = dx1; d2' = dx2 }
-       -- where d1', d2' are cloned versions of d1,d2, with the type substitution applied.
+       -- where d1', d2' are cloned versions of d1,d2, with the type substitution
+       -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2
        --
        -- Note that the substitution is applied to the whole thing.
        -- This is convenient, but just slightly fragile.  Notably:
        --
        -- Note that the substitution is applied to the whole thing.
        -- This is convenient, but just slightly fragile.  Notably:
-       --      * There had better be no name clashes in a/b/c/d
-       --
-        let
-               -- poly_tyvars = [b,d] in the example above
+       --      * There had better be no name clashes in a/b/c
+        do { let
+               -- poly_tyvars = [b] in the example above
                -- spec_tyvars = [a,c] 
                -- spec_tyvars = [a,c] 
-               -- ty_args     = [t1,b,t3,d]
-          poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
-           spec_tyvars = [tv | (tv, Just _)  <- rhs_tyvars `zip` call_ts]
-          ty_args     = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
-                      where
-                        mk_ty_arg rhs_tyvar Nothing   = Type (mkTyVarTy rhs_tyvar)
-                        mk_ty_arg rhs_tyvar (Just ty) = Type ty
-          rhs_subst  = extendTvSubstList subst (spec_tyvars `zip` [ty | Just ty <- call_ts])
-       in
-       cloneBinders rhs_subst rhs_dicts                `thenSM` \ (rhs_subst', rhs_dicts') ->
-       let
-          inst_args = ty_args ++ map Var rhs_dicts'
-
-               -- Figure out the type of the specialised function
-          body_ty = applyTypeToArgs rhs fn_type inst_args
-          (lam_args, app_args)                 -- Add a dummy argument if body_ty is unlifted
-               | isUnLiftedType body_ty        -- C.f. WwLib.mkWorkerArgs
-               = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId])
-               | otherwise = (poly_tyvars, poly_tyvars)
-          spec_id_ty = mkPiTypes lam_args body_ty
-       in
-       newIdSM fn spec_id_ty                           `thenSM` \ spec_f ->
-       specExpr rhs_subst' (mkLams lam_args body)      `thenSM` \ (spec_rhs, rhs_uds) ->       
-       let
+               -- ty_args     = [t1,b,t3]
+               poly_tyvars   = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
+               spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
+               spec_ty_args  = map snd spec_tv_binds
+               ty_args       = mk_ty_args call_ts
+               rhs_subst     = extendTvSubstList subst spec_tv_binds
+
+          ; (rhs_subst1, inst_dict_ids) <- cloneDictBndrs rhs_subst rhs_dict_ids
+                         -- Clone rhs_dicts, including instantiating their types
+
+          ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $
+                                         (my_zipEqual rhs_dict_ids inst_dict_ids call_ds)
+                inst_args = ty_args ++ map Var inst_dict_ids
+
+          ; if already_covered inst_args then
+               return Nothing
+            else do
+          {    -- Figure out the type of the specialised function
+            let body_ty = applyTypeToArgs rhs fn_type inst_args
+                (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted
+                  | isUnLiftedType body_ty     -- C.f. WwLib.mkWorkerArgs
+                  = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId])
+                  | otherwise = (poly_tyvars, poly_tyvars)
+                spec_id_ty = mkPiTypes lam_args body_ty
+       
+           ; spec_f <- newSpecIdSM fn spec_id_ty
+           ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
+          ; let
                -- The rule to put in the function's specialisation is:
                -- The rule to put in the function's specialisation is:
-               --      forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d  
-           spec_env_rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
-                               AlwaysActive (idName fn)
-                               (poly_tyvars ++ rhs_dicts')
-                               inst_args 
-                               (mkVarApps (Var spec_f) app_args)
+               --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b  
+               rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
+               spec_env_rule = mkLocalRule
+                                 rule_name
+                                 inline_prag   -- Note [Auto-specialisation and RULES]
+                                 (idName fn)
+                                 (poly_tyvars ++ inst_dict_ids)
+                                 inst_args 
+                                 (mkVarApps (Var spec_f) app_args)
 
                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
 
                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
-          final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
+               final_uds = foldr addDictBind rhs_uds dx_binds
 
 
-          spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs)
-                  | otherwise  = (spec_f,                               spec_rhs)
-       in
-        returnSM (spec_pr, final_uds, spec_env_rule)
+               spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs)
+                       | otherwise  = (spec_f,                               spec_rhs)
 
 
+          ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
+      where
+       my_zipEqual xs ys zs
+        | debugIsOn && not (equalLength xs ys && equalLength ys zs)
+             = pprPanic "my_zipEqual" (vcat [ ppr xs, ppr ys
+                                           , ppr fn <+> ppr call_ts
+                                           , ppr (idType fn), ppr theta
+                                           , ppr n_dicts, ppr rhs_dict_ids 
+                                           , ppr rhs])
+        | otherwise = zip3 xs ys zs
+
+bindAuxiliaryDicts
+       :: Subst
+       -> [(DictId,DictId,CoreExpr)]   -- (orig_dict, inst_dict, dx)
+       -> (Subst,                      -- Substitute for all orig_dicts
+           [(DictId, CoreExpr)])       -- Auxiliary bindings
+-- Bind any dictionary arguments to fresh names, to preserve sharing
+-- Substitution already substitutes orig_dict -> inst_dict
+bindAuxiliaryDicts subst triples = go subst [] triples
+  where
+    go subst binds []    = (subst, binds)
+    go subst binds ((d, dx_id, dx) : pairs)
+      | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs
+             -- No auxiliary binding necessary
+      | otherwise        = go subst_w_unf ((dx_id,dx) : binds) pairs
       where
       where
-       my_zipEqual doc xs ys 
-#ifdef DEBUG
-        | not (equalLength xs ys) = pprPanic "my_zipEqual" (vcat 
-                                               [ ppr xs, ppr ys
-                                               , ppr fn <+> ppr call_ts
-                                               , ppr (idType fn), ppr theta
-                                               , ppr n_dicts, ppr rhs_dicts 
-                                               , ppr rhs])
-#endif
-        | otherwise               = zipEqual doc xs ys
+        dx_id1 = dx_id `setIdUnfolding` mkUnfolding False dx
+       subst_w_unf = extendIdSubst subst d (Var dx_id1)
+                    -- Important!  We're going to substitute dx_id1 for d
+            -- and we want it to look "interesting", else we won't gather *any*
+            -- consequential calls. E.g.
+            --     f d = ...g d....
+            -- If we specialise f for a call (f (dfun dNumInt)), we'll get 
+            -- a consequent call (g d') with an auxiliary definition
+            --     d' = df dNumInt
+            -- We want that consequent call to look interesting
 \end{code}
 
 \end{code}
 
+Note [Specialising a recursive group]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    let rec { f x = ...g x'...
+            ; g y = ...f y'.... }
+    in f 'a'
+Here we specialise 'f' at Char; but that is very likely to lead to 
+a specialisation of 'g' at Char.  We must do the latter, else the
+whole point of specialisation is lost.
+
+But we do not want to keep iterating to a fixpoint, because in the
+presence of polymorphic recursion we might generate an infinite number
+of specialisations.
+
+So we use the following heuristic:
+  * Arrange the rec block in dependency order, so far as possible
+    (the occurrence analyser already does this)
+
+  * Specialise it much like a sequence of lets
+
+  * Then go through the block a second time, feeding call-info from
+    the RHSs back in the bottom, as it were
+
+In effect, the ordering maxmimises the effectiveness of each sweep,
+and we do just two sweeps.   This should catch almost every case of 
+monomorphic recursion -- the exception could be a very knotted-up
+recursion with multiple cycles tied up together.
+
+This plan is implemented in the Rec case of specBindItself.
+Note [Specialisations already covered]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We obviously don't want to generate two specialisations for the same
+argument pattern.  There are two wrinkles
+
+1. We do the already-covered test in specDefn, not when we generate
+the CallInfo in mkCallUDs.  We used to test in the latter place, but
+we now iterate the specialiser somewhat, and the Id at the call site
+might therefore not have all the RULES that we can see in specDefn
+
+2. What about two specialisations where the second is an *instance*
+of the first?  If the more specific one shows up first, we'll generate
+specialisations for both.  If the *less* specific one shows up first,
+we *don't* currently generate a specialisation for the more specific
+one.  (See the call to lookupRule in already_covered.)  Reasons:
+  (a) lookupRule doesn't say which matches are exact (bad reason)
+  (b) if the earlier specialisation is user-provided, it's
+      far from clear that we should auto-specialise further
+
+Note [Auto-specialisation and RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+   g :: Num a => a -> a
+   g = ...
+
+   f :: (Int -> Int) -> Int
+   f w = ...
+   {-# RULE f g = 0 #-}
+
+Suppose that auto-specialisation makes a specialised version of
+g::Int->Int That version won't appear in the LHS of the RULE for f.
+So if the specialisation rule fires too early, the rule for f may
+never fire. 
+
+It might be possible to add new rules, to "complete" the rewrite system.
+Thus when adding
+       RULE forall d. g Int d = g_spec
+also add
+       RULE f g_spec = 0
+
+But that's a bit complicated.  For now we ask the programmer's help,
+by *copying the INLINE activation pragma* to the auto-specialised rule.
+So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule will also
+not be active until phase 2.  
+
+
 Note [Specialisation shape]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We only specialise a function if it has visible top-level lambdas
 Note [Specialisation shape]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We only specialise a function if it has visible top-level lambdas
@@ -929,7 +1050,7 @@ then its body must look like
 Reason: when specialising the body for a call (f ty dexp), we want to
 substitute dexp for d, and pick up specialised calls in the body of f.
 
 Reason: when specialising the body for a call (f ty dexp), we want to
 substitute dexp for d, and pick up specialised calls in the body of f.
 
-This doesn't always work.  One example I came across was htis:
+This doesn't always work.  One example I came across was this:
        newtype Gen a = MkGen{ unGen :: Int -> a }
 
        choose :: Eq a => a -> Gen a
        newtype Gen a = MkGen{ unGen :: Int -> a }
 
        choose :: Eq a => a -> Gen a
@@ -990,51 +1111,66 @@ data UsageDetails
                        -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
                        -- (Remember, Bags preserve order in GHC.)
 
                        -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
                        -- (Remember, Bags preserve order in GHC.)
 
-       calls     :: !CallDetails
+       calls     :: !CallDetails, 
+
+       ud_fvs :: !VarSet       -- A superset of the variables mentioned in 
+                               -- either dict_binds or calls
     }
 
     }
 
+instance Outputable UsageDetails where
+  ppr (MkUD { dict_binds = dbs, calls = calls, ud_fvs = fvs })
+       = ptext (sLit "MkUD") <+> braces (sep (punctuate comma 
+               [ptext (sLit "binds") <+> equals <+> ppr dbs,
+                ptext (sLit "calls") <+> equals <+> ppr calls,
+                ptext (sLit "fvs")   <+> equals <+> ppr fvs]))
+
 type DictBind = (CoreBind, VarSet)
        -- The set is the free vars of the binding
        -- both tyvars and dicts
 
 type DictExpr = CoreExpr
 
 type DictBind = (CoreBind, VarSet)
        -- The set is the free vars of the binding
        -- both tyvars and dicts
 
 type DictExpr = CoreExpr
 
-emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
-
-type ProtoUsageDetails = ([DictBind],
-                         [(Id, CallKey, ([DictExpr], VarSet))]
-                        )
+emptyUDs :: UsageDetails
+emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM, ud_fvs = emptyVarSet }
 
 ------------------------------------------------------------                   
 type CallDetails  = FiniteMap Id CallInfo
 newtype CallKey   = CallKey [Maybe Type]                       -- Nothing => unconstrained type argument
 
 ------------------------------------------------------------                   
 type CallDetails  = FiniteMap Id CallInfo
 newtype CallKey   = CallKey [Maybe Type]                       -- Nothing => unconstrained type argument
-type CallInfo     = FiniteMap CallKey
-                             ([DictExpr], VarSet)              -- Dict args and the vars of the whole
-                                                               -- call (including tyvars)
-                                                               -- [*not* include the main id itself, of course]
-       -- The finite maps eliminate duplicates
-       -- The list of types and dictionaries is guaranteed to
-       -- match the type of f
+
+-- CallInfo uses a FiniteMap, thereby ensuring that
+-- we record only one call instance for any key
+--
+-- The list of types and dictionaries is guaranteed to
+-- match the type of f
+type CallInfo = FiniteMap CallKey ([DictExpr], VarSet)
+                       -- Range is dict args and the vars of the whole
+                       -- call (including tyvars)
+                       -- [*not* include the main id itself, of course]
+
+instance Outputable CallKey where
+  ppr (CallKey ts) = ppr ts
 
 -- Type isn't an instance of Ord, so that we can control which
 -- instance we use.  That's tiresome here.  Oh well
 instance Eq CallKey where
 
 -- Type isn't an instance of Ord, so that we can control which
 -- instance we use.  That's tiresome here.  Oh well
 instance Eq CallKey where
-  k1 == k2 = case k1 `compare` k2 of { EQ -> True; other -> False }
+  k1 == k2 = case k1 `compare` k2 of { EQ -> True; _ -> False }
 
 instance Ord CallKey where
   compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
                where
 
 instance Ord CallKey where
   compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
                where
-                 cmp Nothing Nothing     = EQ
-                 cmp Nothing (Just t2)   = LT
-                 cmp (Just t1) Nothing   = GT
+                 cmp Nothing   Nothing   = EQ
+                 cmp Nothing   (Just _)  = LT
+                 cmp (Just _)  Nothing   = GT
                  cmp (Just t1) (Just t2) = tcCmpType t1 t2
 
 unionCalls :: CallDetails -> CallDetails -> CallDetails
 unionCalls c1 c2 = plusFM_C plusFM c1 c2
 
                  cmp (Just t1) (Just t2) = tcCmpType t1 t2
 
 unionCalls :: CallDetails -> CallDetails -> CallDetails
 unionCalls c1 c2 = plusFM_C plusFM c1 c2
 
-singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
 singleCall id tys dicts 
 singleCall id tys dicts 
-  = unitFM id (unitFM (CallKey tys) (dicts, call_fvs))
+  = MkUD {dict_binds = emptyBag, 
+         calls      = unitFM id (unitFM (CallKey tys) (dicts, call_fvs)),
+         ud_fvs     = call_fvs }
   where
     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
     tys_fvs  = tyVarsOfTypes (catMaybes tys)
   where
     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
     tys_fvs  = tyVarsOfTypes (catMaybes tys)
@@ -1048,36 +1184,24 @@ singleCall id tys dicts
        --
        -- We don't include the 'id' itself.
 
        --
        -- We don't include the 'id' itself.
 
-listToCallDetails calls
-  = foldr (unionCalls . mk_call) emptyFM calls
-  where
-    mk_call (id, tys, dicts_w_fvs) = unitFM id (unitFM tys dicts_w_fvs)
-       -- NB: the free vars of the call are provided
-
-callDetailsToList calls = [ (id,tys,dicts)
-                         | (id,fm) <- fmToList calls,
-                           (tys, dicts) <- fmToList fm
-                         ]
-
-mkCallUDs subst f args 
-  | null theta
+mkCallUDs :: Id -> [CoreExpr] -> UsageDetails
+mkCallUDs f args 
+  | not (isLocalId f)  -- Imported from elsewhere
+  || null theta                -- Not overloaded
   || not (all isClassPred theta)       
        -- Only specialise if all overloading is on class params. 
        -- In ptic, with implicit params, the type args
        --  *don't* say what the value of the implicit param is!
   || not (spec_tys `lengthIs` n_tyvars)
   || not ( dicts   `lengthIs` n_dicts)
   || not (all isClassPred theta)       
        -- Only specialise if all overloading is on class params. 
        -- In ptic, with implicit params, the type args
        --  *don't* say what the value of the implicit param is!
   || not (spec_tys `lengthIs` n_tyvars)
   || not ( dicts   `lengthIs` n_dicts)
-  || maybeToBool (lookupRule (\act -> True) (substInScope subst) emptyRuleBase f args)
-       -- There's already a rule covering this call.  A typical case
-       -- is where there's an explicit user-provided rule.  Then
-       -- we don't want to create a specialised version 
-       -- of the function that overlaps.
-  = emptyUDs   -- Not overloaded, or no specialisation wanted
+  || not (any interestingArg dicts)    -- Note [Interesting dictionary arguments]
+  -- See also Note [Specialisations already covered]
+  = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)]) 
+    emptyUDs   -- Not overloaded, or no specialisation wanted
 
   | otherwise
 
   | otherwise
-  = MkUD {dict_binds = emptyBag, 
-         calls      = singleCall f spec_tys dicts
-    }
+  = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)]) 
+    singleCall f spec_tys dicts
   where
     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
     constrained_tyvars = tyVarsOfTheta theta 
   where
     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
     constrained_tyvars = tyVarsOfTheta theta 
@@ -1090,29 +1214,47 @@ mkCallUDs subst f args
     mk_spec_ty tyvar ty 
        | tyvar `elemVarSet` constrained_tyvars = Just ty
        | otherwise                             = Nothing
     mk_spec_ty tyvar ty 
        | tyvar `elemVarSet` constrained_tyvars = Just ty
        | otherwise                             = Nothing
+\end{code}
 
 
-------------------------------------------------------------                   
+Note [Interesting dictionary arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+        \a.\d:Eq a.  let f = ... in ...(f d)...
+There really is not much point in specialising f wrt the dictionary d,
+because the code for the specialised f is not improved at all, because
+d is lambda-bound.  We simply get junk specialisations.
+
+We re-use the function SimplUtils.interestingArg function to determine
+what sort of dictionary arguments have *some* information in them.
+
+
+\begin{code}
 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
-plusUDs (MkUD {dict_binds = db1, calls = calls1})
-       (MkUD {dict_binds = db2, calls = calls2})
-  = MkUD {dict_binds = d, calls = c}
+plusUDs (MkUD {dict_binds = db1, calls = calls1, ud_fvs = fvs1})
+       (MkUD {dict_binds = db2, calls = calls2, ud_fvs = fvs2})
+  = MkUD {dict_binds = d, calls = c, ud_fvs = fvs1 `unionVarSet` fvs2}
   where
     d = db1    `unionBags`   db2 
     c = calls1 `unionCalls`  calls2
 
   where
     d = db1    `unionBags`   db2 
     c = calls1 `unionCalls`  calls2
 
+plusUDList :: [UsageDetails] -> UsageDetails
 plusUDList = foldr plusUDs emptyUDs
 
 -- zapCalls deletes calls to ids from uds
 plusUDList = foldr plusUDs emptyUDs
 
 -- zapCalls deletes calls to ids from uds
-zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
+zapCalls :: [Id] -> CallDetails -> CallDetails
+zapCalls ids calls = delListFromFM calls ids
 
 
+mkDB :: CoreBind -> DictBind
 mkDB bind = (bind, bind_fvs bind)
 
 mkDB bind = (bind, bind_fvs bind)
 
+bind_fvs :: CoreBind -> VarSet
 bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
 bind_fvs (Rec prs)        = foldl delVarSet rhs_fvs bndrs
                           where
                             bndrs = map fst prs
                             rhs_fvs = unionVarSets (map pair_fvs prs)
 
 bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
 bind_fvs (Rec prs)        = foldl delVarSet rhs_fvs bndrs
                           where
                             bndrs = map fst prs
                             rhs_fvs = unionVarSets (map pair_fvs prs)
 
+pair_fvs :: (Id, CoreExpr) -> VarSet
 pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
        -- Don't forget variables mentioned in the
        -- rules of the bndr.  C.f. OccAnal.addRuleUsage
 pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
        -- Don't forget variables mentioned in the
        -- rules of the bndr.  C.f. OccAnal.addRuleUsage
@@ -1120,8 +1262,14 @@ pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
        --      type T a = Int
        --      x :: T a = 3
 
        --      type T a = Int
        --      x :: T a = 3
 
-addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
+addDictBind :: (Id,CoreExpr) -> UsageDetails -> UsageDetails
+addDictBind (dict,rhs) uds 
+  = uds { dict_binds = db `consBag` dict_binds uds
+       , ud_fvs = ud_fvs uds `unionVarSet` fvs }
+  where
+    db@(_, fvs) = mkDB (NonRec dict rhs) 
 
 
+dumpAllDictBinds :: UsageDetails -> [CoreBind] -> [CoreBind]
 dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
   = foldrBag add binds dbs
   where
 dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
   = foldrBag add binds dbs
   where
@@ -1130,44 +1278,27 @@ dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
 dumpUDs :: [CoreBndr]
        -> UsageDetails -> CoreExpr
        -> (UsageDetails, CoreExpr)
 dumpUDs :: [CoreBndr]
        -> UsageDetails -> CoreExpr
        -> (UsageDetails, CoreExpr)
-dumpUDs bndrs uds body
-  = (free_uds, foldr add_let body dict_binds)
+dumpUDs bndrs (MkUD { dict_binds = orig_dbs
+                   , calls = orig_calls
+                   , ud_fvs = fvs}) body
+  = (new_uds, foldrBag add_let body dump_dbs)          
+               -- This may delete fewer variables 
+               -- than in priciple possible
   where
   where
-    (free_uds, (dict_binds, _)) = splitUDs bndrs uds
-    add_let (bind,_) body      = Let bind body
-
-splitUDs :: [CoreBndr]
-        -> UsageDetails
-        -> (UsageDetails,              -- These don't mention the binders
-            ProtoUsageDetails)         -- These do
-            
-splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, 
-                         calls      = orig_calls})
-
-  = if isEmptyBag dump_dbs && null dump_calls then
-       -- Common case: binder doesn't affect floats
-       (uds, ([],[]))  
-
-    else
-       -- Binders bind some of the fvs of the floats
-       (MkUD {dict_binds = free_dbs, 
-              calls      = listToCallDetails free_calls},
-        (bagToList dump_dbs, dump_calls)
-       )
+    new_uds = 
+     MkUD { dict_binds = free_dbs
+         , calls      = free_calls 
+         , ud_fvs     = fvs `minusVarSet` bndr_set}
 
 
-  where
     bndr_set = mkVarSet bndrs
     bndr_set = mkVarSet bndrs
+    add_let (bind,_) body = Let bind body
 
 
-    (free_dbs, dump_dbs, dump_idset) 
-         = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
+    (free_dbs, dump_dbs, dump_set) 
+       = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
                -- Important that it's foldl not foldr;
                -- we're accumulating the set of dumped ids in dump_set
 
                -- Important that it's foldl not foldr;
                -- we're accumulating the set of dumped ids in dump_set
 
-       -- Filter out any calls that mention things that are being dumped
-    orig_call_list                = callDetailsToList orig_calls
-    (dump_calls, free_calls)      = partition captured orig_call_list
-    captured (id,tys,(dicts, fvs)) =  fvs `intersectsVarSet` dump_idset
-                                  || id `elemVarSet` dump_idset
+    free_calls = filterCalls dump_set orig_calls
 
     dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
        | dump_idset `intersectsVarSet` fvs     -- Dump it
 
     dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
        | dump_idset `intersectsVarSet` fvs     -- Dump it
@@ -1176,6 +1307,15 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
 
        | otherwise     -- Don't dump it
        = (free_dbs `snocBag` db, dump_dbs, dump_idset)
 
        | otherwise     -- Don't dump it
        = (free_dbs `snocBag` db, dump_dbs, dump_idset)
+
+filterCalls :: VarSet -> CallDetails -> CallDetails
+-- Remove any calls that mention the variables
+filterCalls bs calls
+  = mapFM (\_ cs -> filter_calls cs) $
+    filterFM (\k _ -> not (k `elemVarSet` bs)) calls
+  where
+    filter_calls :: CallInfo -> CallInfo
+    filter_calls = filterFM (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))
 \end{code}
 
 
 \end{code}
 
 
@@ -1188,46 +1328,42 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
 \begin{code}
 type SpecM a = UniqSM a
 
 \begin{code}
 type SpecM a = UniqSM a
 
-thenSM    = thenUs
-returnSM  = returnUs
-getUniqSM = getUniqueUs
-mapSM     = mapUs
+initSM :: UniqSupply -> SpecM a -> a
 initSM   = initUs_
 
 initSM   = initUs_
 
-mapAndCombineSM f []     = returnSM ([], emptyUDs)
-mapAndCombineSM f (x:xs) = f x `thenSM` \ (y, uds1) ->
-                          mapAndCombineSM f xs `thenSM` \ (ys, uds2) ->
-                          returnSM (y:ys, uds1 `plusUDs` uds2)
+mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
+mapAndCombineSM _ []     = return ([], emptyUDs)
+mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
+                              (ys, uds2) <- mapAndCombineSM f xs
+                              return (y:ys, uds1 `plusUDs` uds2)
 
 cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
 -- Clone the binders of the bind; return new bind with the cloned binders
 -- Return the substitution to use for RHSs, and the one to use for the body
 
 cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
 -- Clone the binders of the bind; return new bind with the cloned binders
 -- Return the substitution to use for RHSs, and the one to use for the body
-cloneBindSM subst (NonRec bndr rhs)
-  = getUs      `thenUs` \ us ->
-    let
-       (subst', bndr') = cloneIdBndr subst us bndr
-    in
-    returnUs (subst, subst', NonRec bndr' rhs)
-
-cloneBindSM subst (Rec pairs)
-  = getUs      `thenUs` \ us ->
-    let
-       (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
-    in
-    returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
-
-cloneBinders subst bndrs
-  = getUs      `thenUs` \ us ->
-    returnUs (cloneIdBndrs subst us bndrs)
-
-newIdSM old_id new_ty
-  = getUniqSM          `thenSM` \ uniq ->
-    let 
-       -- Give the new Id a similar occurrence name to the old one
-       name   = idName old_id
-       new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcSpan name)
-    in
-    returnSM new_id
+cloneBindSM subst (NonRec bndr rhs) = do
+    us <- getUniqueSupplyM
+    let (subst', bndr') = cloneIdBndr subst us bndr
+    return (subst, subst', NonRec bndr' rhs)
+
+cloneBindSM subst (Rec pairs) = do
+    us <- getUniqueSupplyM
+    let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
+    return (subst', subst', Rec (bndrs' `zip` map snd pairs))
+
+cloneDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
+cloneDictBndrs subst bndrs 
+  = do { us <- getUniqueSupplyM
+       ; return (cloneIdBndrs subst us bndrs) }
+
+newSpecIdSM :: Id -> Type -> SpecM Id
+    -- Give the new Id a similar occurrence name to the old one
+newSpecIdSM old_id new_ty
+  = do { uniq <- getUniqueM
+       ; let 
+           name    = idName old_id
+           new_occ = mkSpecOcc (nameOccName name)
+           new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
+        ; return new_id }
 \end{code}
 
 
 \end{code}