{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
where
import GHC.Prelude
import GHC.Builtin.PrimOps ( PrimOp(..) )
import GHC.Types.Basic ( CbvMark (..), isMarkedCbv
, TopLevelFlag(..), isTopLevel
, Levity(..) )
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Unique.Supply
import GHC.Types.Unique.FM
import GHC.Types.RepType
import GHC.Types.Var.Set
import GHC.Unit.Types
import GHC.Core.DataCon
import GHC.Core ( AltCon(..) )
import GHC.Core.Type
import GHC.StgToCmm.Types
import GHC.Stg.Utils
import GHC.Stg.Syntax as StgSyn
import GHC.Data.Maybe
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Misc
import GHC.Stg.InferTags.Types
import Control.Monad
newtype RM a = RM { forall a.
RM a -> State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a
unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) }
deriving (forall a b. a -> RM b -> RM a
forall a b. (a -> b) -> RM a -> RM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RM b -> RM a
$c<$ :: forall a b. a -> RM b -> RM a
fmap :: forall a b. (a -> b) -> RM a -> RM b
$cfmap :: forall a b. (a -> b) -> RM a -> RM b
Functor, Applicative RM
forall a. a -> RM a
forall a b. RM a -> RM b -> RM b
forall a b. RM a -> (a -> RM b) -> RM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> RM a
$creturn :: forall a. a -> RM a
>> :: forall a b. RM a -> RM b -> RM b
$c>> :: forall a b. RM a -> RM b -> RM b
>>= :: forall a b. RM a -> (a -> RM b) -> RM b
$c>>= :: forall a b. RM a -> (a -> RM b) -> RM b
Monad, Functor RM
forall a. a -> RM a
forall a b. RM a -> RM b -> RM a
forall a b. RM a -> RM b -> RM b
forall a b. RM (a -> b) -> RM a -> RM b
forall a b c. (a -> b -> c) -> RM a -> RM b -> RM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. RM a -> RM b -> RM a
$c<* :: forall a b. RM a -> RM b -> RM a
*> :: forall a b. RM a -> RM b -> RM b
$c*> :: forall a b. RM a -> RM b -> RM b
liftA2 :: forall a b c. (a -> b -> c) -> RM a -> RM b -> RM c
$cliftA2 :: forall a b c. (a -> b -> c) -> RM a -> RM b -> RM c
<*> :: forall a b. RM (a -> b) -> RM a -> RM b
$c<*> :: forall a b. RM (a -> b) -> RM a -> RM b
pure :: forall a. a -> RM a
$cpure :: forall a. a -> RM a
Applicative)
instance MonadUnique RM where
getUniqueSupplyM :: RM UniqSupply
getUniqueSupplyM = forall a.
State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a -> RM a
RM forall a b. (a -> b) -> a -> b
$ do
(UniqFM Id TagSig
m, UniqSupply
us, Module
mod,IdSet
lcls) <- forall s. State s s
get
let (UniqSupply
us1, UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us
(forall s. s -> State s ()
put) (UniqFM Id TagSig
m,UniqSupply
us2,Module
mod,IdSet
lcls)
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us1
getMap :: RM (UniqFM Id TagSig)
getMap :: RM (UniqFM Id TagSig)
getMap = forall a.
State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a -> RM a
RM forall a b. (a -> b) -> a -> b
$ ((\(UniqFM Id TagSig
fst,UniqSupply
_,Module
_,IdSet
_) -> UniqFM Id TagSig
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. State s s
get)
setMap :: (UniqFM Id TagSig) -> RM ()
setMap :: UniqFM Id TagSig -> RM ()
setMap !UniqFM Id TagSig
m = forall a.
State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a -> RM a
RM forall a b. (a -> b) -> a -> b
$ do
(UniqFM Id TagSig
_,UniqSupply
us,Module
mod,IdSet
lcls) <- forall s. State s s
get
forall s. s -> State s ()
put (UniqFM Id TagSig
m, UniqSupply
us,Module
mod,IdSet
lcls)
getMod :: RM Module
getMod :: RM Module
getMod = forall a.
State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a -> RM a
RM forall a b. (a -> b) -> a -> b
$ ( (\(UniqFM Id TagSig
_,UniqSupply
_,Module
thrd,IdSet
_) -> Module
thrd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. State s s
get)
getFVs :: RM IdSet
getFVs :: RM IdSet
getFVs = forall a.
State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a -> RM a
RM forall a b. (a -> b) -> a -> b
$ ((\(UniqFM Id TagSig
_,UniqSupply
_,Module
_,IdSet
lcls) -> IdSet
lcls) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. State s s
get)
setFVs :: IdSet -> RM ()
setFVs :: IdSet -> RM ()
setFVs !IdSet
fvs = forall a.
State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a -> RM a
RM forall a b. (a -> b) -> a -> b
$ do
(UniqFM Id TagSig
tag_map,UniqSupply
us,Module
mod,IdSet
_lcls) <- forall s. State s s
get
forall s. s -> State s ()
put (UniqFM Id TagSig
tag_map, UniqSupply
us,Module
mod,IdSet
fvs)
withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a
withBind :: forall a.
TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a
withBind TopLevelFlag
top_flag (StgNonRec BinderP 'InferTaggedBinders
bnd GenStgRhs 'InferTaggedBinders
_) RM a
cont = forall a. TopLevelFlag -> (Id, TagSig) -> RM a -> RM a
withBinder TopLevelFlag
top_flag BinderP 'InferTaggedBinders
bnd RM a
cont
withBind TopLevelFlag
top_flag (StgRec [(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
binds) RM a
cont = do
let ([(Id, TagSig)]
bnds,[GenStgRhs 'InferTaggedBinders]
_rhss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders])
forall a. TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a
withBinders TopLevelFlag
top_flag [(Id, TagSig)]
bnds RM a
cont
addTopBind :: GenStgBinding 'InferTaggedBinders -> RM ()
addTopBind :: GenStgBinding 'InferTaggedBinders -> RM ()
addTopBind (StgNonRec (Id
id, TagSig
tag) GenStgRhs 'InferTaggedBinders
_) = do
UniqFM Id TagSig
s <- RM (UniqFM Id TagSig)
getMap
UniqFM Id TagSig -> RM ()
setMap forall a b. (a -> b) -> a -> b
$ forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Id TagSig
s Id
id TagSig
tag
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addTopBind (StgRec [(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
binds) = do
let ([(Id, TagSig)]
bnds,[GenStgRhs 'InferTaggedBinders]
_rhss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
binds
!UniqFM Id TagSig
s <- RM (UniqFM Id TagSig)
getMap
UniqFM Id TagSig -> RM ()
setMap forall a b. (a -> b) -> a -> b
$! forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM UniqFM Id TagSig
s [(Id, TagSig)]
bnds
withBinder :: TopLevelFlag -> (Id, TagSig) -> RM a -> RM a
withBinder :: forall a. TopLevelFlag -> (Id, TagSig) -> RM a -> RM a
withBinder TopLevelFlag
top_flag (Id
id,TagSig
sig) RM a
cont = do
UniqFM Id TagSig
oldMap <- RM (UniqFM Id TagSig)
getMap
UniqFM Id TagSig -> RM ()
setMap forall a b. (a -> b) -> a -> b
$ forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Id TagSig
oldMap Id
id TagSig
sig
a
a <- if TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_flag
then RM a
cont
else forall a. Id -> RM a -> RM a
withLcl Id
id RM a
cont
UniqFM Id TagSig -> RM ()
setMap UniqFM Id TagSig
oldMap
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a
withBinders :: forall a. TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a
withBinders TopLevelFlag
TopLevel [(Id, TagSig)]
sigs RM a
cont = do
UniqFM Id TagSig
oldMap <- RM (UniqFM Id TagSig)
getMap
UniqFM Id TagSig -> RM ()
setMap forall a b. (a -> b) -> a -> b
$ forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM UniqFM Id TagSig
oldMap [(Id, TagSig)]
sigs
a
a <- RM a
cont
UniqFM Id TagSig -> RM ()
setMap UniqFM Id TagSig
oldMap
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
withBinders TopLevelFlag
NotTopLevel [(Id, TagSig)]
sigs RM a
cont = do
UniqFM Id TagSig
oldMap <- RM (UniqFM Id TagSig)
getMap
IdSet
oldFvs <- RM IdSet
getFVs
UniqFM Id TagSig -> RM ()
setMap forall a b. (a -> b) -> a -> b
$ forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM UniqFM Id TagSig
oldMap [(Id, TagSig)]
sigs
IdSet -> RM ()
setFVs forall a b. (a -> b) -> a -> b
$ IdSet -> [Id] -> IdSet
extendVarSetList IdSet
oldFvs (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, TagSig)]
sigs)
a
a <- RM a
cont
UniqFM Id TagSig -> RM ()
setMap UniqFM Id TagSig
oldMap
IdSet -> RM ()
setFVs IdSet
oldFvs
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
withClosureLcls :: DIdSet -> RM a -> RM a
withClosureLcls :: forall a. DIdSet -> RM a -> RM a
withClosureLcls DIdSet
fvs RM a
act = do
IdSet
old_fvs <- RM IdSet
getFVs
let !fvs' :: IdSet
fvs' = forall a. (Id -> a -> a) -> a -> DIdSet -> a
nonDetStrictFoldDVarSet (forall a b c. (a -> b -> c) -> b -> a -> c
flip IdSet -> Id -> IdSet
extendVarSet) IdSet
old_fvs DIdSet
fvs
IdSet -> RM ()
setFVs IdSet
fvs'
!a
r <- RM a
act
IdSet -> RM ()
setFVs IdSet
old_fvs
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
withLcl :: Id -> RM a -> RM a
withLcl :: forall a. Id -> RM a -> RM a
withLcl Id
fv RM a
act = do
IdSet
old_fvs <- RM IdSet
getFVs
let !fvs' :: IdSet
fvs' = IdSet -> Id -> IdSet
extendVarSet IdSet
old_fvs Id
fv
IdSet -> RM ()
setFVs IdSet
fvs'
!a
r <- RM a
act
IdSet -> RM ()
setFVs IdSet
old_fvs
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
isTagged :: Id -> RM Bool
isTagged :: Id -> RM Bool
isTagged Id
v = do
Module
this_mod <- RM Module
getMod
let lookupDefault :: Id -> TagSig
lookupDefault Id
v = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Module -> Bool
isInteractiveModule Module
this_mod)
(forall doc. IsLine doc => String -> doc
text String
"unknown Id:" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr Module
this_mod forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Id
v)
(TagInfo -> TagSig
TagSig TagInfo
TagDunno)
case Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod (Id -> Name
idName Id
v) of
Bool
True
| Just Levity
Unlifted <- HasDebugCallStack => Type -> Maybe Levity
typeLevity_maybe (Id -> Type
idType Id
v)
-> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
| Bool
otherwise -> do
!UniqFM Id TagSig
s <- RM (UniqFM Id TagSig)
getMap
let !sig :: TagSig
sig = forall key elt.
Uniquable key =>
UniqFM key elt -> elt -> key -> elt
lookupWithDefaultUFM UniqFM Id TagSig
s (Id -> TagSig
lookupDefault Id
v) Id
v
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case TagSig
sig of
TagSig TagInfo
info ->
case TagInfo
info of
TagInfo
TagDunno -> Bool
False
TagInfo
TagProper -> Bool
True
TagInfo
TagTagged -> Bool
True
TagTuple [TagInfo]
_ -> Bool
True
Bool
False
| Just DataCon
con <- (Id -> Maybe DataCon
isDataConWorkId_maybe Id
v)
, DataCon -> Bool
isNullaryRepDataCon DataCon
con
-> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
| Just LambdaFormInfo
lf_info <- Id -> Maybe LambdaFormInfo
idLFInfo_maybe Id
v
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$!
case LambdaFormInfo
lf_info of
LFReEntrant {}
-> Bool
True
LFThunk {}
-> Bool
False
LFCon {}
-> Bool
True
LFUnknown {}
-> Bool
False
LFUnlifted {}
-> Bool
True
LFLetNoEscape {}
-> Bool
True
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isArgTagged :: StgArg -> RM Bool
isArgTagged :: StgArg -> RM Bool
isArgTagged (StgLitArg Literal
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isArgTagged (StgVarArg Id
v) = Id -> RM Bool
isTagged Id
v
mkLocalArgId :: Id -> RM Id
mkLocalArgId :: Id -> RM Id
mkLocalArgId Id
id = do
!Unique
u <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Id -> Unique -> Id
setIdUnique (Id -> Id
localiseId Id
id) Unique
u
rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding]
rewriteTopBinds :: Module
-> UniqSupply
-> [GenStgTopBinding 'InferTaggedBinders]
-> [TgStgTopBinding]
rewriteTopBinds Module
mod UniqSupply
us [GenStgTopBinding 'InferTaggedBinders]
binds =
let doBinds :: RM [TgStgTopBinding]
doBinds = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenStgTopBinding 'InferTaggedBinders -> RM TgStgTopBinding
rewriteTop [GenStgTopBinding 'InferTaggedBinders]
binds
in forall s a. State s a -> s -> a
evalState (forall a.
RM a -> State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a
unRM RM [TgStgTopBinding]
doBinds) (forall a. Monoid a => a
mempty, UniqSupply
us, Module
mod, forall a. Monoid a => a
mempty)
rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding
rewriteTop :: GenStgTopBinding 'InferTaggedBinders -> RM TgStgTopBinding
rewriteTop (StgTopStringLit Id
v ByteString
s) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass). Id -> ByteString -> GenStgTopBinding pass
StgTopStringLit Id
v ByteString
s)
rewriteTop (StgTopLifted GenStgBinding 'InferTaggedBinders
bind) = do
GenStgBinding 'InferTaggedBinders -> RM ()
addTopBind GenStgBinding 'InferTaggedBinders
bind
(forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted) forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (TopLevelFlag
-> GenStgBinding 'InferTaggedBinders -> RM TgStgBinding
rewriteBinds TopLevelFlag
TopLevel GenStgBinding 'InferTaggedBinders
bind)
rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)
rewriteBinds :: TopLevelFlag
-> GenStgBinding 'InferTaggedBinders -> RM TgStgBinding
rewriteBinds TopLevelFlag
_top_flag (StgNonRec BinderP 'InferTaggedBinders
v GenStgRhs 'InferTaggedBinders
rhs) = do
(!TgStgRhs
rhs) <- (Id, TagSig) -> GenStgRhs 'InferTaggedBinders -> RM TgStgRhs
rewriteRhs BinderP 'InferTaggedBinders
v GenStgRhs 'InferTaggedBinders
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec (forall a b. (a, b) -> a
fst BinderP 'InferTaggedBinders
v) TgStgRhs
rhs)
rewriteBinds TopLevelFlag
top_flag b :: GenStgBinding 'InferTaggedBinders
b@(StgRec [(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
binds) =
forall a.
TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a
withBind TopLevelFlag
top_flag GenStgBinding 'InferTaggedBinders
b forall a b. (a -> b) -> a -> b
$ do
([TgStgRhs]
rhss) <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Id, TagSig) -> GenStgRhs 'InferTaggedBinders -> RM TgStgRhs
rewriteRhs) [(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
binds
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ([TgStgRhs] -> TgStgBinding
mkRec [TgStgRhs]
rhss)
where
mkRec :: [TgStgRhs] -> TgStgBinding
mkRec :: [TgStgRhs] -> TgStgBinding
mkRec [TgStgRhs]
rhss = forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(BinderP 'InferTaggedBinders, GenStgRhs 'InferTaggedBinders)]
binds) [TgStgRhs]
rhss)
rewriteRhs :: (Id,TagSig) -> InferStgRhs
-> RM (TgStgRhs)
rewriteRhs :: (Id, TagSig) -> GenStgRhs 'InferTaggedBinders -> RM TgStgRhs
rewriteRhs (Id
_id, TagSig
_tagSig) (StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
cn [StgTickish]
ticks [StgArg]
args) = {-# SCC rewriteRhs_ #-} do
[Bool]
fieldInfos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StgArg -> RM Bool
isArgTagged [StgArg]
args
let strictFields :: [(StgArg, Bool)]
strictFields =
forall a. Outputable a => DataCon -> [a] -> [a]
getStrictConArgs DataCon
con (forall a b. [a] -> [b] -> [(a, b)]
zip [StgArg]
args [Bool]
fieldInfos) :: [(StgArg,Bool)]
let needsEval :: [StgArg]
needsEval = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
[(StgArg, Bool)]
strictFields :: [StgArg]
let evalArgs :: [Id]
evalArgs = [Id
v | StgVarArg Id
v <- [StgArg]
needsEval] :: [Id]
if (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
evalArgs)
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
cn [StgTickish]
ticks [StgArg]
args)
else do
let ty_stub :: a
ty_stub = forall a. HasCallStack => String -> a
panic String
"mkSeqs shouldn't use the type arg"
TgStgExpr
conExpr <- [StgArg] -> [Id] -> ([StgArg] -> TgStgExpr) -> RM TgStgExpr
mkSeqs [StgArg]
args [Id]
evalArgs (\[StgArg]
taggedArgs -> forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
con ConstructorNumber
cn [StgArg]
taggedArgs forall {a}. a
ty_stub)
DIdSet
fvs <- [StgArg] -> RM DIdSet
fvArgs [StgArg]
args
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure DIdSet
fvs CostCentreStack
ccs UpdateFlag
ReEntrant [] forall a b. (a -> b) -> a -> b
$! TgStgExpr
conExpr)
rewriteRhs (Id, TagSig)
_binding (StgRhsClosure XRhsClosure 'InferTaggedBinders
fvs CostCentreStack
ccs UpdateFlag
flag [BinderP 'InferTaggedBinders]
args GenStgExpr 'InferTaggedBinders
body) = do
forall a. TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a
withBinders TopLevelFlag
NotTopLevel [BinderP 'InferTaggedBinders]
args forall a b. (a -> b) -> a -> b
$
forall a. DIdSet -> RM a -> RM a
withClosureLcls XRhsClosure 'InferTaggedBinders
fvs forall a b. (a -> b) -> a -> b
$
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'InferTaggedBinders
fvs CostCentreStack
ccs UpdateFlag
flag (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [BinderP 'InferTaggedBinders]
args) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr GenStgExpr 'InferTaggedBinders
body
fvArgs :: [StgArg] -> RM DVarSet
fvArgs :: [StgArg] -> RM DIdSet
fvArgs [StgArg]
args = do
IdSet
fv_lcls <- RM IdSet
getFVs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Id] -> DIdSet
mkDVarSet [ Id
v | StgVarArg Id
v <- [StgArg]
args, Id -> IdSet -> Bool
elemVarSet Id
v IdSet
fv_lcls]
rewriteArgs :: [StgArg] -> RM [StgArg]
rewriteArgs :: [StgArg] -> RM [StgArg]
rewriteArgs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StgArg -> RM StgArg
rewriteArg
rewriteArg :: StgArg -> RM StgArg
rewriteArg :: StgArg -> RM StgArg
rewriteArg (StgVarArg Id
v) = Id -> StgArg
StgVarArg forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Id -> RM Id
rewriteId Id
v
rewriteArg (lit :: StgArg
lit@StgLitArg{}) = forall (m :: * -> *) a. Monad m => a -> m a
return StgArg
lit
rewriteId :: Id -> RM Id
rewriteId :: Id -> RM Id
rewriteId Id
v = do
!Bool
is_tagged <- Id -> RM Bool
isTagged Id
v
if Bool
is_tagged then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Id -> TagSig -> Id
setIdTagSig Id
v (TagInfo -> TagSig
TagSig TagInfo
TagProper)
else forall (m :: * -> *) a. Monad m => a -> m a
return Id
v
rewriteExpr :: InferStgExpr -> RM TgStgExpr
rewriteExpr :: GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr (e :: GenStgExpr 'InferTaggedBinders
e@StgCase {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteCase GenStgExpr 'InferTaggedBinders
e
rewriteExpr (e :: GenStgExpr 'InferTaggedBinders
e@StgLet {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteLet GenStgExpr 'InferTaggedBinders
e
rewriteExpr (e :: GenStgExpr 'InferTaggedBinders
e@StgLetNoEscape {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteLetNoEscape GenStgExpr 'InferTaggedBinders
e
rewriteExpr (StgTick StgTickish
t GenStgExpr 'InferTaggedBinders
e) = forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
t forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr GenStgExpr 'InferTaggedBinders
e
rewriteExpr e :: GenStgExpr 'InferTaggedBinders
e@(StgConApp {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteConApp GenStgExpr 'InferTaggedBinders
e
rewriteExpr e :: GenStgExpr 'InferTaggedBinders
e@(StgApp {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteApp GenStgExpr 'InferTaggedBinders
e
rewriteExpr (StgLit Literal
lit) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
lit)
rewriteExpr (StgOpApp op :: StgOp
op@(StgPrimOp PrimOp
DataToTagOp) [StgArg]
args Type
res_ty) = do
(forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op) forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [StgArg] -> RM [StgArg]
rewriteArgs [StgArg]
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
res_ty
rewriteExpr (StgOpApp StgOp
op [StgArg]
args Type
res_ty) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op [StgArg]
args Type
res_ty)
rewriteCase :: InferStgExpr -> RM TgStgExpr
rewriteCase :: GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteCase (StgCase GenStgExpr 'InferTaggedBinders
scrut BinderP 'InferTaggedBinders
bndr AltType
alt_type [GenStgAlt 'InferTaggedBinders]
alts) =
forall a. TopLevelFlag -> (Id, TagSig) -> RM a -> RM a
withBinder TopLevelFlag
NotTopLevel BinderP 'InferTaggedBinders
bndr forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr GenStgExpr 'InferTaggedBinders
scrut forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a, b) -> a
fst BinderP 'InferTaggedBinders
bndr) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
forall (f :: * -> *) a. Applicative f => a -> f a
pure AltType
alt_type forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenStgAlt 'InferTaggedBinders -> RM (GenStgAlt 'CodeGen)
rewriteAlt [GenStgAlt 'InferTaggedBinders]
alts
rewriteCase GenStgExpr 'InferTaggedBinders
_ = forall a. HasCallStack => String -> a
panic String
"Impossible: nodeCase"
rewriteAlt :: InferStgAlt -> RM TgStgAlt
rewriteAlt :: GenStgAlt 'InferTaggedBinders -> RM (GenStgAlt 'CodeGen)
rewriteAlt alt :: GenStgAlt 'InferTaggedBinders
alt@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
_, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'InferTaggedBinders]
bndrs, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'InferTaggedBinders
rhs} =
forall a. TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a
withBinders TopLevelFlag
NotTopLevel [BinderP 'InferTaggedBinders]
bndrs forall a b. (a -> b) -> a -> b
$ do
!TgStgExpr
rhs' <- GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr GenStgExpr 'InferTaggedBinders
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! GenStgAlt 'InferTaggedBinders
alt {alt_bndrs :: [BinderP 'CodeGen]
alt_bndrs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [BinderP 'InferTaggedBinders]
bndrs, alt_rhs :: TgStgExpr
alt_rhs = TgStgExpr
rhs'}
rewriteLet :: InferStgExpr -> RM TgStgExpr
rewriteLet :: GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteLet (StgLet XLet 'InferTaggedBinders
xt GenStgBinding 'InferTaggedBinders
bind GenStgExpr 'InferTaggedBinders
expr) = do
(!TgStgBinding
bind') <- TopLevelFlag
-> GenStgBinding 'InferTaggedBinders -> RM TgStgBinding
rewriteBinds TopLevelFlag
NotTopLevel GenStgBinding 'InferTaggedBinders
bind
forall a.
TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a
withBind TopLevelFlag
NotTopLevel GenStgBinding 'InferTaggedBinders
bind forall a b. (a -> b) -> a -> b
$ do
!TgStgExpr
expr' <- GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr GenStgExpr 'InferTaggedBinders
expr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'InferTaggedBinders
xt TgStgBinding
bind' TgStgExpr
expr')
rewriteLet GenStgExpr 'InferTaggedBinders
_ = forall a. HasCallStack => String -> a
panic String
"Impossible"
rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr
rewriteLetNoEscape :: GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteLetNoEscape (StgLetNoEscape XLetNoEscape 'InferTaggedBinders
xt GenStgBinding 'InferTaggedBinders
bind GenStgExpr 'InferTaggedBinders
expr) = do
(!TgStgBinding
bind') <- TopLevelFlag
-> GenStgBinding 'InferTaggedBinders -> RM TgStgBinding
rewriteBinds TopLevelFlag
NotTopLevel GenStgBinding 'InferTaggedBinders
bind
forall a.
TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a
withBind TopLevelFlag
NotTopLevel GenStgBinding 'InferTaggedBinders
bind forall a b. (a -> b) -> a -> b
$ do
!TgStgExpr
expr' <- GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr GenStgExpr 'InferTaggedBinders
expr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'InferTaggedBinders
xt TgStgBinding
bind' TgStgExpr
expr')
rewriteLetNoEscape GenStgExpr 'InferTaggedBinders
_ = forall a. HasCallStack => String -> a
panic String
"Impossible"
rewriteConApp :: InferStgExpr -> RM TgStgExpr
rewriteConApp :: GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteConApp (StgConApp DataCon
con ConstructorNumber
cn [StgArg]
args [Type]
tys) = do
[Bool]
fieldInfos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StgArg -> RM Bool
isArgTagged [StgArg]
args
let strictIndices :: [(Bool, StgArg)]
strictIndices = forall a. Outputable a => DataCon -> [a] -> [a]
getStrictConArgs DataCon
con (forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
fieldInfos [StgArg]
args) :: [(Bool, StgArg)]
let needsEval :: [StgArg]
needsEval = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ [(Bool, StgArg)]
strictIndices :: [StgArg]
let evalArgs :: [Id]
evalArgs = [Id
v | StgVarArg Id
v <- [StgArg]
needsEval] :: [Id]
if (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
evalArgs)
then do
[StgArg] -> [Id] -> ([StgArg] -> TgStgExpr) -> RM TgStgExpr
mkSeqs [StgArg]
args [Id]
evalArgs (\[StgArg]
taggedArgs -> forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
con ConstructorNumber
cn [StgArg]
taggedArgs [Type]
tys)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
con ConstructorNumber
cn [StgArg]
args [Type]
tys)
rewriteConApp GenStgExpr 'InferTaggedBinders
_ = forall a. HasCallStack => String -> a
panic String
"Impossible"
rewriteApp :: InferStgExpr -> RM TgStgExpr
rewriteApp :: GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteApp (StgApp Id
f []) = do
Id
f' <- Id -> RM Id
rewriteId Id
f
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f' []
rewriteApp (StgApp Id
f [StgArg]
args)
| Just [CbvMark]
marks <- Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
f
, [CbvMark]
relevant_marks <- forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CbvMark -> Bool
isMarkedCbv) [CbvMark]
marks
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CbvMark -> Bool
isMarkedCbv [CbvMark]
relevant_marks
= forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [CbvMark]
relevant_marks forall a. Ord a => a -> a -> Bool
<= forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args) (forall a. Outputable a => a -> SDoc
ppr Id
f forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [StgArg]
args forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [CbvMark]
relevant_marks)
[CbvMark] -> RM TgStgExpr
unliftArg [CbvMark]
relevant_marks
where
unliftArg :: [CbvMark] -> RM TgStgExpr
unliftArg [CbvMark]
relevant_marks = do
[Bool]
argTags <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StgArg -> RM Bool
isArgTagged [StgArg]
args
let argInfo :: [(StgArg, CbvMark, Bool)]
argInfo = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 ((,,)) [StgArg]
args ([CbvMark]
relevant_marksforall a. [a] -> [a] -> [a]
++forall a. a -> [a]
repeat CbvMark
NotMarkedCbv) [Bool]
argTags :: [(StgArg, CbvMark, Bool)]
cbvArgInfo :: [(StgArg, CbvMark, Bool)]
cbvArgInfo = forall a. (a -> Bool) -> [a] -> [a]
filter (\(StgArg, CbvMark, Bool)
x -> forall a b c. (a, b, c) -> b
sndOf3 (StgArg, CbvMark, Bool)
x forall a. Eq a => a -> a -> Bool
== CbvMark
MarkedCbv Bool -> Bool -> Bool
&& forall a b c. (a, b, c) -> c
thdOf3 (StgArg, CbvMark, Bool)
x forall a. Eq a => a -> a -> Bool
== Bool
False) [(StgArg, CbvMark, Bool)]
argInfo
cbvArgIds :: [Id]
cbvArgIds = [Id
x | StgVarArg Id
x <- forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> a
fstOf3 [(StgArg, CbvMark, Bool)]
cbvArgInfo] :: [Id]
[StgArg] -> [Id] -> ([StgArg] -> TgStgExpr) -> RM TgStgExpr
mkSeqs [StgArg]
args [Id]
cbvArgIds (\[StgArg]
cbv_args -> forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f [StgArg]
cbv_args)
rewriteApp (StgApp Id
f [StgArg]
args) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f [StgArg]
args
rewriteApp GenStgExpr 'InferTaggedBinders
_ = forall a. HasCallStack => String -> a
panic String
"Impossible"
mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr
mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr
mkSeq Id
id Id
bndr !TgStgExpr
expr =
let altTy :: AltType
altTy = forall (p :: StgPass). Id -> [GenStgAlt p] -> AltType
mkStgAltTypeFromStgAlts Id
bndr [GenStgAlt 'CodeGen]
alt
alt :: [GenStgAlt 'CodeGen]
alt = [GenStgAlt {alt_con :: AltCon
alt_con = AltCon
DEFAULT, alt_bndrs :: [BinderP 'CodeGen]
alt_bndrs = [], alt_rhs :: TgStgExpr
alt_rhs = TgStgExpr
expr}]
in forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase (forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
id []) Id
bndr AltType
altTy [GenStgAlt 'CodeGen]
alt
{-# INLINE mkSeqs #-}
mkSeqs :: [StgArg]
-> [Id]
-> ([StgArg] -> TgStgExpr)
-> RM TgStgExpr
mkSeqs :: [StgArg] -> [Id] -> ([StgArg] -> TgStgExpr) -> RM TgStgExpr
mkSeqs [StgArg]
args [Id]
untaggedIds [StgArg] -> TgStgExpr
mkExpr = do
[(Id, Id)]
argMap <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Id
arg -> (Id
arg,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> RM Id
mkLocalArgId Id
arg ) [Id]
untaggedIds :: RM [(InId, OutId)]
let [StgArg]
taggedArgs :: [StgArg]
= forall a b. (a -> b) -> [a] -> [b]
map (\StgArg
v -> case StgArg
v of
StgVarArg Id
v' -> Id -> StgArg
StgVarArg forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Id
v' forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Id
v' [(Id, Id)]
argMap
StgArg
lit -> StgArg
lit)
[StgArg]
args
let conBody :: TgStgExpr
conBody = [StgArg] -> TgStgExpr
mkExpr [StgArg]
taggedArgs
let body :: TgStgExpr
body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Id
v,Id
bndr) TgStgExpr
expr -> Id -> Id -> TgStgExpr -> TgStgExpr
mkSeq Id
v Id
bndr TgStgExpr
expr) TgStgExpr
conBody [(Id, Id)]
argMap
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TgStgExpr
body
getStrictConArgs :: Outputable a => DataCon -> [a] -> [a]
getStrictConArgs :: forall a. Outputable a => DataCon -> [a] -> [a]
getStrictConArgs DataCon
con [a]
args
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con = []
| DataCon -> Bool
isUnboxedSumDataCon DataCon
con = []
| Bool
otherwise =
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
args forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length (HasDebugCallStack => DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
con))
(forall doc. IsLine doc => String -> doc
text String
"Mismatched con arg and con rep strictness lengths:" forall doc. IsDoc doc => doc -> doc -> doc
$$
forall doc. IsLine doc => String -> doc
text String
"Con" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr DataCon
con forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"is applied to" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [a]
args forall doc. IsDoc doc => doc -> doc -> doc
$$
forall doc. IsLine doc => String -> doc
text String
"But seems to have arity" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrictnessMark]
repStrictness)) forall a b. (a -> b) -> a -> b
$
[ a
arg | (a
arg,StrictnessMark
MarkedStrict)
<- forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"getStrictConArgs"
[a]
args
[StrictnessMark]
repStrictness]
where
repStrictness :: [StrictnessMark]
repStrictness = (HasDebugCallStack => DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
con)