Improve the handling of default methods
authorsimonpj@microsoft.com <unknown>
Wed, 6 Jan 2010 16:06:03 +0000 (16:06 +0000)
committersimonpj@microsoft.com <unknown>
Wed, 6 Jan 2010 16:06:03 +0000 (16:06 +0000)
See the long Note [INLINE and default methods].

This patch changes a couple of data types, with a knock-on effect on
the format of interface files.  A lot of files get touched, but is a
relatively minor change.  The main tiresome bit is the extra plumbing
to communicate default methods between the type checker and the
desugarer.

23 files changed:
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/MkId.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsForeign.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/parser/RdrHsSyn.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Specialise.lhs
compiler/stranal/WorkWrap.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/vectorise/VectType.hs
compiler/vectorise/VectUtils.hs
compiler/vectorise/Vectorise.hs

index fa7ead0..b151f5b 100644 (file)
@@ -58,7 +58,7 @@ module BasicTypes(
        Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma,
-       isDefaultInlinePragma, isInlinePragma,
+       isDefaultInlinePragma, isInlinePragma, inlinePragmaSat,
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
@@ -597,6 +597,8 @@ data InlinePragma        -- Note [InlinePragma]
   = InlinePragma
       { inl_inline :: Bool           -- True <=> INLINE, 
                                     -- False <=> no pragma at all, or NOINLINE
+      , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
+                                    --            explicit (non-type, non-dictionary) args
       , inl_act    :: Activation     -- Says during which phases inlining is allowed
       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
     } deriving( Eq )
@@ -664,14 +666,14 @@ isFunLike _            = False
 
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
-defaultInlinePragma 
-  = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False }
-alwaysInlinePragma
-  = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = True }
-neverInlinePragma   
-   = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False }
-dfunInlinePragma   
-   = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False }
+defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
+                                   , inl_rule = FunLike
+                                   , inl_inline = False
+                                   , inl_sat = Nothing }
+
+alwaysInlinePragma = defaultInlinePragma { inl_inline = True }
+neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
+dfunInlinePragma   = defaultInlinePragma { inl_rule   = ConLike }
                                     
 
 isDefaultInlinePragma :: InlinePragma -> Bool
@@ -683,6 +685,9 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation
 isInlinePragma :: InlinePragma -> Bool
 isInlinePragma prag = inl_inline prag
 
+inlinePragmaSat :: InlinePragma -> Maybe Arity
+inlinePragmaSat = inl_sat
+
 inlinePragmaActivation :: InlinePragma -> Activation
 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
 
@@ -706,11 +711,14 @@ instance Outputable RuleMatchInfo where
    ppr FunLike = ptext (sLit "FUNLIKE")
 
 instance Outputable InlinePragma where
-  ppr (InlinePragma { inl_inline = inline, inl_act = activation, inl_rule = info })
-    = pp_inline <+> pp_info <+> pp_activation
+  ppr (InlinePragma { inl_inline = inline, inl_act = activation
+                    , inl_rule = info, inl_sat = mb_arity })
+    = pp_inline <> pp_sat <+> pp_info <+> pp_activation
     where
       pp_inline | inline    = ptext (sLit "INLINE")
                 | otherwise = ptext (sLit "NOINLINE")
+      pp_sat | Just ar <- mb_arity = braces (int ar)
+             | otherwise           = empty
       pp_info | isFunLike info = empty
               | otherwise      = ppr info
       pp_activation 
index b5525dc..16c45b7 100644 (file)
@@ -345,7 +345,7 @@ mkDataConIds wrap_name wkr_name data_con
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
-    wrap_unf = mkInlineRule needSaturated wrap_rhs (length dict_args + length id_args)
+    wrap_unf = mkInlineRule wrap_rhs (Just (length dict_args + length id_args))
     wrap_rhs = mkLams wrap_tvs $ 
                mkLams eq_args $
                mkLams dict_args $ mkLams id_args $
index c98fc01..83692a8 100644 (file)
@@ -474,6 +474,7 @@ data UnfoldingGuidance
                 -- See Note [INLINE for small functions] in CoreUnfold
       ug_unsat_ok  :: Bool,    -- True <=> ok to inline even if unsaturated
       ug_boring_ok :: Bool      -- True <=> ok to inline even if the context is boring
+               -- So True,True means "always"
     }
 
   | UnfIfGoodArgs {    -- Arose from a normal Id; the info here is the
index fc31d5a..7d04154 100644 (file)
@@ -43,6 +43,7 @@ import PprCore                ()      -- Instances
 import OccurAnal
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
+import CoreArity       ( manifestArity )
 import CoreUtils
 import Id
 import DataCon
@@ -140,13 +141,17 @@ mkCompulsoryUnfolding expr           -- Used for things that absolutely must be unfolde
                     expr 0    -- Arity of unfolding doesn't matter
                     (UnfWhen unSaturatedOk boringCxtOk)
 
-mkInlineRule :: Bool -> CoreExpr -> Arity -> Unfolding
-mkInlineRule unsat_ok expr arity 
+mkInlineRule :: CoreExpr -> Maybe Arity -> Unfolding
+mkInlineRule expr mb_arity 
   = mkCoreUnfolding True InlineRule     -- Note [Top-level flag on inline rules]
                    expr' arity 
                    (UnfWhen unsat_ok boring_ok)
   where
     expr' = simpleOptExpr expr
+    (unsat_ok, arity) = case mb_arity of
+                          Nothing -> (unSaturatedOk, manifestArity expr')
+                          Just ar -> (needSaturated, ar)
+              
     boring_ok = case calcUnfoldingGuidance True    -- Treat as cheap
                                           False   -- But not bottoming
                                            (arity+1) expr' of
@@ -184,7 +189,6 @@ calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr
                | uncondInline n_val_bndrs (iBox size)
                 , expr_is_cheap
                -> UnfWhen unSaturatedOk boringCxtOk   -- Note [INLINE for small functions]
-
                | top_bot  -- See Note [Do not inline top-level bottoming functions]
                -> UnfNever
 
@@ -626,9 +630,11 @@ actual arguments.
 \begin{code}
 couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
 couldBeSmallEnoughToInline threshold rhs 
-  = case calcUnfoldingGuidance False False threshold rhs of
-       (_, UnfNever) -> False
-       _             -> True
+  = case sizeExpr (iUnbox threshold) [] body of
+       TooBig -> False
+       _      -> True
+  where
+    (_, body) = collectBinders rhs
 
 ----------------
 smallEnoughToInline :: Unfolding -> Bool
index f6fc5a3..9e29c96 100644 (file)
@@ -142,12 +142,10 @@ dsHsBind _ rest
 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
   = do { core_prs <- ds_lhs_binds NoSccs binds
        ; let env = mkABEnv exports
-             ar_env = mkArityEnv binds
              do_one (lcl_id, rhs) 
                | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
-               = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )     -- Not overloaded
-                  makeCorePair gbl_id (lookupArity ar_env lcl_id)
-                              (addAutoScc auto_scc gbl_id rhs)
+               = WARN( hasSpecPrags spec_prags, pprTcSpecPrags gbl_id spec_prags )       -- Not overloaded
+                  makeCorePair gbl_id False 0 (addAutoScc auto_scc gbl_id rhs)
 
                | otherwise = (lcl_id, rhs)
 
@@ -217,9 +215,7 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
                where
                  fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 
-             ar_env = mkArityEnv binds
              env = mkABEnv exports
-
              mk_lg_bind lcl_id gbl_id tyvars
                 = NonRec (setIdInfo lcl_id vanillaIdInfo)
                                -- Nuke the IdInfo so that no old unfoldings
@@ -229,14 +225,14 @@ 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
-               = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags )     -- Not overloaded
+               = WARN( hasSpecPrags spec_prags, pprTcSpecPrags gbl_id 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'))
+                            makeCorePair gbl_id False 0 rhs'))
                | otherwise
                = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
                     ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
@@ -254,25 +250,24 @@ dsHsBind auto_scc rest
   = 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
-               inl_arity = lookupArity (mkArityEnv binds) local
     
        ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global 
-                                        local inl_arity core_bind prags
+                                        local core_bind prags
 
        ; let   global'   = addIdSpecialisations global rules
                rhs       = addAutoScc auto_scc global $
                            mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
-               main_bind = makeCorePair global' (inl_arity + dictArity dicts) rhs
+               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
-             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)
@@ -297,7 +292,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
                     ; 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 
+                                                     core_bind 
                                                      spec_prags
                     ; let global' = addIdSpecialisations global rules
                           rhs = mkLams tyvars $ mkLams dicts $
@@ -317,50 +312,40 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
                    (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]
-  = (gbl_id `setIdUnfolding` mkInlineRule needSaturated rhs arity,
+  = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just (dict_arity + arity)),
+           -- NB: The arity in the InlineRule takes account of the dictionaries
      etaExpand arity rhs)
+
   | 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
 
-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]
-
-mkArityEnv :: LHsBinds Id -> IdEnv Arity
-       -- Maps a local to the arity of its definition
-mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds
-
-lhsBindArity :: LHsBind Id -> IdEnv Arity
-lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) 
-  = unitVarEnv (unLoc id) (matchGroupArity ms)
-lhsBindArity (L _ (AbsBinds { abs_exports = exports
-                            , abs_dicts = dicts
-                            , abs_binds = binds })) 
-  = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts) 
-             | (_, gbl, lcl, _) <- exports]
-  where             -- See Note [Nested arities] 
-    ar_env = mkArityEnv binds
-    n_val_dicts = dictArity dicts      
-
-lhsBindArity _ = emptyVarEnv   -- PatBind/VarBind
-
-dictArity :: [Var] -> Arity
--- Don't count coercion variables in arity
-dictArity dicts = count isId dicts
-
-lookupArity :: IdEnv Arity -> Id -> Arity
-lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
 \end{code}
 
 Note [Eta-expanding INLINE things]
@@ -435,17 +420,19 @@ Note that
 \begin{code}
 ------------------------
 dsSpecs :: [TyVar] -> [DictId] -> [TyVar]
-        -> Id -> Id -> Arity           -- Global, local, arity of local
-        -> CoreBind -> [LSpecPrag]
+        -> Id -> Id    -- Global, local
+        -> CoreBind -> TcSpecPrags
         -> DsM ( [(Id,CoreExpr)]       -- Binding for specialised Ids
               , [CoreRule] )           -- Rules for the Global Ids
 -- See Note [Implementing SPECIALISE pragmas]
-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) }
+dsSpecs all_tvs dicts tvs poly_id mono_id mono_bind 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 
-    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
@@ -475,8 +462,6 @@ 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
 
-                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]
@@ -488,7 +473,7 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
                                (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_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 
            ; return (Just (spec_pair : unf_pairs, rule))
            } } } }
index fa57d41..034949f 100644 (file)
@@ -207,7 +207,7 @@ dsFCall fn_id fcall = do
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule needSaturated wrap_rhs (length args)
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (Just (length args))
     
     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 \end{code}
index 91d1b90..01af78b 100644 (file)
@@ -399,7 +399,8 @@ cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
 cvtInlineSpec Nothing 
   = defaultInlinePragma
 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
-  = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo, inl_inline = inline }
+  = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
+                 , inl_inline = inline, inl_sat = Nothing }
   where
     matchinfo       = cvtRuleMatchInfo conlike
     opt_activation' = cvtActivation opt_activation
index ba3dbd6..f364883 100644 (file)
@@ -143,7 +143,7 @@ data HsBindLR idL idR
        -- AbsBinds only gets used when idL = idR after renaming,
        -- but these need to be idL's for the collect... code in HsUtil to have
        -- the right type
-       abs_exports :: [([TyVar], idL, idL, [LSpecPrag])],      -- (tvs, poly_id, mono_id, prags)
+       abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],      -- (tvs, poly_id, mono_id, prags)
        abs_binds   :: LHsBinds idL             -- The dictionary bindings and typechecked user bindings
                                                -- mixed up together; you can tell the dict bindings because
                                                -- they are all VarBinds
@@ -292,7 +292,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
   where
     ppr_exp (tvs, gbl, lcl, prags)
        = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
-               nest 2 (vcat (map (pprPrag gbl) prags))]
+               nest 2 (pprTcSpecPrags gbl prags)]
 \end{code}
 
 
@@ -471,15 +471,28 @@ data Sig name     -- Signatures and pragmas
 type LFixitySig name = Located (FixitySig name)
 data FixitySig name = FixitySig (Located name) Fixity 
 
--- A Prag conveys pragmas from the type checker to the desugarer
-type LSpecPrag = Located SpecPrag
-data SpecPrag 
+-- TsSpecPrags conveys pragmas from the type checker to the desugarer
+data TcSpecPrags 
+  = IsDefaultMethod    -- Super-specialised: a default method should 
+                       -- be macro-expanded at every call site
+  | SpecPrags [Located TcSpecPrag]
+
+data TcSpecPrag 
   = SpecPrag   
        HsWrapper       -- An wrapper, that specialises the polymorphic function
        InlinePragma    -- Inlining spec for the specialised function
 
-instance Outputable SpecPrag where
-  ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
+noSpecPrags :: TcSpecPrags
+noSpecPrags = SpecPrags []
+
+hasSpecPrags :: TcSpecPrags -> Bool
+hasSpecPrags (SpecPrags ps) = not (null ps)
+hasSpecPrags IsDefaultMethod = False
+
+isDefaultMethod :: TcSpecPrags -> Bool
+isDefaultMethod IsDefaultMethod = True
+isDefaultMethod (SpecPrags {})  = False
+
 \end{code}
 
 \begin{code}
@@ -600,7 +613,14 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p
     pp_inl | isDefaultInlinePragma inl = empty
            | otherwise = ppr inl
 
-pprPrag :: Outputable id => id -> LSpecPrag -> SDoc
-pprPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
+pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc
+pprTcSpecPrags _   IsDefaultMethod = ptext (sLit "<default method>")
+pprTcSpecPrags gbl (SpecPrags ps)  = vcat (map (pprSpecPrag gbl) ps)
+
+pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc
+pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
+
+instance Outputable TcSpecPrag where
+  ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
 \end{code}
 
index beb39c0..2931ffa 100644 (file)
@@ -600,16 +600,18 @@ instance Binary RuleMatchInfo where
                       else return FunLike
 
 instance Binary InlinePragma where
-    put_ bh (InlinePragma a b c) = do
+    put_ bh (InlinePragma a b c d) = do
             put_ bh a
             put_ bh b
             put_ bh c
+            put_ bh d
 
     get bh = do
            a <- get bh
            b <- get bh
            c <- get bh
-           return (InlinePragma a b c)
+           d <- get bh
+           return (InlinePragma a b c d)
 
 instance Binary StrictnessMark where
     put_ bh MarkedStrict    = putByte bh 0
@@ -1188,11 +1190,12 @@ instance Binary IfaceUnfolding where
     put_ bh (IfCoreUnfold e) = do
        putByte bh 0
        put_ bh e
-    put_ bh (IfInlineRule a b e) = do
+    put_ bh (IfInlineRule a b c d) = do
        putByte bh 1
        put_ bh a
        put_ bh b
-       put_ bh e
+       put_ bh c
+       put_ bh d
     put_ bh (IfWrapper a n) = do
        putByte bh 2
        put_ bh a
@@ -1200,6 +1203,9 @@ instance Binary IfaceUnfolding where
     put_ bh (IfDFunUnfold as) = do
        putByte bh 3
        put_ bh as
+    put_ bh (IfCompulsory e) = do
+       putByte bh 4
+       put_ bh e
     get bh = do
        h <- getByte bh
        case h of
@@ -1207,13 +1213,16 @@ instance Binary IfaceUnfolding where
                  return (IfCoreUnfold e)
          1 -> do a <- get bh
                  b <- get bh
-                 e <- get bh
-                 return (IfInlineRule a b e)
+                 c <- get bh
+                 d <- get bh
+                 return (IfInlineRule a b c d)
          2 -> do a <- get bh
                  n <- get bh
                  return (IfWrapper a n)
-         _ -> do as <- get bh
+         3 -> do as <- get bh
                  return (IfDFunUnfold as)
+         _ -> do e <- get bh
+                 return (IfCompulsory e)
 
 instance Binary IfaceNote where
     put_ bh (IfaceSCC aa) = do
index 9485dc9..1db7822 100644 (file)
@@ -211,11 +211,16 @@ data IfaceInfoItem
 
 data IfaceUnfolding 
   = IfCoreUnfold IfaceExpr
+  | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
+
   | IfInlineRule Arity 
                  Bool          -- OK to inline even if *un*-saturated
+                Bool           -- OK to inline even if context is boring
                  IfaceExpr 
+
   | IfWrapper    Arity Name      -- NB: we need a Name (not just OccName) because the worker
                                  --     can simplify to a function in another module.
+
   | IfDFunUnfold [IfaceExpr]
 
 --------------------------------
@@ -676,10 +681,11 @@ instance Outputable IfaceInfoItem where
   ppr HsNoCafRefs       = ptext (sLit "HasNoCafRefs")
 
 instance Outputable IfaceUnfolding where
+  ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
   ppr (IfCoreUnfold e)     = parens (ppr e)
-  ppr (IfInlineRule a b e) = ptext (sLit "InlineRule:")
-                             <+> parens (ptext (sLit "arity") <+> int a <+> ppr b
-                            <+> parens (ppr e)
+  ppr (IfInlineRule a uok bok e) = ptext (sLit "InlineRule")
+                                  <+> ppr (a,uok,bok
+                                 <+> parens (ppr e)
   ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
   ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns)
 
@@ -799,10 +805,11 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
 freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold e)     = freeNamesIfExpr e
-freeNamesIfUnfold (IfInlineRule _ _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfWrapper _ v)      = unitNameSet v
-freeNamesIfUnfold (IfDFunUnfold vs)    = fnList freeNamesIfExpr vs
+freeNamesIfUnfold (IfCoreUnfold e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v
+freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr vs
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)     = unitNameSet v
index 1c34edc..702a744 100644 (file)
@@ -1503,20 +1503,21 @@ toIfaceIdInfo id_info
 
 --------------------------
 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
-                                , uf_src = src, uf_guidance = guidance })
-  = case src of
-       InlineWrapper w -> Just (HsUnfold lb (IfWrapper arity (idName w)))
-       InlineRule {}   -> Just (HsUnfold lb (IfInlineRule arity sat (toIfaceExpr rhs)))
-        _other          -> Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs)))
+toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+                                    , uf_src = src, uf_guidance = guidance })
+  = Just $ HsUnfold lb $
+    case src of
+       InlineRule {}
+          -> case guidance of
+               UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs)
+               _other                     -> pprPanic "toIfUnfolding" (ppr unf)
+       InlineWrapper w  -> IfWrapper arity (idName w)
+        InlineCompulsory -> IfCompulsory (toIfaceExpr rhs)
+        InlineRhs        -> IfCoreUnfold (toIfaceExpr rhs)
        -- Yes, even if guidance is UnfNever, expose the unfolding
        -- If we didn't want to expose the unfolding, TidyPgm would
        -- have stuck in NoUnfolding.  For supercompilation we want 
        -- to see that unfolding!
-  where
-    sat = case guidance of
-            UnfWhen unsat_ok _ -> unsat_ok
-            _other             -> needSaturated
 
 toIfUnfolding lb (DFunUnfolding _con ops)
   = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
index c9c33db..7d0d02e 100644 (file)
@@ -1015,11 +1015,19 @@ tcUnfolding name _ info (IfCoreUnfold if_expr)
                     Just sig -> isBottomingSig sig
                     Nothing  -> False
 
-tcUnfolding name _ _ (IfInlineRule arity unsat_ok if_expr)
+tcUnfolding name _ _ (IfCompulsory if_expr)
   = do         { mb_expr <- tcPragExpr name if_expr
        ; return (case mb_expr of
                    Nothing   -> NoUnfolding
-                   Just expr -> mkInlineRule unsat_ok expr arity) }
+                   Just expr -> mkCompulsoryUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+  = do         { mb_expr <- tcPragExpr name if_expr
+       ; return (case mb_expr of
+                   Nothing   -> NoUnfolding
+                   Just expr -> mkCoreUnfolding True InlineRule expr arity 
+                                                 (UnfWhen unsat_ok boring_ok))
+    }
 
 tcUnfolding name ty info (IfWrapper arity wkr)
   = do         { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
index 300d886..2700c6f 100644 (file)
@@ -977,6 +977,7 @@ mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
 -- The Maybe is because the user can omit the activation spec (and usually does)
 mkInlinePragma mb_act match_info inl 
   = InlinePragma { inl_inline = inl
+                 , inl_sat    = Nothing
                  , inl_act    = act
                  , inl_rule   = match_info }
   where
index 2001a17..a5a581b 100644 (file)
@@ -1982,7 +1982,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
                      DataAlt dc -> setIdUnfolding case_bndr unf
                          where
                                 -- See Note [Case binders and join points]
-                            unf = mkInlineRule needSaturated rhs 0
+                            unf = mkInlineRule rhs Nothing
                             rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
                                                ++ varsToCoreExprs bndrs')
 
index 4342534..5c29ffb 100644 (file)
@@ -915,10 +915,15 @@ specDefn subst body_uds fn rhs
 
                -- Add an InlineRule if the parent has one
                -- See Note [Inline specialisations]
-               final_spec_f | Just sat <- fn_has_inline_rule
-                            = spec_f_w_arity `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity
-                            | otherwise 
-                            = spec_f_w_arity
+               final_spec_f 
+                  | Just sat <- fn_has_inline_rule
+                 = let 
+                       mb_spec_arity = if sat then Just spec_arity else Nothing
+                    in 
+                    spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity
+                 | otherwise 
+                 = spec_f_w_arity
+
           ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
       where
        my_zipEqual xs ys zs
index 2547978..b0759b9 100644 (file)
@@ -274,8 +274,8 @@ checkSize fn_id rhs thing_inside
 
   | otherwise = thing_inside
   where
-    unfolding = idUnfolding fn_id
-    inline_rule = mkInlineRule unSaturatedOk rhs (unfoldingArity unfolding)
+    unfolding   = idUnfolding fn_id
+    inline_rule = mkInlineRule rhs Nothing
 
 ---------------------
 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
@@ -314,15 +314,16 @@ splitFun fn_id fn_info wrap_dmds res_info rhs
 
        wrap_rhs  = wrap_fn work_id
        wrap_prag = InlinePragma { inl_inline = True
+                                 , inl_sat    = Nothing
                                  , inl_act    = ActiveAfter 0
                                  , inl_rule   = rule_match_info }
+               -- See Note [Wrapper activation]
+               -- The RuleMatchInfo is (and must be) unaffected
+               -- The inl_inline is bound to be False, else we would not be
+               --    making a wrapper
 
        wrap_id   = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity
                          `setInlinePragma` wrap_prag
-                               -- See Note [Wrapper activation]
-                               -- The RuleMatchInfo is (and must be) unaffected
-                               -- The inl_inline is bound to be False, else we would not be
-                               --    making a wrapper
                          `setIdOccInfo` NoOccInfo
                                -- Zap any loop-breaker-ness, to avoid bleating from Lint
                                -- about a loop breaker with an INLINE rule
index f21bbe6..2871f3b 100644 (file)
@@ -149,7 +149,7 @@ tcValBinds _ (ValBindsIn binds _) _
 
 tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
   = do  {       -- Typecheck the signature
-        ; let { prag_fn = mkPragFun sigs
+        ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
               ; ty_sigs = filter isTypeLSig sigs
               ; sig_fn  = mkTcSigFun ty_sigs }
 
@@ -336,9 +336,13 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
   ; if is_strict then
     do  { extendLIEs lie_req
         ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
-              mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
-              mk_export (_,    Just sig, mono_id) _       = ([], sig_id sig,             mono_id, [])
-                        -- ToDo: prags for unlifted bindings
+              mk_export (name, mb_sig,  mono_id) mono_ty 
+                = ([], the_id, mono_id, noSpecPrags)
+                              -- ToDo: prags for unlifted bindings
+               where
+                  the_id = case mb_sig of
+                             Just sig -> sig_id sig
+                             Nothing  -> mkLocalId name mono_ty
 
         ; return ( unitBag $ L loc $ AbsBinds [] [] exports binds',
                    [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
@@ -372,7 +376,7 @@ mkExport :: TopLevelFlag -> RecFlag
                         -- a tuple, so INLINE pragmas won't work
          -> TcPragFun -> [TyVar] -> [TcType]
          -> MonoBindInfo
-         -> TcM ([TyVar], Id, Id, [LSpecPrag])
+         -> TcM ([TyVar], Id, Id, TcSpecPrags)
 -- mkExport generates exports with 
 --      zonked type variables, 
 --      zonked poly_ids
@@ -395,7 +399,7 @@ mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys
                                             poly_id (prag_fn poly_name)
                 -- tcPrags requires a zonked poly_id
 
-        ; return (tvs, poly_id', mono_id, spec_prags) }
+        ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) }
   where
     poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
 
@@ -410,22 +414,41 @@ mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys
 ------------------------
 type TcPragFun = Name -> [LSig Name]
 
-mkPragFun :: [LSig Name] -> TcPragFun
-mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
-        where
-          prs = [(expectJust "mkPragFun" (sigName sig), sig) 
-                | sig <- sigs, isPragLSig sig]
-          env = foldl add emptyNameEnv prs
-          add env (n,p) = extendNameEnv_Acc (:) singleton env n p
+mkPragFun :: [LSig Name] -> LHsBinds Name -> TcPragFun
+mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
+  where
+    prs = mapCatMaybes get_sig sigs
+
+    get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
+    get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig  nm ty (add_arity nm inl))
+    get_sig (L l (InlineSig nm inl))  = Just (nm, L l $ InlineSig nm   (add_arity nm inl))
+    get_sig _                         = Nothing
+
+    add_arity (L _ n) inl_prag   -- Adjust inl_sat field to match visible arity of function
+      | Just ar <- lookupNameEnv ar_env n = inl_prag { inl_sat = Just ar }
+      | otherwise                         = inl_prag
+
+    prag_env :: NameEnv [LSig Name]
+    prag_env = foldl add emptyNameEnv prs
+    add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
+
+    -- ar_env maps a local to the arity of its definition
+    ar_env :: NameEnv Arity
+    ar_env = foldrBag lhsBindArity emptyNameEnv binds
+
+lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
+  = extendNameEnv env (unLoc id) (matchGroupArity ms)
+lhsBindArity _ env = env       -- PatBind/VarBind
 
 tcPrags :: RecFlag
        -> Bool     -- True <=> AbsBinds binds more than one variable
         -> Bool     -- True <=> function is overloaded
         -> Id -> [LSig Name]
-        -> TcM (Id, [LSpecPrag])
+        -> TcM (Id, [Located TcSpecPrag])
 -- Add INLINE and SPECLIASE pragmas
---    INLINE prags are added to the Id directly
---    SPECIALISE prags are passed to the desugarer via [LSpecPrag]
+--    INLINE prags are added to the (polymorphic) Id directly
+--    SPECIALISE prags are passed to the desugarer via TcSpecPrags
 -- Pre-condition: the poly_id is zonked
 -- Reason: required by tcSubExp
 tcPrags _rec_group _multi_bind _is_overloaded_id poly_id prag_sigs
@@ -491,7 +514,7 @@ warnPrags id bad_sigs herald
     ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
 
 --------------
-tcSpecPrag :: TcId -> Sig Name -> TcM SpecPrag
+tcSpecPrag :: TcId -> Sig Name -> TcM TcSpecPrag
 tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl) 
   = addErrCtxt (spec_ctxt prag) $
     do  { let name = idName poly_id
index 23ee423..2d113b7 100644 (file)
@@ -179,7 +179,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
        ; let
              (tyvars, _, _, op_items) = classBigSig clas
              rigid_info  = ClsSkol clas
-             prag_fn     = mkPragFun sigs
+             prag_fn     = mkPragFun sigs default_binds
              sig_fn      = mkTcSigFun sigs
              clas_tyvars = tcSkolSigTyVars rigid_info tyvars
              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
@@ -234,16 +234,20 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id
         ; (dm_id_w_inline, spec_prags) 
                 <- tcPrags NonRecursive False True dm_id (prag_fn sel_name)
 
+        ; warnTc (not (null spec_prags))
+                 (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
+                  <+> quotes (ppr sel_name))
+
         ; tcInstanceMethodBody (instLoc this_dict) 
                                tyvars [this_dict]
                                ([], emptyBag)
                                dm_id_w_inline local_dm_id
-                               dm_sig_fn spec_prags meth_bind }
+                               dm_sig_fn IsDefaultMethod meth_bind }
 
 ---------------
 tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
                     -> ([Inst], LHsBinds Id) -> Id -> Id
-                    -> TcSigFun -> [LSpecPrag] -> LHsBind Name 
+                    -> TcSigFun -> TcSpecPrags -> LHsBind Name 
                     -> TcM (Id, LHsBind Id)
 tcInstanceMethodBody inst_loc tyvars dfun_dicts
                     (this_dict, this_bind) meth_id local_meth_id
index ee6de33..e46ab45 100644 (file)
@@ -363,8 +363,12 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
     zonkExport env (tyvars, global, local, prags)
        -- The tyvars are already zonked
        = zonkIdBndr env global                 `thenM` \ new_global ->
-         mapM zonk_prag prags                  `thenM` \ new_prags -> 
+         zonk_prags prags                      `thenM` \ new_prags -> 
          returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
+
+    zonk_prags IsDefaultMethod = return IsDefaultMethod
+    zonk_prags (SpecPrags ps)  = do { ps' <- mapM zonk_prag ps; return (SpecPrags ps') }
+
     zonk_prag (L loc (SpecPrag co_fn inl))
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag co_fn' inl)) }
index 1af025e..c4c5d58 100644 (file)
@@ -33,8 +33,6 @@ import DataCon
 import Class
 import Var
 import CoreUnfold ( mkDFunUnfolding )
--- import CoreUtils  ( mkPiTypes )
-import PrelNames  ( inlineIdName )
 import Id
 import MkId
 import Name
@@ -667,7 +665,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi)
 
         ; return (unitBag $ noLoc $
                   AbsBinds inst_tvs' (map instToVar dfun_dicts)
-                            [(inst_tvs', dfun_id, instToId this_dict, [])]
+                            [(inst_tvs', dfun_id, instToId this_dict, noSpecPrags)]
                             (dict_bind `consBag` sc_binds)) }
   where
       -----------------------
@@ -753,7 +751,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
        ; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs
 
         -- Typecheck the methods
-       ; let prag_fn = mkPragFun uprags 
+       ; let prag_fn = mkPragFun uprags monobinds
              tc_meth = tcInstanceMethod loc standalone_deriv
                                         clas inst_tyvars'
                                        dfun_dicts inst_tys'
@@ -801,7 +799,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
              main_bind = AbsBinds
                          inst_tyvars'
                          dfun_lam_vars
-                         [(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)]
+                         [(inst_tyvars', dfun_id_w_fun, this_dict_id, SpecPrags spec_inst_prags)]
                          (unitBag dict_bind)
 
        ; showLIE (text "instance")
@@ -891,7 +889,7 @@ tcSuperClass inst_loc tyvars dicts (this_dict, this_bind)
             sc_id      = instToVar sc_dict
             sc_op_bind = AbsBinds tyvars 
                             (map instToVar dicts) 
-                             [(tyvars, sc_op_id, sc_id, [])]
+                             [(tyvars, sc_op_id, sc_id, noSpecPrags)]
                              (this_bind `unionBags` sc_binds)
 
        ; return (sc_op_id, noLoc sc_op_bind) }
@@ -948,7 +946,7 @@ SpecPrag which, as it turns out, can be used unchanged for each method.
 The "it turns out" bit is delicate, but it works fine!
 
 \begin{code}
-tcSpecInst :: Id -> Sig Name -> TcM SpecPrag
+tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
 tcSpecInst dfun_id prag@(SpecInstSig hs_ty) 
   = addErrCtxt (spec_ctxt prag) $
     do  { let name = idName dfun_id
@@ -981,7 +979,7 @@ tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
                 -> [TcType]
                 -> (Inst, LHsBinds Id)  -- "This" and its binding
                 -> TcPragFun            -- Local prags
-                -> [LSpecPrag]          -- Arising from 'SPECLALISE instance'
+                -> [Located TcSpecPrag] -- Arising from 'SPECLALISE instance'
                  -> LHsBinds Name 
                 -> (Id, DefMeth)
                 -> TcM (Id, LHsBind Id)
@@ -1006,13 +1004,13 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
              tc_body rn_bind 
                 = add_meth_ctxt rn_bind $
                   do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True 
-                                                    meth_id (prag_fn sel_name)
+                                                         meth_id (prag_fn sel_name)
                      ; tcInstanceMethodBody (instLoc this_dict)
                                     tyvars dfun_dicts
                                    ([this_dict], this_dict_bind)
                                     meth_id1 local_meth_id
                                    meth_sig_fn 
-                                    (spec_inst_prags ++ spec_prags) 
+                                    (SpecPrags (spec_inst_prags ++ spec_prags))
                                     rn_bind }
 
            --------------
@@ -1040,14 +1038,9 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
                       dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
                                        -- Might not be imported, but will be an OrigName
                     ; dm_id <- tcLookupId dm_name
-                    ; inline_id <- tcLookupId inlineIdName
                      ; let dm_inline_prag = idInlinePragma dm_id
-                           dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
-                                   HsVar dm_id 
-                           rhs | isInlinePragma dm_inline_prag  -- See Note [INLINE and default methods]
-                               = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id)))
-                                       (L loc dm_app)
-                               | otherwise = dm_app
+                           rhs = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
+                                HsVar dm_id 
 
                           meth_bind = L loc $ VarBind { var_id = local_meth_id
                                                        , var_rhs = L loc rhs 
@@ -1057,8 +1050,8 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
                                    -- method to this version. Note [INLINE and default methods]
                                    
                            bind = AbsBinds { abs_tvs = tyvars, abs_dicts =  dfun_lam_vars
-                                           , abs_exports = [( tyvars, meth_id1
-                                                            , local_meth_id, spec_inst_prags)]
+                                           , abs_exports = [( tyvars, meth_id1, local_meth_id
+                                                            , SpecPrags spec_inst_prags)]
                                            , abs_binds = this_dict_bind `unionBags` unitBag meth_bind }
                     -- Default methods in an instance declaration can't have their own 
                     -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
@@ -1143,7 +1136,8 @@ From the class decl we get
    $dmfoo :: forall v x. Baz v x => x -> x
    $dmfoo y = <blah>
 
-Notice that the type is ambiguous.  That's fine, though. The instance decl generates
+Notice that the type is ambiguous.  That's fine, though. The instance
+decl generates
 
    $dBazIntInt = MkBaz fooIntInt
    fooIntInt = $dmfoo Int Int $dBazIntInt
@@ -1155,8 +1149,9 @@ less work to generate the translated version!
 
 Note [INLINE and default methods]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We *copy* any INLINE pragma from the default method to the instance.
-Example:
+Default methods need special case.  They are supposed to behave rather like
+macros.  For exmample
+
   class Foo a where
     op1, op2 :: Bool -> a -> a
 
@@ -1164,31 +1159,57 @@ Example:
     op1 b x = op2 (not b) x
 
   instance Foo Int where
+    -- op1 via default method
     op2 b x = <blah>
+   
+The instance declaration should behave
+
+   just as if 'op1' had been defined with the
+   code, and INLINE pragma, from its original
+   definition. 
+
+That is, just as if you'd written
+
+  instance Foo Int where
+    op2 b x = <blah>
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+So for the above example we generate:
 
-Then we generate:
 
   {-# INLINE $dmop1 #-}
+  -- $dmop1 has an InlineCompulsory unfolding
   $dmop1 d b x = op2 d (not b) x
 
   $fFooInt = MkD $cop1 $cop2
 
   {-# INLINE $cop1 #-}
-  $cop1 = inline $dmop1 $fFooInt
+  $cop1 = $dmop1 $fFooInt
 
   $cop2 = <blah>
 
-Note carefully:
-  a) We copy $dmop1's inline pragma to $cop1.  Otherwise 
-     we'll just inline the former in the latter and stop, which 
-     isn't what the user expected
-
-  b) We use the magic 'inline' Id to ensure that $dmop1 really is
-     inlined in $cop1, even though 
-       (i)  the latter itself has an INLINE pragma
-       (ii) $dmop1 is not saturated
-     That is important to allow the mutual recursion between $fooInt and
-     $cop1 to be broken
+Note carefullly:
+
+* We *copy* any INLINE pragma from the default method $dmop1 to the
+  instance $cop1.  Otherwise we'll just inline the former in the
+  latter and stop, which isn't what the user expected
+
+* Regardless of its pragma, we give the default method an 
+  unfolding with an InlineCompulsory source. That means
+  that it'll be inlined at every use site, notably in
+  each instance declaration, such as $cop1.  This inlining
+  must happen even though 
+    a) $dmop1 is not saturated in $cop1
+    b) $cop1 itself has an INLINE pragma
+
+  It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+  recursion between $fooInt and $cop1 to be broken
+
+* To communicate the need for an InlineCompulsory to the desugarer
+  (which makes the Unfoldings), we use the IsDefaultMethod constructor
+  in TcSpecPrags.
 
 
 %************************************************************************
index f31ecd8..83fd512 100644 (file)
@@ -789,7 +789,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc
 
           raw_worker <- cloneId mkVectOcc orig_worker (exprType body)
           let vect_worker = raw_worker `setIdUnfolding`
-                              mkInlineRule needSaturated body arity
+                              mkInlineRule body (Just arity)
           defGlobalVar orig_worker vect_worker
           return (vect_worker, body)
       where
@@ -830,7 +830,7 @@ buildPADict vect_tc prepr_tc arr_tc repr
           let body = mkLams (tvs ++ args) expr
           raw_var <- newExportedVar (method_name name) (exprType body)
           let var = raw_var
-                      `setIdUnfolding` mkInlineRule needSaturated body (length args)
+                      `setIdUnfolding` mkInlineRule body (Just (length args))
                       `setInlinePragma` alwaysInlinePragma
           hoistBinding var body
           return var
index 8dccd61..c62c405 100644 (file)
@@ -38,7 +38,7 @@ import Var
 import MkId               ( unwrapFamInstScrut )
 import Id                 ( setIdUnfolding )
 import TysWiredIn
-import BasicTypes         ( Boxity(..) )
+import BasicTypes         ( Boxity(..), Arity )
 import Literal            ( Literal, mkMachInt )
 
 import Outputable
@@ -348,7 +348,7 @@ polyVApply expr tys
       return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
 
 
-data Inline = Inline Int -- arity
+data Inline = Inline Arity
             | DontInline
 
 addInlineArity :: Inline -> Int -> Inline
@@ -371,7 +371,7 @@ hoistExpr fs expr inl
   where
     mk_inline var = case inl of
                       Inline arity -> var `setIdUnfolding`
-                                      mkInlineRule needSaturated expr arity
+                                      mkInlineRule expr (Just arity)
                       DontInline   -> var
 
 hoistVExpr :: VExpr -> Inline -> VM VVar
index cc91e9f..c53c638 100644 (file)
@@ -106,7 +106,7 @@ vectTopBinder var inline expr
       return var'
   where
     unfolding = case inline of
-                  Inline arity -> mkInlineRule needSaturated expr arity
+                  Inline arity -> mkInlineRule expr (Just arity)
                   DontInline   -> noUnfolding
 
 vectTopRhs :: Var -> CoreExpr -> VM (Inline, CoreExpr)