Trim redundant import

[ghc-hetmet.git] / compiler / specialise / Specialise.lhs

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index b424e4a..4d8efdd 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -14,26 +14,27 @@ module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
 
 
 #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,
                          UniqSM, initUs_,
                          MonadUnique(..)
 import UniqSupply      ( UniqSupply,
                          UniqSM, initUs_,
                          MonadUnique(..)

@@ -41,8 +42,7 @@ import UniqSupply     ( UniqSupply,
 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 Maybes          ( catMaybes, isJust )

 import Bag
 import Util
 import Outputable
 import Bag
 import Util
 import Outputable

@@ -488,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

@@ -514,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)] => ...

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

@@ -577,21 +575,9 @@ 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 (do (binds', uds') <- go binds
-                                  return (dumpAllDictBinds uds' binds'))
-
-       endPass dflags "Specialise" Opt_D_dump_spec binds'
-
-       dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-                 (withPprStyle defaultUserStyle $
-                  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
   where
        -- We need to start with a Subst that knows all the things
        -- that are in scope, so that the substitution engine doesn't

@@ -618,7 +604,7 @@ 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!)
 --        to avoid name clashes
 --     b) we carry a type substitution to use when analysing
 --        the RHS of specialised bindings (no type-let!)

@@ -644,7 +630,7 @@ specExpr subst expr@(App {})
                                return (App fun' arg', uds_arg `plusUDs` uds_app)
 
     go (Var f)       args = case specVar subst f of
                                return (App fun' arg', uds_arg `plusUDs` uds_app)
 
     go (Var f)       args = case specVar subst f of

-                                Var f' -> return (Var f', mkCallUDs subst f' args)
+                                Var f' -> return (Var f', mkCallUDs f' args)

                                 e'     -> return (e', emptyUDs)        -- I don't expect this!
     go other        _    = specExpr subst other
 
                                 e'     -> return (e', emptyUDs)        -- I don't expect this!
     go other        _    = specExpr subst other
 

@@ -751,39 +737,73 @@ finishSpecBind bind
     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)
 
     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 :: Subst -> CoreBind -> CallDetails -> SpecM (CoreBind, UsageDetails)
 
 -- 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 = do
-    ((bndr',rhs'), spec_defns, spec_uds) <- specDefn rhs_subst call_info (bndr,rhs)
-    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

-    return (new_bind, spec_uds)
-
-specBindItself rhs_subst (Rec pairs) call_info = do
-    stuff <- mapM (specDefn rhs_subst call_info) pairs
-    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')
-    return (new_bind, spec_uds)
-
-
-specDefn :: Subst                      -- Subst to use for RHS
+                 
+specBindItself rhs_subst (Rec pairs) call_info
+       -- 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

@@ -791,27 +811,18 @@ specDefn subst calls (fn, rhs)
 
 --   && not (certainlyWillInline (idUnfolding fn))     -- And it's not small
 --     See Note [Inline specialisation] for why we do not 
 
 --   && not (certainlyWillInline (idUnfolding fn))     -- And it's not small
 --     See Note [Inline specialisation] for why we do not 

---     switch off specialisation for inline functions = do
-  = do
-     -- Specialise the body of the function
-    (rhs', rhs_uds) <- specExpr subst rhs
-
-      -- 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 stuff
-
-        fn' = addIdSpecialisations fn spec_rules
+--     switch off specialisation for inline functions

 
 

-    return ((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
   = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn )
          -- Note [Specialisation shape]
 
   | otherwise  -- No calls or RHS doesn't fit our preconceptions
   = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn )
          -- Note [Specialisation shape]

-    (do  { (rhs', rhs_uds) <- specExpr subst rhs
-       ; return ((fn, rhs'), [], rhs_uds) })
+    return (fn, [], emptyUDs)

   
   where
     fn_type           = idType fn
   
   where
     fn_type           = idType fn

@@ -825,93 +836,182 @@ 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
-    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, ([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, _))
     spec_call (CallKey call_ts, (call_ds, _))

-      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts ) do
-               -- Calls are only recorded for properly-saturated applications
+      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )

        
        

-       -- 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 _         (Just ty) = Type ty
-          rhs_subst  = extendTvSubstList subst (spec_tyvars `zip` [ty | Just ty <- call_ts])
-
-       (rhs_subst', rhs_dicts') <- cloneBinders 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
-
-        spec_f <- newIdSM fn spec_id_ty
-        (spec_rhs, rhs_uds) <- specExpr rhs_subst' (mkLams lam_args body)
-       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)))
-                               inline_prag     -- Note [Auto-specialisation and RULES]
-                               (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)
-
-        return (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 
-        | debugIsOn && 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])
-        | 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:
 Note [Auto-specialisation and RULES]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider:

@@ -950,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

@@ -1036,13 +1136,16 @@ 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
 
 instance Outputable CallKey where
   ppr (CallKey ts) = ppr ts

@@ -1081,24 +1184,24 @@ singleCall id tys dicts
        --
        -- We don't include the 'id' itself.
 
        --
        -- We don't include the 'id' itself.
 

-mkCallUDs :: Subst -> Id -> [CoreExpr] -> UsageDetails
-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

-  = 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 

@@ -1111,8 +1214,21 @@ 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 (MkUD {dict_binds = db1, calls = calls1, ud_fvs = fvs1})
        (MkUD {dict_binds = db2, calls = calls2, ud_fvs = fvs2})
 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
 plusUDs (MkUD {dict_binds = db1, calls = calls1, ud_fvs = fvs1})
        (MkUD {dict_binds = db2, calls = calls2, ud_fvs = fvs2})

@@ -1234,19 +1350,20 @@ cloneBindSM subst (Rec pairs) = do
     let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
     return (subst', subst', Rec (bndrs' `zip` map snd pairs))
 
     let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
     return (subst', subst', Rec (bndrs' `zip` map snd pairs))
 

-cloneBinders :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
-cloneBinders subst bndrs = do
-    us <- getUniqueSupplyM
-    return (cloneIdBndrs subst us bndrs)
-
-newIdSM :: Id -> Type -> SpecM Id
-newIdSM old_id new_ty = do
-    uniq <- getUniqueM
-    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)
-    return new_id
+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}