{-# LANGUAGE CPP #-}
module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Driver.Session
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Types.Demand
import GHC.Core
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Core.Seq ( seqBinds )
import GHC.Utils.Outputable
import GHC.Types.Var.Env
import GHC.Types.Basic
import Data.List ( mapAccumL )
import GHC.Core.DataCon
import GHC.Types.ForeignCall ( isSafeForeignCall )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.Utils
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion ( Coercion, coVarsOfCo )
import GHC.Core.FamInstEnv
import GHC.Utils.Misc
import GHC.Data.Maybe ( isJust )
import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) )
import GHC.Types.Unique.Set
dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram DynFlags
dflags FamInstEnvs
fam_envs CoreProgram
binds = do
let env :: AnalEnv
env = DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv DynFlags
dflags FamInstEnvs
fam_envs
let 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
DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_str_signatures String
"Strictness signatures" DumpFormat
FormatText (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
(IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram (StrictSig -> SDoc
pprIfaceStrictSig (StrictSig -> SDoc) -> (IdInfo -> StrictSig) -> IdInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> StrictSig
strictnessInfo) CoreProgram
binds_plus_dmds
CoreProgram -> ()
seqBinds CoreProgram
binds_plus_dmds () -> IO CoreProgram -> IO CoreProgram
`seq` CoreProgram -> IO CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_plus_dmds
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
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, StrictSig, Expr CoreBndr)
dmdAnalRhsLetDown Maybe [CoreBndr]
forall a. Maybe a
Nothing AnalEnv
env CleanDemand
cleanEvalDmd 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
-> CleanDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix TopLevelFlag
TopLevel AnalEnv
env CleanDemand
cleanEvalDmd [(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
forall s u. JointDmd s (Use u) -> JointDmd s (Use u)
oneifyDmd
dmdAnalStar :: AnalEnv
-> Demand
-> CoreExpr
-> (BothDmdArg, CoreExpr)
dmdAnalStar :: AnalEnv -> Demand -> Expr CoreBndr -> (BothDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env Demand
dmd Expr CoreBndr
e
| (DmdShell
dmd_shell, CleanDemand
cd) <- Demand -> (DmdShell, CleanDemand)
toCleanDmd Demand
dmd
, (DmdType
dmd_ty, Expr CoreBndr
e') <- AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
cd Expr CoreBndr
e
= ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
(DmdShell -> DmdType -> BothDmdArg
postProcessDmdType DmdShell
dmd_shell DmdType
dmd_ty, Expr CoreBndr
e')
dmdAnal, dmdAnal' :: AnalEnv
-> CleanDemand
-> CoreExpr -> (DmdType, CoreExpr)
dmdAnal :: AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
d Expr CoreBndr
e =
AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal' AnalEnv
env CleanDemand
d Expr CoreBndr
e
dmdAnal' :: AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal' AnalEnv
_ CleanDemand
_ (Lit Literal
lit) = (DmdType
nopDmdType, Literal -> Expr CoreBndr
forall b. Literal -> Expr b
Lit Literal
lit)
dmdAnal' AnalEnv
_ CleanDemand
_ (Type Type
ty) = (DmdType
nopDmdType, Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
ty)
dmdAnal' AnalEnv
_ CleanDemand
_ (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 CleanDemand
dmd (Var CoreBndr
var)
= (AnalEnv -> CoreBndr -> CleanDemand -> DmdType
dmdTransform AnalEnv
env CoreBndr
var CleanDemand
dmd, CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
var)
dmdAnal' AnalEnv
env CleanDemand
dmd (Cast Expr CoreBndr
e Coercion
co)
= (DmdType
dmd_ty DmdType -> BothDmdArg -> DmdType
`bothDmdType` DmdEnv -> BothDmdArg
mkBothDmdArg (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 -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
e
dmdAnal' AnalEnv
env CleanDemand
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 -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
e
dmdAnal' AnalEnv
env CleanDemand
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 -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
fun
dmdAnal' AnalEnv
env CleanDemand
dmd (App Expr CoreBndr
fun Expr CoreBndr
arg)
=
let
call_dmd :: CleanDemand
call_dmd = CleanDemand -> CleanDemand
mkCallDmd CleanDemand
dmd
(DmdType
fun_ty, Expr CoreBndr
fun') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
call_dmd Expr CoreBndr
fun
(Demand
arg_dmd, DmdType
res_ty) = DmdType -> (Demand, DmdType)
splitDmdTy DmdType
fun_ty
(BothDmdArg
arg_ty, Expr CoreBndr
arg') = AnalEnv -> Demand -> Expr CoreBndr -> (BothDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env (Expr CoreBndr -> Demand -> Demand
dmdTransformThunkDmd Expr CoreBndr
arg Demand
arg_dmd) Expr CoreBndr
arg
in
(DmdType
res_ty DmdType -> BothDmdArg -> DmdType
`bothDmdType` BothDmdArg
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 CleanDemand
dmd (Lam CoreBndr
var Expr CoreBndr
body)
| CoreBndr -> Bool
isTyVar CoreBndr
var
= let
(DmdType
body_ty, Expr CoreBndr
body') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
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 (CleanDemand
body_dmd, DmdShell
defer_and_use) = CleanDemand -> (CleanDemand, DmdShell)
peelCallDmd CleanDemand
dmd
(DmdType
body_ty, Expr CoreBndr
body') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
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
(DmdShell -> DmdType -> DmdType
postProcessUnsat DmdShell
defer_and_use DmdType
lam_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var' Expr CoreBndr
body')
dmdAnal' AnalEnv
env CleanDemand
dmd (Case Expr CoreBndr
scrut CoreBndr
case_bndr Type
ty [(DataAlt DataCon
dc, [CoreBndr]
bndrs, Expr CoreBndr
rhs)])
| let tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
dc
, Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (TyCon -> Maybe DataCon
isDataProductTyCon_maybe TyCon
tycon)
= let
(DmdType
rhs_ty, Expr CoreBndr
rhs') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
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
id_dmds :: [Demand]
id_dmds = Demand -> [Demand] -> [Demand]
addCaseBndrDmd Demand
case_bndr_dmd [Demand]
dmds
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
scrut_dmd :: CleanDemand
scrut_dmd = [Demand] -> CleanDemand
mkProdDmd [Demand]
id_dmds
(DmdType
scrut_ty, Expr CoreBndr
scrut') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
scrut_dmd Expr CoreBndr
scrut
res_ty :: DmdType
res_ty = DmdType
alt_ty3 DmdType -> BothDmdArg -> DmdType
`bothDmdType` DmdType -> BothDmdArg
toBothDmdArg DmdType
scrut_ty
case_bndr' :: CoreBndr
case_bndr' = CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
case_bndr Demand
case_bndr_dmd
bndrs' :: [CoreBndr]
bndrs' = [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bndrs [Demand]
id_dmds
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 [(DataCon -> AltCon
DataAlt DataCon
dc, [CoreBndr]
bndrs', Expr CoreBndr
rhs')])
dmdAnal' AnalEnv
env CleanDemand
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
-> CleanDemand
-> CoreBndr
-> Alt CoreBndr
-> (DmdType, Alt CoreBndr)
dmdAnalAlt AnalEnv
env CleanDemand
dmd CoreBndr
case_bndr) [Alt CoreBndr]
alts
(DmdType
scrut_ty, Expr CoreBndr
scrut') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
cleanEvalDmd 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 -> BothDmdArg -> DmdType
`bothDmdType` DmdType -> BothDmdArg
toBothDmdArg 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 CleanDemand
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 -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
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
(BothDmdArg
rhs_ty, Expr CoreBndr
rhs') = AnalEnv -> Demand -> Expr CoreBndr -> (BothDmdArg, 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 -> BothDmdArg -> DmdType
`bothDmdType` BothDmdArg
rhs_ty
dmdAnal' AnalEnv
env CleanDemand
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
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, StrictSig, Expr CoreBndr)
dmdAnalRhsLetDown Maybe [CoreBndr]
forall a. Maybe a
Nothing AnalEnv
env CleanDemand
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 -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env1 CleanDemand
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 CleanDemand
dmd (Let (Rec [(CoreBndr, Expr CoreBndr)]
pairs) Expr CoreBndr
body)
= let
(AnalEnv
env', DmdEnv
lazy_fv, [(CoreBndr, Expr CoreBndr)]
pairs') = TopLevelFlag
-> AnalEnv
-> CleanDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix TopLevelFlag
NotTopLevel AnalEnv
env CleanDemand
dmd [(CoreBndr, Expr CoreBndr)]
pairs
(DmdType
body_ty, Expr CoreBndr
body') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env' CleanDemand
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
isUnboxedTupleCon 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
dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)
dmdAnalAlt :: AnalEnv
-> CleanDemand
-> CoreBndr
-> Alt CoreBndr
-> (DmdType, Alt CoreBndr)
dmdAnalAlt AnalEnv
env CleanDemand
dmd CoreBndr
case_bndr (AltCon
con,[CoreBndr]
bndrs,Expr CoreBndr
rhs)
| [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
bndrs
, (DmdType
rhs_ty, Expr CoreBndr
rhs') <- AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
rhs
= (DmdType
rhs_ty, (AltCon
con, [], Expr CoreBndr
rhs'))
| Bool
otherwise
, (DmdType
rhs_ty, Expr CoreBndr
rhs') <- AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
rhs
, (DmdType
alt_ty, [Demand]
dmds) <- AnalEnv -> DmdType -> [CoreBndr] -> (DmdType, [Demand])
findBndrsDmds AnalEnv
env DmdType
rhs_ty [CoreBndr]
bndrs
, let case_bndr_dmd :: Demand
case_bndr_dmd = DmdType -> CoreBndr -> Demand
findIdDemand DmdType
alt_ty CoreBndr
case_bndr
id_dmds :: [Demand]
id_dmds = Demand -> [Demand] -> [Demand]
addCaseBndrDmd Demand
case_bndr_dmd [Demand]
dmds
= (DmdType
alt_ty, (AltCon
con, [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bndrs [Demand]
id_dmds, Expr CoreBndr
rhs'))
dmdTransform :: AnalEnv
-> Id
-> CleanDemand
-> DmdType
dmdTransform :: AnalEnv -> CoreBndr -> CleanDemand -> DmdType
dmdTransform AnalEnv
env CoreBndr
var CleanDemand
dmd
| CoreBndr -> Bool
isDataConWorkId CoreBndr
var
= Int -> CleanDemand -> DmdType
dmdTransformDataConSig (CoreBndr -> Int
idArity CoreBndr
var) CleanDemand
dmd
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DmdTxDictSel (AnalEnv -> DynFlags
ae_dflags AnalEnv
env),
Just Class
_ <- CoreBndr -> Maybe Class
isClassOpId_maybe CoreBndr
var
= StrictSig -> CleanDemand -> DmdType
dmdTransformDictSelSig (CoreBndr -> StrictSig
idStrictness CoreBndr
var) CleanDemand
dmd
| CoreBndr -> Bool
isGlobalId CoreBndr
var
, let res :: DmdType
res = StrictSig -> CleanDemand -> DmdType
dmdTransformSig (CoreBndr -> StrictSig
idStrictness CoreBndr
var) CleanDemand
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 -> CleanDemand -> DmdType
dmdTransformSig StrictSig
sig CleanDemand
dmd
=
if TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
then DmdType
fn_ty
else DmdType -> CoreBndr -> Demand -> DmdType
addVarDmd DmdType
fn_ty CoreBndr
var (CleanDemand -> Demand
mkOnceUsedDmd CleanDemand
dmd)
| Bool
otherwise
=
DmdEnv -> DmdType
unitDmdType (CoreBndr -> Demand -> DmdEnv
forall a. CoreBndr -> a -> VarEnv a
unitVarEnv CoreBndr
var (CleanDemand -> Demand
mkOnceUsedDmd CleanDemand
dmd))
dmdAnalRhsLetDown
:: Maybe [Id]
-> AnalEnv -> CleanDemand
-> Id -> CoreExpr
-> (DmdEnv, StrictSig, CoreExpr)
dmdAnalRhsLetDown :: Maybe [CoreBndr]
-> AnalEnv
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, StrictSig, Expr CoreBndr)
dmdAnalRhsLetDown Maybe [CoreBndr]
rec_flag AnalEnv
env CleanDemand
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 :: CleanDemand
rhs_dmd
| CoreBndr -> Bool
isJoinId CoreBndr
id
= Int -> CleanDemand -> CleanDemand
mkCallDmds Int
rhs_arity CleanDemand
let_dmd
| Bool
otherwise
= AnalEnv -> Int -> Expr CoreBndr -> CleanDemand
mkRhsDmd AnalEnv
env Int
rhs_arity Expr CoreBndr
rhs
(DmdType DmdEnv
rhs_fv [Demand]
rhs_dmds Divergence
rhs_div, Expr CoreBndr
rhs') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
rhs_dmd Expr CoreBndr
rhs
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
(DmdEnv
lazy_fv, DmdEnv
sig_fv) = Bool -> DmdEnv -> (DmdEnv, DmdEnv)
splitFVs Bool
is_thunk DmdEnv
rhs_fv1
is_thunk :: Bool
is_thunk = Bool -> Bool
not (Expr CoreBndr -> Bool
exprIsHNF Expr CoreBndr
rhs) Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreBndr -> Bool
isJoinId CoreBndr
id)
mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand
mkRhsDmd :: AnalEnv -> Int -> Expr CoreBndr -> CleanDemand
mkRhsDmd AnalEnv
_env Int
rhs_arity Expr CoreBndr
_rhs = Int -> CleanDemand -> CleanDemand
mkCallDmds Int
rhs_arity CleanDemand
cleanEvalDmd
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
-> CleanDemand
-> [(Id,CoreExpr)]
-> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
dmdFix :: TopLevelFlag
-> AnalEnv
-> CleanDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix TopLevelFlag
top_lvl AnalEnv
env CleanDemand
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
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, StrictSig, Expr CoreBndr)
dmdAnalRhsLetDown ([CoreBndr] -> Maybe [CoreBndr]
forall a. a -> Maybe a
Just [CoreBndr]
bndrs) AnalEnv
env CleanDemand
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
bothDmd 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) (UniqSet CoreBndr -> VarEnv CoreBndr
forall a. UniqSet a -> UniqFM a a
getUniqSet (UniqSet CoreBndr -> VarEnv CoreBndr)
-> UniqSet CoreBndr -> VarEnv CoreBndr
forall a b. (a -> b) -> a -> b
$ Coercion -> UniqSet CoreBndr
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
bothDmd 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 -> BothDmdArg -> DmdType
`bothDmdType` DmdEnv -> BothDmdArg
mkBothDmdArg 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 -> BothDmdArg -> DmdType
`bothDmdType` BothDmdArg
unf_ty
where
(BothDmdArg
unf_ty, Expr CoreBndr
_) = AnalEnv -> Demand -> Expr CoreBndr -> (BothDmdArg, 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 -> DynFlags
ae_dflags :: DynFlags
, 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 (AE { ae_sigs :: AnalEnv -> SigEnv
ae_sigs = SigEnv
env, ae_virgin :: AnalEnv -> Bool
ae_virgin = Bool
virgin })
= 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 Bool
virgin
, String -> SDoc
text String
"ae_sigs =" SDoc -> SDoc -> SDoc
<+> SigEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr SigEnv
env ])
emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv DynFlags
dflags FamInstEnvs
fam_envs
= AE :: DynFlags -> SigEnv -> Bool -> FamInstEnvs -> AnalEnv
AE { ae_dflags :: DynFlags
ae_dflags = DynFlags
dflags
, 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
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DictsStrict (AnalEnv -> DynFlags
ae_dflags 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