#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, exprArity )
+import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlinePragma,
import TysPrim ( realWorldStatePrimTy )
import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
keysUFM, minusUFM, ufmToList, filterUFM )
-import Type ( isUnLiftedType, eqType )
+import Type ( isUnLiftedType, coreEqType )
import CoreLint ( showPass, endPass )
import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
in
(deferType lam_ty, Lam var' body')
-dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)])
+dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
| let tycon = dataConTyCon dc,
isProductTyCon tycon,
not (isRecursiveTyCon tycon)
(scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
- (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' [alt'])
+ (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
-dmdAnal sigs dmd (Case scrut case_bndr alts)
+dmdAnal sigs dmd (Case scrut case_bndr ty alts)
= let
(alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts
(scrut_ty, scrut') = dmdAnal sigs evalDmd scrut
(alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
in
-- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
- (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' alts')
+ (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
dmdAnal sigs dmd (Let (NonRec id rhs) body)
= let
-- ; print len }
io_hack_reqd = con == DataAlt unboxedPairDataCon &&
- idType (head bndrs) `eqType` realWorldStatePrimTy
+ idType (head bndrs) `coreEqType` realWorldStatePrimTy
in
(final_alt_ty, (con, bndrs', rhs'))
\end{code}
arity = idArity id -- The idArity should be up to date
-- The simplifier was run just beforehand
(rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
- (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty, ppr id )
+ (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id )
+ -- The RHS can be eta-reduced to just a variable,
+ -- in which case we should not complain.
mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
id' = id `setIdNewStrictness` sig_ty
sigs' = extendSigEnv top_lvl sigs id sig_ty
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,
-------------------------
-- 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)