{-# LANGUAGE CPP #-}
module GHC.Core.Opt.DmdAnal
( DmdAnalOpts(..)
, dmdAnalProgram
)
where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Types.Demand
import GHC.Core
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Utils.Outputable
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Basic
import Data.List ( mapAccumL )
import GHC.Core.DataCon
import GHC.Types.ForeignCall ( isSafeForeignCall )
import GHC.Types.Id
import GHC.Core.Utils
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.FVs ( exprFreeIds, ruleRhsFreeIds )
import GHC.Core.Coercion ( Coercion, coVarsOfCo )
import GHC.Core.FamInstEnv
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Data.Maybe ( isJust )
import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Types.Unique.Set
data DmdAnalOpts = DmdAnalOpts
{ DmdAnalOpts -> Bool
dmd_strict_dicts :: !Bool
}
dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> CoreProgram -> CoreProgram
dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> CoreProgram -> CoreProgram
dmdAnalProgram DmdAnalOpts
opts FamInstEnvs
fam_envs CoreProgram
binds = CoreProgram
binds_plus_dmds
where
env :: AnalEnv
env = DmdAnalOpts -> FamInstEnvs -> AnalEnv
emptyAnalEnv DmdAnalOpts
opts FamInstEnvs
fam_envs
binds_plus_dmds :: CoreProgram
binds_plus_dmds = (AnalEnv, CoreProgram) -> CoreProgram
forall a b. (a, b) -> b
snd ((AnalEnv, CoreProgram) -> CoreProgram)
-> (AnalEnv, CoreProgram) -> CoreProgram
forall a b. (a -> b) -> a -> b
$ (AnalEnv -> CoreBind -> (AnalEnv, CoreBind))
-> AnalEnv -> CoreProgram -> (AnalEnv, CoreProgram)
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
dmdAnalTopBind AnalEnv
env CoreProgram
binds
dmdAnalTopBind :: AnalEnv
-> CoreBind
-> (AnalEnv, CoreBind)
dmdAnalTopBind :: AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
dmdAnalTopBind AnalEnv
env (NonRec CoreBndr
id Expr CoreBndr
rhs)
= ( TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
TopLevel AnalEnv
env CoreBndr
id StrictSig
sig
, CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (CoreBndr -> StrictSig -> CoreBndr
setIdStrictness CoreBndr
id StrictSig
sig) Expr CoreBndr
rhs')
where
( DmdEnv
_, StrictSig
sig, Expr CoreBndr
rhs') = Maybe [CoreBndr]
-> AnalEnv
-> SubDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, StrictSig, Expr CoreBndr)
dmdAnalRhsLetDown Maybe [CoreBndr]
forall a. Maybe a
Nothing AnalEnv
env SubDemand
topSubDmd CoreBndr
id Expr CoreBndr
rhs
dmdAnalTopBind AnalEnv
env (Rec [(CoreBndr, Expr CoreBndr)]
pairs)
= (AnalEnv
env', [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
pairs')
where
(AnalEnv
env', DmdEnv
_, [(CoreBndr, Expr CoreBndr)]
pairs') = TopLevelFlag
-> AnalEnv
-> SubDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix TopLevelFlag
TopLevel AnalEnv
env SubDemand
topSubDmd [(CoreBndr, Expr CoreBndr)]
pairs
dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
dmdTransformThunkDmd :: Expr CoreBndr -> Demand -> Demand
dmdTransformThunkDmd Expr CoreBndr
e
| Expr CoreBndr -> Bool
exprIsTrivial Expr CoreBndr
e = Demand -> Demand
forall a. a -> a
id
| Bool
otherwise = Demand -> Demand
oneifyDmd
dmdAnalStar :: AnalEnv
-> Demand
-> CoreExpr
-> (PlusDmdArg, CoreExpr)
dmdAnalStar :: AnalEnv -> Demand -> Expr CoreBndr -> (PlusDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env (Card
n :* SubDemand
cd) Expr CoreBndr
e
| (DmdType
dmd_ty, Expr CoreBndr
e') <- AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
cd Expr CoreBndr
e
= ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
(DmdType -> PlusDmdArg
toPlusDmdArg (DmdType -> PlusDmdArg) -> DmdType -> PlusDmdArg
forall a b. (a -> b) -> a -> b
$ Card -> DmdType -> DmdType
multDmdType Card
n DmdType
dmd_ty, Expr CoreBndr
e')
dmdAnal, dmdAnal' :: AnalEnv
-> SubDemand
-> CoreExpr -> (DmdType, CoreExpr)
dmdAnal :: AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
d Expr CoreBndr
e =
AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal' AnalEnv
env SubDemand
d Expr CoreBndr
e
dmdAnal' :: AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal' AnalEnv
_ SubDemand
_ (Lit Literal
lit) = (DmdType
nopDmdType, Literal -> Expr CoreBndr
forall b. Literal -> Expr b
Lit Literal
lit)
dmdAnal' AnalEnv
_ SubDemand
_ (Type Type
ty) = (DmdType
nopDmdType, Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
ty)
dmdAnal' AnalEnv
_ SubDemand
_ (Coercion Coercion
co)
= (DmdEnv -> DmdType
unitDmdType (Coercion -> DmdEnv
coercionDmdEnv Coercion
co), Coercion -> Expr CoreBndr
forall b. Coercion -> Expr b
Coercion Coercion
co)
dmdAnal' AnalEnv
env SubDemand
dmd (Var CoreBndr
var)
= (AnalEnv -> CoreBndr -> SubDemand -> DmdType
dmdTransform AnalEnv
env CoreBndr
var SubDemand
dmd, CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
var)
dmdAnal' AnalEnv
env SubDemand
dmd (Cast Expr CoreBndr
e Coercion
co)
= (DmdType
dmd_ty DmdType -> PlusDmdArg -> DmdType
`plusDmdType` DmdEnv -> PlusDmdArg
mkPlusDmdArg (Coercion -> DmdEnv
coercionDmdEnv Coercion
co), Expr CoreBndr -> Coercion -> Expr CoreBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr CoreBndr
e' Coercion
co)
where
(DmdType
dmd_ty, Expr CoreBndr
e') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
dmd Expr CoreBndr
e
dmdAnal' AnalEnv
env SubDemand
dmd (Tick Tickish CoreBndr
t Expr CoreBndr
e)
= (DmdType
dmd_ty, Tickish CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick Tickish CoreBndr
t Expr CoreBndr
e')
where
(DmdType
dmd_ty, Expr CoreBndr
e') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
dmd Expr CoreBndr
e
dmdAnal' AnalEnv
env SubDemand
dmd (App Expr CoreBndr
fun (Type Type
ty))
= (DmdType
fun_ty, Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
fun' (Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
ty))
where
(DmdType
fun_ty, Expr CoreBndr
fun') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
dmd Expr CoreBndr
fun
dmdAnal' AnalEnv
env SubDemand
dmd (App Expr CoreBndr
fun Expr CoreBndr
arg)
=
let
call_dmd :: SubDemand
call_dmd = SubDemand -> SubDemand
mkCallDmd SubDemand
dmd
(DmdType
fun_ty, Expr CoreBndr
fun') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
call_dmd Expr CoreBndr
fun
(Demand
arg_dmd, DmdType
res_ty) = DmdType -> (Demand, DmdType)
splitDmdTy DmdType
fun_ty
(PlusDmdArg
arg_ty, Expr CoreBndr
arg') = AnalEnv -> Demand -> Expr CoreBndr -> (PlusDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env (Expr CoreBndr -> Demand -> Demand
dmdTransformThunkDmd Expr CoreBndr
arg Demand
arg_dmd) Expr CoreBndr
arg
in
(DmdType
res_ty DmdType -> PlusDmdArg -> DmdType
`plusDmdType` PlusDmdArg
arg_ty, Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
fun' Expr CoreBndr
arg')
dmdAnal' AnalEnv
env SubDemand
dmd (Lam CoreBndr
var Expr CoreBndr
body)
| CoreBndr -> Bool
isTyVar CoreBndr
var
= let
(DmdType
body_ty, Expr CoreBndr
body') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
dmd Expr CoreBndr
body
in
(DmdType
body_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var Expr CoreBndr
body')
| Bool
otherwise
= let (Card
n, SubDemand
body_dmd) = SubDemand -> (Card, SubDemand)
peelCallDmd SubDemand
dmd
(DmdType
body_ty, Expr CoreBndr
body') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
body_dmd Expr CoreBndr
body
(DmdType
lam_ty, CoreBndr
var') = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateLamIdBndr AnalEnv
env Bool
notArgOfDfun DmdType
body_ty CoreBndr
var
in
(Card -> DmdType -> DmdType
multDmdType Card
n DmdType
lam_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var' Expr CoreBndr
body')
dmdAnal' AnalEnv
env SubDemand
dmd (Case Expr CoreBndr
scrut CoreBndr
case_bndr Type
ty [(AltCon
alt, [CoreBndr]
bndrs, Expr CoreBndr
rhs)])
| AltCon -> Bool
is_non_sum_alt AltCon
alt
= let
(DmdType
rhs_ty, Expr CoreBndr
rhs') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
dmd Expr CoreBndr
rhs
(DmdType
alt_ty1, [Demand]
dmds) = AnalEnv -> DmdType -> [CoreBndr] -> (DmdType, [Demand])
findBndrsDmds AnalEnv
env DmdType
rhs_ty [CoreBndr]
bndrs
(DmdType
alt_ty2, Demand
case_bndr_dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
False DmdType
alt_ty1 CoreBndr
case_bndr
(Card
_ :* SubDemand
case_bndr_sd) = Demand
case_bndr_dmd
([CoreBndr]
bndrs', SubDemand
scrut_sd)
| DataAlt DataCon
_ <- AltCon
alt
, [Demand]
id_dmds <- SubDemand -> [Demand] -> [Demand]
addCaseBndrDmd SubDemand
case_bndr_sd [Demand]
dmds
= ([CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bndrs [Demand]
id_dmds, [Demand] -> SubDemand
mkProd [Demand]
id_dmds)
| Bool
otherwise
= ASSERT( null bndrs ) (bndrs, case_bndr_sd)
fam_envs :: FamInstEnvs
fam_envs = AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env
alt_ty3 :: DmdType
alt_ty3
| FamInstEnvs -> Expr CoreBndr -> Bool
exprMayThrowPreciseException FamInstEnvs
fam_envs Expr CoreBndr
scrut
= DmdType -> DmdType
deferAfterPreciseException DmdType
alt_ty2
| Bool
otherwise
= DmdType
alt_ty2
(DmdType
scrut_ty, Expr CoreBndr
scrut') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
scrut_sd Expr CoreBndr
scrut
res_ty :: DmdType
res_ty = DmdType
alt_ty3 DmdType -> PlusDmdArg -> DmdType
`plusDmdType` DmdType -> PlusDmdArg
toPlusDmdArg DmdType
scrut_ty
case_bndr' :: CoreBndr
case_bndr' = CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
case_bndr Demand
case_bndr_dmd
in
(DmdType
res_ty, Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr CoreBndr
scrut' CoreBndr
case_bndr' Type
ty [(AltCon
alt, [CoreBndr]
bndrs', Expr CoreBndr
rhs')])
where
is_non_sum_alt :: AltCon -> Bool
is_non_sum_alt (DataAlt DataCon
dc) = Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (Maybe DataCon -> Bool) -> Maybe DataCon -> Bool
forall a b. (a -> b) -> a -> b
$ TyCon -> Maybe DataCon
isDataProductTyCon_maybe (TyCon -> Maybe DataCon) -> TyCon -> Maybe DataCon
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dc
is_non_sum_alt AltCon
_ = Bool
True
dmdAnal' AnalEnv
env SubDemand
dmd (Case Expr CoreBndr
scrut CoreBndr
case_bndr Type
ty [Alt CoreBndr]
alts)
= let
([DmdType]
alt_tys, [Alt CoreBndr]
alts') = (Alt CoreBndr -> (DmdType, Alt CoreBndr))
-> [Alt CoreBndr] -> ([DmdType], [Alt CoreBndr])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (AnalEnv
-> SubDemand -> CoreBndr -> Alt CoreBndr -> (DmdType, Alt CoreBndr)
dmdAnalSumAlt AnalEnv
env SubDemand
dmd CoreBndr
case_bndr) [Alt CoreBndr]
alts
(DmdType
scrut_ty, Expr CoreBndr
scrut') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
topSubDmd Expr CoreBndr
scrut
(DmdType
alt_ty, CoreBndr
case_bndr') = AnalEnv -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateBndr AnalEnv
env ((DmdType -> DmdType -> DmdType) -> DmdType -> [DmdType] -> DmdType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DmdType -> DmdType -> DmdType
lubDmdType DmdType
botDmdType [DmdType]
alt_tys) CoreBndr
case_bndr
fam_envs :: FamInstEnvs
fam_envs = AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env
alt_ty2 :: DmdType
alt_ty2
| FamInstEnvs -> Expr CoreBndr -> Bool
exprMayThrowPreciseException FamInstEnvs
fam_envs Expr CoreBndr
scrut
= DmdType -> DmdType
deferAfterPreciseException DmdType
alt_ty
| Bool
otherwise
= DmdType
alt_ty
res_ty :: DmdType
res_ty = DmdType
alt_ty2 DmdType -> PlusDmdArg -> DmdType
`plusDmdType` DmdType -> PlusDmdArg
toPlusDmdArg DmdType
scrut_ty
in
(DmdType
res_ty, Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr CoreBndr
scrut' CoreBndr
case_bndr' Type
ty [Alt CoreBndr]
alts')
dmdAnal' AnalEnv
env SubDemand
dmd (Let (NonRec CoreBndr
id Expr CoreBndr
rhs) Expr CoreBndr
body)
| CoreBndr -> Bool
useLetUp CoreBndr
id
= (DmdType
final_ty, CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
id' Expr CoreBndr
rhs') Expr CoreBndr
body')
where
(DmdType
body_ty, Expr CoreBndr
body') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
dmd Expr CoreBndr
body
(DmdType
body_ty', Demand
id_dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
notArgOfDfun DmdType
body_ty CoreBndr
id
id' :: CoreBndr
id' = CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
id Demand
id_dmd
(PlusDmdArg
rhs_ty, Expr CoreBndr
rhs') = AnalEnv -> Demand -> Expr CoreBndr -> (PlusDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env (Expr CoreBndr -> Demand -> Demand
dmdTransformThunkDmd Expr CoreBndr
rhs Demand
id_dmd) Expr CoreBndr
rhs
final_ty :: DmdType
final_ty = DmdType
body_ty' DmdType -> PlusDmdArg -> DmdType
`plusDmdType` PlusDmdArg
rhs_ty
dmdAnal' AnalEnv
env SubDemand
dmd (Let (NonRec CoreBndr
id Expr CoreBndr
rhs) Expr CoreBndr
body)
= (DmdType
body_ty2, CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
id2 Expr CoreBndr
rhs') Expr CoreBndr
body')
where
(DmdEnv
lazy_fv, StrictSig
sig, Expr CoreBndr
rhs') = Maybe [CoreBndr]
-> AnalEnv
-> SubDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, StrictSig, Expr CoreBndr)
dmdAnalRhsLetDown Maybe [CoreBndr]
forall a. Maybe a
Nothing AnalEnv
env SubDemand
dmd CoreBndr
id Expr CoreBndr
rhs
id1 :: CoreBndr
id1 = CoreBndr -> StrictSig -> CoreBndr
setIdStrictness CoreBndr
id StrictSig
sig
env1 :: AnalEnv
env1 = TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
NotTopLevel AnalEnv
env CoreBndr
id StrictSig
sig
(DmdType
body_ty, Expr CoreBndr
body') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env1 SubDemand
dmd Expr CoreBndr
body
(DmdType
body_ty1, CoreBndr
id2) = AnalEnv -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateBndr AnalEnv
env DmdType
body_ty CoreBndr
id1
body_ty2 :: DmdType
body_ty2 = DmdType -> DmdEnv -> DmdType
addLazyFVs DmdType
body_ty1 DmdEnv
lazy_fv
dmdAnal' AnalEnv
env SubDemand
dmd (Let (Rec [(CoreBndr, Expr CoreBndr)]
pairs) Expr CoreBndr
body)
= let
(AnalEnv
env', DmdEnv
lazy_fv, [(CoreBndr, Expr CoreBndr)]
pairs') = TopLevelFlag
-> AnalEnv
-> SubDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix TopLevelFlag
NotTopLevel AnalEnv
env SubDemand
dmd [(CoreBndr, Expr CoreBndr)]
pairs
(DmdType
body_ty, Expr CoreBndr
body') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env' SubDemand
dmd Expr CoreBndr
body
body_ty1 :: DmdType
body_ty1 = DmdType -> [CoreBndr] -> DmdType
deleteFVs DmdType
body_ty (((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
pairs)
body_ty2 :: DmdType
body_ty2 = DmdType -> DmdEnv -> DmdType
addLazyFVs DmdType
body_ty1 DmdEnv
lazy_fv
in
DmdType
body_ty2 DmdType -> (DmdType, Expr CoreBndr) -> (DmdType, Expr CoreBndr)
`seq`
(DmdType
body_ty2, CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let ([(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
pairs') Expr CoreBndr
body')
exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool
exprMayThrowPreciseException :: FamInstEnvs -> Expr CoreBndr -> Bool
exprMayThrowPreciseException FamInstEnvs
envs Expr CoreBndr
e
| Bool -> Bool
not (FamInstEnvs -> Type -> Bool
forcesRealWorld FamInstEnvs
envs (Expr CoreBndr -> Type
exprType Expr CoreBndr
e))
= Bool
False
| (Var CoreBndr
f, [Expr CoreBndr]
_) <- Expr CoreBndr -> (Expr CoreBndr, [Expr CoreBndr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr CoreBndr
e
, Just PrimOp
op <- CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
f
, PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
/= PrimOp
RaiseIOOp
= Bool
False
| (Var CoreBndr
f, [Expr CoreBndr]
_) <- Expr CoreBndr -> (Expr CoreBndr, [Expr CoreBndr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr CoreBndr
e
, Just ForeignCall
fcall <- CoreBndr -> Maybe ForeignCall
isFCallId_maybe CoreBndr
f
, Bool -> Bool
not (ForeignCall -> Bool
isSafeForeignCall ForeignCall
fcall)
= Bool
False
| Bool
otherwise
= Bool
True
forcesRealWorld :: FamInstEnvs -> Type -> Bool
forcesRealWorld :: FamInstEnvs -> Type -> Bool
forcesRealWorld FamInstEnvs
fam_envs Type
ty
| Type
ty Type -> Type -> Bool
`eqType` Type
realWorldStatePrimTy
= Bool
True
| Just DataConAppContext{ dcac_dc :: DataConAppContext -> DataCon
dcac_dc = DataCon
dc, dcac_arg_tys :: DataConAppContext -> [(Scaled Type, StrictnessMark)]
dcac_arg_tys = [(Scaled Type, StrictnessMark)]
field_tys }
<- FamInstEnvs -> Type -> Maybe DataConAppContext
deepSplitProductType_maybe FamInstEnvs
fam_envs Type
ty
, DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
= ((Scaled Type, StrictnessMark) -> Bool)
-> [(Scaled Type, StrictnessMark)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Scaled Type
ty,StrictnessMark
_) -> Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty Type -> Type -> Bool
`eqType` Type
realWorldStatePrimTy) [(Scaled Type, StrictnessMark)]
field_tys
| Bool
otherwise
= Bool
False
dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var)
dmdAnalSumAlt :: AnalEnv
-> SubDemand -> CoreBndr -> Alt CoreBndr -> (DmdType, Alt CoreBndr)
dmdAnalSumAlt AnalEnv
env SubDemand
dmd CoreBndr
case_bndr (AltCon
con,[CoreBndr]
bndrs,Expr CoreBndr
rhs)
| (DmdType
rhs_ty, Expr CoreBndr
rhs') <- AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
dmd Expr CoreBndr
rhs
, (DmdType
alt_ty, [Demand]
dmds) <- AnalEnv -> DmdType -> [CoreBndr] -> (DmdType, [Demand])
findBndrsDmds AnalEnv
env DmdType
rhs_ty [CoreBndr]
bndrs
, let (Card
_ :* SubDemand
case_bndr_sd) = DmdType -> CoreBndr -> Demand
findIdDemand DmdType
alt_ty CoreBndr
case_bndr
id_dmds :: [Demand]
id_dmds = SubDemand -> [Demand] -> [Demand]
addCaseBndrDmd SubDemand
case_bndr_sd [Demand]
dmds
= (DmdType
alt_ty, (AltCon
con, [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bndrs [Demand]
id_dmds, Expr CoreBndr
rhs'))
dmdTransform :: AnalEnv
-> Id
-> SubDemand
-> DmdType
dmdTransform :: AnalEnv -> CoreBndr -> SubDemand -> DmdType
dmdTransform AnalEnv
env CoreBndr
var SubDemand
dmd
| CoreBndr -> Bool
isDataConWorkId CoreBndr
var
= Int -> SubDemand -> DmdType
dmdTransformDataConSig (CoreBndr -> Int
idArity CoreBndr
var) SubDemand
dmd
| Just Class
_ <- CoreBndr -> Maybe Class
isClassOpId_maybe CoreBndr
var
=
StrictSig -> SubDemand -> DmdType
dmdTransformDictSelSig (CoreBndr -> StrictSig
idStrictness CoreBndr
var) SubDemand
dmd
| CoreBndr -> Bool
isGlobalId CoreBndr
var
, let res :: DmdType
res = StrictSig -> SubDemand -> DmdType
dmdTransformSig (CoreBndr -> StrictSig
idStrictness CoreBndr
var) SubDemand
dmd
=
DmdType
res
| Just (StrictSig
sig, TopLevelFlag
top_lvl) <- AnalEnv -> CoreBndr -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv AnalEnv
env CoreBndr
var
, let fn_ty :: DmdType
fn_ty = StrictSig -> SubDemand -> DmdType
dmdTransformSig StrictSig
sig SubDemand
dmd
=
if TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
then DmdType
fn_ty
else DmdType -> CoreBndr -> Demand -> DmdType
addVarDmd DmdType
fn_ty CoreBndr
var (Card
C_11 Card -> SubDemand -> Demand
:* SubDemand
dmd)
| Bool
otherwise
=
DmdEnv -> DmdType
unitDmdType (CoreBndr -> Demand -> DmdEnv
forall a. CoreBndr -> a -> VarEnv a
unitVarEnv CoreBndr
var (Card
C_11 Card -> SubDemand -> Demand
:* SubDemand
dmd))
dmdAnalRhsLetDown
:: Maybe [Id]
-> AnalEnv -> SubDemand
-> Id -> CoreExpr
-> (DmdEnv, StrictSig, CoreExpr)
dmdAnalRhsLetDown :: Maybe [CoreBndr]
-> AnalEnv
-> SubDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, StrictSig, Expr CoreBndr)
dmdAnalRhsLetDown Maybe [CoreBndr]
rec_flag AnalEnv
env SubDemand
let_dmd CoreBndr
id Expr CoreBndr
rhs
=
(DmdEnv
lazy_fv, StrictSig
sig, Expr CoreBndr
rhs')
where
rhs_arity :: Int
rhs_arity = CoreBndr -> Int
idArity CoreBndr
id
rhs_dmd :: SubDemand
rhs_dmd
| CoreBndr -> Bool
isJoinId CoreBndr
id
= Int -> SubDemand -> SubDemand
mkCallDmds Int
rhs_arity SubDemand
let_dmd
| Bool
otherwise
= AnalEnv -> Int -> Expr CoreBndr -> SubDemand
mkRhsDmd AnalEnv
env Int
rhs_arity Expr CoreBndr
rhs
(DmdType
rhs_dmd_ty, Expr CoreBndr
rhs') = AnalEnv -> SubDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env SubDemand
rhs_dmd Expr CoreBndr
rhs
DmdType DmdEnv
rhs_fv [Demand]
rhs_dmds Divergence
rhs_div = DmdType
rhs_dmd_ty
sig :: StrictSig
sig = Int -> DmdType -> StrictSig
mkStrictSigForArity Int
rhs_arity (DmdEnv -> [Demand] -> Divergence -> DmdType
DmdType DmdEnv
sig_fv [Demand]
rhs_dmds Divergence
rhs_div)
rhs_fv1 :: DmdEnv
rhs_fv1 = case Maybe [CoreBndr]
rec_flag of
Just [CoreBndr]
bs -> DmdEnv -> DmdEnv
reuseEnv (DmdEnv -> [CoreBndr] -> DmdEnv
forall a. VarEnv a -> [CoreBndr] -> VarEnv a
delVarEnvList DmdEnv
rhs_fv [CoreBndr]
bs)
Maybe [CoreBndr]
Nothing -> DmdEnv
rhs_fv
rhs_fv2 :: DmdEnv
rhs_fv2 = DmdEnv
rhs_fv1 DmdEnv -> IdSet -> DmdEnv
`keepAliveDmdEnv` IdSet
extra_fvs
extra_fvs :: IdSet
extra_fvs = (CoreRule -> IdSet -> IdSet) -> IdSet -> [CoreRule] -> IdSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (IdSet -> IdSet -> IdSet
unionVarSet (IdSet -> IdSet -> IdSet)
-> (CoreRule -> IdSet) -> CoreRule -> IdSet -> IdSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreRule -> IdSet
ruleRhsFreeIds) IdSet
unf_fvs ([CoreRule] -> IdSet) -> [CoreRule] -> IdSet
forall a b. (a -> b) -> a -> b
$
CoreBndr -> [CoreRule]
idCoreRules CoreBndr
id
(DmdEnv
lazy_fv, DmdEnv
sig_fv) = (Demand -> Bool) -> DmdEnv -> (DmdEnv, DmdEnv)
forall a. (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)
partitionVarEnv Demand -> Bool
isWeakDmd DmdEnv
rhs_fv2
unf :: Unfolding
unf = CoreBndr -> Unfolding
realIdUnfolding CoreBndr
id
unf_fvs :: IdSet
unf_fvs | Unfolding -> Bool
isStableUnfolding Unfolding
unf
, Just Expr CoreBndr
unf_body <- Unfolding -> Maybe (Expr CoreBndr)
maybeUnfoldingTemplate Unfolding
unf
= Expr CoreBndr -> IdSet
exprFreeIds Expr CoreBndr
unf_body
| Bool
otherwise = IdSet
emptyVarSet
mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> SubDemand
mkRhsDmd :: AnalEnv -> Int -> Expr CoreBndr -> SubDemand
mkRhsDmd AnalEnv
_env Int
rhs_arity Expr CoreBndr
_rhs = Int -> SubDemand -> SubDemand
mkCallDmds Int
rhs_arity SubDemand
topSubDmd
useLetUp :: Var -> Bool
useLetUp :: CoreBndr -> Bool
useLetUp CoreBndr
f = CoreBndr -> Int
idArity CoreBndr
f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreBndr -> Bool
isJoinId CoreBndr
f)
dmdFix :: TopLevelFlag
-> AnalEnv
-> SubDemand
-> [(Id,CoreExpr)]
-> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
dmdFix :: TopLevelFlag
-> AnalEnv
-> SubDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix TopLevelFlag
top_lvl AnalEnv
env SubDemand
let_dmd [(CoreBndr, Expr CoreBndr)]
orig_pairs
= Int
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
loop Int
1 [(CoreBndr, Expr CoreBndr)]
initial_pairs
where
bndrs :: [CoreBndr]
bndrs = ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
orig_pairs
initial_pairs :: [(CoreBndr, Expr CoreBndr)]
initial_pairs | AnalEnv -> Bool
ae_virgin AnalEnv
env = [(CoreBndr -> StrictSig -> CoreBndr
setIdStrictness CoreBndr
id StrictSig
botSig, Expr CoreBndr
rhs) | (CoreBndr
id, Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
orig_pairs ]
| Bool
otherwise = [(CoreBndr, Expr CoreBndr)]
orig_pairs
abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
abort :: (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
abort = (AnalEnv
env, DmdEnv
lazy_fv', [(CoreBndr, Expr CoreBndr)]
zapped_pairs)
where (DmdEnv
lazy_fv, [(CoreBndr, Expr CoreBndr)]
pairs') = Bool
-> [(CoreBndr, Expr CoreBndr)]
-> (DmdEnv, [(CoreBndr, Expr CoreBndr)])
step Bool
True ([(CoreBndr, Expr CoreBndr)] -> [(CoreBndr, Expr CoreBndr)]
zapIdStrictness [(CoreBndr, Expr CoreBndr)]
orig_pairs)
non_lazy_fvs :: DmdEnv
non_lazy_fvs = [DmdEnv] -> DmdEnv
forall a. [VarEnv a] -> VarEnv a
plusVarEnvList ([DmdEnv] -> DmdEnv) -> [DmdEnv] -> DmdEnv
forall a b. (a -> b) -> a -> b
$ ((CoreBndr, Expr CoreBndr) -> DmdEnv)
-> [(CoreBndr, Expr CoreBndr)] -> [DmdEnv]
forall a b. (a -> b) -> [a] -> [b]
map (StrictSig -> DmdEnv
strictSigDmdEnv (StrictSig -> DmdEnv)
-> ((CoreBndr, Expr CoreBndr) -> StrictSig)
-> (CoreBndr, Expr CoreBndr)
-> DmdEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> StrictSig
idStrictness (CoreBndr -> StrictSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> StrictSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, Expr CoreBndr)]
pairs'
lazy_fv' :: DmdEnv
lazy_fv' = DmdEnv
lazy_fv DmdEnv -> DmdEnv -> DmdEnv
forall a. VarEnv a -> VarEnv a -> VarEnv a
`plusVarEnv` (Demand -> Demand) -> DmdEnv -> DmdEnv
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (Demand -> Demand -> Demand
forall a b. a -> b -> a
const Demand
topDmd) DmdEnv
non_lazy_fvs
zapped_pairs :: [(CoreBndr, Expr CoreBndr)]
zapped_pairs = [(CoreBndr, Expr CoreBndr)] -> [(CoreBndr, Expr CoreBndr)]
zapIdStrictness [(CoreBndr, Expr CoreBndr)]
pairs'
loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
loop :: Int
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
loop Int
n [(CoreBndr, Expr CoreBndr)]
pairs =
Int
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
loop' Int
n [(CoreBndr, Expr CoreBndr)]
pairs
loop' :: Int
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
loop' Int
n [(CoreBndr, Expr CoreBndr)]
pairs
| Bool
found_fixpoint = (AnalEnv
final_anal_env, DmdEnv
lazy_fv, [(CoreBndr, Expr CoreBndr)]
pairs')
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 = (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
abort
| Bool
otherwise = Int
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
loop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(CoreBndr, Expr CoreBndr)]
pairs'
where
found_fixpoint :: Bool
found_fixpoint = ((CoreBndr, Expr CoreBndr) -> StrictSig)
-> [(CoreBndr, Expr CoreBndr)] -> [StrictSig]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> StrictSig
idStrictness (CoreBndr -> StrictSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> StrictSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, Expr CoreBndr)]
pairs' [StrictSig] -> [StrictSig] -> Bool
forall a. Eq a => a -> a -> Bool
== ((CoreBndr, Expr CoreBndr) -> StrictSig)
-> [(CoreBndr, Expr CoreBndr)] -> [StrictSig]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> StrictSig
idStrictness (CoreBndr -> StrictSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> StrictSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, Expr CoreBndr)]
pairs
first_round :: Bool
first_round = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
(DmdEnv
lazy_fv, [(CoreBndr, Expr CoreBndr)]
pairs') = Bool
-> [(CoreBndr, Expr CoreBndr)]
-> (DmdEnv, [(CoreBndr, Expr CoreBndr)])
step Bool
first_round [(CoreBndr, Expr CoreBndr)]
pairs
final_anal_env :: AnalEnv
final_anal_env = TopLevelFlag -> AnalEnv -> [CoreBndr] -> AnalEnv
extendAnalEnvs TopLevelFlag
top_lvl AnalEnv
env (((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
pairs')
step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
step :: Bool
-> [(CoreBndr, Expr CoreBndr)]
-> (DmdEnv, [(CoreBndr, Expr CoreBndr)])
step Bool
first_round [(CoreBndr, Expr CoreBndr)]
pairs = (DmdEnv
lazy_fv, [(CoreBndr, Expr CoreBndr)]
pairs')
where
start_env :: AnalEnv
start_env | Bool
first_round = AnalEnv
env
| Bool
otherwise = AnalEnv -> AnalEnv
nonVirgin AnalEnv
env
start :: (AnalEnv, DmdEnv)
start = (TopLevelFlag -> AnalEnv -> [CoreBndr] -> AnalEnv
extendAnalEnvs TopLevelFlag
top_lvl AnalEnv
start_env (((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
pairs), DmdEnv
emptyDmdEnv)
((AnalEnv
_,DmdEnv
lazy_fv), [(CoreBndr, Expr CoreBndr)]
pairs') = ((AnalEnv, DmdEnv)
-> (CoreBndr, Expr CoreBndr)
-> ((AnalEnv, DmdEnv), (CoreBndr, Expr CoreBndr)))
-> (AnalEnv, DmdEnv)
-> [(CoreBndr, Expr CoreBndr)]
-> ((AnalEnv, DmdEnv), [(CoreBndr, Expr CoreBndr)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (AnalEnv, DmdEnv)
-> (CoreBndr, Expr CoreBndr)
-> ((AnalEnv, DmdEnv), (CoreBndr, Expr CoreBndr))
my_downRhs (AnalEnv, DmdEnv)
start [(CoreBndr, Expr CoreBndr)]
pairs
my_downRhs :: (AnalEnv, DmdEnv)
-> (CoreBndr, Expr CoreBndr)
-> ((AnalEnv, DmdEnv), (CoreBndr, Expr CoreBndr))
my_downRhs (AnalEnv
env, DmdEnv
lazy_fv) (CoreBndr
id,Expr CoreBndr
rhs)
=
((AnalEnv
env', DmdEnv
lazy_fv'), (CoreBndr
id', Expr CoreBndr
rhs'))
where
(DmdEnv
lazy_fv1, StrictSig
sig, Expr CoreBndr
rhs') = Maybe [CoreBndr]
-> AnalEnv
-> SubDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, StrictSig, Expr CoreBndr)
dmdAnalRhsLetDown ([CoreBndr] -> Maybe [CoreBndr]
forall a. a -> Maybe a
Just [CoreBndr]
bndrs) AnalEnv
env SubDemand
let_dmd CoreBndr
id Expr CoreBndr
rhs
lazy_fv' :: DmdEnv
lazy_fv' = (Demand -> Demand -> Demand) -> DmdEnv -> DmdEnv -> DmdEnv
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C Demand -> Demand -> Demand
plusDmd DmdEnv
lazy_fv DmdEnv
lazy_fv1
env' :: AnalEnv
env' = TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
top_lvl AnalEnv
env CoreBndr
id StrictSig
sig
id' :: CoreBndr
id' = CoreBndr -> StrictSig -> CoreBndr
setIdStrictness CoreBndr
id StrictSig
sig
zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
zapIdStrictness :: [(CoreBndr, Expr CoreBndr)] -> [(CoreBndr, Expr CoreBndr)]
zapIdStrictness [(CoreBndr, Expr CoreBndr)]
pairs = [(CoreBndr -> StrictSig -> CoreBndr
setIdStrictness CoreBndr
id StrictSig
nopSig, Expr CoreBndr
rhs) | (CoreBndr
id, Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
pairs ]
unitDmdType :: DmdEnv -> DmdType
unitDmdType :: DmdEnv -> DmdType
unitDmdType DmdEnv
dmd_env = DmdEnv -> [Demand] -> Divergence -> DmdType
DmdType DmdEnv
dmd_env [] Divergence
topDiv
coercionDmdEnv :: Coercion -> DmdEnv
coercionDmdEnv :: Coercion -> DmdEnv
coercionDmdEnv Coercion
co = (CoreBndr -> Demand) -> VarEnv CoreBndr -> DmdEnv
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (Demand -> CoreBndr -> Demand
forall a b. a -> b -> a
const Demand
topDmd) (IdSet -> VarEnv CoreBndr
forall a. UniqSet a -> UniqFM a a
getUniqSet (IdSet -> VarEnv CoreBndr) -> IdSet -> VarEnv CoreBndr
forall a b. (a -> b) -> a -> b
$ Coercion -> IdSet
coVarsOfCo Coercion
co)
addVarDmd :: DmdType -> Var -> Demand -> DmdType
addVarDmd :: DmdType -> CoreBndr -> Demand -> DmdType
addVarDmd (DmdType DmdEnv
fv [Demand]
ds Divergence
res) CoreBndr
var Demand
dmd
= DmdEnv -> [Demand] -> Divergence -> DmdType
DmdType ((Demand -> Demand -> Demand)
-> DmdEnv -> CoreBndr -> Demand -> DmdEnv
forall a. (a -> a -> a) -> VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv_C Demand -> Demand -> Demand
plusDmd DmdEnv
fv CoreBndr
var Demand
dmd) [Demand]
ds Divergence
res
addLazyFVs :: DmdType -> DmdEnv -> DmdType
addLazyFVs :: DmdType -> DmdEnv -> DmdType
addLazyFVs DmdType
dmd_ty DmdEnv
lazy_fvs
= DmdType
dmd_ty DmdType -> PlusDmdArg -> DmdType
`plusDmdType` DmdEnv -> PlusDmdArg
mkPlusDmdArg DmdEnv
lazy_fvs
setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]
setBndrsDemandInfo :: [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo (CoreBndr
b:[CoreBndr]
bs) (Demand
d:[Demand]
ds)
| CoreBndr -> Bool
isTyVar CoreBndr
b = CoreBndr
b CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bs (Demand
dDemand -> [Demand] -> [Demand]
forall a. a -> [a] -> [a]
:[Demand]
ds)
| Bool
otherwise = CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
b Demand
d CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bs [Demand]
ds
setBndrsDemandInfo [] [Demand]
ds = ASSERT( null ds ) []
setBndrsDemandInfo [CoreBndr]
bs [Demand]
_ = String -> SDoc -> [CoreBndr]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setBndrsDemandInfo" ([CoreBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreBndr]
bs)
annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
annotateBndr :: AnalEnv -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateBndr AnalEnv
env DmdType
dmd_ty CoreBndr
var
| CoreBndr -> Bool
isId CoreBndr
var = (DmdType
dmd_ty', CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
var Demand
dmd)
| Bool
otherwise = (DmdType
dmd_ty, CoreBndr
var)
where
(DmdType
dmd_ty', Demand
dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
False DmdType
dmd_ty CoreBndr
var
annotateLamIdBndr :: AnalEnv
-> DFunFlag
-> DmdType
-> Id
-> (DmdType,
Id)
annotateLamIdBndr :: AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateLamIdBndr AnalEnv
env Bool
arg_of_dfun DmdType
dmd_ty CoreBndr
id
= ASSERT( isId id )
(DmdType
final_ty, CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
id Demand
dmd)
where
final_ty :: DmdType
final_ty = case Unfolding -> Maybe (Expr CoreBndr)
maybeUnfoldingTemplate (CoreBndr -> Unfolding
idUnfolding CoreBndr
id) of
Maybe (Expr CoreBndr)
Nothing -> DmdType
main_ty
Just Expr CoreBndr
unf -> DmdType
main_ty DmdType -> PlusDmdArg -> DmdType
`plusDmdType` PlusDmdArg
unf_ty
where
(PlusDmdArg
unf_ty, Expr CoreBndr
_) = AnalEnv -> Demand -> Expr CoreBndr -> (PlusDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env Demand
dmd Expr CoreBndr
unf
main_ty :: DmdType
main_ty = Demand -> DmdType -> DmdType
addDemand Demand
dmd DmdType
dmd_ty'
(DmdType
dmd_ty', Demand
dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
arg_of_dfun DmdType
dmd_ty CoreBndr
id
deleteFVs :: DmdType -> [Var] -> DmdType
deleteFVs :: DmdType -> [CoreBndr] -> DmdType
deleteFVs (DmdType DmdEnv
fvs [Demand]
dmds Divergence
res) [CoreBndr]
bndrs
= DmdEnv -> [Demand] -> Divergence -> DmdType
DmdType (DmdEnv -> [CoreBndr] -> DmdEnv
forall a. VarEnv a -> [CoreBndr] -> VarEnv a
delVarEnvList DmdEnv
fvs [CoreBndr]
bndrs) [Demand]
dmds Divergence
res
type DFunFlag = Bool
notArgOfDfun :: DFunFlag
notArgOfDfun :: Bool
notArgOfDfun = Bool
False
data AnalEnv = AE
{ AnalEnv -> Bool
ae_strict_dicts :: !Bool
, AnalEnv -> SigEnv
ae_sigs :: !SigEnv
, AnalEnv -> Bool
ae_virgin :: !Bool
, AnalEnv -> FamInstEnvs
ae_fam_envs :: !FamInstEnvs
}
type SigEnv = VarEnv (StrictSig, TopLevelFlag)
instance Outputable AnalEnv where
ppr :: AnalEnv -> SDoc
ppr AnalEnv
env = String -> SDoc
text String
"AE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"ae_virgin =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AnalEnv -> Bool
ae_virgin AnalEnv
env)
, String -> SDoc
text String
"ae_strict_dicts =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AnalEnv -> Bool
ae_strict_dicts AnalEnv
env)
, String -> SDoc
text String
"ae_sigs =" SDoc -> SDoc -> SDoc
<+> SigEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AnalEnv -> SigEnv
ae_sigs AnalEnv
env)
])
emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv
emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv
emptyAnalEnv DmdAnalOpts
opts FamInstEnvs
fam_envs
= AE :: Bool -> SigEnv -> Bool -> FamInstEnvs -> AnalEnv
AE { ae_strict_dicts :: Bool
ae_strict_dicts = DmdAnalOpts -> Bool
dmd_strict_dicts DmdAnalOpts
opts
, ae_sigs :: SigEnv
ae_sigs = SigEnv
emptySigEnv
, ae_virgin :: Bool
ae_virgin = Bool
True
, ae_fam_envs :: FamInstEnvs
ae_fam_envs = FamInstEnvs
fam_envs
}
emptySigEnv :: SigEnv
emptySigEnv :: SigEnv
emptySigEnv = SigEnv
forall a. VarEnv a
emptyVarEnv
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [CoreBndr] -> AnalEnv
extendAnalEnvs TopLevelFlag
top_lvl AnalEnv
env [CoreBndr]
vars
= AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = TopLevelFlag -> SigEnv -> [CoreBndr] -> SigEnv
extendSigEnvs TopLevelFlag
top_lvl (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) [CoreBndr]
vars }
extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
extendSigEnvs :: TopLevelFlag -> SigEnv -> [CoreBndr] -> SigEnv
extendSigEnvs TopLevelFlag
top_lvl SigEnv
sigs [CoreBndr]
vars
= SigEnv -> [(CoreBndr, (StrictSig, TopLevelFlag))] -> SigEnv
forall a. VarEnv a -> [(CoreBndr, a)] -> VarEnv a
extendVarEnvList SigEnv
sigs [ (CoreBndr
var, (CoreBndr -> StrictSig
idStrictness CoreBndr
var, TopLevelFlag
top_lvl)) | CoreBndr
var <- [CoreBndr]
vars]
extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
extendAnalEnv :: TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
top_lvl AnalEnv
env CoreBndr
var StrictSig
sig
= AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = TopLevelFlag -> SigEnv -> CoreBndr -> StrictSig -> SigEnv
extendSigEnv TopLevelFlag
top_lvl (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) CoreBndr
var StrictSig
sig }
extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
extendSigEnv :: TopLevelFlag -> SigEnv -> CoreBndr -> StrictSig -> SigEnv
extendSigEnv TopLevelFlag
top_lvl SigEnv
sigs CoreBndr
var StrictSig
sig = SigEnv -> CoreBndr -> (StrictSig, TopLevelFlag) -> SigEnv
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv SigEnv
sigs CoreBndr
var (StrictSig
sig, TopLevelFlag
top_lvl)
lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv :: AnalEnv -> CoreBndr -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv AnalEnv
env CoreBndr
id = SigEnv -> CoreBndr -> Maybe (StrictSig, TopLevelFlag)
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) CoreBndr
id
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin AnalEnv
env = AnalEnv
env { ae_virgin :: Bool
ae_virgin = Bool
False }
findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
findBndrsDmds :: AnalEnv -> DmdType -> [CoreBndr] -> (DmdType, [Demand])
findBndrsDmds AnalEnv
env DmdType
dmd_ty [CoreBndr]
bndrs
= DmdType -> [CoreBndr] -> (DmdType, [Demand])
go DmdType
dmd_ty [CoreBndr]
bndrs
where
go :: DmdType -> [CoreBndr] -> (DmdType, [Demand])
go DmdType
dmd_ty [] = (DmdType
dmd_ty, [])
go DmdType
dmd_ty (CoreBndr
b:[CoreBndr]
bs)
| CoreBndr -> Bool
isId CoreBndr
b = let (DmdType
dmd_ty1, [Demand]
dmds) = DmdType -> [CoreBndr] -> (DmdType, [Demand])
go DmdType
dmd_ty [CoreBndr]
bs
(DmdType
dmd_ty2, Demand
dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
False DmdType
dmd_ty1 CoreBndr
b
in (DmdType
dmd_ty2, Demand
dmd Demand -> [Demand] -> [Demand]
forall a. a -> [a] -> [a]
: [Demand]
dmds)
| Bool
otherwise = DmdType -> [CoreBndr] -> (DmdType, [Demand])
go DmdType
dmd_ty [CoreBndr]
bs
findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
findBndrDmd :: AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
arg_of_dfun DmdType
dmd_ty CoreBndr
id
=
(DmdType
dmd_ty', Demand
dmd')
where
dmd' :: Demand
dmd' = Demand -> Demand
strictify (Demand -> Demand) -> Demand -> Demand
forall a b. (a -> b) -> a -> b
$
Demand -> TypeShape -> Demand
trimToType Demand
starting_dmd (FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs Type
id_ty)
(DmdType
dmd_ty', Demand
starting_dmd) = DmdType -> CoreBndr -> (DmdType, Demand)
peelFV DmdType
dmd_ty CoreBndr
id
id_ty :: Type
id_ty = CoreBndr -> Type
idType CoreBndr
id
strictify :: Demand -> Demand
strictify Demand
dmd
| AnalEnv -> Bool
ae_strict_dicts AnalEnv
env
, Bool -> Bool
not Bool
arg_of_dfun
= Type -> Demand -> Demand
strictifyDictDmd Type
id_ty Demand
dmd
| Bool
otherwise
= Demand
dmd
fam_envs :: FamInstEnvs
fam_envs = AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env