%
% (c) The GRASP/AQUA Project, Glasgow University, 19931998
%
A demand analysis
\begin{code}
module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs,
both
) where
#include "HsVersions.h"
import DynFlags ( DynFlags, DynFlag(..) )
import StaticFlags ( opt_MaxWorkerArgs )
import NewDemand
import CoreSyn
import PprCore
import CoreUtils ( exprIsHNF, exprIsTrivial )
import CoreArity ( exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlineActivation,
isDataConWorkId, isGlobalId, idArity,
#ifdef OLD_STRICTNESS
idDemandInfo, idStrictness, idCprInfo, idName,
#endif
idNewStrictness, idNewStrictness_maybe,
setIdNewStrictness, idNewDemandInfo,
idNewDemandInfo_maybe,
setIdNewDemandInfo
)
#ifdef OLD_STRICTNESS
import IdInfo ( newStrictnessFromOld, newDemand )
#endif
import Var ( Var )
import VarEnv
import TysWiredIn ( unboxedPairDataCon )
import TysPrim ( realWorldStatePrimTy )
import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
keysUFM, minusUFM, ufmToList, filterUFM )
import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
import Coercion ( coercionKind )
import CoreLint ( showPass, endPass )
import Util ( mapAndUnzip, lengthIs )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
RecFlag(..), isRec )
import Maybes ( orElse, expectJust )
import Outputable
import Data.List
\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 dflags binds
= do {
let { binds_plus_dmds = do_prog binds } ;
#ifdef OLD_STRICTNESS
let { dmd_changes = get_changes binds_plus_dmds } ;
printDump (text "Changes in demands" $$ dmd_changes) ;
#endif
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)
= let
( _, _, (_, rhs1)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs)
(sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs1)
in
(sigs2, NonRec id2 rhs2)
dmdAnalTopBind sigs (Rec pairs)
= let
(sigs', _, pairs') = dmdFix TopLevel sigs pairs
in
(sigs', Rec pairs')
\end{code}
\begin{code}
dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr)
dmdAnalTopRhs rhs
= (sig, rhs2)
where
call_dmd = vanillaCall (exprArity rhs)
(_, rhs1) = dmdAnal emptySigEnv call_dmd rhs
(rhs_ty, rhs2) = dmdAnal emptySigEnv call_dmd rhs1
sig = mkTopSigTy rhs rhs_ty
\end{code}
%************************************************************************
%* *
\subsection{The analyser itself}
%* *
%************************************************************************
\begin{code}
dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
dmdAnal sigs Abs e = (topDmdType, e)
dmdAnal sigs dmd e
| not (isStrictDmd dmd)
= let
(res_ty, e') = dmdAnal sigs evalDmd e
in
(deferType res_ty, e')
dmdAnal sigs dmd (Lit lit)
= (topDmdType, Lit lit)
dmdAnal sigs dmd (Var var)
= (dmdTransform sigs var dmd, Var var)
dmdAnal sigs dmd (Cast e co)
= (dmd_ty, Cast e' co)
where
(dmd_ty, e') = dmdAnal sigs dmd' e
to_co = snd (coercionKind co)
dmd'
| Just (tc, args) <- splitTyConApp_maybe to_co
, isRecursiveTyCon tc = evalDmd
| otherwise = dmd
dmdAnal sigs dmd (Note n e)
= (dmd_ty, Note n e')
where
(dmd_ty, e') = dmdAnal sigs dmd e
dmdAnal sigs dmd (App fun (Type ty))
= (fun_ty, App fun' (Type ty))
where
(fun_ty, fun') = dmdAnal sigs dmd fun
dmdAnal sigs dmd e@(App fun arg)
= let
(fun_ty, fun') = dmdAnal sigs (Call dmd) fun
(arg_ty, arg') = dmdAnal sigs arg_dmd arg
(arg_dmd, res_ty) = splitDmdTy fun_ty
in
(res_ty `bothType` arg_ty, App fun' arg')
dmdAnal sigs dmd (Lam var body)
| isTyVar var
= let
(body_ty, body') = dmdAnal sigs dmd body
in
(body_ty, Lam var body')
| Call body_dmd <- dmd
= let
sigs' = extendSigsWithLam sigs var
(body_ty, body') = dmdAnal sigs' body_dmd body
(lam_ty, var') = annotateLamIdBndr body_ty var
in
(lam_ty, Lam var' body')
| otherwise
= let
(body_ty, body') = dmdAnal sigs evalDmd body
(lam_ty, var') = annotateLamIdBndr body_ty var
in
(deferType lam_ty, Lam var' body')
dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
| let tycon = dataConTyCon dc,
isProductTyCon tycon,
not (isRecursiveTyCon tycon)
= let
sigs_alt = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig
(alt_ty, alt') = dmdAnalAlt sigs_alt dmd alt
(alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
(_, bndrs', _) = alt'
case_bndr_sig = cprSig
alt_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
scrut_dmd = alt_dmd `both`
idNewDemandInfo case_bndr'
(scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
(alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
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
(alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
dmdAnal sigs dmd (Let (NonRec id rhs) body)
= let
(sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive sigs (id, rhs)
(body_ty, body') = dmdAnal 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 sigs dmd (Let (Rec pairs) body)
= let
bndrs = map fst pairs
(sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs
(body_ty, body') = dmdAnal 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 sigs dmd (con,bndrs,rhs)
= let
(rhs_ty, rhs') = dmdAnal sigs dmd rhs
(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'))
\end{code}
%************************************************************************
%* *
\subsection{Bindings}
%* *
%************************************************************************
\begin{code}
dmdFix :: TopLevelFlag
-> SigEnv
-> [(Id,CoreExpr)]
-> (SigEnv, DmdEnv,
[(Id,CoreExpr)])
dmdFix top_lvl sigs orig_pairs
= loop 1 initial_sigs orig_pairs
where
bndrs = map fst orig_pairs
initial_sigs = extendSigEnvList sigs [(id, (initialSig id, top_lvl)) | id <- bndrs]
loop :: Int
-> SigEnv
-> [(Id,CoreExpr)]
-> (SigEnv, DmdEnv, [(Id,CoreExpr)])
loop n sigs pairs
| found_fixpoint
= (sigs', lazy_fv, pairs')
| n >= 10 = pprTrace "dmdFix loop" (ppr n <+> (vcat
[ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs],
text "env:" <+> ppr (ufmToList sigs),
text "binds:" <+> pprCoreBinding (Rec pairs)]))
(emptySigEnv, lazy_fv, orig_pairs)
| otherwise = loop (n+1) sigs' pairs'
where
found_fixpoint = all (same_sig sigs sigs') bndrs
((sigs',lazy_fv), pairs') = mapAccumL (my_downRhs top_lvl) (sigs, emptyDmdEnv) pairs
my_downRhs top_lvl (sigs,lazy_fv) (id,rhs)
=
((sigs', lazy_fv'), pair')
where
(sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs)
lazy_fv' = plusUFM_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
initialSig id = idNewStrictness_maybe id `orElse` botSig
dmdAnalRhs :: TopLevelFlag -> RecFlag
-> SigEnv -> (Id, CoreExpr)
-> (SigEnv, DmdEnv, (Id, CoreExpr))
dmdAnalRhs top_lvl rec_flag sigs (id, rhs)
= (sigs', lazy_fv, (id', rhs'))
where
arity = idArity id
(rhs_dmd_ty, rhs') = dmdAnal sigs (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 `setIdNewStrictness` sig_ty
sigs' = extendSigEnv top_lvl sigs 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 = idNewDemandInfo_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 [CPRANDSTRICTNESS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 thunksplitting 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 thunksplitting, 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 toplevel nonrecs. Top level recs will get at
least 2 iterations except for totallybottom functions
which aren't very interesting anyway.
NB: strictly_demanded is never true of a toplevel Id, or of a recursive Id.
The Nothing case in thunk_cpr_ok [CPRANDSTRICTNESS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 'notdemanded' 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
notdemanded; 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 nonrecursive bindings we must
iterate twice to be sure of not getting overoptimistic CPR info,
in the case where t turns out to be notdemanded. This is handled
by dmdAnalTopBind.
Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The strictness analyser used to have a HACK which ensured that NOINLNE
things were not strictnessanalysed. The reason was unsafePerformIO.
Left to itself, the strictness analyser would discover this strictness
for unsafePerformIO:
unsafePerformIO: C(U(AV))
But then consider this subexpression
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 wiredin identityfunction Id, of type a->a, which is
magically NONSTRICT, and is inlined after strictness analysis. So
unsafePerformIO will look nonstrict, 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 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
other -> 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 (d : ds) = 1 + nonAbsentArgs ds
\end{code}
%************************************************************************
%* *
\subsection{Strictness signatures and types}
%* *
%************************************************************************
\begin{code}
unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
| isTopLevel top_lvl = dmd_ty
| otherwise = DmdType (extendVarEnv fv var dmd) ds res
addLazyFVs (DmdType fv ds res) lazy_fvs
= DmdType both_fv1 ds res
where
both_fv = (plusUFM_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
| isTyVar var = (dmd_ty, var)
| otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
annotateBndrs = mapAccumR annotateBndr
annotateLamIdBndr :: DmdType
-> Id
-> (DmdType,
Id)
annotateLamIdBndr dmd_ty@(DmdType fv ds res) id
= ASSERT( isId id )
(DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
where
(fv', dmd) = removeFV fv id res
hacked_dmd = argDemand dmd
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 is Bot = Bot
zapUnlifted id Abs = Abs
zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
| otherwise = dmd
\end{code}
%************************************************************************
%* *
\subsection{Strictness signatures}
%* *
%************************************************************************
\begin{code}
type SigEnv = VarEnv (StrictSig, TopLevelFlag)
emptySigEnv = emptyVarEnv
extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl)
extendSigEnvList = extendVarEnvList
extendSigsWithLam :: SigEnv -> Id -> SigEnv
extendSigsWithLam sigs id
= case idNewDemandInfo_maybe id of
Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel)
Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel)
other -> sigs
dmdTransform :: SigEnv
-> Id
-> Demand
-> DmdType
dmdTransform sigs var dmd
| isDataConWorkId var
= let
StrictSig dmd_ty = idNewStrictness 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
other -> 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 = idNewStrictness var
= if dmdTypeDepth dmd_ty <= call_depth then
dmd_ty
else
topDmdType
| Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var
= let
fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty
| otherwise = deferType dmd_ty
in
addVarDmd top_lvl fn_ty var dmd
| otherwise
= unitVarDmd var dmd
where
(call_depth, res_dmd) = splitCallDmd dmd
\end{code}
%************************************************************************
%* *
\subsection{Demands}
%* *
%************************************************************************
\begin{code}
splitDmdTy :: DmdType -> (Demand, DmdType)
splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
splitDmdTy ty@(DmdType fv [] 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 d) = 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 fv1 ds1 r1) (DmdType fv2 ds2 r2)
= DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
where
lub_fv = plusUFM_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 fv1 ds1 r1) (DmdType fv2 ds2 r2)
= DmdType both_fv2 ds1 (r1 `bothRes` r2)
where
both_fv = plusUFM_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 BotRes r = r
lubRes r BotRes = r
lubRes RetCPR RetCPR = RetCPR
lubRes r1 r2 = TopRes
bothRes r1 BotRes = BotRes
bothRes r1 r2 = 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 (keysUFM (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 d2 = 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 d1@(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 ds1 ds2 = zipWithDmds lub ds1 ds2
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 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 = 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 d = 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 d2) = Box d1
both d1@(Box _) d2 = d2 `both` d1
both (Call d1) (Call d2) = Call (d1 `both` d2)
both (Call d1) (Eval ds2) = Call d1
both (Call d1) (Defer ds2) = Call d1
both d1@(Call _) d2 = d1 `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 ds1) d2 = d2 `both` d1
both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
both d1@(Defer ds1) d2 = d2 `both` d1
boths ds1 ds2 = zipWithDmds both ds1 ds2
\end{code}
%************************************************************************
%* *
\subsection{Miscellaneous
%* *
%************************************************************************
\begin{code}
#ifdef OLD_STRICTNESS
get_changes binds = vcat (map get_changes_bind binds)
get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
get_changes_pr (id,rhs)
= get_changes_var id $$ get_changes_expr rhs
get_changes_var var
| isId var = get_changes_str var $$ get_changes_dmd var
| otherwise = empty
get_changes_expr (Type t) = empty
get_changes_expr (Var v) = empty
get_changes_expr (Lit l) = empty
get_changes_expr (Note n e) = get_changes_expr e
get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2
get_changes_expr (Lam b e) = get_changes_expr e
get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e
get_changes_expr (Case e b a) = get_changes_expr e $$ vcat (map get_changes_alt a)
get_changes_alt (con,bs,rhs) = get_changes_expr rhs
get_changes_str id
| new_better && old_better = empty
| new_better = message "BETTER"
| old_better = message "WORSE"
| otherwise = message "INCOMPARABLE"
where
message word = text word <+> text "strictness for" <+> ppr id <+> info
info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
new = squashSig (idNewStrictness id)
old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
old_better = old `betterStrictness` new
new_better = new `betterStrictness` old
get_changes_dmd id
| isUnLiftedType (idType id) = empty
| new_better && old_better = empty
| new_better = message "BETTER"
| old_better = message "WORSE"
| otherwise = message "INCOMPARABLE"
where
message word = text word <+> text "demand for" <+> ppr id <+> info
info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
new = squashDmd (argDemand (idNewDemandInfo id))
old = newDemand (idDemandInfo id)
new_better = new `betterDemand` old
old_better = old `betterDemand` new
betterStrictness :: StrictSig -> StrictSig -> Bool
betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
betterDmdType t1 t2 = (t1 `lubType` t2) == t2
betterDemand :: Demand -> Demand -> Bool
betterDemand d1 d2 = (d1 `lub` d2) == d2
squashSig (StrictSig (DmdType fv ds res))
= StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
where
squashDmd (Call d) = evalDmd
squashDmd (Box d) = Box (squashDmd d)
squashDmd (Eval ds) = Eval (mapDmds squashDmd ds)
squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)
squashDmd d = d
#endif
\end{code}