{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module GHC.Stg.InferTags.Types
( module GHC.Stg.InferTags.Types
, module TagSig)
where
import GHC.Prelude
import GHC.Core.DataCon
import GHC.Core.Type (isUnliftedType)
import GHC.Types.Id
import GHC.Stg.Syntax
import GHC.Stg.InferTags.TagSig as TagSig
import GHC.Types.Var.Env
import GHC.Utils.Outputable
import GHC.Utils.Misc( zipWithEqual )
import GHC.Utils.Panic
import GHC.StgToCmm.Types
type instance BinderP 'InferTaggedBinders = (Id, TagSig)
type instance XLet 'InferTaggedBinders = XLet 'CodeGen
type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen
type instance XRhsClosure 'InferTaggedBinders = XRhsClosure 'CodeGen
type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders
type InferStgBinding = GenStgBinding 'InferTaggedBinders
type InferStgExpr = GenStgExpr 'InferTaggedBinders
type InferStgRhs = GenStgRhs 'InferTaggedBinders
type InferStgAlt = GenStgAlt 'InferTaggedBinders
combineAltInfo :: TagInfo -> TagInfo -> TagInfo
combineAltInfo :: TagInfo -> TagInfo -> TagInfo
combineAltInfo TagInfo
TagDunno TagInfo
_ = TagInfo
TagDunno
combineAltInfo TagInfo
_ TagInfo
TagDunno = TagInfo
TagDunno
combineAltInfo (TagTuple {}) TagInfo
TagProper = String -> TagInfo
forall a. String -> a
panic String
"Combining unboxed tuple with non-tuple result"
combineAltInfo TagInfo
TagProper (TagTuple {}) = String -> TagInfo
forall a. String -> a
panic String
"Combining unboxed tuple with non-tuple result"
combineAltInfo TagInfo
TagProper TagInfo
TagProper = TagInfo
TagProper
combineAltInfo (TagTuple [TagInfo]
is1) (TagTuple [TagInfo]
is2) = [TagInfo] -> TagInfo
TagTuple (String
-> (TagInfo -> TagInfo -> TagInfo)
-> [TagInfo]
-> [TagInfo]
-> [TagInfo]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"combineAltInfo" TagInfo -> TagInfo -> TagInfo
combineAltInfo [TagInfo]
is1 [TagInfo]
is2)
combineAltInfo (TagInfo
TagTagged) TagInfo
ti = TagInfo
ti
combineAltInfo TagInfo
ti TagInfo
TagTagged = TagInfo
ti
type TagSigEnv = IdEnv TagSig
data TagEnv p = TE { forall (p :: StgPass). TagEnv p -> TagSigEnv
te_env :: TagSigEnv
, forall (p :: StgPass). TagEnv p -> BinderP p -> Id
te_get :: BinderP p -> Id
}
instance Outputable (TagEnv p) where
ppr :: TagEnv p -> SDoc
ppr TagEnv p
te = TagSigEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TagEnv p -> TagSigEnv
forall (p :: StgPass). TagEnv p -> TagSigEnv
te_env TagEnv p
te)
getBinderId :: TagEnv p -> BinderP p -> Id
getBinderId :: forall (p :: StgPass). TagEnv p -> BinderP p -> Id
getBinderId = TagEnv p -> BinderP p -> Id
forall (p :: StgPass). TagEnv p -> BinderP p -> Id
te_get
initEnv :: TagEnv 'CodeGen
initEnv :: TagEnv 'CodeGen
initEnv = TE { te_env :: TagSigEnv
te_env = TagSigEnv
forall a. VarEnv a
emptyVarEnv
, te_get :: BinderP 'CodeGen -> Id
te_get = \BinderP 'CodeGen
x -> Id
BinderP 'CodeGen
x}
makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders
makeTagged :: forall (p :: StgPass). TagEnv p -> TagEnv 'InferTaggedBinders
makeTagged TagEnv p
env = TE { te_env :: TagSigEnv
te_env = TagEnv p -> TagSigEnv
forall (p :: StgPass). TagEnv p -> TagSigEnv
te_env TagEnv p
env
, te_get :: BinderP 'InferTaggedBinders -> Id
te_get = (Id, TagSig) -> Id
BinderP 'InferTaggedBinders -> Id
forall a b. (a, b) -> a
fst }
noSig :: TagEnv p -> BinderP p -> (Id, TagSig)
noSig :: forall (p :: StgPass). TagEnv p -> BinderP p -> (Id, TagSig)
noSig TagEnv p
env BinderP p
bndr
| (() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
var) = (Id
var, TagInfo -> TagSig
TagSig TagInfo
TagProper)
| Bool
otherwise = (Id
var, TagInfo -> TagSig
TagSig TagInfo
TagDunno)
where
var :: Id
var = TagEnv p -> BinderP p -> Id
forall (p :: StgPass). TagEnv p -> BinderP p -> Id
getBinderId TagEnv p
env BinderP p
bndr
lookupSig :: TagEnv p -> Id -> Maybe TagSig
lookupSig :: forall (p :: StgPass). TagEnv p -> Id -> Maybe TagSig
lookupSig TagEnv p
env Id
fun = TagSigEnv -> Id -> Maybe TagSig
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (TagEnv p -> TagSigEnv
forall (p :: StgPass). TagEnv p -> TagSigEnv
te_env TagEnv p
env) Id
fun
lookupInfo :: TagEnv p -> StgArg -> TagInfo
lookupInfo :: forall (p :: StgPass). TagEnv p -> StgArg -> TagInfo
lookupInfo TagEnv p
env (StgVarArg Id
var)
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
var
, DataCon -> Bool
isNullaryRepDataCon DataCon
dc
= TagInfo
TagProper
| (() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
var)
= TagInfo
TagProper
| Just (TagSig TagInfo
info) <- TagSigEnv -> Id -> Maybe TagSig
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (TagEnv p -> TagSigEnv
forall (p :: StgPass). TagEnv p -> TagSigEnv
te_env TagEnv p
env) Id
var
= TagInfo
info
| Just LambdaFormInfo
lf_info <- Id -> Maybe LambdaFormInfo
idLFInfo_maybe Id
var
= case LambdaFormInfo
lf_info of
LFReEntrant {}
-> TagInfo
TagProper
LFThunk {}
-> TagInfo
TagDunno
LFCon {}
-> TagInfo
TagProper
LFUnknown {}
-> TagInfo
TagDunno
LFUnlifted {}
-> TagInfo
TagProper
LFLetNoEscape {} -> String -> TagInfo
forall a. String -> a
panic String
"LFLetNoEscape exported"
| Bool
otherwise
= TagInfo
TagDunno
lookupInfo TagEnv p
_ (StgLitArg {})
= TagInfo
TagProper
isDunnoSig :: TagSig -> Bool
isDunnoSig :: TagSig -> Bool
isDunnoSig (TagSig TagInfo
TagDunno) = Bool
True
isDunnoSig (TagSig TagInfo
TagProper) = Bool
False
isDunnoSig (TagSig TagTuple{}) = Bool
False
isDunnoSig (TagSig TagTagged{}) = Bool
False
isTaggedInfo :: TagInfo -> Bool
isTaggedInfo :: TagInfo -> Bool
isTaggedInfo TagInfo
TagProper = Bool
True
isTaggedInfo TagInfo
TagTagged = Bool
True
isTaggedInfo TagInfo
_ = Bool
False
extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p
extendSigEnv :: forall (p :: StgPass). TagEnv p -> [(Id, TagSig)] -> TagEnv p
extendSigEnv env :: TagEnv p
env@(TE { te_env :: forall (p :: StgPass). TagEnv p -> TagSigEnv
te_env = TagSigEnv
sig_env }) [(Id, TagSig)]
bndrs
= TagEnv p
env { te_env :: TagSigEnv
te_env = TagSigEnv -> [(Id, TagSig)] -> TagSigEnv
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList TagSigEnv
sig_env [(Id, TagSig)]
bndrs }