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.
Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike,
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma,
- isDefaultInlinePragma, isInlinePragma,
+ isDefaultInlinePragma, isInlinePragma, inlinePragmaSat,
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
= 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 )
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
isInlinePragma :: InlinePragma -> Bool
isInlinePragma prag = inl_inline prag
+inlinePragmaSat :: InlinePragma -> Maybe Arity
+inlinePragmaSat = inl_sat
+
inlinePragmaActivation :: InlinePragma -> Activation
inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
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
-- ...(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 $
-- 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
import OccurAnal
import CoreSubst hiding( substTy )
import CoreFVs ( exprFreeVars )
+import CoreArity ( manifestArity )
import CoreUtils
import Id
import DataCon
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
| 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
\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
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)
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
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,
= 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)
; 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 $
(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]
\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
-- 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]
(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))
} } } }
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}
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
-- 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
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}
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}
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}
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
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
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
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
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]
--------------------------------
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)
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
--------------------------
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)))
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)
-- 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
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')
-- 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
| 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
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
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 }
; 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
-- 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
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))
------------------------
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
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
; 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)
; (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
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)) }
import Class
import Var
import CoreUnfold ( mkDFunUnfolding )
--- import CoreUtils ( mkPiTypes )
-import PrelNames ( inlineIdName )
import Id
import MkId
import Name
; 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
-----------------------
; 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'
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")
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) }
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
-> [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)
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 }
--------------
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
-- 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
$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
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
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.
%************************************************************************
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
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
import MkId ( unwrapFamInstScrut )
import Id ( setIdUnfolding )
import TysWiredIn
-import BasicTypes ( Boxity(..) )
+import BasicTypes ( Boxity(..), Arity )
import Literal ( Literal, mkMachInt )
import Outputable
return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
-data Inline = Inline Int -- arity
+data Inline = Inline Arity
| DontInline
addInlineArity :: Inline -> Int -> Inline
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
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)
projects / ghc-hetmet.git / commitdiff