#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), opt_MaxWorkerArgs )
+import DynFlags ( DynFlags, DynFlag(..) )
+import StaticFlags ( opt_MaxWorkerArgs )
import NewDemand -- All of it
import CoreSyn
import PprCore
-import CoreUtils ( exprIsValue, exprIsTrivial, exprArity )
+import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlinePragma,
-- 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}
%************************************************************************
in
(deferType lam_ty, Lam var' body')
--- gaw 2004
dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
| let tycon = dataConTyCon dc,
isProductTyCon tycon,
(scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
--- gaw 2004
(alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
--- gaw 2004
dmdAnal sigs dmd (Case scrut case_bndr ty alts)
= let
(alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts
(alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
in
-- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
--- gaw 2004
(alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
dmdAnal sigs dmd (Let (NonRec id rhs) body)
res' = case res of
RetCPR | ignore_cpr_info -> TopRes
other -> res
- ignore_cpr_info = not (exprIsValue rhs || thunk_cpr_ok)
+ ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
\end{code}
The unpack strategy determines whether we'll *really* unpack the argument,
-- (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!).
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
-------------------------
-- Consider (if x then y else []) with demand V
-- Then the first branch gives {y->V} and the second
--- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
+-- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
-- in the result env.
lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
= DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)