Make arity of INLINE things consistent

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

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 85487e6..bfe4323 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -38,6 +38,7 @@ import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
 import Id
 import CostCentre
 import Module
 import Id

+import Name    ( localiseName )

 import MkId    ( seqId )
 import Var     ( Var, TyVar, tyVarKind )
 import IdInfo  ( vanillaIdInfo )
 import MkId    ( seqId )
 import Var     ( Var, TyVar, tyVarKind )
 import IdInfo  ( vanillaIdInfo )

@@ -55,7 +56,6 @@ import Util           ( count, lengthExceeds )
 
 import MonadUtils
 import Control.Monad
 
 import MonadUtils
 import Control.Monad

-import Data.List

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

@@ -115,92 +115,28 @@ dsHsBind _ rest
        ; sel_binds <- mkSelectorBinds pat body_expr
        ; return (sel_binds ++ rest) }
 
        ; sel_binds <- mkSelectorBinds pat body_expr
        ; return (sel_binds ++ rest) }
 

-{-  Note [Rules and inlining]
-    ~~~~~~~~~~~~~~~~~~~~~~~~~
-    Common special case: no type or dictionary abstraction
-    This is a bit less trivial than you might suppose
-    The naive way woudl be to desguar to something like
-       f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
-       M.f = f_lcl             -- Generated from "exports"
-    But we don't want that, because if M.f isn't exported,
-    it'll be inlined unconditionally at every call site (its rhs is 
-    trivial).  That would be ok unless it has RULES, which would 
-    thereby be completely lost.  Bad, bad, bad.
-
-    Instead we want to generate
-       M.f = ...f_lcl...
-       f_lcl = M.f
-    Now all is cool. The RULES are attached to M.f (by SimplCore), 
-    and f_lcl is rapidly inlined away.
-
-    This does not happen in the same way to polymorphic binds,
-    because they desugar to
-       M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
-    Although I'm a bit worried about whether full laziness might
-    float the f_lcl binding out and then inline M.f at its call site -}
-

 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
   = do { core_prs <- ds_lhs_binds NoSccs binds
        ; let env = mkABEnv exports
 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
   = do { core_prs <- ds_lhs_binds NoSccs binds
        ; let env = mkABEnv exports

-             ar_env = mkArityEnv binds

              do_one (lcl_id, rhs) 
                | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
              do_one (lcl_id, rhs) 
                | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id

-               = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )     -- Not overloaded
-                  makeCorePair gbl_id (lookupArity ar_env lcl_id)
-                              (addAutoScc auto_scc gbl_id rhs)
+               = do { let rhs' = addAutoScc auto_scc gbl_id rhs
+                    ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
+                                   -- See Note [Specialising in no-dict case]
+                     ; let   gbl_id'   = addIdSpecialisations gbl_id rules
+                             main_bind = makeCorePair gbl_id' False 0 rhs'
+                    ; return (main_bind : spec_binds) }

 
 

-               | otherwise = (lcl_id, rhs)
+               | otherwise = return [(lcl_id, rhs)]

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

-       ; return (map do_one core_prs ++ locals' ++ rest) }
+        ; export_binds <- mapM do_one core_prs
+       ; return (concat export_binds ++ locals' ++ rest) }

                -- No Rec needed here (contrast the other AbsBinds cases)
                -- because we can rely on the enclosing dsBind to wrap in Rec
 
 
                -- No Rec needed here (contrast the other AbsBinds cases)
                -- because we can rely on the enclosing dsBind to wrap in Rec
 
 

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

 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
   | opt_DsMultiTyVar   -- This (static) debug flag just lets us
                        -- switch on and off this optimisation to
 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
   | opt_DsMultiTyVar   -- This (static) debug flag just lets us
                        -- switch on and off this optimisation to

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

-             ar_env = mkArityEnv binds

              env = mkABEnv exports
              env = mkABEnv exports

-

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

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

-               = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )     -- Not overloaded
-                  (let rhs' = addAutoScc auto_scc gbl_id  $
-                             mkLams id_tvs $
-                             mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
-                                    | tv <- tyvars, not (tv `elem` id_tvs)] $
-                             add_lets lg_binds rhs
-                 in return (mk_lg_bind lcl_id gbl_id id_tvs,
-                            makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs'))
+               = do { let rhs' = addAutoScc auto_scc gbl_id  $
+                                 mkLams id_tvs $
+                                 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
+                                        | tv <- tyvars, not (tv `elem` id_tvs)] $
+                                 add_lets lg_binds rhs
+                    ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
+                     ; let   gbl_id'   = addIdSpecialisations gbl_id rules
+                             main_bind = makeCorePair gbl_id' False 0 rhs'
+                    ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }

                | otherwise
                = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
                     ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
                | otherwise
                = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
                     ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,

-                             (non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))) }
+                              [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }

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

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

 
        -- Another common case: one exported variable
        -- Non-recursive bindings come through this way
 
        -- Another common case: one exported variable
        -- Non-recursive bindings come through this way

@@ -254,25 +189,23 @@ dsHsBind auto_scc rest
   = ASSERT( all (`elem` tyvars) all_tyvars )
     do { core_prs <- ds_lhs_binds NoSccs binds
 
   = ASSERT( all (`elem` tyvars) all_tyvars )
     do { core_prs <- ds_lhs_binds NoSccs binds
 

-       ; let   -- Always treat the binds as recursive, because the typechecker
-               -- makes rather mixed-up dictionary bindings
+       ; let   -- Always treat the binds as recursive, because the 
+               -- typechecker makes rather mixed-up dictionary bindings

                core_bind = Rec core_prs
                core_bind = Rec core_prs

-               inl_arity = lookupArity (mkArityEnv binds) local
+               rhs       = addAutoScc auto_scc global $
+                           mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)

     
     

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

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

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

     
        ; return (main_bind : spec_binds ++ rest) }
 
 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
   = do { core_prs <- ds_lhs_binds NoSccs binds
        ; let env = mkABEnv exports
     
        ; return (main_bind : spec_binds ++ rest) }
 
 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
   = do { core_prs <- ds_lhs_binds NoSccs binds
        ; let env = mkABEnv exports

-             ar_env = mkArityEnv binds

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

@@ -280,30 +213,30 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
                -- Rec because of mixed-up dictionary bindings
              core_bind = Rec (map do_one core_prs)
 
                -- Rec because of mixed-up dictionary bindings
              core_bind = Rec (map do_one core_prs)
 

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

 
 

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

 
 

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

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

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

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

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

                     ; return ((global', rhs) : spec_binds) }
                where
                  mk_ty_arg all_tyvar
                     ; return ((global', rhs) : spec_binds) }
                where
                  mk_ty_arg all_tyvar

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

-       ; return ((poly_tup_id, poly_tup_expr) : 
+       ; return ((poly_tup_id, poly_tup_rhs) : 

                    (concat export_binds_s ++ rest)) }
 
 ------------------------
                    (concat export_binds_s ++ rest)) }
 
 ------------------------

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

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

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

   | otherwise
   | otherwise

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

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

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

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

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

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

+\end{code}

 
 

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

 
 

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

 
 

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

 
 

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

 
 

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

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

@@ -376,9 +383,9 @@ get to do the inlining, which is a Terribly Bad thing given that the
 user said "inline"!
 
 To avoid this we pre-emptively eta-expand the definition, so that foo
 user said "inline"!
 
 To avoid this we pre-emptively eta-expand the definition, so that foo

-has arity 2 (one for the Eq and one for x); and that in turn should
-mean that (foo d) is a PAP and we don't share it.
-
+has the arity with which it is declared in the source code.  In this
+example it has arity 2 (one for the Eq and one for x). Doing this 
+should mean that (foo d) is a PAP and we don't share it.

 
 Note [Nested arities]
 ~~~~~~~~~~~~~~~~~~~~~
 
 Note [Nested arities]
 ~~~~~~~~~~~~~~~~~~~~~

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

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

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

-dsSpecs :: [TyVar] -> [DictId] -> [TyVar]
-        -> Id -> Id -> Arity           -- Global, local, arity of local
-        -> CoreBind -> [LSpecPrag]
+dsSpecs :: Id          -- The polymorphic Id
+        -> CoreExpr     -- Its rhs
+        -> TcSpecPrags

         -> DsM ( [(Id,CoreExpr)]       -- Binding for specialised Ids
               , [CoreRule] )           -- Rules for the Global Ids
         -> DsM ( [(Id,CoreExpr)]       -- Binding for specialised Ids
               , [CoreRule] )           -- Rules for the Global Ids

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

  where 
  where 

-    spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
+    spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))

     spec_one (L loc (SpecPrag spec_co spec_inl))
       = putSrcSpanDs loc $ 
         do { let poly_name = idName poly_id
     spec_one (L loc (SpecPrag spec_co spec_inl))
       = putSrcSpanDs loc $ 
         do { let poly_name = idName poly_id

@@ -452,10 +473,9 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
                bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
                   | otherwise -> do
 
                bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
                   | otherwise -> do
 

-          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (idUnfolding poly_id)
+          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)

 
 

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

                 spec_id  = mkLocalId spec_name spec_ty 
                            `setInlinePragma` inl_prag
                            `setIdUnfolding`  spec_unf
                 spec_id  = mkLocalId spec_name spec_ty 
                            `setInlinePragma` inl_prag
                            `setIdUnfolding`  spec_unf

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

-                spec_id_arity = inl_arity + count isDictId bndrs
-
-                extra_dict_bndrs = [ localiseId d  -- See Note [Constant rule dicts]
-                                        | d <- varSetElems (exprFreeVars ds_spec_expr)
-                                        , isDictId d]
-                               -- Note [Const rule dicts]
+                extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
+                                            -- See Note [Constant rule dicts]
+                                   | d <- varSetElems (exprFreeVars ds_spec_expr)
+                                   , isDictId d]

 
                 rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
                                AlwaysActive poly_name
                                (extra_dict_bndrs ++ bndrs) args
                                (mkVarApps (Var spec_id) bndrs)
 
 
                 rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
                                AlwaysActive poly_name
                                (extra_dict_bndrs ++ bndrs) args
                                (mkVarApps (Var spec_id) bndrs)
 

-                 spec_rhs = wrap_fn (mkLams (tvs ++ dicts) f_body)
-                 spec_pair = makeCorePair spec_id spec_id_arity spec_rhs
+                 spec_rhs  = wrap_fn poly_rhs
+                 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs

 
            ; return (Just (spec_pair : unf_pairs, rule))
            } } } }
 
 
            ; return (Just (spec_pair : unf_pairs, rule))
            } } } }
 

-       -- Bind to Any any of all_ptvs that aren't 
-       -- relevant for this particular function 
-    fix_up body | null void_tvs = body
-               | otherwise     = mkTyApps (mkLams void_tvs body) $
-                                  map dsMkArbitraryType void_tvs
-
-    void_tvs = all_tvs \\ tvs
-

     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
                                 <+> ptext (sLit "in specialied type:"),
                             nest 2 (pprTheta (map get_pred bs))]
     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
                                 <+> ptext (sLit "in specialied type:"),
                             nest 2 (pprTheta (map get_pred bs))]

@@ -544,7 +554,7 @@ the constraint is unused.  We could bind 'd' to (error "unused")
 but it seems better to reject the program because it's almost certainly
 a mistake.  That's what the isDeadBinder call detects.
 
 but it seems better to reject the program because it's almost certainly
 a mistake.  That's what the isDeadBinder call detects.
 

-Note [Const rule dicts]
+Note [Constant rule dicts]

 ~~~~~~~~~~~~~~~~~~~~~~~
 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
 which is presumably in scope at the function definition site, we can quantify 
 ~~~~~~~~~~~~~~~~~~~~~~~
 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
 which is presumably in scope at the function definition site, we can quantify 

@@ -565,8 +575,9 @@ And from that we want the rule
 
 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 Name, and you can't bind them in a lambda or forall without getting things
 
 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 Name, and you can't bind them in a lambda or forall without getting things

-confused. Hence the use of 'localiseId' to make it Internal.
-
+confused.   Likewise it might have an InlineRule or something, which would be
+utterly bogus. So we really make a fresh Id, with the same unique and type
+as the old one, but with an Internal name and no IdInfo.

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

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

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

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

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

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

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