{-# 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.Types.Id
import GHC.Types.Name
import GHC.Types.Unique.Supply
import GHC.Types.Unique.FM
import GHC.Types.RepType
import GHC.Unit.Types (Module, isInteractiveModule)
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.Panic.Plain
import GHC.Utils.Outputable
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Misc
import GHC.Stg.InferTags.Types
import Control.Monad
import GHC.Types.Basic (CbvMark (NotMarkedCbv, MarkedCbv), isMarkedCbv, TopLevelFlag(..), isTopLevel)
import GHC.Types.Var.Set
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)
(String -> SDoc
text String
"unknown Id:" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Module
this_mod SDoc -> SDoc -> SDoc
<+> 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
| HasDebugCallStack => Type -> Bool
isUnliftedType (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. 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. 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
<$> Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr Bool
False 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]
type IsScrut = Bool
rewriteExpr :: IsScrut -> InferStgExpr -> RM TgStgExpr
rewriteExpr :: Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr Bool
_ (e :: GenStgExpr 'InferTaggedBinders
e@StgCase {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteCase GenStgExpr 'InferTaggedBinders
e
rewriteExpr Bool
_ (e :: GenStgExpr 'InferTaggedBinders
e@StgLet {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteLet GenStgExpr 'InferTaggedBinders
e
rewriteExpr Bool
_ (e :: GenStgExpr 'InferTaggedBinders
e@StgLetNoEscape {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteLetNoEscape GenStgExpr 'InferTaggedBinders
e
rewriteExpr Bool
isScrut (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
<$!> Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr Bool
isScrut GenStgExpr 'InferTaggedBinders
e
rewriteExpr Bool
_ e :: GenStgExpr 'InferTaggedBinders
e@(StgConApp {}) = GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteConApp GenStgExpr 'InferTaggedBinders
e
rewriteExpr Bool
isScrut e :: GenStgExpr 'InferTaggedBinders
e@(StgApp {}) = Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteApp Bool
isScrut GenStgExpr 'InferTaggedBinders
e
rewriteExpr Bool
_ (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 Bool
_ (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
<*>
Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr Bool
True 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. 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' <- Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr Bool
False 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' <- Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr Bool
False 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. 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' <- Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteExpr Bool
False 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. 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. 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. String -> a
panic String
"Impossible"
rewriteApp :: IsScrut -> InferStgExpr -> RM TgStgExpr
rewriteApp :: Bool -> GenStgExpr 'InferTaggedBinders -> RM TgStgExpr
rewriteApp Bool
True (StgApp Id
f []) = do
Bool
f_tagged <- Id -> RM Bool
isTagged Id
f
let f' :: Id
f' = if Bool
f_tagged
then Id -> TagSig -> Id
setIdTagSig Id
f (TagInfo -> TagSig
TagSig TagInfo
TagProper)
else 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 Bool
_ (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 -> a -> a
assert (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)
[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 Bool
_ (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 Bool
_ GenStgExpr 'InferTaggedBinders
_ = forall a. 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 :: DataCon -> [a] -> [a]
getStrictConArgs :: forall a. DataCon -> [a] -> [a]
getStrictConArgs DataCon
con [a]
args
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con = []
| DataCon -> Bool
isUnboxedSumDataCon DataCon
con = []
| Bool
otherwise =
[ a
arg | (a
arg,StrictnessMark
MarkedStrict)
<- forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"getStrictConArgs"
[a]
args
(HasDebugCallStack => DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
con)]