%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-----------------
A demand analysis
-----------------
\begin{code}
module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs,
both
) where
#include "HsVersions.h"
import DynFlags ( DynFlags )
import StaticFlags ( opt_MaxWorkerArgs )
import Demand
import CoreSyn
import PprCore
import CoreUtils ( exprIsHNF, exprIsTrivial )
import CoreArity ( exprArity )
import DataCon ( dataConTyCon, dataConRepStrictness )
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlineActivation,
isDataConWorkId, isGlobalId, idArity,
idStrictness,
setIdStrictness, idDemandInfo, idUnfolding,
idDemandInfo_maybe, setIdDemandInfo
)
import Var ( Var )
import VarEnv
import TysWiredIn ( unboxedPairDataCon )
import TysPrim ( realWorldStatePrimTy )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly,
minusUFM, filterUFM )
import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
import Coercion ( coercionKind )
import Util ( mapAndUnzip, lengthIs, zipEqual )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
RecFlag(..), isRec, isMarkedStrict )
import Maybes ( orElse, expectJust )
import Outputable
import Data.List
import FastString
\end{code}
To think about
* set a noinline pragma on bottoming Ids
* Consider f x = x+1 `fatbar` error (show x)
We'd like to unbox x, even if that means reboxing it in the error case.
%************************************************************************
%* *
\subsection{Top level stuff}
%* *
%************************************************************************
\begin{code}
dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
dmdAnalPgm _ binds
= do {
let { binds_plus_dmds = do_prog binds } ;
return binds_plus_dmds
}
where
do_prog :: [CoreBind] -> [CoreBind]
do_prog binds = snd $ mapAccumL dmdAnalTopBind emptySigEnv binds
dmdAnalTopBind :: SigEnv
-> CoreBind
-> (SigEnv, CoreBind)
dmdAnalTopBind sigs (NonRec id rhs)
= (sigs2, NonRec id2 rhs2)
where
( _, _, (_, rhs1)) = dmdAnalRhs TopLevel NonRecursive (virgin sigs) (id, rhs)
(sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive (nonVirgin sigs) (id, rhs1)
dmdAnalTopBind sigs (Rec pairs)
= (sigs', Rec pairs')
where
(sigs', _, pairs') = dmdFix TopLevel (virgin sigs) pairs
\end{code}
\begin{code}
dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr)
dmdAnalTopRhs rhs
= (sig, rhs2)
where
call_dmd = vanillaCall (exprArity rhs)
(_, rhs1) = dmdAnal (virgin emptySigEnv) call_dmd rhs
(rhs_ty, rhs2) = dmdAnal (nonVirgin emptySigEnv) call_dmd rhs1
sig = mkTopSigTy rhs rhs_ty
\end{code}
%************************************************************************
%* *
\subsection{The analyser itself}
%* *
%************************************************************************
\begin{code}
dmdAnal :: AnalEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
dmdAnal _ Abs e = (topDmdType, e)
dmdAnal env dmd e
| not (isStrictDmd dmd)
= let
(res_ty, e') = dmdAnal env evalDmd e
in
(deferType res_ty, e')
dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit)
dmdAnal _ _ (Type ty) = (topDmdType, Type ty)
dmdAnal env dmd (Var var)
= (dmdTransform env var dmd, Var var)
dmdAnal env dmd (Cast e co)
= (dmd_ty, Cast e' co)
where
(dmd_ty, e') = dmdAnal env dmd' e
to_co = snd (coercionKind co)
dmd'
| Just (tc, _) <- splitTyConApp_maybe to_co
, isRecursiveTyCon tc = evalDmd
| otherwise = dmd
dmdAnal env dmd (Note n e)
= (dmd_ty, Note n e')
where
(dmd_ty, e') = dmdAnal env dmd e
dmdAnal env dmd (App fun (Type ty))
= (fun_ty, App fun' (Type ty))
where
(fun_ty, fun') = dmdAnal env dmd fun
dmdAnal env dmd (App fun arg)
= let
(fun_ty, fun') = dmdAnal env (Call dmd) fun
(arg_ty, arg') = dmdAnal env arg_dmd arg
(arg_dmd, res_ty) = splitDmdTy fun_ty
in
(res_ty `bothType` arg_ty, App fun' arg')
dmdAnal env dmd (Lam var body)
| isTyCoVar var
= let
(body_ty, body') = dmdAnal env dmd body
in
(body_ty, Lam var body')
| Call body_dmd <- dmd
= let
env' = extendSigsWithLam env var
(body_ty, body') = dmdAnal env' body_dmd body
(lam_ty, var') = annotateLamIdBndr env body_ty var
in
(lam_ty, Lam var' body')
| otherwise
= let
(body_ty, body') = dmdAnal env evalDmd body
(lam_ty, var') = annotateLamIdBndr env body_ty var
in
(deferType lam_ty, Lam var' body')
dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
| let tycon = dataConTyCon dc
, isProductTyCon tycon
, not (isRecursiveTyCon tycon)
= let
env_alt = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
(alt_ty, alt') = dmdAnalAlt env_alt dmd alt
(alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
(_, bndrs', _) = alt'
case_bndr_sig = cprSig
alt_dmd = Eval (Prod [idDemandInfo b | b <- bndrs', isId b])
scrut_dmd = alt_dmd `both`
idDemandInfo case_bndr'
(scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
in
(alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
dmdAnal env dmd (Case scrut case_bndr ty alts)
= let
(alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts
(scrut_ty, scrut') = dmdAnal env evalDmd scrut
(alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
in
(alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
dmdAnal env dmd (Let (NonRec id rhs) body)
= let
(sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive env (id, rhs)
(body_ty, body') = dmdAnal (updSigEnv env sigs') dmd body
(body_ty1, id2) = annotateBndr body_ty id1
body_ty2 = addLazyFVs body_ty1 lazy_fv
in
(body_ty2, Let (NonRec id2 rhs') body')
dmdAnal env dmd (Let (Rec pairs) body)
= let
bndrs = map fst pairs
(sigs', lazy_fv, pairs') = dmdFix NotTopLevel env pairs
(body_ty, body') = dmdAnal (updSigEnv env sigs') dmd body
body_ty1 = addLazyFVs body_ty lazy_fv
in
sigs' `seq` body_ty `seq`
let
(body_ty2, _) = annotateBndrs body_ty1 bndrs
in
(body_ty2, Let (Rec pairs') body')
dmdAnalAlt :: AnalEnv -> Demand -> Alt Var -> (DmdType, Alt Var)
dmdAnalAlt env dmd (con,bndrs,rhs)
= let
(rhs_ty, rhs') = dmdAnal env dmd rhs
rhs_ty' = addDataConPatDmds con bndrs rhs_ty
(alt_ty, bndrs') = annotateBndrs rhs_ty' bndrs
final_alt_ty | io_hack_reqd = alt_ty `lubType` topDmdType
| otherwise = alt_ty
io_hack_reqd = con == DataAlt unboxedPairDataCon &&
idType (head bndrs) `coreEqType` realWorldStatePrimTy
in
(final_alt_ty, (con, bndrs', rhs'))
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
where
add bndr dmd_ty = addVarDmd dmd_ty bndr seqDmd
str_bndrs = [ b | (b,s) <- zipEqual "addDataConPatBndrs"
(filter isId bndrs)
(dataConRepStrictness con)
, isMarkedStrict s ]
\end{code}
Note [Add demands for strict constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this program (due to Roman):
data X a = X !a
foo :: X Int -> Int -> Int
foo (X a) n = go 0
where
go i | i < n = a + go (i+1)
| otherwise = 0
We want the worker for 'foo' too look like this:
$wfoo :: Int# -> Int# -> Int#
with the first argument unboxed, so that it is not eval'd each time
around the loop (which would otherwise happen, since 'foo' is not
strict in 'a'. It is sound for the wrapper to pass an unboxed arg
because X is strict, so its argument must be evaluated. And if we
*don't* pass an unboxed argument, we can't even repair it by adding a
`seq` thus:
foo (X a) n = a `seq` go 0
because the seq is discarded (very early) since X is strict!
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
-> Id
-> Demand
-> DmdType
dmdTransform env var dmd
| isDataConWorkId var
= let
StrictSig dmd_ty = idStrictness var
DmdType _ _ con_res = dmd_ty
arity = idArity var
in
if arity == call_depth then
let
dmd_ds = case res_dmd of
Box (Eval ds) -> mapDmds box ds
Eval ds -> ds
_ -> Poly Top
arg_ds = case dmd_ds of
Poly d -> replicate arity d
Prod ds -> ASSERT( ds `lengthIs` arity ) ds
in
mkDmdType emptyDmdEnv arg_ds con_res
else
topDmdType
| isGlobalId var,
let StrictSig dmd_ty = idStrictness var
=
if dmdTypeDepth dmd_ty <= call_depth then
dmd_ty
else
topDmdType
| Just (StrictSig dmd_ty, top_lvl) <- lookupSigEnv env var
= let
fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty
| otherwise = deferType dmd_ty
in
if isTopLevel top_lvl then fn_ty
else addVarDmd fn_ty var dmd
| otherwise
= unitVarDmd var dmd
where
(call_depth, res_dmd) = splitCallDmd dmd
\end{code}
%************************************************************************
%* *
\subsection{Bindings}
%* *
%************************************************************************
\begin{code}
dmdFix :: TopLevelFlag
-> AnalEnv
-> [(Id,CoreExpr)]
-> (SigEnv, DmdEnv,
[(Id,CoreExpr)])
dmdFix top_lvl env orig_pairs
= loop 1 initial_env orig_pairs
where
bndrs = map fst orig_pairs
initial_env = addInitialSigs top_lvl env bndrs
loop :: Int
-> AnalEnv
-> [(Id,CoreExpr)]
-> (SigEnv, DmdEnv, [(Id,CoreExpr)])
loop n env pairs
=
loop' n env pairs
loop' n env pairs
| found_fixpoint
= (sigs', lazy_fv, pairs')
| n >= 10
= pprTrace "dmdFix loop" (ppr n <+> (vcat
[ text "Sigs:" <+> ppr [ (id,lookupVarEnv sigs id, lookupVarEnv sigs' id)
| (id,_) <- pairs],
text "env:" <+> ppr env,
text "binds:" <+> pprCoreBinding (Rec pairs)]))
(sigEnv env, lazy_fv, orig_pairs)
| otherwise
= loop (n+1) (nonVirgin sigs') pairs'
where
sigs = sigEnv env
found_fixpoint = all (same_sig sigs sigs') bndrs
((sigs',lazy_fv), pairs') = mapAccumL my_downRhs (sigs, emptyDmdEnv) pairs
my_downRhs (sigs,lazy_fv) (id,rhs)
= ((sigs', lazy_fv'), pair')
where
(sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive (updSigEnv env sigs) (id,rhs)
lazy_fv' = plusVarEnv_C both lazy_fv lazy_fv1
same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
lookup sigs var = case lookupVarEnv sigs var of
Just (sig,_) -> sig
Nothing -> pprPanic "dmdFix" (ppr var)
dmdAnalRhs :: TopLevelFlag -> RecFlag
-> AnalEnv -> (Id, CoreExpr)
-> (SigEnv, DmdEnv, (Id, CoreExpr))
dmdAnalRhs top_lvl rec_flag env (id, rhs)
= (sigs', lazy_fv, (id', rhs'))
where
arity = idArity id
(rhs_dmd_ty, rhs') = dmdAnal env (vanillaCall arity) rhs
(lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id )
mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
id' = id `setIdStrictness` sig_ty
sigs' = extendSigEnv top_lvl (sigEnv env) id sig_ty
\end{code}
%************************************************************************
%* *
\subsection{Strictness signatures and types}
%* *
%************************************************************************
\begin{code}
mkTopSigTy :: CoreExpr -> DmdType -> StrictSig
mkTopSigTy rhs dmd_ty = snd (mk_sig_ty False False rhs dmd_ty)
mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
mkSigTy top_lvl rec_flag id rhs dmd_ty
= mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
where
never_inline = isNeverActive (idInlineActivation id)
maybe_id_dmd = idDemandInfo_maybe id
thunk_cpr_ok
| isTopLevel top_lvl = False
| isRec rec_flag = False
| Just dmd <- maybe_id_dmd = isStrictDmd dmd
| otherwise = True
\end{code}
The thunk_cpr_ok stuff [CPR-AND-STRICTNESS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the rhs is a thunk, we usually forget the CPR info, because
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 ...
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 ...
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)
Does f have the CPR property? Well, no.
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
(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...
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 ....
(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.)
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)
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
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.
NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
The Nothing case in thunk_cpr_ok [CPR-AND-STRICTNESS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Demand info now has a 'Nothing' state, just like strictness info.
The analysis works from 'dangerous' towards a 'safe' state; so we
start with botSig for 'Nothing' strictness infos, and we start with
"yes, it's demanded" for 'Nothing' in the demand info. The
fixpoint iteration will sort it all out.
We can't start with 'not-demanded' because then consider
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
we'd see that t was demanded, and so give it the CPR property, but by
now f has TopRes, so it will stay TopRes. Instead, with the Nothing
setting the first time round, we say 'yes t is demanded' the first
time.
However, this does mean that for non-recursive bindings we must
iterate twice to be sure of not getting over-optimistic CPR info,
in the case where t turns out to be not-demanded. This is handled
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
for unsafePerformIO:
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 #)
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.
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)
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)
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.
Now we don't need the hack in the strictness analyser. HOWEVER, this
decision does mean that even a NOINLINE function is not entirely
opaque: some aspect of its implementation leaks out, notably its
strictness. For example, if you have a function implemented by an
error stub, but which has RULES, you may want it not to be eliminated
in favour of error!
\begin{code}
mk_sig_ty :: Bool -> Bool -> CoreExpr
-> DmdType -> (DmdEnv, StrictSig)
mk_sig_ty _never_inline thunk_cpr_ok rhs (DmdType fv dmds res)
= (lazy_fv, mkStrictSig dmd_ty)
where
dmd_ty = DmdType strict_fv final_dmds res'
lazy_fv = filterUFM (not . isStrictDmd) fv
strict_fv = filterUFM isStrictDmd fv
final_dmds = setUnpackStrategy dmds
res' = case res of
RetCPR | ignore_cpr_info -> TopRes
_ -> res
ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
\end{code}
The unpack strategy determines whether we'll *really* unpack the argument,
or whether we'll just remember its strictness. If unpacking would give
rise to a *lot* of worker args, we may decide not to unpack after all.
\begin{code}
setUnpackStrategy :: [Demand] -> [Demand]
setUnpackStrategy ds
= snd (go (opt_MaxWorkerArgs nonAbsentArgs ds) ds)
where
go :: Int
-> [Demand]
-> (Int, [Demand])
go n (Eval (Prod cs) : ds)
| n' >= 0 = Eval (Prod cs') `cons` go n'' ds
| otherwise = Box (Eval (Prod cs)) `cons` go n ds
where
(n'',cs') = go n' cs
n' = n + 1 non_abs_args
non_abs_args = nonAbsentArgs cs
go n (d:ds) = d `cons` go n ds
go n [] = (n,[])
cons d (n,ds) = (n, d:ds)
nonAbsentArgs :: [Demand] -> Int
nonAbsentArgs [] = 0
nonAbsentArgs (Abs : ds) = nonAbsentArgs ds
nonAbsentArgs (_ : ds) = 1 + nonAbsentArgs ds
\end{code}
%************************************************************************
%* *
\subsection{Strictness signatures and types}
%* *
%************************************************************************
\begin{code}
unitVarDmd :: Var -> Demand -> DmdType
unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
addVarDmd :: DmdType -> Var -> Demand -> DmdType
addVarDmd (DmdType fv ds res) var dmd
= DmdType (extendVarEnv_C both fv var dmd) ds res
addLazyFVs :: DmdType -> DmdEnv -> DmdType
addLazyFVs (DmdType fv ds res) lazy_fvs
= DmdType both_fv1 ds res
where
both_fv = plusVarEnv_C both fv lazy_fvs
both_fv1 = modifyEnv (isBotRes res) (`both` Bot) lazy_fvs fv both_fv
annotateBndr :: DmdType -> Var -> (DmdType, Var)
annotateBndr dmd_ty@(DmdType fv ds res) var
| isTyCoVar var = (dmd_ty, var)
| otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
annotateBndrs :: DmdType -> [Var] -> (DmdType, [Var])
annotateBndrs = mapAccumR annotateBndr
annotateLamIdBndr :: AnalEnv
-> DmdType
-> Id
-> (DmdType,
Id)
annotateLamIdBndr env (DmdType fv ds res) id
= ASSERT( isId id )
(final_ty, setIdDemandInfo id hacked_dmd)
where
final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
Nothing -> main_ty
Just unf -> main_ty `bothType` unf_ty
where
(unf_ty, _) = dmdAnal env dmd unf
main_ty = DmdType fv' (hacked_dmd:ds) res
(fv', dmd) = removeFV fv id res
hacked_dmd = argDemand dmd
removeFV :: DmdEnv -> Var -> DmdResult -> (DmdEnv, Demand)
removeFV fv id res = (fv', zapUnlifted id dmd)
where
fv' = fv `delVarEnv` id
dmd = lookupVarEnv fv id `orElse` deflt
deflt | isBotRes res = Bot
| otherwise = Abs
zapUnlifted :: Id -> Demand -> Demand
zapUnlifted _ Bot = Bot
zapUnlifted _ Abs = Abs
zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
| otherwise = dmd
\end{code}
Note [Lamba-bound unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We allow a lambda-bound variable to carry an unfolding, a facility that is used
exclusively for join points; see Note [Case binders and join points]. If so,
we must be careful to demand-analyse the RHS of the unfolding! Example
\x. \y{=Just x}.
Then if uses 'y', then transitively it uses 'x', and we must not
forget that fact, otherwise we might make 'x' absent when it isn't.
%************************************************************************
%* *
\subsection{Strictness signatures}
%* *
%************************************************************************
\begin{code}
data AnalEnv
= AE { ae_sigs :: SigEnv
, ae_virgin :: Bool }
type SigEnv = VarEnv (StrictSig, TopLevelFlag)
instance Outputable AnalEnv where
ppr (AE { ae_sigs = env, ae_virgin = virgin })
= ptext (sLit "AE") <+> braces (vcat
[ ptext (sLit "ae_virgin =") <+> ppr virgin
, ptext (sLit "ae_sigs =") <+> ppr env ])
emptySigEnv :: SigEnv
emptySigEnv = emptyVarEnv
sigEnv :: AnalEnv -> SigEnv
sigEnv = ae_sigs
updSigEnv :: AnalEnv -> SigEnv -> AnalEnv
updSigEnv env sigs = env { ae_sigs = sigs }
extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
extendAnalEnv top_lvl env var sig
= env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids
= env { ae_sigs = extendVarEnvList sigs [ (id, (init_sig id, top_lvl))
| id <- ids ] }
where
init_sig | virgin = \_ -> botSig
| otherwise = idStrictness
virgin, nonVirgin :: SigEnv -> AnalEnv
virgin sigs = AE { ae_sigs = sigs, ae_virgin = True }
nonVirgin sigs = AE { ae_sigs = sigs, ae_virgin = False }
extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
extendSigsWithLam env id
= case idDemandInfo_maybe id of
Nothing -> extendAnalEnv NotTopLevel env id cprSig
Just (Eval (Prod _)) -> extendAnalEnv NotTopLevel env id cprSig
_ -> env
\end{code}
Note [Initialising strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Our basic plan is to initialise the strictness of each Id in
a recursive group to "bottom", and find a fixpoint from there.
However, this group A might be inside an *enclosing* recursive
group B, in which case we'll do the entire fixpoint shebang on A
for each iteration of B.
To speed things up, we initialise each iteration of B from the result
of the last one, which is neatly recorded in each binder. That way we
make use of earlier iterations of the fixpoint algorithm. (Cunning
plan.)
But on the *first* iteration we want to *ignore* the current strictness
of the Id, and start from "bottom". Nowadays the Id can have a current
strictness, because interface files record strictness for nested bindings.
To know when we are in the first iteration, we look at the ae_virgin
field of the AnalEnv.
%************************************************************************
%* *
Demands
%* *
%************************************************************************
\begin{code}
splitDmdTy :: DmdType -> (Demand, DmdType)
splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty)
splitCallDmd :: Demand -> (Int, Demand)
splitCallDmd (Call d) = case splitCallDmd d of
(n, r) -> (n+1, r)
splitCallDmd d = (0, d)
vanillaCall :: Arity -> Demand
vanillaCall 0 = evalDmd
vanillaCall n = Call (vanillaCall (n1))
deferType :: DmdType -> DmdType
deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes
deferEnv :: DmdEnv -> DmdEnv
deferEnv fv = mapVarEnv defer fv
argDemand :: Demand -> Demand
argDemand Top = lazyDmd
argDemand (Defer _) = lazyDmd
argDemand (Eval ds) = Eval (mapDmds argDemand ds)
argDemand (Box Bot) = evalDmd
argDemand (Box d) = box (argDemand d)
argDemand Bot = Abs
argDemand d = d
\end{code}
\begin{code}
lubType :: DmdType -> DmdType -> DmdType
lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
= DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
where
lub_fv = plusVarEnv_C lub fv1 fv2
lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv
lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1
lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2
lub_ds [] [] = []
lub_ds ds1 [] = map (`lub` resTypeArgDmd r2) ds1
lub_ds [] ds2 = map (resTypeArgDmd r1 `lub`) ds2
bothType :: DmdType -> DmdType -> DmdType
bothType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2)
= DmdType both_fv2 ds1 (r1 `bothRes` r2)
where
both_fv = plusVarEnv_C both fv1 fv2
both_fv1 = modifyEnv (isBotRes r1) (`both` Bot) fv2 fv1 both_fv
both_fv2 = modifyEnv (isBotRes r2) (`both` Bot) fv1 fv2 both_fv1
\end{code}
\begin{code}
lubRes :: DmdResult -> DmdResult -> DmdResult
lubRes BotRes r = r
lubRes r BotRes = r
lubRes RetCPR RetCPR = RetCPR
lubRes _ _ = TopRes
bothRes :: DmdResult -> DmdResult -> DmdResult
bothRes _ BotRes = BotRes
bothRes r1 _ = r1
\end{code}
\begin{code}
modifyEnv :: Bool
-> (Demand -> Demand)
-> DmdEnv -> DmdEnv
-> DmdEnv -> DmdEnv
modifyEnv need_to_modify zapper env1 env2 env
| need_to_modify = foldr zap env (varEnvKeys (env1 `minusUFM` env2))
| otherwise = env
where
zap uniq env = addToUFM_Directly env uniq (zapper current_val)
where
current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq)
\end{code}
%************************************************************************
%* *
\subsection{LUB and BOTH}
%* *
%************************************************************************
\begin{code}
lub :: Demand -> Demand -> Demand
lub Bot d2 = d2
lub Abs d2 = absLub d2
lub Top _ = Top
lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2)
lub (Call d1) (Call d2) = Call (d1 `lub` d2)
lub d1@(Call _) (Box d2) = d1 `lub` d2
lub (Call _) d2@(Eval _) = d2
lub d1@(Call _) d2 = d2 `lub` d1
lub (Eval ds1) (Eval ds2) = Eval (ds1 `lubs` ds2)
lub (Eval ds1) (Box Bot) = Eval (mapDmds (`lub` Box Bot) ds1)
lub (Eval ds1) (Box (Eval ds2)) = Eval (ds1 `lubs` mapDmds box ds2)
lub (Eval ds1) (Box Abs) = deferEval (mapDmds (`lub` Box Bot) ds1)
lub d1@(Eval _) d2 = d2 `lub` d1
lub (Box d1) (Box d2) = box (d1 `lub` d2)
lub d1@(Box _) d2 = d2 `lub` d1
lubs :: Demands -> Demands -> Demands
lubs ds1 ds2 = zipWithDmds lub ds1 ds2
box :: Demand -> Demand
box (Call d) = Call d
box (Box d) = Box d
box (Defer _) = lazyDmd
box Top = lazyDmd
box Abs = lazyDmd
box d = Box d
defer :: Demand -> Demand
defer Bot = Abs
defer Abs = Abs
defer Top = Top
defer (Call _) = lazyDmd
defer (Box _) = lazyDmd
defer (Defer ds) = Defer ds
defer (Eval ds) = deferEval ds
deferEval :: Demands -> Demand
deferEval ds | allTop ds = Top
| otherwise = Defer ds
absLub :: Demand -> Demand
absLub Bot = Abs
absLub Abs = Abs
absLub Top = Top
absLub (Call _) = Top
absLub (Box _) = Top
absLub (Eval ds) = Defer (absLubs ds)
absLub (Defer ds) = Defer (absLubs ds)
absLubs :: Demands -> Demands
absLubs = mapDmds absLub
both :: Demand -> Demand -> Demand
both Abs d2 = d2
both Bot Bot = Bot
both Bot Abs = Bot
both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds)
both Bot (Defer ds) = Eval (mapDmds (`both` Bot) ds)
both Bot _ = errDmd
both Top Bot = errDmd
both Top Abs = Top
both Top Top = Top
both Top (Box d) = Box d
both Top (Call d) = Call d
both Top (Eval ds) = Eval (mapDmds (`both` Top) ds)
both Top (Defer ds)
= deferEval (mapDmds (`both` Top) ds)
both (Box d1) (Box d2) = box (d1 `both` d2)
both (Box d1) d2@(Call _) = box (d1 `both` d2)
both (Box d1) d2@(Eval _) = box (d1 `both` d2)
both (Box d1) (Defer _) = Box d1
both d1@(Box _) d2 = d2 `both` d1
both (Call d1) (Call d2) = Call (d1 `both` d2)
both (Call d1) (Eval _) = Call d1
both (Call d1) (Defer _) = Call d1
both d1@(Call _) d2 = d2 `both` d1
both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2)
both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2)
both d1@(Eval _) d2 = d2 `both` d1
both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
both d1@(Defer _) d2 = d2 `both` d1
boths :: Demands -> Demands -> Demands
boths ds1 ds2 = zipWithDmds both ds1 ds2
\end{code}
Note [Bottom demands]
~~~~~~~~~~~~~~~~~~~~~
Consider
f x = error x
From 'error' itself we get demand Bot on x
From the arg demand on x we get
x :-> evalDmd = Box (Eval (Poly Abs))
So we get Bot `both` Box (Eval (Poly Abs))
= Seq Keep (Poly Bot)
Consider also
f x = if ... then error (fst x) else fst x
Then we get (Eval (Box Bot, Bot) `lub` Eval (SA))
= Eval (SA)
which is what we want.
Consider also
f x = error [fst x]
Then we get
x :-> Bot `both` Defer [SA]
and we want the Bot demand to cancel out the Defer
so that we get Eval [SA]. Otherwise we'd have the odd
situation that
f x = error (fst x) -- Strictness U(SA)b
g x = error ('y':fst x) -- Strictness Tb