{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wname-shadowing #-}
module GHC.Stg.EnforceEpt ( enforceEpt ) where
import GHC.Prelude hiding (id)
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Types.Id
import GHC.Types.Id.Info (tagSigInfo)
import GHC.Types.Name
import GHC.Stg.Syntax
import GHC.Types.Basic ( CbvMark (..) )
import GHC.Types.Demand (isDeadEndAppSig)
import GHC.Types.Unique.Supply (mkSplitUniqSupply)
import GHC.Types.RepType (dataConRuntimeRepStrictness)
import GHC.Core (AltCon(..))
import Data.List (mapAccumL)
import GHC.Utils.Outputable
import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )
import GHC.Stg.EnforceEpt.Types
import GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds)
import Data.Maybe
import GHC.Types.Name.Env (mkNameEnv, NameEnv)
import GHC.Driver.DynFlags
import GHC.Utils.Logger
import qualified GHC.Unit.Types
enforceEpt :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)
enforceEpt :: StgPprOpts
-> Bool
-> Logger
-> Module
-> [CgStgTopBinding]
-> IO ([CgStgTopBinding], NameEnv TagSig)
enforceEpt StgPprOpts
ppr_opts !Bool
for_bytecode Logger
logger Module
this_mod [CgStgTopBinding]
stg_binds = do
let (![GenStgTopBinding 'InferTaggedBinders]
stg_binds_w_tags) = {-# SCC "StgEptInfer" #-}
Bool -> [CgStgTopBinding] -> [GenStgTopBinding 'InferTaggedBinders]
inferTags Bool
for_bytecode [CgStgTopBinding]
stg_binds
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_stg_tags String
"CodeGenAnal STG:" DumpFormat
FormatSTG (StgPprOpts -> [GenStgTopBinding 'InferTaggedBinders] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings StgPprOpts
ppr_opts [GenStgTopBinding 'InferTaggedBinders]
stg_binds_w_tags)
let export_tag_info :: NameEnv TagSig
export_tag_info = [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig
collectExportInfo [GenStgTopBinding 'InferTaggedBinders]
stg_binds_w_tags
us_t <- Char -> IO UniqSupply
mkSplitUniqSupply Char
't'
let rewritten_binds = {-# SCC "StgEptRewrite" #-} Module
-> UniqSupply
-> [GenStgTopBinding 'InferTaggedBinders]
-> [CgStgTopBinding]
rewriteTopBinds Module
this_mod UniqSupply
us_t [GenStgTopBinding 'InferTaggedBinders]
stg_binds_w_tags :: [TgStgTopBinding]
return (rewritten_binds,export_tag_info)
type OutputableInferPass p = (Outputable (TagEnv p)
, Outputable (GenStgExpr p)
, Outputable (BinderP p)
, Outputable (GenStgRhs p))
type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders
, XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders
, XRhsClosure i ~ XRhsClosure 'InferTaggedBinders)
inferTags :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]
inferTags :: Bool -> [CgStgTopBinding] -> [GenStgTopBinding 'InferTaggedBinders]
inferTags Bool
for_bytecode [CgStgTopBinding]
binds =
(TagEnv 'CodeGen, [GenStgTopBinding 'InferTaggedBinders])
-> [GenStgTopBinding 'InferTaggedBinders]
forall a b. (a, b) -> b
snd ((TagEnv 'CodeGen
-> CgStgTopBinding
-> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders))
-> TagEnv 'CodeGen
-> [CgStgTopBinding]
-> (TagEnv 'CodeGen, [GenStgTopBinding 'InferTaggedBinders])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL TagEnv 'CodeGen
-> CgStgTopBinding
-> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)
inferTagTopBind (Bool -> TagEnv 'CodeGen
initEnv Bool
for_bytecode) [CgStgTopBinding]
binds)
inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen
-> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)
inferTagTopBind :: TagEnv 'CodeGen
-> CgStgTopBinding
-> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)
inferTagTopBind TagEnv 'CodeGen
env (StgTopStringLit Id
id ByteString
bs)
= (TagEnv 'CodeGen
env, Id -> ByteString -> GenStgTopBinding 'InferTaggedBinders
forall (pass :: StgPass). Id -> ByteString -> GenStgTopBinding pass
StgTopStringLit Id
id ByteString
bs)
inferTagTopBind TagEnv 'CodeGen
env (StgTopLifted GenStgBinding 'CodeGen
bind)
= (TagEnv 'CodeGen
env', GenStgBinding 'InferTaggedBinders
-> GenStgTopBinding 'InferTaggedBinders
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted GenStgBinding 'InferTaggedBinders
bind')
where
(TagEnv 'CodeGen
env', GenStgBinding 'InferTaggedBinders
bind') = TagEnv 'CodeGen
-> GenStgBinding 'CodeGen
-> (TagEnv 'CodeGen, GenStgBinding 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)
inferTagBind TagEnv 'CodeGen
env GenStgBinding 'CodeGen
bind
inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p)
=> TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr :: forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr TagEnv p
env (StgApp Id
fun [StgArg]
args)
=
(TagInfo
info, Id -> [StgArg] -> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
fun [StgArg]
args)
where
!fun_arity :: Arity
fun_arity = Id -> Arity
idArity Id
fun
info :: TagInfo
info
| DmdSig -> Arity -> Bool
isDeadEndAppSig (Id -> DmdSig
idDmdSig Id
fun) ([StgArg] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [StgArg]
args)
= TagInfo
TagTagged
| Arity
fun_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
= TagInfo
TagDunno
| Just (TagSig TagInfo
res_info) <- IdInfo -> Maybe TagSig
tagSigInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
fun)
, Arity
fun_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== [StgArg] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [StgArg]
args
= TagInfo
res_info
| Just (TagSig TagInfo
res_info) <- TagEnv p -> Id -> Maybe TagSig
forall (p :: StgPass). TagEnv p -> Id -> Maybe TagSig
lookupSig TagEnv p
env Id
fun
, Arity
fun_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== [StgArg] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [StgArg]
args
= TagInfo
res_info
| Bool
otherwise
=
TagInfo
TagDunno
inferTagExpr TagEnv p
env (StgConApp DataCon
con ConstructorNumber
cn [StgArg]
args [[PrimRep]]
tys)
= (TagEnv p -> DataCon -> [StgArg] -> TagInfo
forall (p :: StgPass). TagEnv p -> DataCon -> [StgArg] -> TagInfo
inferConTag TagEnv p
env DataCon
con [StgArg]
args, DataCon
-> ConstructorNumber
-> [StgArg]
-> [[PrimRep]]
-> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
StgConApp DataCon
con ConstructorNumber
cn [StgArg]
args [[PrimRep]]
tys)
inferTagExpr TagEnv p
_ (StgLit Literal
l)
= (TagInfo
TagTagged, Literal -> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)
inferTagExpr TagEnv p
env (StgTick StgTickish
tick GenStgExpr p
body)
= (TagInfo
info, StgTickish
-> GenStgExpr 'InferTaggedBinders -> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick GenStgExpr 'InferTaggedBinders
body')
where
(TagInfo
info, GenStgExpr 'InferTaggedBinders
body') = TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr TagEnv p
env GenStgExpr p
body
inferTagExpr TagEnv p
_ (StgOpApp StgOp
op [StgArg]
args Type
ty)
= (TagInfo
TagDunno, StgOp -> [StgArg] -> Type -> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op [StgArg]
args Type
ty)
inferTagExpr TagEnv p
env (StgLet XLet p
ext GenStgBinding p
bind GenStgExpr p
body)
= (TagInfo
info, XLet 'InferTaggedBinders
-> GenStgBinding 'InferTaggedBinders
-> GenStgExpr 'InferTaggedBinders
-> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet p
XLet 'InferTaggedBinders
ext GenStgBinding 'InferTaggedBinders
bind' GenStgExpr 'InferTaggedBinders
body')
where
(TagEnv p
env', GenStgBinding 'InferTaggedBinders
bind') = TagEnv p
-> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)
inferTagBind TagEnv p
env GenStgBinding p
bind
(TagInfo
info, GenStgExpr 'InferTaggedBinders
body') = TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr TagEnv p
env' GenStgExpr p
body
inferTagExpr TagEnv p
env (StgLetNoEscape XLetNoEscape p
ext GenStgBinding p
bind GenStgExpr p
body)
= (TagInfo
info, XLetNoEscape 'InferTaggedBinders
-> GenStgBinding 'InferTaggedBinders
-> GenStgExpr 'InferTaggedBinders
-> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape p
XLetNoEscape 'InferTaggedBinders
ext GenStgBinding 'InferTaggedBinders
bind' GenStgExpr 'InferTaggedBinders
body')
where
(TagEnv p
env', GenStgBinding 'InferTaggedBinders
bind') = TagEnv p
-> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)
inferTagBind TagEnv p
env GenStgBinding p
bind
(TagInfo
info, GenStgExpr 'InferTaggedBinders
body') = TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr TagEnv p
env' GenStgExpr p
body
inferTagExpr TagEnv p
in_env (StgCase GenStgExpr p
scrut BinderP p
bndr AltType
ty [GenStgAlt p]
alts)
| [GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=DataAlt DataCon
con, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP p]
bndrs, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr p
rhs}] <- [GenStgAlt p]
alts
, DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
, Just [TagInfo]
infos <- [BinderP p] -> Maybe [TagInfo]
scrut_infos [BinderP p]
bndrs
, let bndrs' :: [(Id, TagSig)]
bndrs' = String
-> (BinderP p -> TagInfo -> (Id, TagSig))
-> [BinderP p]
-> [TagInfo]
-> [(Id, TagSig)]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"inferTagExpr" BinderP p -> TagInfo -> (Id, TagSig)
mk_bndr [BinderP p]
bndrs [TagInfo]
infos
mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig)
mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig)
mk_bndr BinderP p
tup_bndr TagInfo
tup_info =
(TagEnv p -> BinderP p -> Id
forall (p :: StgPass). TagEnv p -> BinderP p -> Id
getBinderId TagEnv p
in_env BinderP p
tup_bndr, TagInfo -> TagSig
TagSig TagInfo
tup_info)
alt_env :: TagEnv p
alt_env = TagEnv p -> [(Id, TagSig)] -> TagEnv p
forall (p :: StgPass). TagEnv p -> [(Id, TagSig)] -> TagEnv p
extendSigEnv TagEnv p
in_env [(Id, TagSig)]
bndrs'
(TagInfo
info, GenStgExpr 'InferTaggedBinders
rhs') = TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr TagEnv p
alt_env GenStgExpr p
rhs
=
(TagInfo
info, GenStgExpr 'InferTaggedBinders
-> BinderP 'InferTaggedBinders
-> AltType
-> [GenStgAlt 'InferTaggedBinders]
-> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'InferTaggedBinders
scrut' (TagEnv p -> BinderP p -> (Id, TagSig)
forall (p :: StgPass). TagEnv p -> BinderP p -> (Id, TagSig)
noSig TagEnv p
in_env BinderP p
bndr) AltType
ty [GenStgAlt{ alt_con :: AltCon
alt_con=DataCon -> AltCon
DataAlt DataCon
con
, alt_bndrs :: [BinderP 'InferTaggedBinders]
alt_bndrs=[(Id, TagSig)]
[BinderP 'InferTaggedBinders]
bndrs'
, alt_rhs :: GenStgExpr 'InferTaggedBinders
alt_rhs=GenStgExpr 'InferTaggedBinders
rhs'}])
| [GenStgAlt p] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStgAlt p]
alts
=
(TagInfo
TagDunno, GenStgExpr 'InferTaggedBinders
-> BinderP 'InferTaggedBinders
-> AltType
-> [GenStgAlt 'InferTaggedBinders]
-> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'InferTaggedBinders
scrut' (Id, TagSig)
BinderP 'InferTaggedBinders
bndr' AltType
ty [])
| Bool
otherwise
=
let
case_env :: TagEnv p
case_env = TagEnv p -> [(Id, TagSig)] -> TagEnv p
forall (p :: StgPass). TagEnv p -> [(Id, TagSig)] -> TagEnv p
extendSigEnv TagEnv p
in_env [(Id, TagSig)
bndr']
([TagInfo]
infos, [GenStgAlt 'InferTaggedBinders]
alts')
= [(TagInfo, GenStgAlt 'InferTaggedBinders)]
-> ([TagInfo], [GenStgAlt 'InferTaggedBinders])
forall a b. [(a, b)] -> ([a], [b])
unzip [ (TagInfo
info, GenStgAlt p
g {alt_bndrs=bndrs', alt_rhs=rhs'})
| g :: GenStgAlt p
g@GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = AltCon
con
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP p]
bndrs
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr p
rhs
} <- [GenStgAlt p]
alts
, let (TagEnv p
alt_env,[BinderP 'InferTaggedBinders]
bndrs') = TagEnv p
-> AltCon
-> [BinderP p]
-> (TagEnv p, [BinderP 'InferTaggedBinders])
forall (p :: StgPass).
TagEnv p
-> AltCon
-> [BinderP p]
-> (TagEnv p, [BinderP 'InferTaggedBinders])
addAltBndrInfo TagEnv p
case_env AltCon
con [BinderP p]
bndrs
(TagInfo
info, GenStgExpr 'InferTaggedBinders
rhs') = TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr TagEnv p
alt_env GenStgExpr p
rhs
]
alt_info :: TagInfo
alt_info = (TagInfo -> TagInfo -> TagInfo) -> TagInfo -> [TagInfo] -> TagInfo
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TagInfo -> TagInfo -> TagInfo
combineAltInfo TagInfo
TagTagged [TagInfo]
infos
in ( TagInfo
alt_info, GenStgExpr 'InferTaggedBinders
-> BinderP 'InferTaggedBinders
-> AltType
-> [GenStgAlt 'InferTaggedBinders]
-> GenStgExpr 'InferTaggedBinders
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'InferTaggedBinders
scrut' (Id, TagSig)
BinderP 'InferTaggedBinders
bndr' AltType
ty [GenStgAlt 'InferTaggedBinders]
alts')
where
scrut_infos :: [BinderP p] -> Maybe [TagInfo]
scrut_infos [BinderP p]
bndrs = case TagInfo
scrut_info of
TagInfo
TagTagged -> [TagInfo] -> Maybe [TagInfo]
forall a. a -> Maybe a
Just ([TagInfo] -> Maybe [TagInfo]) -> [TagInfo] -> Maybe [TagInfo]
forall a b. (a -> b) -> a -> b
$ Arity -> TagInfo -> [TagInfo]
forall a. Arity -> a -> [a]
replicate ([BinderP p] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [BinderP p]
bndrs) TagInfo
TagProper
TagTuple [TagInfo]
infos -> [TagInfo] -> Maybe [TagInfo]
forall a. a -> Maybe a
Just [TagInfo]
infos
TagInfo
_ -> Maybe [TagInfo]
forall a. Maybe a
Nothing
(TagInfo
scrut_info, GenStgExpr 'InferTaggedBinders
scrut') = TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr TagEnv p
in_env GenStgExpr p
scrut
bndr' :: (Id, TagSig)
bndr' = (TagEnv p -> BinderP p -> Id
forall (p :: StgPass). TagEnv p -> BinderP p -> Id
getBinderId TagEnv p
in_env BinderP p
bndr, TagInfo -> TagSig
TagSig TagInfo
TagProper)
addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders])
addAltBndrInfo :: forall (p :: StgPass).
TagEnv p
-> AltCon
-> [BinderP p]
-> (TagEnv p, [BinderP 'InferTaggedBinders])
addAltBndrInfo TagEnv p
env (DataAlt DataCon
con) [BinderP p]
bndrs
| Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con)
= (TagEnv p
out_env, [(Id, TagSig)]
[BinderP 'InferTaggedBinders]
out_bndrs)
where
marks :: [StrictnessMark]
marks = HasDebugCallStack => DataCon -> [StrictnessMark]
DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
con :: [StrictnessMark]
out_bndrs :: [(Id, TagSig)]
out_bndrs = (BinderP p -> StrictnessMark -> (Id, TagSig))
-> [BinderP p] -> [StrictnessMark] -> [(Id, TagSig)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith BinderP p -> StrictnessMark -> (Id, TagSig)
mk_bndr [BinderP p]
bndrs [StrictnessMark]
marks
out_env :: TagEnv p
out_env = TagEnv p -> [(Id, TagSig)] -> TagEnv p
forall (p :: StgPass). TagEnv p -> [(Id, TagSig)] -> TagEnv p
extendSigEnv TagEnv p
env [(Id, TagSig)]
out_bndrs
mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig))
mk_bndr :: BinderP p -> StrictnessMark -> (Id, TagSig)
mk_bndr BinderP p
bndr StrictnessMark
mark
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
id) Bool -> Bool -> Bool
|| StrictnessMark -> Bool
isMarkedStrict StrictnessMark
mark
= (Id
id, TagInfo -> TagSig
TagSig TagInfo
TagProper)
| Bool
otherwise
= TagEnv p -> BinderP p -> (Id, TagSig)
forall (p :: StgPass). TagEnv p -> BinderP p -> (Id, TagSig)
noSig TagEnv p
env BinderP p
bndr
where
id :: Id
id = TagEnv p -> BinderP p -> Id
forall (p :: StgPass). TagEnv p -> BinderP p -> Id
getBinderId TagEnv p
env BinderP p
bndr
addAltBndrInfo TagEnv p
env AltCon
_ [BinderP p]
bndrs = (TagEnv p
env, (BinderP p -> (Id, TagSig)) -> [BinderP p] -> [(Id, TagSig)]
forall a b. (a -> b) -> [a] -> [b]
map (TagEnv p -> BinderP p -> (Id, TagSig)
forall (p :: StgPass). TagEnv p -> BinderP p -> (Id, TagSig)
noSig TagEnv p
env) [BinderP p]
bndrs)
inferTagBind :: (OutputableInferPass p, InferExtEq p)
=> TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)
inferTagBind :: forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)
inferTagBind TagEnv p
in_env (StgNonRec BinderP p
bndr GenStgRhs p
rhs)
=
(TagEnv p
env', BinderP 'InferTaggedBinders
-> GenStgRhs 'InferTaggedBinders
-> GenStgBinding 'InferTaggedBinders
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec (Id
id, TagSig
out_sig) GenStgRhs 'InferTaggedBinders
rhs')
where
id :: Id
id = TagEnv p -> BinderP p -> Id
forall (p :: StgPass). TagEnv p -> BinderP p -> Id
getBinderId TagEnv p
in_env BinderP p
bndr
(TagSig
in_sig,GenStgRhs 'InferTaggedBinders
rhs') = Id
-> TagEnv p
-> GenStgRhs p
-> (TagSig, GenStgRhs 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
Id
-> TagEnv p
-> GenStgRhs p
-> (TagSig, GenStgRhs 'InferTaggedBinders)
inferTagRhs Id
id TagEnv p
in_env GenStgRhs p
rhs
out_sig :: TagSig
out_sig = TagEnv p -> TagSig -> TagSig
forall (p :: StgPass). TagEnv p -> TagSig -> TagSig
mkLetSig TagEnv p
in_env TagSig
in_sig
env' :: TagEnv p
env' = TagEnv p -> [(Id, TagSig)] -> TagEnv p
forall (p :: StgPass). TagEnv p -> [(Id, TagSig)] -> TagEnv p
extendSigEnv TagEnv p
in_env [(Id
id, TagSig
out_sig)]
inferTagBind TagEnv p
in_env (StgRec [(BinderP p, GenStgRhs p)]
pairs)
=
(TagEnv p
in_env { te_env = out_env }, [(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
-> GenStgBinding 'InferTaggedBinders
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec [((Id, TagSig), GenStgRhs 'InferTaggedBinders)]
[(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
pairs')
where
([BinderP p]
bndrs, [GenStgRhs p]
rhss) = [(BinderP p, GenStgRhs p)] -> ([BinderP p], [GenStgRhs p])
forall a b. [(a, b)] -> ([a], [b])
unzip [(BinderP p, GenStgRhs p)]
pairs
in_ids :: [Id]
in_ids = (BinderP p -> Id) -> [BinderP p] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (TagEnv p -> BinderP p -> Id
forall (p :: StgPass). TagEnv p -> BinderP p -> Id
getBinderId TagEnv p
in_env) [BinderP p]
bndrs
init_sigs :: [TagSig]
init_sigs = ((Id, GenStgRhs p) -> TagSig) -> [(Id, GenStgRhs p)] -> [TagSig]
forall a b. (a -> b) -> [a] -> [b]
map ((Id, GenStgRhs p) -> TagSig
forall (p :: StgPass). (Id, GenStgRhs p) -> TagSig
initSig) ([(Id, GenStgRhs p)] -> [TagSig])
-> [(Id, GenStgRhs p)] -> [TagSig]
forall a b. (a -> b) -> a -> b
$ [Id] -> [GenStgRhs p] -> [(Id, GenStgRhs p)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
in_ids [GenStgRhs p]
rhss
(TagSigEnv
out_env, [((Id, TagSig), GenStgRhs 'InferTaggedBinders)]
pairs') = TagEnv p
-> [TagSig]
-> [GenStgRhs p]
-> (TagSigEnv, [((Id, TagSig), GenStgRhs 'InferTaggedBinders)])
forall (q :: StgPass).
(OutputableInferPass q, InferExtEq q) =>
TagEnv q
-> [TagSig]
-> [GenStgRhs q]
-> (TagSigEnv, [((Id, TagSig), GenStgRhs 'InferTaggedBinders)])
go TagEnv p
in_env [TagSig]
init_sigs [GenStgRhs p]
rhss
go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q]
-> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)])
go :: forall (q :: StgPass).
(OutputableInferPass q, InferExtEq q) =>
TagEnv q
-> [TagSig]
-> [GenStgRhs q]
-> (TagSigEnv, [((Id, TagSig), GenStgRhs 'InferTaggedBinders)])
go TagEnv q
go_env [TagSig]
in_sigs [GenStgRhs q]
go_rhss
| [TagSig]
in_sigs [TagSig] -> [TagSig] -> Bool
forall a. Eq a => a -> a -> Bool
== [TagSig]
out_sigs = (TagEnv q -> TagSigEnv
forall (p :: StgPass). TagEnv p -> TagSigEnv
te_env TagEnv q
rhs_env, [(Id, TagSig)]
out_bndrs [(Id, TagSig)]
-> [GenStgRhs 'InferTaggedBinders]
-> [((Id, TagSig), GenStgRhs 'InferTaggedBinders)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [GenStgRhs 'InferTaggedBinders]
rhss')
| Bool
otherwise = TagEnv 'InferTaggedBinders
-> [TagSig]
-> [GenStgRhs 'InferTaggedBinders]
-> (TagSigEnv, [((Id, TagSig), GenStgRhs 'InferTaggedBinders)])
forall (q :: StgPass).
(OutputableInferPass q, InferExtEq q) =>
TagEnv q
-> [TagSig]
-> [GenStgRhs q]
-> (TagSigEnv, [((Id, TagSig), GenStgRhs 'InferTaggedBinders)])
go TagEnv 'InferTaggedBinders
env' [TagSig]
out_sigs [GenStgRhs 'InferTaggedBinders]
rhss'
where
in_bndrs :: [(Id, TagSig)]
in_bndrs = [Id]
in_ids [Id] -> [TagSig] -> [(Id, TagSig)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TagSig]
in_sigs
out_bndrs :: [(Id, TagSig)]
out_bndrs = ((Id, TagSig) -> (Id, TagSig)) -> [(Id, TagSig)] -> [(Id, TagSig)]
forall a b. (a -> b) -> [a] -> [b]
map (Id, TagSig) -> (Id, TagSig)
updateBndr [(Id, TagSig)]
in_bndrs
rhs_env :: TagEnv q
rhs_env = TagEnv q -> [(Id, TagSig)] -> TagEnv q
forall (p :: StgPass). TagEnv p -> [(Id, TagSig)] -> TagEnv p
extendSigEnv TagEnv q
go_env [(Id, TagSig)]
in_bndrs
([TagSig]
out_sigs, [GenStgRhs 'InferTaggedBinders]
rhss') = [(TagSig, GenStgRhs 'InferTaggedBinders)]
-> ([TagSig], [GenStgRhs 'InferTaggedBinders])
forall a b. [(a, b)] -> ([a], [b])
unzip (String
-> (Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders))
-> [Id]
-> [GenStgRhs q]
-> [(TagSig, GenStgRhs 'InferTaggedBinders)]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"inferTagBind" Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)
anaRhs [Id]
in_ids [GenStgRhs q]
go_rhss)
env' :: TagEnv 'InferTaggedBinders
env' = TagEnv q -> TagEnv 'InferTaggedBinders
forall (p :: StgPass). TagEnv p -> TagEnv 'InferTaggedBinders
makeTagged TagEnv q
go_env
anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)
anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)
anaRhs Id
bnd GenStgRhs q
rhs =
let (TagSig
sig_rhs,GenStgRhs 'InferTaggedBinders
rhs') = Id
-> TagEnv q
-> GenStgRhs q
-> (TagSig, GenStgRhs 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
Id
-> TagEnv p
-> GenStgRhs p
-> (TagSig, GenStgRhs 'InferTaggedBinders)
inferTagRhs Id
bnd TagEnv q
rhs_env GenStgRhs q
rhs
in (TagEnv q -> TagSig -> TagSig
forall (p :: StgPass). TagEnv p -> TagSig -> TagSig
mkLetSig TagEnv q
go_env TagSig
sig_rhs, GenStgRhs 'InferTaggedBinders
rhs')
updateBndr :: (Id,TagSig) -> (Id,TagSig)
updateBndr :: (Id, TagSig) -> (Id, TagSig)
updateBndr (Id
v,TagSig
sig) = (Id -> TagSig -> Id
setIdTagSig Id
v TagSig
sig, TagSig
sig)
initSig :: forall p. (Id, GenStgRhs p) -> TagSig
initSig :: forall (p :: StgPass). (Id, GenStgRhs p) -> TagSig
initSig (Id
_bndr, StgRhsCon {}) = TagInfo -> TagSig
TagSig TagInfo
TagTagged
initSig (Id
bndr, StgRhsClosure XRhsClosure p
_ CostCentreStack
_ UpdateFlag
_ [BinderP p]
_ GenStgExpr p
_ Type
_) =
TagSig -> Maybe TagSig -> TagSig
forall a. a -> Maybe a -> a
fromMaybe TagSig
defaultSig (Id -> Maybe TagSig
idTagSig_maybe Id
bndr)
where defaultSig :: TagSig
defaultSig = (TagInfo -> TagSig
TagSig TagInfo
TagTagged)
inferTagRhs :: forall p.
(OutputableInferPass p, InferExtEq p)
=> Id
-> TagEnv p
-> GenStgRhs p
-> (TagSig, GenStgRhs 'InferTaggedBinders)
inferTagRhs :: forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
Id
-> TagEnv p
-> GenStgRhs p
-> (TagSig, GenStgRhs 'InferTaggedBinders)
inferTagRhs Id
bnd_id TagEnv p
in_env (StgRhsClosure XRhsClosure p
ext CostCentreStack
cc UpdateFlag
upd [BinderP p]
bndrs GenStgExpr p
body Type
typ)
| Id -> Bool
isDeadEndId Id
bnd_id Bool -> Bool -> Bool
&& (forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull) [BinderP p]
bndrs
= (TagInfo -> TagSig
TagSig TagInfo
TagTagged, XRhsClosure 'InferTaggedBinders
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'InferTaggedBinders]
-> GenStgExpr 'InferTaggedBinders
-> Type
-> GenStgRhs 'InferTaggedBinders
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure p
XRhsClosure 'InferTaggedBinders
ext CostCentreStack
cc UpdateFlag
upd [(Id, TagSig)]
[BinderP 'InferTaggedBinders]
out_bndrs GenStgExpr 'InferTaggedBinders
body' Type
typ)
| Bool
otherwise
=
(TagInfo -> TagSig
TagSig TagInfo
info', XRhsClosure 'InferTaggedBinders
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'InferTaggedBinders]
-> GenStgExpr 'InferTaggedBinders
-> Type
-> GenStgRhs 'InferTaggedBinders
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure p
XRhsClosure 'InferTaggedBinders
ext CostCentreStack
cc UpdateFlag
upd [(Id, TagSig)]
[BinderP 'InferTaggedBinders]
out_bndrs GenStgExpr 'InferTaggedBinders
body' Type
typ)
where
out_bndrs :: [(Id, TagSig)]
out_bndrs
| Just [CbvMark]
marks <- Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
bnd_id
= (BinderP p -> CbvMark -> (Id, TagSig))
-> [BinderP p] -> [CbvMark] -> [(Id, TagSig)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (BinderP p -> CbvMark -> (Id, TagSig)
mkArgSig) [BinderP p]
bndrs ([CbvMark]
marks [CbvMark] -> [CbvMark] -> [CbvMark]
forall a. [a] -> [a] -> [a]
++ CbvMark -> [CbvMark]
forall a. a -> [a]
repeat CbvMark
NotMarkedCbv)
| Bool
otherwise = (BinderP p -> (Id, TagSig)) -> [BinderP p] -> [(Id, TagSig)]
forall a b. (a -> b) -> [a] -> [b]
map (TagEnv p -> BinderP p -> (Id, TagSig)
forall (p :: StgPass). TagEnv p -> BinderP p -> (Id, TagSig)
noSig TagEnv p
env') [BinderP p]
bndrs :: [(Id,TagSig)]
env' :: TagEnv p
env' = TagEnv p -> [(Id, TagSig)] -> TagEnv p
forall (p :: StgPass). TagEnv p -> [(Id, TagSig)] -> TagEnv p
extendSigEnv TagEnv p
in_env [(Id, TagSig)]
out_bndrs
(TagInfo
info, GenStgExpr 'InferTaggedBinders
body') = TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
forall (p :: StgPass).
(OutputableInferPass p, InferExtEq p) =>
TagEnv p
-> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
inferTagExpr TagEnv p
env' GenStgExpr p
body
info' :: TagInfo
info'
| [BinderP p] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BinderP p]
bndrs
= TagInfo
TagDunno
| Bool
otherwise = TagInfo
info
mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig)
mkArgSig :: BinderP p -> CbvMark -> (Id, TagSig)
mkArgSig BinderP p
bndp CbvMark
mark =
let id :: Id
id = TagEnv p -> BinderP p -> Id
forall (p :: StgPass). TagEnv p -> BinderP p -> Id
getBinderId TagEnv p
in_env BinderP p
bndp
tag :: TagInfo
tag = case CbvMark
mark of
CbvMark
MarkedCbv -> TagInfo
TagProper
CbvMark
_
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
id) -> TagInfo
TagProper
| Bool
otherwise -> TagInfo
TagDunno
in (Id
id, TagInfo -> TagSig
TagSig TagInfo
tag)
inferTagRhs Id
_ TagEnv p
env _rhs :: GenStgRhs p
_rhs@(StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
cn [StgTickish]
ticks [StgArg]
args Type
typ)
=
(TagInfo -> TagSig
TagSig (TagEnv p -> DataCon -> [StgArg] -> TagInfo
forall (p :: StgPass). TagEnv p -> DataCon -> [StgArg] -> TagInfo
inferConTag TagEnv p
env DataCon
con [StgArg]
args), CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs 'InferTaggedBinders
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs pass
StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
cn [StgTickish]
ticks [StgArg]
args Type
typ)
mkLetSig :: TagEnv p -> TagSig -> TagSig
mkLetSig :: forall (p :: StgPass). TagEnv p -> TagSig -> TagSig
mkLetSig TagEnv p
env TagSig
in_sig
| Bool
for_bytecode = TagInfo -> TagSig
TagSig TagInfo
TagDunno
| Bool
otherwise = TagSig
in_sig
where
for_bytecode :: Bool
for_bytecode = TagEnv p -> Bool
forall (p :: StgPass). TagEnv p -> Bool
te_bytecode TagEnv p
env
inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo
inferConTag :: forall (p :: StgPass). TagEnv p -> DataCon -> [StgArg] -> TagInfo
inferConTag TagEnv p
env DataCon
con [StgArg]
args
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
= [TagInfo] -> TagInfo
TagTuple ([TagInfo] -> TagInfo) -> [TagInfo] -> TagInfo
forall a b. (a -> b) -> a -> b
$ (StgArg -> TagInfo) -> [StgArg] -> [TagInfo]
forall a b. (a -> b) -> [a] -> [b]
map (TagInfo -> TagInfo
flatten_arg_tag (TagInfo -> TagInfo) -> (StgArg -> TagInfo) -> StgArg -> TagInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagEnv p -> StgArg -> TagInfo
forall (p :: StgPass). TagEnv p -> StgArg -> TagInfo
lookupInfo TagEnv p
env) [StgArg]
args
| Bool
otherwise =
TagInfo
info
where
info :: TagInfo
info = if ((StgArg, StrictnessMark) -> Bool)
-> [(StgArg, StrictnessMark)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (StgArg, StrictnessMark) -> Bool
arg_needs_eval [(StgArg, StrictnessMark)]
strictArgs then TagInfo
TagDunno else TagInfo
TagProper
strictArgs :: [(StgArg, StrictnessMark)]
strictArgs = String
-> [StgArg] -> [StrictnessMark] -> [(StgArg, StrictnessMark)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"inferTagRhs" [StgArg]
args (HasDebugCallStack => DataCon -> [StrictnessMark]
DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
con) :: ([(StgArg, StrictnessMark)])
arg_needs_eval :: (StgArg, StrictnessMark) -> Bool
arg_needs_eval (StgArg
arg,StrictnessMark
strict)
| Bool -> Bool
not (StrictnessMark -> Bool
isMarkedStrict StrictnessMark
strict) = Bool
False
| TagInfo
tag <- (TagEnv p -> StgArg -> TagInfo
forall (p :: StgPass). TagEnv p -> StgArg -> TagInfo
lookupInfo TagEnv p
env StgArg
arg)
= Bool -> Bool
not (TagInfo -> Bool
isTaggedInfo TagInfo
tag)
flatten_arg_tag :: TagInfo -> TagInfo
flatten_arg_tag (TagInfo
TagTagged) = TagInfo
TagProper
flatten_arg_tag (TagInfo
TagProper ) = TagInfo
TagProper
flatten_arg_tag (TagTuple [TagInfo]
_) = TagInfo
TagDunno
flatten_arg_tag (TagInfo
TagDunno) = TagInfo
TagDunno
collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig
collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig
collectExportInfo [GenStgTopBinding 'InferTaggedBinders]
binds =
[(Name, TagSig)] -> NameEnv TagSig
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, TagSig)]
bndr_info
where
bndr_info :: [(Name, TagSig)]
bndr_info = (GenStgTopBinding 'InferTaggedBinders -> [(Name, TagSig)])
-> [GenStgTopBinding 'InferTaggedBinders] -> [(Name, TagSig)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenStgTopBinding 'InferTaggedBinders -> [(Name, TagSig)]
forall {pass :: StgPass}.
(BinderP pass ~ (Id, TagSig)) =>
GenStgTopBinding pass -> [(Name, TagSig)]
collect [GenStgTopBinding 'InferTaggedBinders]
binds :: [(Name,TagSig)]
collect :: GenStgTopBinding pass -> [(Name, TagSig)]
collect (StgTopStringLit {}) = []
collect (StgTopLifted GenStgBinding pass
bnd) =
case GenStgBinding pass
bnd of
StgNonRec (Id
id,TagSig
sig) GenStgRhs pass
_rhs
| TagSig TagInfo
TagDunno <- TagSig
sig -> []
| Bool
otherwise -> [(Id -> Name
idName Id
id,TagSig
sig)]
StgRec [(BinderP pass, GenStgRhs pass)]
bnds -> [(BinderP 'InferTaggedBinders, GenStgRhs pass)] -> [(Name, TagSig)]
forall rhs.
[(BinderP 'InferTaggedBinders, rhs)] -> [(Name, TagSig)]
collectRec [(BinderP pass, GenStgRhs pass)]
[(BinderP 'InferTaggedBinders, GenStgRhs pass)]
bnds
collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)]
collectRec :: forall rhs.
[(BinderP 'InferTaggedBinders, rhs)] -> [(Name, TagSig)]
collectRec [] = []
collectRec ((BinderP 'InferTaggedBinders, rhs)
bnd:[(BinderP 'InferTaggedBinders, rhs)]
bnds)
| (BinderP 'InferTaggedBinders
p,rhs
_rhs) <- (BinderP 'InferTaggedBinders, rhs)
bnd
, (Id
id,TagSig
sig) <- BinderP 'InferTaggedBinders
p
, TagSig TagInfo
TagDunno <- TagSig
sig
= (Id -> Name
idName Id
id,TagSig
sig) (Name, TagSig) -> [(Name, TagSig)] -> [(Name, TagSig)]
forall a. a -> [a] -> [a]
: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name, TagSig)]
forall rhs.
[(BinderP 'InferTaggedBinders, rhs)] -> [(Name, TagSig)]
collectRec [(BinderP 'InferTaggedBinders, rhs)]
bnds
| Bool
otherwise = [(BinderP 'InferTaggedBinders, rhs)] -> [(Name, TagSig)]
forall rhs.
[(BinderP 'InferTaggedBinders, rhs)] -> [(Name, TagSig)]
collectRec [(BinderP 'InferTaggedBinders, rhs)]
bnds