-
+%
% (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 CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, maybeUnfoldingTemplate,
callSiteInline, hasSomeUnfolding, noUnfolding
)
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial, exprIsConApp_maybe,
exprType, coreAltsType, exprArity, exprIsValue, idAppIsCheap,
exprOkForSpeculation, etaReduceExpr,
- mkCoerce, mkSCC, mkInlineMe
+ mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
import Rules ( lookupRule )
import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
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
simplExprF fun (ApplyTo NoDup arg se cont)
simplExprF (Case scrut bndr alts) cont
- = getSubst `thenSmpl` \ subst ->
+ = getSubstEnv `thenSmpl` \ subst_env ->
getSwitchChecker `thenSmpl` \ chkr ->
- if switchIsOn chkr NoCaseOfCase then
- -- If case-of-case is off, simply simplify the scrutinee and rebuild
- simplExprC scrut (Stop (substTy subst (idType bndr))) `thenSmpl` \ scrut' ->
- rebuild_case False scrut' bndr alts (substEnv subst) cont
+ if not (switchIsOn chkr NoCaseOfCase) then
+ -- Simplify the scrutinee with a Select continuation
+ simplExprF scrut (Select NoDup bndr alts subst_env cont)
+
else
- -- But if it's on, we simplify the scrutinee with a Select continuation
- simplExprF scrut (Select NoDup bndr alts (substEnv subst) cont)
+ -- If case-of-case is off, simply simplify the case expression
+ -- in a vanilla Stop context, and rebuild the result around it
+ simplExprC scrut (Select NoDup bndr alts subst_env
+ (Stop (contResultType cont))) `thenSmpl` \ case_expr' ->
+ rebuild case_expr' cont
simplExprF (Let (Rec pairs) body) cont
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
-- v = E
-- z = \w -> g v w
-- Which is what we want; chances are z will be inlined now.
+--
+-- This defn isn't quite like
+-- exprIsCheap (it ignores non-cheap args)
+-- exprIsValue (may not say True for a lone variable)
+-- which is slightly weird
wantToExpose n (Var v) = idAppIsCheap v n
wantToExpose n (Lit l) = True
-wantToExpose n (Lam _ e) = ASSERT( n==0 ) True -- We won't have applied \'s
+wantToExpose n (Lam _ e) = True
wantToExpose n (Note _ e) = wantToExpose n e
wantToExpose n (App f (Type _)) = wantToExpose n f
wantToExpose n (App f a) = wantToExpose (n+1) f
completeCall var occ cont
= getBlackList `thenSmpl` \ black_list_fn ->
- getSwitchChecker `thenSmpl` \ chkr ->
getInScope `thenSmpl` \ in_scope ->
+ getSwitchChecker `thenSmpl` \ chkr ->
let
- black_listed = black_list_fn var
+ dont_use_rules = switchIsOn chkr DontApplyRules
+ no_case_of_case = switchIsOn chkr NoCaseOfCase
+ black_listed = black_list_fn var
+
(arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont
discard_inline_cont | inline_call = discardInline cont
| otherwise = cont
-- won't occur for things that have specialisations till a later phase, so
-- it's ok to try for inlining first.
- prepareArgs (switchIsOn chkr NoCaseOfCase) var cont $ \ args' cont' ->
+ prepareArgs no_case_of_case var cont $ \ args' cont' ->
let
- maybe_rule | switchIsOn chkr DontApplyRules = Nothing
- | otherwise = lookupRule in_scope var args'
+ maybe_rule | dont_use_rules = Nothing
+ | otherwise = lookupRule in_scope var args'
in
case maybe_rule of {
Just (rule_name, rule_rhs) ->
= 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}
= rebuild (Note InlineCall expr) cont
rebuild scrut (Select _ bndr alts se cont)
- = rebuild_case True scrut bndr alts se cont
+ = rebuild_case scrut bndr alts se cont
\end{code}
Case elimination [see the code above]
---------------------------------------------------------
-- Eliminate the case if possible
-rebuild_case add_eval_info scrut bndr alts se cont
+rebuild_case scrut bndr alts se cont
| maybeToBool maybe_con_app
= knownCon scrut (DataAlt con) args bndr alts se cont
simplExprF (head (rhssOfAlts alts)) cont)
| otherwise
- = complete_case add_eval_info scrut bndr alts se cont
+ = complete_case scrut bndr alts se cont
where
- maybe_con_app = analyse (collectArgs scrut)
+ maybe_con_app = exprIsConApp_maybe scrut
Just (con, args) = maybe_con_app
- analyse (Var fun, args)
- | maybeToBool maybe_con_app = maybe_con_app
- where
- maybe_con_app = case isDataConId_maybe fun of
- Just con | length args >= dataConRepArity con
- -- Might be > because the arity excludes type args
- -> Just (con, args)
- other -> Nothing
-
- analyse (Var fun, [])
- = case maybeUnfoldingTemplate (idUnfolding fun) of
- Nothing -> Nothing
- Just unf -> analyse (collectArgs unf)
-
- analyse other = Nothing
-
-
-- See if we can get rid of the case altogether
-- See the extensive notes on case-elimination above
canEliminateCase scrut bndr alts
---------------------------------------------------------
-- Case of something else
-complete_case add_eval_info scrut case_bndr alts se cont
+complete_case scrut case_bndr alts se cont
= -- Prepare case alternatives
prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
impossible_cons alts `thenSmpl` \ better_alts ->
-- Deal with variable scrutinee
- ( simplCaseBinder add_eval_info scrut case_bndr $ \ case_bndr' zap_occ_info ->
+ (
+ getSwitchChecker `thenSmpl` \ chkr ->
+ simplCaseBinder (switchIsOn chkr NoCaseOfCase)
+ scrut case_bndr $ \ case_bndr' zap_occ_info ->
-- Deal with the case alternatives
simplAlts zap_occ_info impossible_cons
which might prevent some full laziness happening. I've seen this
in action in spectral/cichelli/Prog.hs:
[(m,n) | m <- [1..max], n <- [1..max]]
-Hence the add_eval_info argument
+Hence the no_case_of_case argument
If we do this, then we have to nuke any occurrence info (eg IAmDead)
happened. Hence the zap_occ_info function returned by simplCaseBinder
\begin{code}
-simplCaseBinder add_eval_info (Var v) case_bndr thing_inside
- | add_eval_info
+simplCaseBinder no_case_of_case (Var v) case_bndr thing_inside
+ | not no_case_of_case
= simplBinder (zap case_bndr) $ \ case_bndr' ->
modifyInScope v case_bndr' $
-- We could extend the substitution instead, but it would be
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