Commit b822aa0e authored by simonpj's avatar simonpj
Browse files

[project @ 2000-03-30 16:23:56 by simonpj]

* Remove the unnecessary CPR parameter to mkUnfolding and friends

* Make sure that even trivial wrappers have a __inline__
  (this was causing lots of 'substWorker' DEBUG messages)

* Nuke demand info when the unfolding is a value
  (see notes with IdInfo.setUnfoldingInfo)

* Add an update-in-place test to the 'interesting context'
  predicate in SimplUtils.
parent bbf0592f
......@@ -166,9 +166,23 @@ setOccInfo info oc = oc `seq` info { occInfo = oc }
setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
-- Try to avoid spack leaks by seq'ing
setUnfoldingInfo info uf = info { unfoldingInfo = uf }
setUnfoldingInfo info uf
| isEvaldUnfolding uf && isStrict (demandInfo info)
-- If the unfolding is a value, the demand info may
-- go pear-shaped, so we nuke it. Example:
-- let x = (a,b) in
-- case x of (p,q) -> h p q x
-- Here x is certainly demanded. But after we've nuked
-- the case, we'll get just
-- let x = (a,b) in h a b x
-- and now x is not demanded (I'm assuming h is lazy)
-- This really happens. The solution here is a bit ad hoc...
= info { unfoldingInfo = uf, demandInfo = wwLazy }
| otherwise
-- We do *not* seq on the unfolding info, For some reason, doing so
-- actually increases residency significantly.
= info { unfoldingInfo = uf }
setUpdateInfo info ud = info { updateInfo = ud }
setDemandInfo info dd = info { demandInfo = dd }
......
......@@ -229,7 +229,7 @@ mkDataConWrapId data_con
work_id = dataConId data_con
info = mkIdInfo (DataConWrapId data_con)
`setUnfoldingInfo` mkTopUnfolding cpr_info (mkInlineMe wrap_rhs)
`setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
`setCprInfo` cpr_info
-- The Cpr info can be important inside INLINE rhss, where the
-- wrapper constructor isn't inlined
......@@ -369,7 +369,7 @@ mkRecordSelId tycon field_label
`setCafInfo` NoCafRefs
-- ToDo: consider adding further IdInfo
unfolding = mkTopUnfolding NoCPRInfo sel_rhs
unfolding = mkTopUnfolding sel_rhs
[data_id] = mkTemplateLocals [data_ty]
......@@ -430,7 +430,7 @@ mkDictSelId name clas ty
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
unfolding = mkTopUnfolding NoCPRInfo rhs
unfolding = mkTopUnfolding rhs
tyvars = classTyVars clas
......
......@@ -77,15 +77,15 @@ import GlaExts ( fromInt )
%************************************************************************
\begin{code}
mkTopUnfolding cpr_info expr = mkUnfolding True {- Top level -} cpr_info expr
mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
mkUnfolding top_lvl cpr_info expr
mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseGlobalExpr expr)
top_lvl
(exprIsCheap expr)
(exprIsValue expr)
(exprIsBottom expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold cpr_info expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold expr)
-- Sometimes during simplification, there's a large let-bound thing
-- which has been substituted, and so is now dead; so 'expr' contains
-- two copies of the thing while the occurrence-analysed expression doesn't
......@@ -120,10 +120,9 @@ instance Outputable UnfoldingGuidance where
\begin{code}
calcUnfoldingGuidance
:: Int -- bomb out if size gets bigger than this
-> CprInfo -- CPR info for this RHS
-> CoreExpr -- expression to look at
-> UnfoldingGuidance
calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr
calcUnfoldingGuidance bOMB_OUT_SIZE expr
= case collect_val_bndrs expr of { (inline, val_binders, body) ->
let
n_val_binders = length val_binders
......@@ -135,16 +134,6 @@ calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr
-- so that INLINE things don't get inlined into entirely boring contexts,
-- but no more.
-- Experimental thing commented in for now
-- max_inline_size = case cpr_info of
-- NoCPRInfo -> n_val_binders + 2
-- ReturnsCPR -> n_val_binders + 1
-- However, the wrapper for a CPR'd function is particularly good to inline,
-- even in a boring context, because we may get to do update in place:
-- let x = case y of { I# y# -> I# (y# +# 1#) }
-- Hence the case on cpr_info
in
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
......@@ -437,7 +426,7 @@ Just the same as smallEnoughToInline, except that it has no actual arguments.
\begin{code}
couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold NoCPRInfo rhs of
couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of
UnfoldNever -> False
other -> True
......
......@@ -202,15 +202,13 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
(op_sigs, non_op_sigs) = partition isClassOpSig sigs
(fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
in
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs
`thenRn` \ (sigs', sig_fvs) ->
mapRn_ (unknownSigErr) non_sigs `thenRn_`
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
mapRn_ (unknownSigErr) non_sigs `thenRn_`
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
in
renameSigs False binders lookupOccRn fix_sigs
`thenRn` \ (fixs', fix_fvs) ->
renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) ->
-- Check the methods
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
......
......@@ -27,13 +27,13 @@ import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExp
import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
import Id ( Id, idType, isId, idName,
idOccInfo, idUnfolding,
idDemandInfo, mkId, idInfo
mkId, idInfo
)
import IdInfo ( arityLowerBound, setOccInfo, vanillaIdInfo )
import Maybes ( maybeToBool, catMaybes )
import Name ( isLocalName, setNameUnique )
import SimplMonad
import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
)
import DataCon ( dataConRepArity )
......@@ -284,7 +284,9 @@ discardInline cont = cont
-- small arity. But arity zero isn't good -- we share the single copy
-- for that case, so no point in sharing.
canUpdateInPlace ty = case splitAlgTyConApp_maybe ty of
-- Note the repType: we want to look through newtypes for this purpose
canUpdateInPlace ty = case splitAlgTyConApp_maybe (repType ty) of
Just (_, _, [dc]) -> arity == 1 || arity == 2
where
arity = dataConRepArity dc
......
......@@ -551,12 +551,12 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
old_info = idInfo old_bndr
new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
`setArityInfo` ArityAtLeast (exprArity new_rhs)
`setUnfoldingInfo` mkUnfolding top_lvl (cprInfo old_info) new_rhs
`setUnfoldingInfo` mkUnfolding top_lvl new_rhs
final_id = new_bndr `setIdInfo` new_bndr_info
in
-- These seqs force the Ids, and hence the IdInfos, and hence any
-- inner substitutions
-- These seqs forces the Id, and hence its IdInfo,
-- and hence any inner substitutions
final_id `seq`
addLetBind final_id new_rhs $
modifyInScope new_bndr final_id thing_inside
......@@ -1395,7 +1395,7 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
-- Bind the case-binder to (con args)
let
unfolding = mkUnfolding False NoCPRInfo (mkAltExpr con vs' inst_tys')
unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
in
modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $
simplExprC rhs cont' `thenSmpl` \ rhs' ->
......
......@@ -14,11 +14,11 @@ import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core,
opt_D_dump_worker_wrapper
)
import CoreLint ( beginPass, endPass )
import CoreUtils ( exprType, exprArity, exprEtaExpandArity, mkInlineMe )
import CoreUtils ( exprType, exprArity, exprEtaExpandArity )
import DataCon ( DataCon )
import MkId ( mkWorkerId )
import Id ( Id, idType, idStrictness, setIdArityInfo, isOneShotLambda,
setIdStrictness, idDemandInfo, idInlinePragma,
setIdStrictness, idInlinePragma,
setIdWorkerInfo, idCprInfo, setInlinePragma )
import VarSet
import Type ( Type, isNewType, splitForAllTys, splitFunTys )
......@@ -196,7 +196,7 @@ tryWW non_rec fn_id rhs
-- twice, this test also prevents wrappers (which are INLINEd)
-- from being re-done.
--
-- OUT OF DATE NOTE:
-- OUT OF DATE NOTE, kept for info:
-- In this case we add an INLINE pragma to the RHS. Why?
-- Because consider
-- f = \x -> g x x
......@@ -237,6 +237,7 @@ tryWW non_rec fn_id rhs
in
returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
-- Worker first, because wrapper mentions it
-- Arrange to inline the wrapper unconditionally
where
fun_ty = idType fn_id
arity = exprEtaExpandArity rhs
......
......@@ -235,8 +235,15 @@ mkWwBodies fun_ty arity demands res_bot one_shots cpr_info
mkWWfixup cpr_res_ty work_dmds `thenUs` \ (final_work_dmds, wrap_fn_fixup, work_fn_fixup) ->
returnUs (final_work_dmds,
mkInlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup . Var,
Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup . Var,
work_fn_fixup . work_fn_str . work_fn_cpr . work_fn_args)
-- We use an INLINE unconditionally, even if the wrapper turns out to be
-- something trivial like
-- fw = ...
-- f = __inline__ (coerce T fw)
-- The point is to propagate the coerce to f's call sites, so even though
-- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
-- fw from being inlined into f's RHS
where
demands' = demands ++ repeat wwLazy
one_shots' = one_shots ++ repeat False
......
......@@ -96,7 +96,7 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins
-- is never inspected; so the typecheck doesn't even happen
unfold_info = case maybe_expr' of
Nothing -> noUnfolding
Just expr' -> mkTopUnfolding (cprInfo info) expr'
Just expr' -> mkTopUnfolding expr'
info1 = info `setUnfoldingInfo` unfold_info
info2 = info1 `setInlinePragInfo` inline_prag
in
......@@ -119,7 +119,7 @@ tcWorkerInfo unf_env ty info worker_name
let
-- Watch out! We can't pull on unf_env too eagerly!
info' = case explicitLookupValue unf_env worker_name of
Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding cpr_info (wrap_fn worker_id)
Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
`setWorkerInfo` HasWorker worker_id arity
Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment