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 }
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
`setCafInfo` NoCafRefs
-- ToDo: consider adding further IdInfo
- unfolding = mkTopUnfolding NoCPRInfo sel_rhs
+ unfolding = mkTopUnfolding sel_rhs
[data_id] = mkTemplateLocals [data_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
%************************************************************************
\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
\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
-- 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
\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
(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_`
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 )
-- 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
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
-- 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' ->
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 )
-- 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
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
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
-- 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
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
projects / ghc-hetmet.git / commitdiff