From 95c13506a9988cfe613618ef5c76fe95f4048d22 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Tue, 31 Jan 2006 15:32:47 +0000
Subject: [PATCH] Fix long-standing bug in CPR analysis
MERGE TO STABLE
For a long time (2002!) the CPR analysis done by
dmdAnalTopRhs has been bogus. In particular, it's possible
for a newtype constructor to look CPR-ish when it simply isn't.
This fixes it. Test is stranal/newtype
---
ghc/compiler/stranal/DmdAnal.lhs | 17 ++++++++++++-----
1 file changed, 12 insertions(+), 5 deletions(-)
diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index f0dcc0042bc1..c5cfb7b4bded 100644
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -112,11 +112,18 @@ dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr)
-- a) appropriate strictness info
-- b) the unfolding (decorated with stricntess info)
dmdAnalTopRhs rhs
- = (sig, rhs')
+ = (sig, rhs2)
where
- arity = exprArity rhs
- (rhs_ty, rhs') = dmdAnal emptySigEnv (vanillaCall arity) rhs
+ call_dmd = vanillaCall (exprArity rhs)
+ (_, rhs1) = dmdAnal emptySigEnv call_dmd rhs
+ (rhs_ty, rhs2) = dmdAnal emptySigEnv call_dmd rhs1
sig = mkTopSigTy rhs rhs_ty
+ -- Do two passes; see notes with extendSigsWithLam
+ -- Otherwise we get bogus CPR info for constructors like
+ -- newtype T a = MkT a
+ -- The constructor looks like (\x::T a -> x), modulo the coerce
+ -- extendSigsWithLam will optimistically give x a CPR tag the
+ -- first time, which is wrong in the end.
\end{code}
%************************************************************************
@@ -761,8 +768,6 @@ extendSigsWithLam :: SigEnv -> Id -> SigEnv
-- (a,b)
-- We want f to have the CPR property because x does, by the time f has been w/w'd
--
--- NOTE: see notes [CPR-AND-STRICTNESS]
---
-- Also note that we only want to do this for something that
-- definitely has product type, else we may get over-optimistic
-- CPR results (e.g. from \x -> x!).
@@ -770,6 +775,8 @@ extendSigsWithLam :: SigEnv -> Id -> SigEnv
extendSigsWithLam sigs id
= case idNewDemandInfo_maybe id of
Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel)
+ -- Optimistic in the Nothing case;
+ -- See notes [CPR-AND-STRICTNESS]
Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel)
other -> sigs
--
GitLab