From 4e36a8b19e25e69d28c43f8d09d5ecc02329948d Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 16 May 2008 08:51:49 +0000 Subject: [PATCH] Improve the treatment of 'seq' (Trac #2273) Trac #2273 showed a case in which 'seq' didn't cure the space leak it was supposed to. This patch does two things to help a) It removes a now-redundant special case in Simplify, which switched off the case-binder-swap in the early stages. This isn't necessary any more because FloatOut has improved since the Simplify code was written. And switching off the binder-swap is harmful for seq. However fix (a) is a bit fragile, so I did (b) too: b) Desugar 'seq' specially. See Note [Desugaring seq (2)] in DsUtils This isn't very robust either, since it's defeated by abstraction, but that's not something GHC can fix; the programmer should use a let! instead. --- compiler/basicTypes/MkId.lhs | 20 +++++++++----- compiler/deSugar/DsUtils.lhs | 55 ++++++++++++++++++++++++++++++++------- compiler/simplCore/Simplify.lhs | 27 ++++++++++--------- 3 files changed, 74 insertions(+), 28 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 9f9b3fe..637d4c5 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1154,6 +1154,7 @@ nonExhaustiveGuardsErrorName \end{code} \begin{code} +------------------------------------------------ -- unsafeCoerce# :: forall a b. a -> b unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info @@ -1167,17 +1168,23 @@ unsafeCoerceId rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy) +------------------------------------------------ +nullAddrId :: Id -- nullAddr# :: Addr# -- The reason is is here is because we don't provide -- a way to write this literal in Haskell. -nullAddrId - = pcMiscPrelId nullAddrName addrPrimTy info +nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) -seqId - = pcMiscPrelId seqName ty info +------------------------------------------------ +seqId :: Id +-- 'seq' is very special. See notes with +-- See DsUtils.lhs Note [Desugaring seq (1)] and +-- Note [Desugaring seq (2)] and +-- Fixity is set in LoadIface.ghcPrimIface +seqId = pcMiscPrelId seqName ty info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -1187,6 +1194,8 @@ seqId [x,y] = mkTemplateLocals [alphaTy, openBetaTy] rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]) +------------------------------------------------ +lazyId :: Id -- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) -- Used to lazify pseq: pseq a b = a `seq` lazy b -- @@ -1198,8 +1207,7 @@ seqId -- (see WorkWrap.wwExpr) -- We could use inline phases to do this, but that would be vulnerable to changes in -- phase numbering....we must inline precisely after strictness analysis. -lazyId - = pcMiscPrelId lazyIdName ty info +lazyId = pcMiscPrelId lazyIdName ty info where info = noCafIdInfo ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index ef16317f..4334a12 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -163,14 +163,18 @@ mkDsApps fun args (arg_ty, res_ty) = splitFunTy fun_ty ----------- mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr +mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty + | f == seqId -- Note [Desugaring seq (1), (2)] + = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)] + where + case_bndr = case arg1 of + Var v1 -> v1 -- Note [Desugaring seq (2)] + _ -> mkWildId ty1 + mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant] | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg = App fun arg -- The vastly common case -mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty - | f == seqId -- Note [Desugaring seq] - = Case arg1 (mkWildId ty1) res_ty [(DEFAULT,[],arg2)] - mk_val_app fun arg arg_ty res_ty = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))] where @@ -178,8 +182,8 @@ mk_val_app fun arg arg_ty res_ty -- because 'fun ' should not have a free wild-id \end{code} -Note [Desugaring seq] cf Trac #1031 -~~~~~~~~~~~~~~~~~~~~~ +Note [Desugaring seq (1)] cf Trac #1031 +~~~~~~~~~~~~~~~~~~~~~~~~~ f x y = x `seq` (y `seq` (# x,y #)) The [CoreSyn let/app invariant] means that, other things being equal, because @@ -194,10 +198,41 @@ But that is bad for two reasons: Seq is very, very special! So we recognise it right here, and desugar to case x of _ -> case y of _ -> (# x,y #) -The special case would be valid for all calls to 'seq', but it's only *necessary* -for ones whose second argument has an unlifted type. So we only catch the latter -case here, to avoid unnecessary tests. - +Note [Desugaring seq (2)] cf Trac #2231 +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let chp = case b of { True -> fst x; False -> 0 } + in chp `seq` ...chp... +Here the seq is designed to plug the space leak of retaining (snd x) +for too long. + +If we rely on the ordinary inlining of seq, we'll get + let chp = case b of { True -> fst x; False -> 0 } + case chp of _ { I# -> ...chp... } + +But since chp is cheap, and the case is an alluring contet, we'll +inline chp into the case scrutinee. Now there is only one use of chp, +so we'll inline a second copy. Alas, we've now ruined the purpose of +the seq, by re-introducing the space leak: + case (case b of {True -> fst x; False -> 0}) of + I# _ -> ...case b of {True -> fst x; False -> 0}... + +We can try to avoid doing this by ensuring that the binder-swap in the +case happens, so we get his at an early stage: + case chp of chp2 { I# -> ...chp2... } +But this is fragile. The real culprit is the source program. Perhpas we +should have said explicitly + let !chp2 = chp in ...chp2... + +But that's painful. So the code here does a little hack to make seq +more robust: a saturated application of 'seq' is turned *directly* into +the case expression. So we desugar to: + let chp = case b of { True -> fst x; False -> 0 } + case chp of chp { I# -> ...chp... } +Notice the shadowing of the case binder! And now all is well. + +The reason it's a hack is because if you define mySeq=seq, the hack +won't work on mySeq. %************************************************************************ %* * diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 249dae2..f718bcb 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1265,15 +1265,18 @@ inlined. Note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~ -There is a time we *don't* want to do that, namely when --fno-case-of-case is on. This happens in the first simplifier pass, -and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) -If we eliminate the inner case, we trap it inside the I# v -> arm, -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 check for NoCaseOfCase. +We *used* to suppress the binder-swap in case expressoins when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + 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 check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. Note [Suppressing the case binder-swap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1495,9 +1498,9 @@ simplCaseBinder env0 scrut0 case_bndr0 alts improve_case_bndr env scrut case_bndr - | switchIsOn (getSwitchChecker env) NoCaseOfCase - -- See Note [no-case-of-case] - = (env, case_bndr) + -- See Note [no-case-of-case] + -- | switchIsOn (getSwitchChecker env) NoCaseOfCase + -- = (env, case_bndr) | otherwise -- Failed try; see Note [Suppressing the case binder-swap] -- not (isEvaldUnfolding (idUnfolding v)) -- 1.7.10.4