{-# 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.Utils

import Data.Char
import Data.Either
import Data.List (partition)
import Data.Maybe


-- | Unfloat some top-level unexported things
--
-- GHC floats constants to the top level. This is fine in native code, but with JS
-- they occupy some global variable name. We can unfloat some unexported things:
--
-- - global constructors, as long as they're referenced only once by another global
--      constructor and are not in a recursive binding group
-- - literals (small literals may also be sunk if they are used more than once)
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
       -- ^ the module, since we treat definitions from the current module
       -- differently
  -> [CgStgBinding]
       -- ^ the bindings
  -> (UniqFM Id CgStgExpr, [CgStgBinding])
       -- ^ a map with sunken replacements for nodes, for where the replacement
       -- does not fit in the 'StgBinding' AST and the new bindings
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)

-- | always sinkable, values that may be duplicated in the generated code (e.g.
-- small literals)
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) Type
_
    | 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] Type
_typ
    | 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


-- | once sinkable: may be sunk, but duplication is not ok
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 Type
_typ -> 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{}) Type
_typ -> 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
_ = []

-- | collect all idents used only once in an argument at the top level
--   and never anywhere else
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)

-- | fold over all id in StgArg used at the top level in an StgRhsCon
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 Type
_typ -> (StgArg -> [Id]) -> [StgArg] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap StgArg -> [Id]
collectArgsA [StgArg]
args
  StgRhsClosure {}                        -> []

-- | fold over all Id in StgArg in the AST
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 Type
_typ     -> CgStgExpr -> [Id]
collectArgsE CgStgExpr
e
  StgRhsCon CostCentreStack
_ccs DataCon
_con ConstructorNumber
_mu [StgTickish]
_ticks [StgArg]
args Type
_typ -> (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)

-- | since we have sequential initialization, topsort the non-recursive
-- constructor bindings
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 Type
_typ)) =
      [ (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)