Commit 77166b17 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Improve the handling of default methods

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.
parent 0af418be
......@@ -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
......
......@@ -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 $
......
......@@ -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
......
......@@ -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
......
......@@ -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))
} } } }
......
......@@ -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}
......
......@@ -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
......
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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)))
......
......@@ -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)
......
......@@ -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
......
......@@ -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')
......
......@@ -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
......
......@@ -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
......
......@@ -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
......