-
+%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
import Id ( Id, idType, idInfo, idUnique, isDataConId, isDataConId_maybe,
idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
idSpecialisation, setIdSpecialisation,
- idDemandInfo, setIdDemandInfo,
+ idDemandInfo,
setIdInfo,
idOccInfo, setIdOccInfo,
zapLamIdInfo, zapFragileIdInfo,
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
specInfo, inlinePragInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo,
- CprInfo(..), cprInfo
+ CprInfo(..), cprInfo, occInfo
)
import Demand ( Demand, isStrict, wwLazy )
import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity,
import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
-import BasicTypes ( TopLevelFlag(..), isTopLevel )
+import BasicTypes ( TopLevelFlag(..), isTopLevel, isLoopBreaker )
import Maybes ( maybeToBool )
import Util ( zipWithEqual, lengthExceeds )
import PprCore
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
- final_id = new_bndr `setIdInfo` new_bndr_info
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing we can get into an infinite loop
+ info_w_unf | isLoopBreaker (occInfo old_info) = new_bndr_info
+ | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
+
+ final_id = new_bndr `setIdInfo` info_w_unf
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
= simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
-- A data constructor whose argument is now non-trivial;
-- so let/case bind it.
- newId arg_ty $ \ arg_id ->
+ newId SLIT("a") arg_ty $ \ arg_id ->
addNonRecBind arg_id new_arg $
go (Var arg_id : acc) ds' res_ty cont
postInlineUnconditionally black_listed occ_info bndr rhs
| isExportedId bndr ||
black_listed ||
- loop_breaker = False -- Don't inline these
- | otherwise = exprIsTrivial rhs -- Duplicating is free
+ isLoopBreaker occ_info = False -- Don't inline these
+ | otherwise = exprIsTrivial rhs -- Duplicating is free
-- Don't inline even WHNFs inside lambdas; doing so may
-- simply increase allocation when the function is called
-- This isn't the last chance; see NOTE above.
-- NB: Even NOINLINEis ignored here: if the rhs is trivial
-- it's best to inline it anyway. We often get a=E; b=a
-- from desugaring, with both a and b marked NOINLINE.
- where
- loop_breaker = case occ_info of
- IAmALoopBreaker -> True
- other -> False
\end{code}
let
ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
+ arg_tys = dataConArgTys data_con
+ (inst_tys ++ mkTyVarTys ex_tyvars')
in
- newIds (dataConArgTys
- data_con
- (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
+ newIds SLIT("a") arg_tys $ \ bndrs ->
returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
other -> returnSmpl filtered_alts
-- 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' ->
mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
= -- Build the RHS of the join point
- newId join_arg_ty ( \ arg_id ->
+ newId SLIT("a") join_arg_ty ( \ arg_id ->
cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs))
) `thenSmpl` \ join_rhs ->
-- Build the join Id and continuation
- newId (exprType join_rhs) $ \ join_id ->
+ -- We give it a "$j" name just so that for later amusement
+ -- we can identify any join points that don't end up as let-no-escapes
+ newId SLIT("$j") (exprType join_rhs) $ \ join_id ->
let
new_cont = ArgOf OkToDup cont_ty
(\arg' -> rebuild_done (App (Var join_id) arg'))
if exprIsDupable arg' then
thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
else
- newId (exprType arg') $ \ bndr ->
+ newId SLIT("a") (exprType arg') $ \ bndr ->
- tick (CaseOfCase bndr) `thenSmpl_`
+ tick (CaseOfCase bndr) `thenSmpl_`
-- Want to tick here so that we go round again,
-- and maybe copy or inline the code;
-- not strictly CaseOf Case
-- then 78
-- else 5
- then newId realWorldStatePrimTy $ \ rw_id ->
+ then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
)
`thenSmpl` \ (final_bndrs', final_args) ->
- newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
+ -- See comment about "$j" name above
+ newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
-- Notice that we make the lambdas into one-shot-lambdas. The
-- join point is sure to be applied at most once, and doing so
projects / ghc-hetmet.git / blobdiff