{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
module GHC.StgToJS.Sinker (sinkPgm) where
import GHC.Prelude
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import GHC.Types.Var.Set
import GHC.Stg.Syntax
import GHC.Types.Id
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Types.Literal
import GHC.Data.Graph.Directed
import GHC.StgToJS.CoreUtils
import Data.Char
import Data.Either
import Data.List (partition)
import Data.Maybe
sinkPgm :: Module
-> [CgStgTopBinding]
-> (UniqFM Id CgStgExpr, [CgStgTopBinding])
sinkPgm :: Module
-> [CgStgTopBinding] -> (UniqFM Id CgStgExpr, [CgStgTopBinding])
sinkPgm Module
m [CgStgTopBinding]
pgm = (UniqFM Id CgStgExpr
sunk, (GenStgBinding 'CodeGen -> CgStgTopBinding)
-> [GenStgBinding 'CodeGen] -> [CgStgTopBinding]
forall a b. (a -> b) -> [a] -> [b]
map GenStgBinding 'CodeGen -> CgStgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted [GenStgBinding 'CodeGen]
pgm'' [CgStgTopBinding] -> [CgStgTopBinding] -> [CgStgTopBinding]
forall a. [a] -> [a] -> [a]
++ [CgStgTopBinding]
stringLits)
where
selectLifted :: GenStgTopBinding pass
-> Either (GenStgBinding pass) (GenStgTopBinding pass)
selectLifted (StgTopLifted GenStgBinding pass
b) = GenStgBinding pass
-> Either (GenStgBinding pass) (GenStgTopBinding pass)
forall a b. a -> Either a b
Left GenStgBinding pass
b
selectLifted GenStgTopBinding pass
x = GenStgTopBinding pass
-> Either (GenStgBinding pass) (GenStgTopBinding pass)
forall a b. b -> Either a b
Right GenStgTopBinding pass
x
([GenStgBinding 'CodeGen]
pgm', [CgStgTopBinding]
stringLits) = [Either (GenStgBinding 'CodeGen) CgStgTopBinding]
-> ([GenStgBinding 'CodeGen], [CgStgTopBinding])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((CgStgTopBinding
-> Either (GenStgBinding 'CodeGen) CgStgTopBinding)
-> [CgStgTopBinding]
-> [Either (GenStgBinding 'CodeGen) CgStgTopBinding]
forall a b. (a -> b) -> [a] -> [b]
map CgStgTopBinding -> Either (GenStgBinding 'CodeGen) CgStgTopBinding
forall {pass :: StgPass}.
GenStgTopBinding pass
-> Either (GenStgBinding pass) (GenStgTopBinding pass)
selectLifted [CgStgTopBinding]
pgm)
(UniqFM Id CgStgExpr
sunk, [GenStgBinding 'CodeGen]
pgm'') = Module
-> [GenStgBinding 'CodeGen]
-> (UniqFM Id CgStgExpr, [GenStgBinding 'CodeGen])
sinkPgm' Module
m [GenStgBinding 'CodeGen]
pgm'
sinkPgm'
:: Module
-> [CgStgBinding]
-> (UniqFM Id CgStgExpr, [CgStgBinding])
sinkPgm' :: Module
-> [GenStgBinding 'CodeGen]
-> (UniqFM Id CgStgExpr, [GenStgBinding 'CodeGen])
sinkPgm' Module
m [GenStgBinding 'CodeGen]
pgm =
let usedOnce :: IdSet
usedOnce = [GenStgBinding 'CodeGen] -> IdSet
collectUsedOnce [GenStgBinding 'CodeGen]
pgm
sinkables :: UniqFM Id CgStgExpr
sinkables = [(Id, CgStgExpr)] -> UniqFM Id CgStgExpr
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM ([(Id, CgStgExpr)] -> UniqFM Id CgStgExpr)
-> [(Id, CgStgExpr)] -> UniqFM Id CgStgExpr
forall a b. (a -> b) -> a -> b
$
(GenStgBinding 'CodeGen -> [(Id, CgStgExpr)])
-> [GenStgBinding 'CodeGen] -> [(Id, CgStgExpr)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenStgBinding 'CodeGen -> [(Id, CgStgExpr)]
alwaysSinkable [GenStgBinding 'CodeGen]
pgm [(Id, CgStgExpr)] -> [(Id, CgStgExpr)] -> [(Id, CgStgExpr)]
forall a. [a] -> [a] -> [a]
++
((Id, CgStgExpr) -> Bool) -> [(Id, CgStgExpr)] -> [(Id, CgStgExpr)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Id -> IdSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` IdSet
usedOnce) (Id -> Bool) -> ((Id, CgStgExpr) -> Id) -> (Id, CgStgExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, CgStgExpr) -> Id
forall a b. (a, b) -> a
fst) ((GenStgBinding 'CodeGen -> [(Id, CgStgExpr)])
-> [GenStgBinding 'CodeGen] -> [(Id, CgStgExpr)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Module -> GenStgBinding 'CodeGen -> [(Id, CgStgExpr)]
onceSinkable Module
m) [GenStgBinding 'CodeGen]
pgm)
isSunkBind :: GenStgBinding 'CodeGen -> Bool
isSunkBind (StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
_e) | Id -> UniqFM Id CgStgExpr -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM Id
BinderP 'CodeGen
b UniqFM Id CgStgExpr
sinkables = Bool
True
isSunkBind GenStgBinding 'CodeGen
_ = Bool
False
in (UniqFM Id CgStgExpr
sinkables, (GenStgBinding 'CodeGen -> Bool)
-> [GenStgBinding 'CodeGen] -> [GenStgBinding 'CodeGen]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (GenStgBinding 'CodeGen -> Bool)
-> GenStgBinding 'CodeGen
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgBinding 'CodeGen -> Bool
isSunkBind) ([GenStgBinding 'CodeGen] -> [GenStgBinding 'CodeGen])
-> [GenStgBinding 'CodeGen] -> [GenStgBinding 'CodeGen]
forall a b. (a -> b) -> a -> b
$ Module -> [GenStgBinding 'CodeGen] -> [GenStgBinding 'CodeGen]
topSortDecls Module
m [GenStgBinding 'CodeGen]
pgm)
alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)]
alwaysSinkable :: GenStgBinding 'CodeGen -> [(Id, CgStgExpr)]
alwaysSinkable (StgRec {}) = []
alwaysSinkable (StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
rhs) = case GenStgRhs 'CodeGen
rhs of
StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
_ e :: CgStgExpr
e@(StgLit Literal
l)
| Literal -> Bool
isSmallSinkableLit Literal
l
, Id -> Bool
isLocal Id
BinderP 'CodeGen
b
-> [(Id
BinderP 'CodeGen
b,CgStgExpr
e)]
StgRhsCon CostCentreStack
_ccs DataCon
dc ConstructorNumber
cnum [StgTickish]
_ticks as :: [StgArg]
as@[StgLitArg Literal
l]
| Literal -> Bool
isSmallSinkableLit Literal
l
, Id -> Bool
isLocal Id
BinderP 'CodeGen
b
, DataCon -> Bool
isUnboxableCon DataCon
dc
-> [(Id
BinderP 'CodeGen
b,DataCon -> ConstructorNumber -> [StgArg] -> [Type] -> CgStgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
cnum [StgArg]
as [])]
GenStgRhs 'CodeGen
_ -> []
isSmallSinkableLit :: Literal -> Bool
isSmallSinkableLit :: Literal -> Bool
isSmallSinkableLit (LitChar Char
c) = Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100000
isSmallSinkableLit (LitNumber LitNumType
_ Integer
i) = Integer -> Integer
forall a. Num a => a -> a
abs Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
100000
isSmallSinkableLit Literal
_ = Bool
False
onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)]
onceSinkable :: Module -> GenStgBinding 'CodeGen -> [(Id, CgStgExpr)]
onceSinkable Module
_m (StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
rhs)
| Just CgStgExpr
e <- GenStgRhs 'CodeGen -> Maybe CgStgExpr
forall {pass :: StgPass}. GenStgRhs pass -> Maybe (GenStgExpr pass)
getSinkable GenStgRhs 'CodeGen
rhs
, Id -> Bool
isLocal Id
BinderP 'CodeGen
b = [(Id
BinderP 'CodeGen
b,CgStgExpr
e)]
where
getSinkable :: GenStgRhs pass -> Maybe (GenStgExpr pass)
getSinkable = \case
StgRhsCon CostCentreStack
_ccs DataCon
dc ConstructorNumber
cnum [StgTickish]
_ticks [StgArg]
args -> GenStgExpr pass -> Maybe (GenStgExpr pass)
forall a. a -> Maybe a
Just (DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
cnum [StgArg]
args [])
StgRhsClosure XRhsClosure pass
_ CostCentreStack
_ UpdateFlag
_ [BinderP pass]
_ e :: GenStgExpr pass
e@(StgLit{}) -> GenStgExpr pass -> Maybe (GenStgExpr pass)
forall a. a -> Maybe a
Just GenStgExpr pass
e
GenStgRhs pass
_ -> Maybe (GenStgExpr pass)
forall a. Maybe a
Nothing
onceSinkable Module
_ GenStgBinding 'CodeGen
_ = []
collectUsedOnce :: [CgStgBinding] -> IdSet
collectUsedOnce :: [GenStgBinding 'CodeGen] -> IdSet
collectUsedOnce [GenStgBinding 'CodeGen]
binds = IdSet -> IdSet -> IdSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets ([Id] -> IdSet
usedOnce [Id]
args) ([Id] -> IdSet
usedOnce [Id]
top_args)
where
top_args :: [Id]
top_args = (GenStgBinding 'CodeGen -> [Id])
-> [GenStgBinding 'CodeGen] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenStgBinding 'CodeGen -> [Id]
collectArgsTop [GenStgBinding 'CodeGen]
binds
args :: [Id]
args = (GenStgBinding 'CodeGen -> [Id])
-> [GenStgBinding 'CodeGen] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenStgBinding 'CodeGen -> [Id]
collectArgs [GenStgBinding 'CodeGen]
binds
usedOnce :: [Id] -> IdSet
usedOnce = (IdSet, IdSet) -> IdSet
forall a b. (a, b) -> a
fst ((IdSet, IdSet) -> IdSet)
-> ([Id] -> (IdSet, IdSet)) -> [Id] -> IdSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id -> (IdSet, IdSet) -> (IdSet, IdSet))
-> (IdSet, IdSet) -> [Id] -> (IdSet, IdSet)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> (IdSet, IdSet) -> (IdSet, IdSet)
forall {a}.
Uniquable a =>
a -> (UniqSet a, UniqSet a) -> (UniqSet a, UniqSet a)
g (IdSet
forall a. UniqSet a
emptyUniqSet, IdSet
forall a. UniqSet a
emptyUniqSet)
g :: a -> (UniqSet a, UniqSet a) -> (UniqSet a, UniqSet a)
g a
i t :: (UniqSet a, UniqSet a)
t@(UniqSet a
once, UniqSet a
mult)
| a
i a -> UniqSet a -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet a
mult = (UniqSet a, UniqSet a)
t
| a
i a -> UniqSet a -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet a
once
= (UniqSet a -> a -> UniqSet a
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet a
once a
i, UniqSet a -> a -> UniqSet a
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet a
mult a
i)
| Bool
otherwise = (UniqSet a -> a -> UniqSet a
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet a
once a
i, UniqSet a
mult)
collectArgsTop :: CgStgBinding -> [Id]
collectArgsTop :: GenStgBinding 'CodeGen -> [Id]
collectArgsTop = \case
StgNonRec BinderP 'CodeGen
_b GenStgRhs 'CodeGen
r -> GenStgRhs 'CodeGen -> [Id]
collectArgsTopRhs GenStgRhs 'CodeGen
r
StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs -> ((Id, GenStgRhs 'CodeGen) -> [Id])
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenStgRhs 'CodeGen -> [Id]
collectArgsTopRhs (GenStgRhs 'CodeGen -> [Id])
-> ((Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen)
-> (Id, GenStgRhs 'CodeGen)
-> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen
forall a b. (a, b) -> b
snd) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
collectArgsTopRhs :: CgStgRhs -> [Id]
collectArgsTopRhs :: GenStgRhs 'CodeGen -> [Id]
collectArgsTopRhs = \case
StgRhsCon CostCentreStack
_ccs DataCon
_dc ConstructorNumber
_mu [StgTickish]
_ticks [StgArg]
args -> (StgArg -> [Id]) -> [StgArg] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap StgArg -> [Id]
collectArgsA [StgArg]
args
StgRhsClosure {} -> []
collectArgs :: CgStgBinding -> [Id]
collectArgs :: GenStgBinding 'CodeGen -> [Id]
collectArgs = \case
StgNonRec BinderP 'CodeGen
_b GenStgRhs 'CodeGen
r -> GenStgRhs 'CodeGen -> [Id]
collectArgsR GenStgRhs 'CodeGen
r
StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs -> ((Id, GenStgRhs 'CodeGen) -> [Id])
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenStgRhs 'CodeGen -> [Id]
collectArgsR (GenStgRhs 'CodeGen -> [Id])
-> ((Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen)
-> (Id, GenStgRhs 'CodeGen)
-> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen
forall a b. (a, b) -> b
snd) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
collectArgsR :: CgStgRhs -> [Id]
collectArgsR :: GenStgRhs 'CodeGen -> [Id]
collectArgsR = \case
StgRhsClosure XRhsClosure 'CodeGen
_x0 CostCentreStack
_x1 UpdateFlag
_x2 [BinderP 'CodeGen]
_x3 CgStgExpr
e -> CgStgExpr -> [Id]
collectArgsE CgStgExpr
e
StgRhsCon CostCentreStack
_ccs DataCon
_con ConstructorNumber
_mu [StgTickish]
_ticks [StgArg]
args -> (StgArg -> [Id]) -> [StgArg] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap StgArg -> [Id]
collectArgsA [StgArg]
args
collectArgsAlt :: CgStgAlt -> [Id]
collectArgsAlt :: CgStgAlt -> [Id]
collectArgsAlt CgStgAlt
alt = CgStgExpr -> [Id]
collectArgsE (CgStgAlt -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs CgStgAlt
alt)
collectArgsE :: CgStgExpr -> [Id]
collectArgsE :: CgStgExpr -> [Id]
collectArgsE = \case
StgApp Id
x [StgArg]
args
-> Id
x Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: (StgArg -> [Id]) -> [StgArg] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap StgArg -> [Id]
collectArgsA [StgArg]
args
StgConApp DataCon
_con ConstructorNumber
_mn [StgArg]
args [Type]
_ts
-> (StgArg -> [Id]) -> [StgArg] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap StgArg -> [Id]
collectArgsA [StgArg]
args
StgOpApp StgOp
_x [StgArg]
args Type
_t
-> (StgArg -> [Id]) -> [StgArg] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap StgArg -> [Id]
collectArgsA [StgArg]
args
StgCase CgStgExpr
e BinderP 'CodeGen
_b AltType
_a [CgStgAlt]
alts
-> CgStgExpr -> [Id]
collectArgsE CgStgExpr
e [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (CgStgAlt -> [Id]) -> [CgStgAlt] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CgStgAlt -> [Id]
collectArgsAlt [CgStgAlt]
alts
StgLet XLet 'CodeGen
_x GenStgBinding 'CodeGen
b CgStgExpr
e
-> GenStgBinding 'CodeGen -> [Id]
collectArgs GenStgBinding 'CodeGen
b [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ CgStgExpr -> [Id]
collectArgsE CgStgExpr
e
StgLetNoEscape XLetNoEscape 'CodeGen
_x GenStgBinding 'CodeGen
b CgStgExpr
e
-> GenStgBinding 'CodeGen -> [Id]
collectArgs GenStgBinding 'CodeGen
b [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ CgStgExpr -> [Id]
collectArgsE CgStgExpr
e
StgTick StgTickish
_i CgStgExpr
e
-> CgStgExpr -> [Id]
collectArgsE CgStgExpr
e
StgLit Literal
_
-> []
collectArgsA :: StgArg -> [Id]
collectArgsA :: StgArg -> [Id]
collectArgsA = \case
StgVarArg Id
i -> [Id
i]
StgLitArg Literal
_ -> []
isLocal :: Id -> Bool
isLocal :: Id -> Bool
isLocal Id
i = Maybe Module -> Bool
forall a. Maybe a -> Bool
isNothing (Name -> Maybe Module
nameModule_maybe (Name -> Maybe Module) -> (Id -> Name) -> Id -> Maybe Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
idName (Id -> Maybe Module) -> Id -> Maybe Module
forall a b. (a -> b) -> a -> b
$ Id
i) Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isExportedId Id
i)
topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding]
topSortDecls :: Module -> [GenStgBinding 'CodeGen] -> [GenStgBinding 'CodeGen]
topSortDecls Module
_m [GenStgBinding 'CodeGen]
binds = [GenStgBinding 'CodeGen]
rest [GenStgBinding 'CodeGen]
-> [GenStgBinding 'CodeGen] -> [GenStgBinding 'CodeGen]
forall a. [a] -> [a] -> [a]
++ [GenStgBinding 'CodeGen]
nr'
where
([GenStgBinding 'CodeGen]
nr, [GenStgBinding 'CodeGen]
rest) = (GenStgBinding 'CodeGen -> Bool)
-> [GenStgBinding 'CodeGen]
-> ([GenStgBinding 'CodeGen], [GenStgBinding 'CodeGen])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition GenStgBinding 'CodeGen -> Bool
forall {pass :: StgPass}. GenStgBinding pass -> Bool
isNonRec [GenStgBinding 'CodeGen]
binds
isNonRec :: GenStgBinding pass -> Bool
isNonRec StgNonRec{} = Bool
True
isNonRec GenStgBinding pass
_ = Bool
False
vs :: [Node Id (GenStgBinding 'CodeGen)]
vs = (GenStgBinding 'CodeGen -> Node Id (GenStgBinding 'CodeGen))
-> [GenStgBinding 'CodeGen] -> [Node Id (GenStgBinding 'CodeGen)]
forall a b. (a -> b) -> [a] -> [b]
map GenStgBinding 'CodeGen -> Node Id (GenStgBinding 'CodeGen)
GenStgBinding 'CodeGen
-> Node (BinderP 'CodeGen) (GenStgBinding 'CodeGen)
forall {pass :: StgPass}.
GenStgBinding pass -> Node (BinderP pass) (GenStgBinding pass)
getV [GenStgBinding 'CodeGen]
nr
keys :: IdSet
keys = [Id] -> IdSet
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ((Node Id (GenStgBinding 'CodeGen) -> Id)
-> [Node Id (GenStgBinding 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Node Id (GenStgBinding 'CodeGen) -> Id
forall key payload. Node key payload -> key
node_key [Node Id (GenStgBinding 'CodeGen)]
vs)
getV :: GenStgBinding pass -> Node (BinderP pass) (GenStgBinding pass)
getV e :: GenStgBinding pass
e@(StgNonRec BinderP pass
b GenStgRhs pass
_) = GenStgBinding pass
-> BinderP pass
-> [BinderP pass]
-> Node (BinderP pass) (GenStgBinding pass)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenStgBinding pass
e BinderP pass
b []
getV GenStgBinding pass
_ = [Char] -> Node (BinderP pass) (GenStgBinding pass)
forall a. HasCallStack => [Char] -> a
error [Char]
"topSortDecls: getV, unexpected binding"
collectDeps :: GenStgBinding 'CodeGen -> [(Id, Id)]
collectDeps (StgNonRec BinderP 'CodeGen
b (StgRhsCon CostCentreStack
_cc DataCon
_dc ConstructorNumber
_cnum [StgTickish]
_ticks [StgArg]
args)) =
[ (Id
i, Id
BinderP 'CodeGen
b) | StgVarArg Id
i <- [StgArg]
args, Id
i Id -> IdSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` IdSet
keys ]
collectDeps GenStgBinding 'CodeGen
_ = []
g :: Graph (Node Id (GenStgBinding 'CodeGen))
g = [Node Id (GenStgBinding 'CodeGen)]
-> [(Id, Id)] -> Graph (Node Id (GenStgBinding 'CodeGen))
forall key payload.
Ord key =>
[Node key payload] -> [(key, key)] -> Graph (Node key payload)
graphFromVerticesAndAdjacency [Node Id (GenStgBinding 'CodeGen)]
vs ((GenStgBinding 'CodeGen -> [(Id, Id)])
-> [GenStgBinding 'CodeGen] -> [(Id, Id)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenStgBinding 'CodeGen -> [(Id, Id)]
collectDeps [GenStgBinding 'CodeGen]
nr)
nr' :: [GenStgBinding 'CodeGen]
nr' | (Bool -> Bool
not (Bool -> Bool) -> ([()] -> Bool) -> [()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [()| CyclicSCC [Node Id (GenStgBinding 'CodeGen)]
_ <- Graph (Node Id (GenStgBinding 'CodeGen))
-> [SCC (Node Id (GenStgBinding 'CodeGen))]
forall node. Graph node -> [SCC node]
stronglyConnCompG Graph (Node Id (GenStgBinding 'CodeGen))
g]
= [Char] -> [GenStgBinding 'CodeGen]
forall a. HasCallStack => [Char] -> a
error [Char]
"topSortDecls: unexpected cycle"
| Bool
otherwise = (Node Id (GenStgBinding 'CodeGen) -> GenStgBinding 'CodeGen)
-> [Node Id (GenStgBinding 'CodeGen)] -> [GenStgBinding 'CodeGen]
forall a b. (a -> b) -> [a] -> [b]
map Node Id (GenStgBinding 'CodeGen) -> GenStgBinding 'CodeGen
forall key payload. Node key payload -> payload
node_payload (Graph (Node Id (GenStgBinding 'CodeGen))
-> [Node Id (GenStgBinding 'CodeGen)]
forall node. Graph node -> [node]
topologicalSortG Graph (Node Id (GenStgBinding 'CodeGen))
g)