summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorAustin Seipp <austin@well-typed.com>2014-08-20 03:42:38 -0500
committerAustin Seipp <austin@well-typed.com>2014-08-20 03:47:36 -0500
commit07d01c9f77b510c6e1d64e090f6ff008d9fb5d56 (patch)
tree31c96543c9e25483dea7552e9dd18ee31fa9abd0 /compiler
parent8396e44500606368e1acd1c7c0c98e66c9da8f66 (diff)
downloadhaskell-07d01c9f77b510c6e1d64e090f6ff008d9fb5d56.tar.gz
stranal: detabify/dewhitespace DmdAnal
Signed-off-by: Austin Seipp <austin@well-typed.com>
Diffstat (limited to 'compiler')
-rw-r--r--compiler/stranal/DmdAnal.lhs603
1 files changed, 301 insertions, 302 deletions
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index a3b7c0b72a..5cb2655afd 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -2,13 +2,12 @@
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
- -----------------
- A demand analysis
- -----------------
+ -----------------
+ A demand analysis
+ -----------------
\begin{code}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
module DmdAnal ( dmdAnalProgram ) where
@@ -16,42 +15,42 @@ module DmdAnal ( dmdAnalProgram ) where
import DynFlags
import WwLib ( findTypeShape, deepSplitProductType_maybe )
-import Demand -- All of it
+import Demand -- All of it
import CoreSyn
import Outputable
import VarEnv
-import BasicTypes
+import BasicTypes
import FastString
import Data.List
import DataCon
import Id
-import CoreUtils ( exprIsHNF, exprType, exprIsTrivial )
+import CoreUtils ( exprIsHNF, exprType, exprIsTrivial )
import TyCon
import Type
import FamInstEnv
import Util
-import Maybes ( isJust )
-import TysWiredIn ( unboxedPairDataCon )
-import TysPrim ( realWorldStatePrimTy )
+import Maybes ( isJust )
+import TysWiredIn ( unboxedPairDataCon )
+import TysPrim ( realWorldStatePrimTy )
import ErrUtils ( dumpIfSet_dyn )
import Name ( getName, stableNameCmp )
import Data.Function ( on )
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Top level stuff}
-%* *
+%* *
%************************************************************************
\begin{code}
dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram dflags fam_envs binds
= do {
- let { binds_plus_dmds = do_prog binds } ;
+ let { binds_plus_dmds = do_prog binds } ;
dumpIfSet_dyn dflags Opt_D_dump_strsigs "Strictness signatures" $
dumpStrSig binds_plus_dmds ;
- return binds_plus_dmds
+ return binds_plus_dmds
}
where
do_prog :: CoreProgram -> CoreProgram
@@ -59,40 +58,40 @@ dmdAnalProgram dflags fam_envs binds
-- Analyse a (group of) top-level binding(s)
dmdAnalTopBind :: AnalEnv
- -> CoreBind
- -> (AnalEnv, CoreBind)
+ -> CoreBind
+ -> (AnalEnv, CoreBind)
dmdAnalTopBind sigs (NonRec id rhs)
= (extendAnalEnv TopLevel sigs id sig, NonRec id2 rhs2)
where
( _, _, _, rhs1) = dmdAnalRhs TopLevel Nothing sigs id rhs
(sig, _, id2, rhs2) = dmdAnalRhs TopLevel Nothing (nonVirgin sigs) id rhs1
- -- Do two passes to improve CPR information
- -- See comments with ignore_cpr_info in mk_sig_ty
- -- and with extendSigsWithLam
+ -- Do two passes to improve CPR information
+ -- See comments with ignore_cpr_info in mk_sig_ty
+ -- and with extendSigsWithLam
dmdAnalTopBind sigs (Rec pairs)
= (sigs', Rec pairs')
where
(sigs', _, pairs') = dmdFix TopLevel sigs pairs
- -- We get two iterations automatically
- -- c.f. the NonRec case above
+ -- We get two iterations automatically
+ -- c.f. the NonRec case above
\end{code}
%************************************************************************
-%* *
-\subsection{The analyser itself}
-%* *
+%* *
+\subsection{The analyser itself}
+%* *
%************************************************************************
Note [Ensure demand is strict]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important not to analyse e with a lazy demand because
-a) When we encounter case s of (a,b) ->
- we demand s with U(d1d2)... but if the overall demand is lazy
- that is wrong, and we'd need to reduce the demand on s,
- which is inconvenient
+a) When we encounter case s of (a,b) ->
+ we demand s with U(d1d2)... but if the overall demand is lazy
+ that is wrong, and we'd need to reduce the demand on s,
+ which is inconvenient
b) More important, consider
- f (let x = R in x+x), where f is lazy
+ f (let x = R in x+x), where f is lazy
We still want to mark x as demanded, because it will be when we
enter the let. If we analyse f's arg with a Lazy demand, we'll
just mark x as Lazy
@@ -111,17 +110,17 @@ dmdTransformThunkDmd e
-- Do not process absent demands
-- Otherwise act like in a normal demand analysis
-- See |-* relation in the companion paper
-dmdAnalStar :: AnalEnv
- -> Demand -- This one takes a *Demand*
+dmdAnalStar :: AnalEnv
+ -> Demand -- This one takes a *Demand*
-> CoreExpr -> (BothDmdArg, CoreExpr)
-dmdAnalStar env dmd e
+dmdAnalStar env dmd e
| (cd, defer_and_use) <- toCleanDmd dmd (exprType e)
, (dmd_ty, e') <- dmdAnal env cd e
= (postProcessDmdTypeM defer_and_use dmd_ty, e')
-- Main Demand Analsysis machinery
dmdAnal, dmdAnal' :: AnalEnv
- -> CleanDemand -- The main one takes a *CleanDemand*
+ -> CleanDemand -- The main one takes a *CleanDemand*
-> CoreExpr -> (DmdType, CoreExpr)
-- The CleanDemand is always strict and not absent
@@ -131,7 +130,7 @@ dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
dmdAnal' env d e
dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit)
-dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact
+dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact
dmdAnal' _ _ (Coercion co) = (nopDmdType, Coercion co)
dmdAnal' env dmd (Var var)
@@ -148,11 +147,11 @@ dmdAnal' env dmd (Cast e co)
| Just tc <- tyConAppTyCon_maybe to_co
, isRecursiveTyCon tc = cleanEvalDmd
| otherwise = dmd
- -- This coerce usually arises from a recursive
+ -- This coerce usually arises from a recursive
-- newtype, and we don't want to look inside them
- -- for exactly the same reason that we don't look
- -- inside recursive products -- we might not reach
- -- a fixpoint. So revert to a vanilla Eval demand
+ -- for exactly the same reason that we don't look
+ -- inside recursive products -- we might not reach
+ -- a fixpoint. So revert to a vanilla Eval demand
-}
dmdAnal' env dmd (Tick t e)
@@ -172,12 +171,12 @@ dmdAnal' sigs dmd (App fun (Coercion co))
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
-dmdAnal' env dmd (App fun arg) -- Non-type arguments
- = let -- [Type arg handled above]
+dmdAnal' env dmd (App fun arg) -- Non-type arguments
+ = let -- [Type arg handled above]
call_dmd = mkCallDmd dmd
- (fun_ty, fun') = dmdAnal env call_dmd fun
- (arg_dmd, res_ty) = splitDmdTy fun_ty
- (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
+ (fun_ty, fun') = dmdAnal env call_dmd fun
+ (arg_dmd, res_ty) = splitDmdTy fun_ty
+ (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
in
-- pprTrace "dmdAnal:app" (vcat
-- [ text "dmd =" <+> ppr dmd
@@ -192,8 +191,8 @@ dmdAnal' env dmd (App fun arg) -- Non-type arguments
-- this is an anonymous lambda, since @dmdAnalRhs@ uses @collectBinders@
dmdAnal' env dmd (Lam var body)
| isTyVar var
- = let
- (body_ty, body') = dmdAnal env dmd body
+ = let
+ (body_ty, body') = dmdAnal env dmd body
in
(body_ty, Lam var body')
@@ -203,59 +202,59 @@ dmdAnal' env dmd (Lam var body)
-- one_shot - one-shotness of the lambda
-- hence, cardinality of its free vars
- env' = extendSigsWithLam env var
- (body_ty, body') = dmdAnal env' body_dmd body
- (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty one_shot var
+ env' = extendSigsWithLam env var
+ (body_ty, body') = dmdAnal env' body_dmd body
+ (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty one_shot var
in
(postProcessUnsat defer_and_use lam_ty, Lam var' body')
dmdAnal' env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
-- Only one alternative with a product constructor
| let tycon = dataConTyCon dc
- , isProductTyCon tycon
+ , isProductTyCon tycon
, Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
= let
env_w_tc = env { ae_rec_tc = rec_tc' }
- env_alt = extendAnalEnv NotTopLevel env_w_tc case_bndr case_bndr_sig
- (alt_ty, alt') = dmdAnalAlt env_alt dmd alt
- (alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr
- (_, bndrs', _) = alt'
- case_bndr_sig = cprProdSig (dataConRepArity dc)
- -- Inside the alternative, the case binder has the CPR property.
- -- Meaning that a case on it will successfully cancel.
- -- Example:
- -- f True x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
- -- f False x = I# 3
- --
- -- We want f to have the CPR property:
- -- f b x = case fw b x of { r -> I# r }
- -- fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
- -- fw False x = 3
-
- -- Figure out whether the demand on the case binder is used, and use
- -- that to set the scrut_dmd. This is utterly essential.
- -- Consider f x = case x of y { (a,b) -> k y a }
- -- If we just take scrut_demand = U(L,A), then we won't pass x to the
- -- worker, so the worker will rebuild
- -- x = (a, absent-error)
- -- and that'll crash.
- -- So at one stage I had:
- -- dead_case_bndr = isAbsDmd (idDemandInfo case_bndr')
- -- keepity | dead_case_bndr = Drop
- -- | otherwise = Keep
- --
- -- But then consider
- -- case x of y { (a,b) -> h y + a }
- -- where h : U(LL) -> T
- -- The above code would compute a Keep for x, since y is not Abs, which is silly
- -- The insight is, of course, that a demand on y is a demand on the
- -- scrutinee, so we need to `both` it with the scrut demand
-
- scrut_dmd1 = mkProdDmd [idDemandInfo b | b <- bndrs', isId b]
+ env_alt = extendAnalEnv NotTopLevel env_w_tc case_bndr case_bndr_sig
+ (alt_ty, alt') = dmdAnalAlt env_alt dmd alt
+ (alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr
+ (_, bndrs', _) = alt'
+ case_bndr_sig = cprProdSig (dataConRepArity dc)
+ -- Inside the alternative, the case binder has the CPR property.
+ -- Meaning that a case on it will successfully cancel.
+ -- Example:
+ -- f True x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
+ -- f False x = I# 3
+ --
+ -- We want f to have the CPR property:
+ -- f b x = case fw b x of { r -> I# r }
+ -- fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
+ -- fw False x = 3
+
+ -- Figure out whether the demand on the case binder is used, and use
+ -- that to set the scrut_dmd. This is utterly essential.
+ -- Consider f x = case x of y { (a,b) -> k y a }
+ -- If we just take scrut_demand = U(L,A), then we won't pass x to the
+ -- worker, so the worker will rebuild
+ -- x = (a, absent-error)
+ -- and that'll crash.
+ -- So at one stage I had:
+ -- dead_case_bndr = isAbsDmd (idDemandInfo case_bndr')
+ -- keepity | dead_case_bndr = Drop
+ -- | otherwise = Keep
+ --
+ -- But then consider
+ -- case x of y { (a,b) -> h y + a }
+ -- where h : U(LL) -> T
+ -- The above code would compute a Keep for x, since y is not Abs, which is silly
+ -- The insight is, of course, that a demand on y is a demand on the
+ -- scrutinee, so we need to `both` it with the scrut demand
+
+ scrut_dmd1 = mkProdDmd [idDemandInfo b | b <- bndrs', isId b]
scrut_dmd2 = strictenDmd (idDemandInfo case_bndr')
scrut_dmd = scrut_dmd1 `bothCleanDmd` scrut_dmd2
- (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
+ (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
res_ty = alt_ty1 `bothDmdType` toBothDmdArg scrut_ty
in
-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
@@ -269,9 +268,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
dmdAnal' env dmd (Case scrut case_bndr ty alts)
= let -- Case expression with multiple alternatives
- (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts
- (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut
- (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
+ (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts
+ (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut
+ (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty
in
-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
@@ -282,36 +281,36 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
(res_ty, Case scrut' case_bndr' ty alts')
dmdAnal' env dmd (Let (NonRec id rhs) body)
- = (body_ty2, Let (NonRec id2 annotated_rhs) body')
+ = (body_ty2, Let (NonRec id2 annotated_rhs) body')
where
(sig, lazy_fv, id1, rhs') = dmdAnalRhs NotTopLevel Nothing env id rhs
- (body_ty, body') = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body
+ (body_ty, body') = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body
(body_ty1, id2) = annotateBndr env body_ty id1
- body_ty2 = addLazyFVs body_ty1 lazy_fv
+ body_ty2 = addLazyFVs body_ty1 lazy_fv
-- Annotate top-level lambdas at RHS basing on the aggregated demand info
- -- See Note [Annotating lambdas at right-hand side]
- annotated_rhs = annLamWithShotness (idDemandInfo id2) rhs'
-
- -- If the actual demand is better than the vanilla call
- -- demand, you might think that we might do better to re-analyse
- -- the RHS with the stronger demand.
- -- But (a) That seldom happens, because it means that *every* path in
- -- the body of the let has to use that stronger demand
- -- (b) It often happens temporarily in when fixpointing, because
- -- the recursive function at first seems to place a massive demand.
- -- But we don't want to go to extra work when the function will
- -- probably iterate to something less demanding.
- -- In practice, all the times the actual demand on id2 is more than
- -- the vanilla call demand seem to be due to (b). So we don't
- -- bother to re-analyse the RHS.
+ -- See Note [Annotating lambdas at right-hand side]
+ annotated_rhs = annLamWithShotness (idDemandInfo id2) rhs'
+
+ -- If the actual demand is better than the vanilla call
+ -- demand, you might think that we might do better to re-analyse
+ -- the RHS with the stronger demand.
+ -- But (a) That seldom happens, because it means that *every* path in
+ -- the body of the let has to use that stronger demand
+ -- (b) It often happens temporarily in when fixpointing, because
+ -- the recursive function at first seems to place a massive demand.
+ -- But we don't want to go to extra work when the function will
+ -- probably iterate to something less demanding.
+ -- In practice, all the times the actual demand on id2 is more than
+ -- the vanilla call demand seem to be due to (b). So we don't
+ -- bother to re-analyse the RHS.
dmdAnal' env dmd (Let (Rec pairs) body)
= let
- (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs
- (body_ty, body') = dmdAnal env' dmd body
+ (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs
+ (body_ty, body') = dmdAnal env' dmd body
body_ty1 = deleteFVs body_ty (map fst pairs)
- body_ty2 = addLazyFVs body_ty1 lazy_fv
+ body_ty2 = addLazyFVs body_ty1 lazy_fv
in
body_ty2 `seq`
(body_ty2, Let (Rec pairs') body')
@@ -325,7 +324,7 @@ annLamWithShotness d e
go u e
| Just (c, u') <- peelUseCall u
, Lam bndr body <- e
- = if isTyVar bndr
+ = if isTyVar bndr
then Lam bndr (go u body)
else Lam (setOneShotness c bndr) (go u' body)
| otherwise
@@ -337,35 +336,35 @@ setOneShotness Many bndr = bndr
dmdAnalAlt :: AnalEnv -> CleanDemand -> Alt Var -> (DmdType, Alt Var)
dmdAnalAlt env dmd (con,bndrs,rhs)
- = let
- (rhs_ty, rhs') = dmdAnal env dmd rhs
+ = let
+ (rhs_ty, rhs') = dmdAnal env dmd rhs
rhs_ty' = addDataConPatDmds con bndrs rhs_ty
- (alt_ty, bndrs') = annotateBndrs env rhs_ty' bndrs
- final_alt_ty | io_hack_reqd = deferAfterIO alt_ty
- | otherwise = alt_ty
+ (alt_ty, bndrs') = annotateBndrs env rhs_ty' bndrs
+ final_alt_ty | io_hack_reqd = deferAfterIO alt_ty
+ | otherwise = alt_ty
-- Note [IO hack in the demand analyser]
--
- -- There's a hack here for I/O operations. Consider
- -- case foo x s of { (# s, r #) -> y }
- -- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O
- -- operation that simply terminates the program (not in an erroneous way)?
- -- In that case we should not evaluate y before the call to 'foo'.
- -- Hackish solution: spot the IO-like situation and add a virtual branch,
- -- as if we had
- -- case foo x s of
- -- (# s, r #) -> y
- -- other -> return ()
- -- So the 'y' isn't necessarily going to be evaluated
- --
- -- A more complete example (Trac #148, #1592) where this shows up is:
- -- do { let len = <expensive> ;
- -- ; when (...) (exitWith ExitSuccess)
- -- ; print len }
-
- io_hack_reqd = con == DataAlt unboxedPairDataCon &&
- idType (head bndrs) `eqType` realWorldStatePrimTy
- in
+ -- There's a hack here for I/O operations. Consider
+ -- case foo x s of { (# s, r #) -> y }
+ -- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O
+ -- operation that simply terminates the program (not in an erroneous way)?
+ -- In that case we should not evaluate y before the call to 'foo'.
+ -- Hackish solution: spot the IO-like situation and add a virtual branch,
+ -- as if we had
+ -- case foo x s of
+ -- (# s, r #) -> y
+ -- other -> return ()
+ -- So the 'y' isn't necessarily going to be evaluated
+ --
+ -- A more complete example (Trac #148, #1592) where this shows up is:
+ -- do { let len = <expensive> ;
+ -- ; when (...) (exitWith ExitSuccess)
+ -- ; print len }
+
+ io_hack_reqd = con == DataAlt unboxedPairDataCon &&
+ idType (head bndrs) `eqType` realWorldStatePrimTy
+ in
(final_alt_ty, (con, bndrs', rhs'))
\end{code}
@@ -390,15 +389,15 @@ transformer:
transf[x](U) = {y |-> U1}
-so the resulting demand on |y| is U1.
+so the resulting demand on |y| is U1.
The situation is, however, different for strictness, where this
aggregating approach exhibits worse results because of the nature of
|both| operation for strictness. Consider the example:
-f y c =
+f y c =
let h x = y |seq| x
- in case of
+ in case of
True -> h True
False -> y
@@ -424,7 +423,7 @@ usage demand on |h| from the body of |let|-expression, which is C1(U)
in this case.
In other words, for locally-bound lambdas we can infer
-one-shotness.
+one-shotness.
\begin{code}
addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType
@@ -432,7 +431,7 @@ addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType
addDataConPatDmds DEFAULT _ dmd_ty = dmd_ty
addDataConPatDmds (LitAlt _) _ dmd_ty = dmd_ty
addDataConPatDmds (DataAlt con) bndrs dmd_ty
- = foldr add dmd_ty str_bndrs
+ = foldr add dmd_ty str_bndrs
where
add bndr dmd_ty = addVarDmd dmd_ty bndr seqDmd
str_bndrs = [ b | (b,s) <- zipEqual "addDataConPatBndrs"
@@ -468,34 +467,34 @@ because X is strict, so its argument must be evaluated. And if we
because the seq is discarded (very early) since X is strict!
-There is the usual danger of reboxing, which as usual we ignore. But
+There is the usual danger of reboxing, which as usual we ignore. But
if X is monomorphic, and has an UNPACK pragma, then this optimisation
is even more important. We don't want the wrapper to rebox an unboxed
argument, and pass an Int to $wfoo!
%************************************************************************
-%* *
+%* *
Demand transformer
-%* *
+%* *
%************************************************************************
\begin{code}
-dmdTransform :: AnalEnv -- The strictness environment
- -> Id -- The function
- -> CleanDemand -- The demand on the function
- -> DmdType -- The demand type of the function in this context
- -- Returned DmdEnv includes the demand on
- -- this function plus demand on its free variables
+dmdTransform :: AnalEnv -- The strictness environment
+ -> Id -- The function
+ -> CleanDemand -- The demand on the function
+ -> DmdType -- The demand type of the function in this context
+ -- Returned DmdEnv includes the demand on
+ -- this function plus demand on its free variables
dmdTransform env var dmd
- | isDataConWorkId var -- Data constructor
+ | isDataConWorkId var -- Data constructor
= dmdTransformDataConSig (idArity var) (idStrictness var) dmd
| gopt Opt_DmdTxDictSel (ae_dflags env),
Just _ <- isClassOpId_maybe var -- Dictionary component selector
= dmdTransformDictSelSig (idStrictness var) dmd
- | isGlobalId var -- Imported function
+ | isGlobalId var -- Imported function
= let res = dmdTransformSig (idStrictness var) dmd in
-- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
res
@@ -507,24 +506,24 @@ dmdTransform env var dmd
then fn_ty -- Don't record top level things
else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
- | otherwise -- Local non-letrec-bound thing
+ | otherwise -- Local non-letrec-bound thing
= unitVarDmd var (mkOnceUsedDmd dmd)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Bindings}
-%* *
+%* *
%************************************************************************
\begin{code}
-- Recursive bindings
dmdFix :: TopLevelFlag
- -> AnalEnv -- Does not include bindings for this binding
+ -> AnalEnv -- Does not include bindings for this binding
-> [(Id,CoreExpr)]
-> (AnalEnv, DmdEnv,
- [(Id,CoreExpr)]) -- Binders annotated with stricness info
+ [(Id,CoreExpr)]) -- Binders annotated with stricness info
dmdFix top_lvl env orig_pairs
= (updSigEnv env (sigEnv final_env), lazy_fv, pairs')
@@ -533,11 +532,11 @@ dmdFix top_lvl env orig_pairs
bndrs = map fst orig_pairs
initial_env = addInitialSigs top_lvl env bndrs
(final_env, lazy_fv, pairs') = loop 1 initial_env orig_pairs
-
+
loop :: Int
- -> AnalEnv -- Already contains the current sigs
- -> [(Id,CoreExpr)]
- -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+ -> AnalEnv -- Already contains the current sigs
+ -> [(Id,CoreExpr)]
+ -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
loop n env pairs
= -- pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $
loop' n env pairs
@@ -545,52 +544,52 @@ dmdFix top_lvl env orig_pairs
loop' n env pairs
| found_fixpoint
= (env', lazy_fv, pairs')
- -- Note: return pairs', not pairs. pairs' is the result of
- -- processing the RHSs with sigs (= sigs'), whereas pairs
- -- is the result of processing the RHSs with the *previous*
- -- iteration of sigs.
+ -- Note: return pairs', not pairs. pairs' is the result of
+ -- processing the RHSs with sigs (= sigs'), whereas pairs
+ -- is the result of processing the RHSs with the *previous*
+ -- iteration of sigs.
| n >= 10
- = -- pprTrace "dmdFix loop" (ppr n <+> (vcat
- -- [ text "Sigs:" <+> ppr [ (id,lookupVarEnv (sigEnv env) id,
- -- lookupVarEnv (sigEnv env') id)
+ = -- pprTrace "dmdFix loop" (ppr n <+> (vcat
+ -- [ text "Sigs:" <+> ppr [ (id,lookupVarEnv (sigEnv env) id,
+ -- lookupVarEnv (sigEnv env') id)
-- | (id,_) <- pairs],
-- text "env:" <+> ppr env,
-- text "binds:" <+> pprCoreBinding (Rec pairs)]))
- (env, lazy_fv, orig_pairs) -- Safe output
- -- The lazy_fv part is really important! orig_pairs has no strictness
- -- info, including nothing about free vars. But if we have
- -- letrec f = ....y..... in ...f...
- -- where 'y' is free in f, we must record that y is mentioned,
- -- otherwise y will get recorded as absent altogether
+ (env, lazy_fv, orig_pairs) -- Safe output
+ -- The lazy_fv part is really important! orig_pairs has no strictness
+ -- info, including nothing about free vars. But if we have
+ -- letrec f = ....y..... in ...f...
+ -- where 'y' is free in f, we must record that y is mentioned,
+ -- otherwise y will get recorded as absent altogether
| otherwise
= loop (n+1) (nonVirgin env') pairs'
where
- found_fixpoint = all (same_sig (sigEnv env) (sigEnv env')) bndrs
+ found_fixpoint = all (same_sig (sigEnv env) (sigEnv env')) bndrs
+
+ ((env',lazy_fv), pairs') = mapAccumL my_downRhs (env, emptyDmdEnv) pairs
+ -- mapAccumL: Use the new signature to do the next pair
+ -- The occurrence analyser has arranged them in a good order
+ -- so this can significantly reduce the number of iterations needed
- ((env',lazy_fv), pairs') = mapAccumL my_downRhs (env, emptyDmdEnv) pairs
- -- mapAccumL: Use the new signature to do the next pair
- -- The occurrence analyser has arranged them in a good order
- -- so this can significantly reduce the number of iterations needed
-
my_downRhs (env, lazy_fv) (id,rhs)
= ((env', lazy_fv'), (id', rhs'))
where
- (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
- lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+ (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
+ lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1
env' = extendAnalEnv top_lvl env id sig
-
+
same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
lookup sigs var = case lookupVarEnv sigs var of
- Just (sig,_) -> sig
+ Just (sig,_) -> sig
Nothing -> pprPanic "dmdFix" (ppr var)
-- Non-recursive bindings
-dmdAnalRhs :: TopLevelFlag
+dmdAnalRhs :: TopLevelFlag
-> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive
- -> AnalEnv -> Id -> CoreExpr
- -> (StrictSig, DmdEnv, Id, CoreExpr)
+ -> AnalEnv -> Id -> CoreExpr
+ -> (StrictSig, DmdEnv, Id, CoreExpr)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
dmdAnalRhs top_lvl rec_flag env id rhs
@@ -603,7 +602,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs
-- fn_fv: don't forget to produce a demand for fn itself
-- Lacking this caused Trac #9128
-- The demand is very conservative (topDmd), but that doesn't
- -- matter; trivial bindings are usually inlined, so it only
+ -- matter; trivial bindings are usually inlined, so it only
-- kicks in for top-level bindings and NOINLINE bindings
= (fn_str, fn_fv, set_idStrictness env id fn_str, rhs)
@@ -617,8 +616,8 @@ dmdAnalRhs top_lvl rec_flag env id rhs
(DmdType rhs_fv rhs_dmds rhs_res, bndrs')
= annotateLamBndrs env (isDFunId id) body_ty' bndrs
sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
- id' = set_idStrictness env id sig_ty
- -- See Note [NOINLINE and strictness]
+ id' = set_idStrictness env id sig_ty
+ -- See Note [NOINLINE and strictness]
-- See Note [Product demands for function body]
body_dmd = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
@@ -639,15 +638,15 @@ dmdAnalRhs top_lvl rec_flag env id rhs
-- See Note [CPR for thunks]
is_thunk = not (exprIsHNF rhs)
- not_strict
- = isTopLevel top_lvl -- Top level and recursive things don't
+ not_strict
+ = isTopLevel top_lvl -- Top level and recursive things don't
|| isJust rec_flag -- get their demandInfo set at all
|| not (isStrictDmd (idDemandInfo id) || ae_virgin env)
-- See Note [Optimistic CPR in the "virgin" case]
unpackTrivial :: CoreExpr -> Maybe Id
-- Returns (Just v) if the arg is really equal to v, modulo
--- casts, type applications etc
+-- casts, type applications etc
-- See Note [Demand analysis for trivial right-hand sides]
unpackTrivial (Var v) = Just v
unpackTrivial (Cast e _) = unpackTrivial e
@@ -659,7 +658,7 @@ unpackTrivial _ = Nothing
Note [Demand analysis for trivial right-hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
- foo = plusInt |> co
+ foo = plusInt |> co
where plusInt is an arity-2 function with known strictness. Clearly
we want plusInt's strictness to propagate to foo! But because it has
no manifest lambdas, it won't do so automatically, and indeed 'co' might
@@ -679,34 +678,34 @@ Note [Product demands for function body]
This example comes from shootout/binary_trees:
Main.check' = \ b z ds. case z of z' { I# ip ->
- case ds_d13s of
- Main.Nil -> z'
- Main.Node s14k s14l s14m ->
- Main.check' (not b)
- (Main.check' b
- (case b {
- False -> I# (-# s14h s14k);
- True -> I# (+# s14h s14k)
- })
- s14l)
- s14m } } }
+ case ds_d13s of
+ Main.Nil -> z'
+ Main.Node s14k s14l s14m ->
+ Main.check' (not b)
+ (Main.check' b
+ (case b {
+ False -> I# (-# s14h s14k);
+ True -> I# (+# s14h s14k)
+ })
+ s14l)
+ s14m } } }
Here we *really* want to unbox z, even though it appears to be used boxed in
the Nil case. Partly the Nil case is not a hot path. But more specifically,
-the whole function gets the CPR property if we do.
+the whole function gets the CPR property if we do.
So for the demand on the body of a RHS we use a product demand if it's
a product type.
%************************************************************************
-%* *
+%* *
\subsection{Strictness signatures and types}
-%* *
+%* *
%************************************************************************
\begin{code}
unitVarDmd :: Var -> Demand -> DmdType
-unitVarDmd var dmd
+unitVarDmd var dmd
= DmdType (unitVarEnv var dmd) [] topRes
addVarDmd :: DmdType -> Var -> Demand -> DmdType
@@ -716,29 +715,29 @@ addVarDmd (DmdType fv ds res) var dmd
addLazyFVs :: DmdType -> DmdEnv -> DmdType
addLazyFVs dmd_ty lazy_fvs
= dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
- -- Using bothDmdType (rather than just both'ing the envs)
+ -- Using bothDmdType (rather than just both'ing the envs)
-- is vital. Consider
- -- let f = \x -> (x,y)
- -- in error (f 3)
- -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L
- -- demand with the bottom coming up from 'error'
- --
- -- I got a loop in the fixpointer without this, due to an interaction
- -- with the lazy_fv filtering in dmdAnalRhs. Roughly, it was
- -- letrec f n x
- -- = letrec g y = x `fatbar`
- -- letrec h z = z + ...g...
- -- in h (f (n-1) x)
- -- in ...
- -- In the initial iteration for f, f=Bot
- -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
- -- is lazy. Now consider the fixpoint iteration for g, esp the demands it
- -- places on its free variables. Suppose it places none. Then the
- -- x `fatbar` ...call to h...
- -- will give a x->V demand for x. That turns into a L demand for x,
- -- which floats out of the defn for h. Without the modifyEnv, that
- -- L demand doesn't get both'd with the Bot coming up from the inner
- -- call to f. So we just get an L demand for x for g.
+ -- let f = \x -> (x,y)
+ -- in error (f 3)
+ -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L
+ -- demand with the bottom coming up from 'error'
+ --
+ -- I got a loop in the fixpointer without this, due to an interaction
+ -- with the lazy_fv filtering in dmdAnalRhs. Roughly, it was
+ -- letrec f n x
+ -- = letrec g y = x `fatbar`
+ -- letrec h z = z + ...g...
+ -- in h (f (n-1) x)
+ -- in ...
+ -- In the initial iteration for f, f=Bot
+ -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
+ -- is lazy. Now consider the fixpoint iteration for g, esp the demands it
+ -- places on its free variables. Suppose it places none. Then the
+ -- x `fatbar` ...call to h...
+ -- will give a x->V demand for x. That turns into a L demand for x,
+ -- which floats out of the defn for h. Without the modifyEnv, that
+ -- L demand doesn't get both'd with the Bot coming up from the inner
+ -- call to f. So we just get an L demand for x for g.
\end{code}
Note [Do not strictify the argument dictionaries of a dfun]
@@ -773,9 +772,9 @@ annotateLamIdBndr :: AnalEnv
-> DFunFlag -- is this lambda at the top of the RHS of a dfun?
-> DmdType -- Demand type of body
-> Count -- One-shot-ness of the lambda
- -> Id -- Lambda binder
- -> (DmdType, -- Demand type of lambda
- Id) -- and binder annotated with demand
+ -> Id -- Lambda binder
+ -> (DmdType, -- Demand type of lambda
+ Id) -- and binder annotated with demand
annotateLamIdBndr env arg_of_dfun dmd_ty one_shot id
-- For lambdas we add the demand to the argument demands
@@ -828,76 +827,76 @@ guaranteed OK for products, but sums definitely lose sometimes.
Note [CPR for thunks]
~~~~~~~~~~~~~~~~~~~~~
If the rhs is a thunk, we usually forget the CPR info, because
-it is presumably shared (else it would have been inlined, and
+it is presumably shared (else it would have been inlined, and
so we'd lose sharing if w/w'd it into a function). E.g.
- let r = case expensive of
- (a,b) -> (b,a)
- in ...
+ let r = case expensive of
+ (a,b) -> (b,a)
+ in ...
If we marked r as having the CPR property, then we'd w/w into
- let $wr = \() -> case expensive of
- (a,b) -> (# b, a #)
- r = case $wr () of
- (# b,a #) -> (b,a)
- in ...
+ let $wr = \() -> case expensive of
+ (a,b) -> (# b, a #)
+ r = case $wr () of
+ (# b,a #) -> (b,a)
+ in ...
But now r is a thunk, which won't be inlined, so we are no further ahead.
But consider
- f x = let r = case expensive of (a,b) -> (b,a)
- in if foo r then r else (x,x)
+ f x = let r = case expensive of (a,b) -> (b,a)
+ in if foo r then r else (x,x)
Does f have the CPR property? Well, no.
-However, if the strictness analyser has figured out (in a previous
+However, if the strictness analyser has figured out (in a previous
iteration) that it's strict, then we DON'T need to forget the CPR info.
-Instead we can retain the CPR info and do the thunk-splitting transform
+Instead we can retain the CPR info and do the thunk-splitting transform
(see WorkWrap.splitThunk).
This made a big difference to PrelBase.modInt, which had something like
- modInt = \ x -> let r = ... -> I# v in
- ...body strict in r...
+ modInt = \ x -> let r = ... -> I# v in
+ ...body strict in r...
r's RHS isn't a value yet; but modInt returns r in various branches, so
if r doesn't have the CPR property then neither does modInt
Another case I found in practice (in Complex.magnitude), looks like this:
- let k = if ... then I# a else I# b
- in ... body strict in k ....
+ let k = if ... then I# a else I# b
+ in ... body strict in k ....
(For this example, it doesn't matter whether k is returned as part of
-the overall result; but it does matter that k's RHS has the CPR property.)
+the overall result; but it does matter that k's RHS has the CPR property.)
Left to itself, the simplifier will make a join point thus:
- let $j k = ...body strict in k...
- if ... then $j (I# a) else $j (I# b)
+ let $j k = ...body strict in k...
+ if ... then $j (I# a) else $j (I# b)
With thunk-splitting, we get instead
- let $j x = let k = I#x in ...body strict in k...
- in if ... then $j a else $j b
+ let $j x = let k = I#x in ...body strict in k...
+ in if ... then $j a else $j b
This is much better; there's a good chance the I# won't get allocated.
The difficulty with this is that we need the strictness type to
look at the body... but we now need the body to calculate the demand
on the variable, so we can decide whether its strictness type should
-have a CPR in it or not. Simple solution:
- a) use strictness info from the previous iteration
- b) make sure we do at least 2 iterations, by doing a second
- round for top-level non-recs. Top level recs will get at
- least 2 iterations except for totally-bottom functions
- which aren't very interesting anyway.
+have a CPR in it or not. Simple solution:
+ a) use strictness info from the previous iteration
+ b) make sure we do at least 2 iterations, by doing a second
+ round for top-level non-recs. Top level recs will get at
+ least 2 iterations except for totally-bottom functions
+ which aren't very interesting anyway.
NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
Note [Optimistic CPR in the "virgin" case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Demand and strictness info are initialized by top elements. However,
this prevents from inferring a CPR property in the first pass of the
analyser, so we keep an explicit flag ae_virgin in the AnalEnv
datatype.
We can't start with 'not-demanded' (i.e., top) because then consider
- f x = let
- t = ... I# x
- in
- if ... then t else I# y else f x'
+ f x = let
+ t = ... I# x
+ in
+ if ... then t else I# y else f x'
In the first iteration we'd have no demand info for x, so assume
not-demanded; then we'd get TopRes for f's CPR info. Next iteration
@@ -915,14 +914,14 @@ by dmdAnalTopBind.
Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The strictness analyser used to have a HACK which ensured that NOINLNE
-things were not strictness-analysed. The reason was unsafePerformIO.
-Left to itself, the strictness analyser would discover this strictness
+things were not strictness-analysed. The reason was unsafePerformIO.
+Left to itself, the strictness analyser would discover this strictness
for unsafePerformIO:
- unsafePerformIO: C(U(AV))
+ unsafePerformIO: C(U(AV))
But then consider this sub-expression
- unsafePerformIO (\s -> let r = f x in
- case writeIORef v r s of (# s1, _ #) ->
- (# s1, r #)
+ unsafePerformIO (\s -> let r = f x in
+ case writeIORef v r s of (# s1, _ #) ->
+ (# s1, r #)
The strictness analyser will now find that r is sure to be eval'd,
and may then hoist it out. This makes tests/lib/should_run/memo002
deadlock.
@@ -930,14 +929,14 @@ deadlock.
Solving this by making all NOINLINE things have no strictness info is overkill.
In particular, it's overkill for runST, which is perfectly respectable.
Consider
- f x = runST (return x)
+ f x = runST (return x)
This should be strict in x.
So the new plan is to define unsafePerformIO using the 'lazy' combinator:
- unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
+ unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
-Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
+Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
magically NON-STRICT, and is inlined after strictness analysis. So
unsafePerformIO will look non-strict, and that's what we want.
@@ -950,25 +949,25 @@ in favour of error!
Note [Lazy and unleasheable free variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We put the strict and once-used FVs in the DmdType of the Id, so
+We put the strict and once-used FVs in the DmdType of the Id, so
that at its call sites we unleash demands on its strict fvs.
An example is 'roll' in imaginary/wheel-sieve2
Something like this:
- roll x = letrec
- go y = if ... then roll (x-1) else x+1
- in
- go ms
+ roll x = letrec
+ go y = if ... then roll (x-1) else x+1
+ in
+ go ms
We want to see that roll is strict in x, which is because
go is called. So we put the DmdEnv for x in go's DmdType.
Another example:
- f :: Int -> Int -> Int
- f x y = let t = x+1
- h z = if z==0 then t else
- if z==1 then x+1 else
- x + h (z-1)
- in h y
+ f :: Int -> Int -> Int
+ f x y = let t = x+1
+ h z = if z==0 then t else
+ if z==1 then x+1 else
+ x + h (z-1)
+ in h y
Calling h does indeed evaluate x, but we can only see
that if we unleash a demand on x at the call site for t.
@@ -976,9 +975,9 @@ that if we unleash a demand on x at the call site for t.
Incidentally, here's a place where lambda-lifting h would
lose the cigar --- we couldn't see the joint strictness in t/x
- ON THE OTHER HAND
+ ON THE OTHER HAND
We don't want to put *all* the fv's from the RHS into the
-DmdType, because that makes fixpointing very slow --- the
+DmdType, because that makes fixpointing very slow --- the
DmdType gets full of lazy demands that are slow to converge.
@@ -993,9 +992,9 @@ forget that fact, otherwise we might make 'x' absent when it isn't.
%************************************************************************
-%* *
+%* *
\subsection{Strictness signatures}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -1008,17 +1007,17 @@ data AnalEnv
= AE { ae_dflags :: DynFlags
, ae_sigs :: SigEnv
, ae_virgin :: Bool -- True on first iteration only
- -- See Note [Initialising strictness]
+ -- See Note [Initialising strictness]
, ae_rec_tc :: RecTcChecker
, ae_fam_envs :: FamInstEnvs
}
- -- We use the se_env to tell us whether to
- -- record info about a variable in the DmdEnv
- -- We do so if it's a LocalId, but not top-level
- --
- -- The DmdEnv gives the demand on the free vars of the function
- -- when it is given enough args to satisfy the strictness signature
+ -- We use the se_env to tell us whether to
+ -- record info about a variable in the DmdEnv
+ -- We do so if it's a LocalId, but not top-level
+ --
+ -- The DmdEnv gives the demand on the free vars of the function
+ -- when it is given enough args to satisfy the strictness signature
type SigEnv = VarEnv (StrictSig, TopLevelFlag)
@@ -1139,10 +1138,10 @@ CPR signature, because in the likely event that this is a lambda on a
fn defn [we only use this when the lambda is being consumed with a
call demand], it'll be w/w'd and so it will be CPR-ish. E.g.
- f = \x::(Int,Int). if ...strict in x... then
- x
- else
- (a,b)
+ f = \x::(Int,Int). if ...strict in x... then
+ x
+ else
+ (a,b)
We want f to have the CPR property because x does, by the time f has been w/w'd
Also note that we only want to do this for something that definitely