summaryrefslogtreecommitdiff
path: root/ghc
diff options
context:
space:
mode:
Diffstat (limited to 'ghc')
-rw-r--r--ghc/compiler/basicTypes/IdInfo.lhs16
-rw-r--r--ghc/compiler/basicTypes/MkId.lhs6
-rw-r--r--ghc/compiler/coreSyn/CoreUnfold.lhs21
-rw-r--r--ghc/compiler/rename/RnSource.lhs10
-rw-r--r--ghc/compiler/simplCore/SimplUtils.lhs8
-rw-r--r--ghc/compiler/simplCore/Simplify.lhs8
-rw-r--r--ghc/compiler/stranal/WorkWrap.lhs7
-rw-r--r--ghc/compiler/stranal/WwLib.lhs9
-rw-r--r--ghc/compiler/typecheck/TcIfaceSig.lhs4
9 files changed, 50 insertions, 39 deletions
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index e7056de0cb..c94e81b39f 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -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 }
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 871b77df37..c06c67c2e4 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -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
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 80f9a0698f..35491cd4b7 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -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
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 982acdafd8..abf41500d2 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -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_`
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 22d13573c6..f84278ebd9 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -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
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 9febaa79fe..8c08c66b26 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -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' ->
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index b6d021a67f..92eaf088aa 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -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
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index be6f333b72..1215078bfd 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -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
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 57ff4c0319..1778c8e6ca 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -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
View Lorry Controller Status