{-# LANGUAGE CPP #-}
module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Session
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Core
import GHC.Core.Seq
import GHC.Utils.Outputable
import GHC.Builtin.Names ( runRWKey )
import GHC.Types.Var.Env
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.DataCon
import GHC.Core.Multiplicity
import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram )
import GHC.Core.Type
import GHC.Core.FamInstEnv
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) )
import GHC.Data.Graph.UnVar
import GHC.Data.Maybe ( isNothing )
import Control.Monad ( guard )
import Data.List ( mapAccumL )
import GHC.Driver.Ppr
String -> SDoc -> Any -> Any
_ = String -> SDoc -> Any -> Any
forall a. String -> SDoc -> a -> a
pprTrace
cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
cprAnalProgram Logger
logger DynFlags
dflags FamInstEnvs
fam_envs CoreProgram
binds = do
let env :: AnalEnv
env = FamInstEnvs -> AnalEnv
emptyAnalEnv FamInstEnvs
fam_envs
let binds_plus_cpr :: CoreProgram
binds_plus_cpr = (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 :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
cprAnalTopBind AnalEnv
env CoreProgram
binds
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cpr_signatures String
"Cpr signatures" DumpFormat
FormatText (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
(IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram (CprSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CprSig -> SDoc) -> (IdInfo -> CprSig) -> IdInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> CprSig
cprInfo) CoreProgram
binds_plus_cpr
CoreProgram -> ()
seqBinds CoreProgram
binds_plus_cpr () -> IO CoreProgram -> IO CoreProgram
`seq` CoreProgram -> IO CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_plus_cpr
cprAnalTopBind :: AnalEnv
-> CoreBind
-> (AnalEnv, CoreBind)
cprAnalTopBind :: AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
cprAnalTopBind AnalEnv
env (NonRec CoreBndr
id Expr CoreBndr
rhs)
= (AnalEnv
env', CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
id' Expr CoreBndr
rhs')
where
(CoreBndr
id', Expr CoreBndr
rhs', AnalEnv
env') = TopLevelFlag
-> AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> (CoreBndr, Expr CoreBndr, AnalEnv)
cprAnalBind TopLevelFlag
TopLevel AnalEnv
env CoreBndr
id Expr CoreBndr
rhs
cprAnalTopBind 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', [(CoreBndr, Expr CoreBndr)]
pairs') = TopLevelFlag
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
cprFix TopLevelFlag
TopLevel AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs
cprAnal, cprAnal'
:: AnalEnv
-> CoreExpr
-> (CprType, CoreExpr)
cprAnal :: AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
e =
AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal' AnalEnv
env Expr CoreBndr
e
cprAnal' :: AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal' AnalEnv
_ (Lit Literal
lit) = (CprType
topCprType, Literal -> Expr CoreBndr
forall b. Literal -> Expr b
Lit Literal
lit)
cprAnal' AnalEnv
_ (Type Type
ty) = (CprType
topCprType, Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
ty)
cprAnal' AnalEnv
_ (Coercion Coercion
co) = (CprType
topCprType, Coercion -> Expr CoreBndr
forall b. Coercion -> Expr b
Coercion Coercion
co)
cprAnal' AnalEnv
env (Cast Expr CoreBndr
e Coercion
co)
= (CprType
cpr_ty, Expr CoreBndr -> Coercion -> Expr CoreBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr CoreBndr
e' Coercion
co)
where
(CprType
cpr_ty, Expr CoreBndr
e') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
e
cprAnal' AnalEnv
env (Tick CoreTickish
t Expr CoreBndr
e)
= (CprType
cpr_ty, CoreTickish -> Expr CoreBndr -> Expr CoreBndr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t Expr CoreBndr
e')
where
(CprType
cpr_ty, Expr CoreBndr
e') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
e
cprAnal' AnalEnv
env e :: Expr CoreBndr
e@(Var{})
= AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
e [] []
cprAnal' AnalEnv
env e :: Expr CoreBndr
e@(App{})
= AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
e [] []
cprAnal' AnalEnv
env (Lam CoreBndr
var Expr CoreBndr
body)
| CoreBndr -> Bool
isTyVar CoreBndr
var
, (CprType
body_ty, Expr CoreBndr
body') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
body
= (CprType
body_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var Expr CoreBndr
body')
| Bool
otherwise
= (CprType
lam_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var Expr CoreBndr
body')
where
env' :: AnalEnv
env' = AnalEnv -> CoreBndr -> AnalEnv
extendSigEnvForArg AnalEnv
env CoreBndr
var
(CprType
body_ty, Expr CoreBndr
body') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env' Expr CoreBndr
body
lam_ty :: CprType
lam_ty = CprType -> CprType
abstractCprTy CprType
body_ty
cprAnal' AnalEnv
env (Case Expr CoreBndr
scrut CoreBndr
case_bndr Type
ty [Alt CoreBndr]
alts)
= (CprType
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')
where
(CprType
scrut_ty, Expr CoreBndr
scrut') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
scrut
env' :: AnalEnv
env' = AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
case_bndr (CprType -> CprSig
CprSig CprType
scrut_ty)
([CprType]
alt_tys, [Alt CoreBndr]
alts') = (Alt CoreBndr -> (CprType, Alt CoreBndr))
-> [Alt CoreBndr] -> ([CprType], [Alt CoreBndr])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (AnalEnv -> CprType -> Alt CoreBndr -> (CprType, Alt CoreBndr)
cprAnalAlt AnalEnv
env' CprType
scrut_ty) [Alt CoreBndr]
alts
res_ty :: CprType
res_ty = (CprType -> CprType -> CprType) -> CprType -> [CprType] -> CprType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CprType -> CprType -> CprType
lubCprType CprType
botCprType [CprType]
alt_tys
cprAnal' AnalEnv
env (Let (NonRec CoreBndr
id Expr CoreBndr
rhs) Expr CoreBndr
body)
= (CprType
body_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
(CoreBndr
id', Expr CoreBndr
rhs', AnalEnv
env') = TopLevelFlag
-> AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> (CoreBndr, Expr CoreBndr, AnalEnv)
cprAnalBind TopLevelFlag
NotTopLevel AnalEnv
env CoreBndr
id Expr CoreBndr
rhs
(CprType
body_ty, Expr CoreBndr
body') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env' Expr CoreBndr
body
cprAnal' AnalEnv
env (Let (Rec [(CoreBndr, Expr CoreBndr)]
pairs) Expr CoreBndr
body)
= CprType
body_ty CprType -> (CprType, Expr CoreBndr) -> (CprType, Expr CoreBndr)
`seq` (CprType
body_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
Rec [(CoreBndr, Expr CoreBndr)]
pairs') Expr CoreBndr
body')
where
(AnalEnv
env', [(CoreBndr, Expr CoreBndr)]
pairs') = TopLevelFlag
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
cprFix TopLevelFlag
NotTopLevel AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs
(CprType
body_ty, Expr CoreBndr
body') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env' Expr CoreBndr
body
cprAnalAlt
:: AnalEnv
-> CprType
-> Alt Var
-> (CprType, Alt Var)
cprAnalAlt :: AnalEnv -> CprType -> Alt CoreBndr -> (CprType, Alt CoreBndr)
cprAnalAlt AnalEnv
env CprType
scrut_ty (Alt AltCon
con [CoreBndr]
bndrs Expr CoreBndr
rhs)
= (CprType
rhs_ty, AltCon -> [CoreBndr] -> Expr CoreBndr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
bndrs Expr CoreBndr
rhs')
where
env_alt :: AnalEnv
env_alt
| DataAlt DataCon
dc <- AltCon
con
, let ids :: [CoreBndr]
ids = (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreBndr -> Bool
isId [CoreBndr]
bndrs
, CprType Arity
arity Cpr
cpr <- CprType
scrut_ty
, ASSERT( arity == 0 ) True
= case DataCon -> Cpr -> UnpackConFieldsResult
unpackConFieldsCpr DataCon
dc Cpr
cpr of
AllFieldsSame Cpr
field_cpr
| let sig :: CprSig
sig = Arity -> Cpr -> CprSig
mkCprSig Arity
0 Cpr
field_cpr
-> AnalEnv -> [CoreBndr] -> CprSig -> AnalEnv
extendSigEnvAllSame AnalEnv
env [CoreBndr]
ids CprSig
sig
ForeachField [Cpr]
field_cprs
| let sigs :: [CprSig]
sigs = (CoreBndr -> Cpr -> CprSig) -> [CoreBndr] -> [Cpr] -> [CprSig]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Arity -> Cpr -> CprSig
mkCprSig (Arity -> Cpr -> CprSig)
-> (CoreBndr -> Arity) -> CoreBndr -> Cpr -> CprSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Arity
idArity) [CoreBndr]
ids [Cpr]
field_cprs
-> AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
extendSigEnvList AnalEnv
env (String -> [CoreBndr] -> [CprSig] -> [(CoreBndr, CprSig)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"cprAnalAlt" [CoreBndr]
ids [CprSig]
sigs)
| Bool
otherwise
= AnalEnv
env
(CprType
rhs_ty, Expr CoreBndr
rhs') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env_alt Expr CoreBndr
rhs
cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr)
cprAnalApp :: AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
e [Expr CoreBndr]
args' [CprType]
arg_tys
| App Expr CoreBndr
fn Expr CoreBndr
arg <- Expr CoreBndr
e, Expr CoreBndr -> Bool
forall b. Expr b -> Bool
isTypeArg Expr CoreBndr
arg
= AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
fn (Expr CoreBndr
argExpr CoreBndr -> [Expr CoreBndr] -> [Expr CoreBndr]
forall a. a -> [a] -> [a]
:[Expr CoreBndr]
args') [CprType]
arg_tys
| App Expr CoreBndr
fn Expr CoreBndr
arg <- Expr CoreBndr
e
, (CprType
arg_ty, Expr CoreBndr
arg') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
arg
= AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
fn (Expr CoreBndr
arg'Expr CoreBndr -> [Expr CoreBndr] -> [Expr CoreBndr]
forall a. a -> [a] -> [a]
:[Expr CoreBndr]
args') (CprType
arg_tyCprType -> [CprType] -> [CprType]
forall a. a -> [a] -> [a]
:[CprType]
arg_tys)
| Var CoreBndr
fn <- Expr CoreBndr
e
= (AnalEnv -> CoreBndr -> [CprType] -> CprType
cprTransform AnalEnv
env CoreBndr
fn [CprType]
arg_tys, Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr CoreBndr
e [Expr CoreBndr]
args')
| Bool
otherwise
, (CprType
e_ty, Expr CoreBndr
e') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
e
= (CprType -> Arity -> CprType
applyCprTy CprType
e_ty ([CprType] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CprType]
arg_tys), Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr CoreBndr
e' [Expr CoreBndr]
args')
cprTransform :: AnalEnv
-> Id
-> [CprType]
-> CprType
cprTransform :: AnalEnv -> CoreBndr -> [CprType] -> CprType
cprTransform AnalEnv
env CoreBndr
id [CprType]
args
=
CprType
sig
where
sig :: CprType
sig
| Just CprSig
sig <- AnalEnv -> CoreBndr -> Maybe CprSig
lookupSigEnv AnalEnv
env CoreBndr
id
= CprType -> Arity -> CprType
applyCprTy (CprSig -> CprType
getCprSig CprSig
sig) ([CprType] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CprType]
args)
| Just CprType
cpr_ty <- CoreBndr -> [CprType] -> Maybe CprType
cprTransformSpecial CoreBndr
id [CprType]
args
= CprType
cpr_ty
| Just Expr CoreBndr
rhs <- CoreBndr -> Maybe (Expr CoreBndr)
cprDataStructureUnfolding_maybe CoreBndr
id
= (CprType, Expr CoreBndr) -> CprType
forall a b. (a, b) -> a
fst ((CprType, Expr CoreBndr) -> CprType)
-> (CprType, Expr CoreBndr) -> CprType
forall a b. (a -> b) -> a -> b
$ AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
rhs
| CoreBndr -> Bool
isGlobalId CoreBndr
id
= CprType -> Arity -> CprType
applyCprTy (CprSig -> CprType
getCprSig (CoreBndr -> CprSig
idCprInfo CoreBndr
id)) ([CprType] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CprType]
args)
| Bool
otherwise
= CprType
topCprType
cprTransformSpecial :: Id -> [CprType] -> Maybe CprType
cprTransformSpecial :: CoreBndr -> [CprType] -> Maybe CprType
cprTransformSpecial CoreBndr
id [CprType]
args
| CoreBndr -> Unique
idUnique CoreBndr
id Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
runRWKey
, [CprType
arg] <- [CprType]
args
= CprType -> Maybe CprType
forall a. a -> Maybe a
Just (CprType -> Maybe CprType) -> CprType -> Maybe CprType
forall a b. (a -> b) -> a -> b
$ CprType -> Arity -> CprType
applyCprTy CprType
arg Arity
1
| Bool
otherwise
= Maybe CprType
forall a. Maybe a
Nothing
cprFix :: TopLevelFlag
-> AnalEnv
-> [(Id,CoreExpr)]
-> (AnalEnv, [(Id,CoreExpr)])
cprFix :: TopLevelFlag
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
cprFix TopLevelFlag
top_lvl AnalEnv
orig_env [(CoreBndr, Expr CoreBndr)]
orig_pairs
= Arity
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
loop Arity
1 AnalEnv
init_env [(CoreBndr, Expr CoreBndr)]
init_pairs
where
init_sig :: CoreBndr -> Expr CoreBndr -> CprSig
init_sig CoreBndr
id Expr CoreBndr
rhs
| CoreBndr -> Expr CoreBndr -> Bool
isDataStructure CoreBndr
id Expr CoreBndr
rhs = CprSig
topCprSig
| Bool
otherwise = Arity -> Cpr -> CprSig
mkCprSig Arity
0 Cpr
botCpr
orig_virgin :: Bool
orig_virgin = AnalEnv -> Bool
ae_virgin AnalEnv
orig_env
init_pairs :: [(CoreBndr, Expr CoreBndr)]
init_pairs | Bool
orig_virgin = [(CoreBndr -> CprSig -> CoreBndr
setIdCprInfo CoreBndr
id (CoreBndr -> Expr CoreBndr -> CprSig
init_sig CoreBndr
id Expr CoreBndr
rhs), Expr CoreBndr
rhs) | (CoreBndr
id, Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
orig_pairs ]
| Bool
otherwise = [(CoreBndr, Expr CoreBndr)]
orig_pairs
init_env :: AnalEnv
init_env = AnalEnv -> [CoreBndr] -> AnalEnv
extendSigEnvFromIds AnalEnv
orig_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)]
init_pairs)
loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
loop :: Arity
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
loop Arity
n AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs
| Bool
found_fixpoint = (AnalEnv
reset_env', [(CoreBndr, Expr CoreBndr)]
pairs')
| Bool
otherwise = Arity
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
loop (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) AnalEnv
env' [(CoreBndr, Expr CoreBndr)]
pairs'
where
(AnalEnv
env', [(CoreBndr, Expr CoreBndr)]
pairs') = AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
step (Bool -> (AnalEnv -> AnalEnv) -> AnalEnv -> AnalEnv
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Arity
nArity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
/=Arity
1) AnalEnv -> AnalEnv
nonVirgin AnalEnv
env) [(CoreBndr, Expr CoreBndr)]
pairs
reset_env' :: AnalEnv
reset_env' = AnalEnv
env'{ ae_virgin :: Bool
ae_virgin = Bool
orig_virgin }
found_fixpoint :: Bool
found_fixpoint = ((CoreBndr, Expr CoreBndr) -> CprSig)
-> [(CoreBndr, Expr CoreBndr)] -> [CprSig]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> CprSig
idCprInfo (CoreBndr -> CprSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> CprSig
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' [CprSig] -> [CprSig] -> Bool
forall a. Eq a => a -> a -> Bool
== ((CoreBndr, Expr CoreBndr) -> CprSig)
-> [(CoreBndr, Expr CoreBndr)] -> [CprSig]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> CprSig
idCprInfo (CoreBndr -> CprSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> CprSig
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
step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)])
step :: AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
step AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs = (AnalEnv
-> (CoreBndr, Expr CoreBndr)
-> (AnalEnv, (CoreBndr, Expr CoreBndr)))
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL AnalEnv
-> (CoreBndr, Expr CoreBndr)
-> (AnalEnv, (CoreBndr, Expr CoreBndr))
go AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs
where
go :: AnalEnv
-> (CoreBndr, Expr CoreBndr)
-> (AnalEnv, (CoreBndr, Expr CoreBndr))
go AnalEnv
env (CoreBndr
id, Expr CoreBndr
rhs) = (AnalEnv
env', (CoreBndr
id', Expr CoreBndr
rhs'))
where
(CoreBndr
id', Expr CoreBndr
rhs', AnalEnv
env') = TopLevelFlag
-> AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> (CoreBndr, Expr CoreBndr, AnalEnv)
cprAnalBind TopLevelFlag
top_lvl AnalEnv
env CoreBndr
id Expr CoreBndr
rhs
cprAnalBind
:: TopLevelFlag
-> AnalEnv
-> Id
-> CoreExpr
-> (Id, CoreExpr, AnalEnv)
cprAnalBind :: TopLevelFlag
-> AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> (CoreBndr, Expr CoreBndr, AnalEnv)
cprAnalBind TopLevelFlag
top_lvl AnalEnv
env CoreBndr
id Expr CoreBndr
rhs
| CoreBndr -> Expr CoreBndr -> Bool
isDataStructure CoreBndr
id Expr CoreBndr
rhs
= (CoreBndr
id, Expr CoreBndr
rhs, AnalEnv
env)
| Bool
otherwise
= (CoreBndr
id', Expr CoreBndr
rhs', AnalEnv
env')
where
(CprType
rhs_ty, Expr CoreBndr
rhs') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
rhs
rhs_ty' :: CprType
rhs_ty'
| Bool
stays_thunk = CprType -> CprType
trimCprTy CprType
rhs_ty
| Bool
returns_sum = CprType -> CprType
trimCprTy CprType
rhs_ty
| Bool
otherwise = CprType
rhs_ty
sig :: CprSig
sig = Arity -> CprType -> CprSig
mkCprSigForArity (CoreBndr -> Arity
idArity CoreBndr
id) CprType
rhs_ty'
id' :: CoreBndr
id' = CoreBndr -> CprSig -> CoreBndr
setIdCprInfo CoreBndr
id CprSig
sig
env' :: AnalEnv
env' = AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id CprSig
sig
stays_thunk :: Bool
stays_thunk = Bool
is_thunk Bool -> Bool -> Bool
&& Bool
not_strict
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)
not_strict :: Bool
not_strict = Bool -> Bool
not (Demand -> Bool
isStrUsedDmd (CoreBndr -> Demand
idDemandInfo CoreBndr
id))
([TyCoBinder]
_, Type
ret_ty) = Type -> ([TyCoBinder], Type)
splitPiTys (CoreBndr -> Type
idType CoreBndr
id)
not_a_prod :: Bool
not_a_prod = Maybe DataConPatContext -> Bool
forall a. Maybe a -> Bool
isNothing (FamInstEnvs -> Type -> Maybe DataConPatContext
splitArgType_maybe (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) Type
ret_ty)
returns_sum :: Bool
returns_sum = Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl) Bool -> Bool -> Bool
&& Bool
not_a_prod
isDataStructure :: Id -> CoreExpr -> Bool
isDataStructure :: CoreBndr -> Expr CoreBndr -> Bool
isDataStructure CoreBndr
id Expr CoreBndr
rhs =
CoreBndr -> Arity
idArity CoreBndr
id Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0 Bool -> Bool -> Bool
&& Expr CoreBndr -> Bool
exprIsHNF Expr CoreBndr
rhs
cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr
cprDataStructureUnfolding_maybe :: CoreBndr -> Maybe (Expr CoreBndr)
cprDataStructureUnfolding_maybe CoreBndr
id = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Activation -> Bool
activeInFinalPhase (CoreBndr -> Activation
idInlineActivation CoreBndr
id))
Expr CoreBndr
unf <- Unfolding -> Maybe (Expr CoreBndr)
expandUnfolding_maybe (CoreBndr -> Unfolding
idUnfolding CoreBndr
id)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (CoreBndr -> Expr CoreBndr -> Bool
isDataStructure CoreBndr
id Expr CoreBndr
unf)
Expr CoreBndr -> Maybe (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
unf
data AnalEnv
= AE
{ AnalEnv -> SigEnv
ae_sigs :: SigEnv
, AnalEnv -> Bool
ae_virgin :: Bool
, AnalEnv -> FamInstEnvs
ae_fam_envs :: FamInstEnvs
}
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 ])
data SigEnv
= SE
{ SigEnv -> UnVarSet
se_tops :: !UnVarSet
, SigEnv -> VarEnv CprSig
se_sigs :: !(VarEnv CprSig)
}
instance Outputable SigEnv where
ppr :: SigEnv -> SDoc
ppr (SE { se_tops :: SigEnv -> UnVarSet
se_tops = UnVarSet
tops, se_sigs :: SigEnv -> VarEnv CprSig
se_sigs = VarEnv CprSig
sigs })
= String -> SDoc
text String
"SE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"se_tops =" SDoc -> SDoc -> SDoc
<+> UnVarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnVarSet
tops
, String -> SDoc
text String
"se_sigs =" SDoc -> SDoc -> SDoc
<+> VarEnv CprSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarEnv CprSig
sigs ])
emptyAnalEnv :: FamInstEnvs -> AnalEnv
emptyAnalEnv :: FamInstEnvs -> AnalEnv
emptyAnalEnv FamInstEnvs
fam_envs
= AE
{ ae_sigs :: SigEnv
ae_sigs = UnVarSet -> VarEnv CprSig -> SigEnv
SE UnVarSet
emptyUnVarSet VarEnv CprSig
forall a. VarEnv a
emptyVarEnv
, ae_virgin :: Bool
ae_virgin = Bool
True
, ae_fam_envs :: FamInstEnvs
ae_fam_envs = FamInstEnvs
fam_envs
}
modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
modifySigEnv SigEnv -> SigEnv
f AnalEnv
env = AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = SigEnv -> SigEnv
f (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) }
lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig
lookupSigEnv :: AnalEnv -> CoreBndr -> Maybe CprSig
lookupSigEnv AE{ae_sigs :: AnalEnv -> SigEnv
ae_sigs = SE UnVarSet
tops VarEnv CprSig
sigs} CoreBndr
id
| CoreBndr
id CoreBndr -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
tops = CprSig -> Maybe CprSig
forall a. a -> Maybe a
Just CprSig
topCprSig
| Bool
otherwise = VarEnv CprSig -> CoreBndr -> Maybe CprSig
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv VarEnv CprSig
sigs CoreBndr
id
extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv
extendSigEnv :: AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id CprSig
sig
| CprSig -> Bool
isTopCprSig CprSig
sig
= (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
modifySigEnv (\SigEnv
se -> SigEnv
se{se_tops :: UnVarSet
se_tops = CoreBndr -> UnVarSet -> UnVarSet
extendUnVarSet CoreBndr
id (SigEnv -> UnVarSet
se_tops SigEnv
se)}) AnalEnv
env
| Bool
otherwise
= (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
modifySigEnv (\SigEnv
se -> SigEnv
se{se_sigs :: VarEnv CprSig
se_sigs = VarEnv CprSig -> CoreBndr -> CprSig -> VarEnv CprSig
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv (SigEnv -> VarEnv CprSig
se_sigs SigEnv
se) CoreBndr
id CprSig
sig}) AnalEnv
env
extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv
extendSigEnvList :: AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
extendSigEnvList AnalEnv
env [(CoreBndr, CprSig)]
ids_cprs
= (AnalEnv -> (CoreBndr, CprSig) -> AnalEnv)
-> AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\AnalEnv
env (CoreBndr
id, CprSig
sig) -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id CprSig
sig) AnalEnv
env [(CoreBndr, CprSig)]
ids_cprs
extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv
extendSigEnvFromIds :: AnalEnv -> [CoreBndr] -> AnalEnv
extendSigEnvFromIds AnalEnv
env [CoreBndr]
ids
= (AnalEnv -> CoreBndr -> AnalEnv)
-> AnalEnv -> [CoreBndr] -> AnalEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\AnalEnv
env CoreBndr
id -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id (CoreBndr -> CprSig
idCprInfo CoreBndr
id)) AnalEnv
env [CoreBndr]
ids
extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv
extendSigEnvAllSame :: AnalEnv -> [CoreBndr] -> CprSig -> AnalEnv
extendSigEnvAllSame AnalEnv
env [CoreBndr]
ids CprSig
sig
= (AnalEnv -> CoreBndr -> AnalEnv)
-> AnalEnv -> [CoreBndr] -> AnalEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\AnalEnv
env CoreBndr
id -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id CprSig
sig) AnalEnv
env [CoreBndr]
ids
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin AnalEnv
env = AnalEnv
env { ae_virgin :: Bool
ae_virgin = Bool
False }
extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv
extendSigEnvForArg :: AnalEnv -> CoreBndr -> AnalEnv
extendSigEnvForArg AnalEnv
env CoreBndr
id
= AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id (CprType -> CprSig
CprSig (AnalEnv -> Type -> Demand -> CprType
argCprType AnalEnv
env (CoreBndr -> Type
idType CoreBndr
id) (CoreBndr -> Demand
idDemandInfo CoreBndr
id)))
argCprType :: AnalEnv -> Type -> Demand -> CprType
argCprType :: AnalEnv -> Type -> Demand -> CprType
argCprType AnalEnv
env Type
arg_ty Demand
dmd = Arity -> Cpr -> CprType
CprType Arity
0 (Type -> Demand -> Cpr
go Type
arg_ty Demand
dmd)
where
go :: Type -> Demand -> Cpr
go Type
ty Demand
dmd
| Unbox (DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: DataConPatContext -> [Type]
dcpc_tc_args = [Type]
tc_args }) [Demand]
ds
<- FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand
wantToUnbox (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) Bool
no_inlineable_prag Type
ty Demand
dmd
, [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [CoreBndr]
dataConExTyCoVars DataCon
dc)
, let arg_tys :: [Type]
arg_tys = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
dc [Type]
tc_args)
= Arity -> [Cpr] -> Cpr
ConCpr (DataCon -> Arity
dataConTag DataCon
dc) ((Type -> Demand -> Cpr) -> [Type] -> [Demand] -> [Cpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Demand -> Cpr
go [Type]
arg_tys [Demand]
ds)
| Bool
otherwise
= Cpr
topCpr
no_inlineable_prag :: Bool
no_inlineable_prag = Bool
False