{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module GHC.Cmm.Info.Build
( CAFSet, CAFEnv, cafAnal, cafAnalData
, doSRTs, ModuleSRTInfo (..), emptySRT
, SRTMap, srtMapNonCAFs
) where
import GHC.Prelude hiding (succ)
import GHC.Platform
import GHC.Platform.Profile
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow
import GHC.Unit.Module
import GHC.Data.Graph.Directed
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Driver.Session
import GHC.Data.Maybe
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Runtime.Heap.Layout
import GHC.Types.Unique.Supply
import GHC.Types.CostCentre
import GHC.StgToCmm.Heap
import GHC.CmmToAsm
import Control.Monad
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.List (unzip4)
import GHC.Types.Name.Set
newtype CAFLabel = CAFLabel CLabel
deriving (CAFLabel -> CAFLabel -> Bool
(CAFLabel -> CAFLabel -> Bool)
-> (CAFLabel -> CAFLabel -> Bool) -> Eq CAFLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CAFLabel -> CAFLabel -> Bool
$c/= :: CAFLabel -> CAFLabel -> Bool
== :: CAFLabel -> CAFLabel -> Bool
$c== :: CAFLabel -> CAFLabel -> Bool
Eq,Eq CAFLabel
Eq CAFLabel
-> (CAFLabel -> CAFLabel -> Ordering)
-> (CAFLabel -> CAFLabel -> Bool)
-> (CAFLabel -> CAFLabel -> Bool)
-> (CAFLabel -> CAFLabel -> Bool)
-> (CAFLabel -> CAFLabel -> Bool)
-> (CAFLabel -> CAFLabel -> CAFLabel)
-> (CAFLabel -> CAFLabel -> CAFLabel)
-> Ord CAFLabel
CAFLabel -> CAFLabel -> Bool
CAFLabel -> CAFLabel -> Ordering
CAFLabel -> CAFLabel -> CAFLabel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CAFLabel -> CAFLabel -> CAFLabel
$cmin :: CAFLabel -> CAFLabel -> CAFLabel
max :: CAFLabel -> CAFLabel -> CAFLabel
$cmax :: CAFLabel -> CAFLabel -> CAFLabel
>= :: CAFLabel -> CAFLabel -> Bool
$c>= :: CAFLabel -> CAFLabel -> Bool
> :: CAFLabel -> CAFLabel -> Bool
$c> :: CAFLabel -> CAFLabel -> Bool
<= :: CAFLabel -> CAFLabel -> Bool
$c<= :: CAFLabel -> CAFLabel -> Bool
< :: CAFLabel -> CAFLabel -> Bool
$c< :: CAFLabel -> CAFLabel -> Bool
compare :: CAFLabel -> CAFLabel -> Ordering
$ccompare :: CAFLabel -> CAFLabel -> Ordering
$cp1Ord :: Eq CAFLabel
Ord)
deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel
type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet
mkCAFLabel :: Platform -> CLabel -> CAFLabel
mkCAFLabel :: Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
lbl = CLabel -> CAFLabel
CAFLabel (Platform -> CLabel -> CLabel
toClosureLbl Platform
platform CLabel
lbl)
newtype SRTEntry = SRTEntry CLabel
deriving (SRTEntry -> SRTEntry -> Bool
(SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> Bool) -> Eq SRTEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SRTEntry -> SRTEntry -> Bool
$c/= :: SRTEntry -> SRTEntry -> Bool
== :: SRTEntry -> SRTEntry -> Bool
$c== :: SRTEntry -> SRTEntry -> Bool
Eq, Eq SRTEntry
Eq SRTEntry
-> (SRTEntry -> SRTEntry -> Ordering)
-> (SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> SRTEntry)
-> (SRTEntry -> SRTEntry -> SRTEntry)
-> Ord SRTEntry
SRTEntry -> SRTEntry -> Bool
SRTEntry -> SRTEntry -> Ordering
SRTEntry -> SRTEntry -> SRTEntry
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SRTEntry -> SRTEntry -> SRTEntry
$cmin :: SRTEntry -> SRTEntry -> SRTEntry
max :: SRTEntry -> SRTEntry -> SRTEntry
$cmax :: SRTEntry -> SRTEntry -> SRTEntry
>= :: SRTEntry -> SRTEntry -> Bool
$c>= :: SRTEntry -> SRTEntry -> Bool
> :: SRTEntry -> SRTEntry -> Bool
$c> :: SRTEntry -> SRTEntry -> Bool
<= :: SRTEntry -> SRTEntry -> Bool
$c<= :: SRTEntry -> SRTEntry -> Bool
< :: SRTEntry -> SRTEntry -> Bool
$c< :: SRTEntry -> SRTEntry -> Bool
compare :: SRTEntry -> SRTEntry -> Ordering
$ccompare :: SRTEntry -> SRTEntry -> Ordering
$cp1Ord :: Eq SRTEntry
Ord)
deriving newtype instance OutputableP env CLabel => OutputableP env SRTEntry
addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
l CAFSet
s
| Just Name
_ <- CLabel -> Maybe Name
hasHaskellName CLabel
l
, let caf_label :: CAFLabel
caf_label = Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
l
, CLabel -> Bool
hasCAF CLabel
l
= CAFLabel -> CAFSet -> CAFSet
forall a. Ord a => a -> Set a -> Set a
Set.insert CAFLabel
caf_label CAFSet
s
| Bool
otherwise
= CAFSet
s
cafAnalData
:: Platform
-> CmmStatics
-> CAFSet
cafAnalData :: Platform -> CmmStatics -> CAFSet
cafAnalData Platform
platform CmmStatics
st = case CmmStatics
st of
CmmStaticsRaw CLabel
_lbl [CmmStatic]
_data -> CAFSet
forall a. Set a
Set.empty
CmmStatics CLabel
_lbl CmmInfoTable
_itbl CostCentreStack
_ccs [CmmLit]
payload ->
(CAFSet -> CmmLit -> CAFSet) -> CAFSet -> [CmmLit] -> CAFSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CAFSet -> CmmLit -> CAFSet
analyzeStatic CAFSet
forall a. Set a
Set.empty [CmmLit]
payload
where
analyzeStatic :: CAFSet -> CmmLit -> CAFSet
analyzeStatic CAFSet
s CmmLit
lit =
case CmmLit
lit of
CmmLabel CLabel
c -> Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
c CAFSet
s
CmmLabelOff CLabel
c Int
_ -> Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
c CAFSet
s
CmmLabelDiffOff CLabel
c1 CLabel
c2 Int
_ Width
_ -> Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
c1 (CAFSet -> CAFSet) -> CAFSet -> CAFSet
forall a b. (a -> b) -> a -> b
$! Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
c2 CAFSet
s
CmmLit
_ -> CAFSet
s
cafAnal
:: Platform
-> LabelSet
-> CLabel
-> CmmGraph
-> CAFEnv
cafAnal :: Platform -> LabelSet -> CLabel -> CmmGraph -> CAFEnv
cafAnal Platform
platform LabelSet
contLbls CLabel
topLbl CmmGraph
cmmGraph =
DataflowLattice CAFSet
-> TransferFun CAFSet -> CmmGraph -> CAFEnv -> CAFEnv
forall f.
DataflowLattice f
-> TransferFun f -> CmmGraph -> FactBase f -> FactBase f
analyzeCmmBwd DataflowLattice CAFSet
cafLattice
(Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers Platform
platform LabelSet
contLbls (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
cmmGraph) CLabel
topLbl) CmmGraph
cmmGraph CAFEnv
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
cafLattice :: DataflowLattice CAFSet
cafLattice :: DataflowLattice CAFSet
cafLattice = CAFSet -> JoinFun CAFSet -> DataflowLattice CAFSet
forall a. a -> JoinFun a -> DataflowLattice a
DataflowLattice CAFSet
forall a. Set a
Set.empty JoinFun CAFSet
forall a.
Ord a =>
OldFact (Set a) -> NewFact (Set a) -> JoinedFact (Set a)
add
where
add :: OldFact (Set a) -> NewFact (Set a) -> JoinedFact (Set a)
add (OldFact Set a
old) (NewFact Set a
new) =
let !new' :: Set a
new' = Set a
old Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set a
new
in Bool -> Set a -> JoinedFact (Set a)
forall a. Bool -> a -> JoinedFact a
changedIf (Set a -> Int
forall a. Set a -> Int
Set.size Set a
new' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Set a -> Int
forall a. Set a -> Int
Set.size Set a
old) Set a
new'
cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers Platform
platform LabelSet
contLbls Label
entry CLabel
topLbl
block :: CmmBlock
block@(BlockCC CmmNode C O
eNode Block CmmNode O O
middle CmmNode O C
xNode) CAFEnv
fBase =
let joined :: CAFSet
joined :: CAFSet
joined = CmmNode O C -> CAFSet -> CAFSet
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CAFSet -> CAFSet
cafsInNode CmmNode O C
xNode (CAFSet -> CAFSet) -> CAFSet -> CAFSet
forall a b. (a -> b) -> a -> b
$! CAFSet
live'
result :: CAFSet
!result :: CAFSet
result = (CmmNode O O -> CAFSet -> CAFSet)
-> Block CmmNode O O -> CAFSet -> CAFSet
forall f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO CmmNode O O -> CAFSet -> CAFSet
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CAFSet -> CAFSet
cafsInNode Block CmmNode O O
middle CAFSet
joined
facts :: [Set CAFLabel]
facts :: [CAFSet]
facts = (Label -> Maybe CAFSet) -> [Label] -> [CAFSet]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Label -> Maybe CAFSet
successorFact (CmmNode O C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors CmmNode O C
xNode)
live' :: CAFSet
live' :: CAFSet
live' = DataflowLattice CAFSet -> [CAFSet] -> CAFSet
forall f. DataflowLattice f -> [f] -> f
joinFacts DataflowLattice CAFSet
cafLattice [CAFSet]
facts
successorFact :: Label -> Maybe (Set CAFLabel)
successorFact :: Label -> Maybe CAFSet
successorFact Label
s
| Label
s Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
entry = CAFSet -> Maybe CAFSet
forall a. a -> Maybe a
Just (Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
topLbl CAFSet
forall a. Set a
Set.empty)
| Label
ElemOf LabelSet
s ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` LabelSet
contLbls
= CAFSet -> Maybe CAFSet
forall a. a -> Maybe a
Just (CAFLabel -> CAFSet
forall a. a -> Set a
Set.singleton (Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform (Label -> CLabel
infoTblLbl Label
s)))
| Bool
otherwise
= Label -> CAFEnv -> Maybe CAFSet
forall f. Label -> FactBase f -> Maybe f
lookupFact Label
s CAFEnv
fBase
cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
cafsInNode CmmNode e x
node CAFSet
set = (CmmExpr -> CAFSet -> CAFSet) -> CmmNode e x -> CAFSet -> CAFSet
forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExpDeep CmmExpr -> CAFSet -> CAFSet
addCafExpr CmmNode e x
node CAFSet
set
addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel
addCafExpr :: CmmExpr -> CAFSet -> CAFSet
addCafExpr CmmExpr
expr !CAFSet
set =
case CmmExpr
expr of
CmmLit (CmmLabel CLabel
c) ->
Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
c CAFSet
set
CmmLit (CmmLabelOff CLabel
c Int
_) ->
Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
c CAFSet
set
CmmLit (CmmLabelDiffOff CLabel
c1 CLabel
c2 Int
_ Width
_) ->
Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
c1 (CAFSet -> CAFSet) -> CAFSet -> CAFSet
forall a b. (a -> b) -> a -> b
$! Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel Platform
platform CLabel
c2 CAFSet
set
CmmExpr
_ ->
CAFSet
set
in
String -> SDoc -> CAFEnv -> CAFEnv
forall b. String -> SDoc -> b -> b
srtTrace String
"cafTransfers" (String -> SDoc
text String
"block:" SDoc -> SDoc -> SDoc
<+> Platform -> CmmBlock -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmBlock
block SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"contLbls:" SDoc -> SDoc -> SDoc
<+> LabelSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelSet
contLbls SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"entry:" SDoc -> SDoc -> SDoc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
entry SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"topLbl:" SDoc -> SDoc -> SDoc
<+> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
topLbl SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"cafs in exit:" SDoc -> SDoc -> SDoc
<+> Platform -> CAFSet -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CAFSet
joined SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"result:" SDoc -> SDoc -> SDoc
<+> Platform -> CAFSet -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CAFSet
result) (CAFEnv -> CAFEnv) -> CAFEnv -> CAFEnv
forall a b. (a -> b) -> a -> b
$
KeyOf LabelMap -> CAFSet -> CAFEnv
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton (CmmNode C O -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmNode C O
eNode) CAFSet
result
data ModuleSRTInfo = ModuleSRTInfo
{ ModuleSRTInfo -> Module
thisModule :: Module
, ModuleSRTInfo -> Map (Set SRTEntry) SRTEntry
dedupSRTs :: Map (Set SRTEntry) SRTEntry
, ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
flatSRTs :: Map SRTEntry (Set SRTEntry)
, ModuleSRTInfo -> SRTMap
moduleSRTMap :: SRTMap
}
instance OutputableP env CLabel => OutputableP env ModuleSRTInfo where
pdoc :: env -> ModuleSRTInfo -> SDoc
pdoc env
env ModuleSRTInfo{Map (Set SRTEntry) SRTEntry
Map SRTEntry (Set SRTEntry)
SRTMap
Module
moduleSRTMap :: SRTMap
flatSRTs :: Map SRTEntry (Set SRTEntry)
dedupSRTs :: Map (Set SRTEntry) SRTEntry
thisModule :: Module
moduleSRTMap :: ModuleSRTInfo -> SRTMap
flatSRTs :: ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
dedupSRTs :: ModuleSRTInfo -> Map (Set SRTEntry) SRTEntry
thisModule :: ModuleSRTInfo -> Module
..} =
String -> SDoc
text String
"ModuleSRTInfo {" SDoc -> SDoc -> SDoc
$$
(Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"dedupSRTs =" SDoc -> SDoc -> SDoc
<+> env -> Map (Set SRTEntry) SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env Map (Set SRTEntry) SRTEntry
dedupSRTs SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"flatSRTs =" SDoc -> SDoc -> SDoc
<+> env -> Map SRTEntry (Set SRTEntry) -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env Map SRTEntry (Set SRTEntry)
flatSRTs SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"moduleSRTMap =" SDoc -> SDoc -> SDoc
<+> env -> SRTMap -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env SRTMap
moduleSRTMap) SDoc -> SDoc -> SDoc
$$ Char -> SDoc
char Char
'}'
emptySRT :: Module -> ModuleSRTInfo
emptySRT :: Module -> ModuleSRTInfo
emptySRT Module
mod =
ModuleSRTInfo :: Module
-> Map (Set SRTEntry) SRTEntry
-> Map SRTEntry (Set SRTEntry)
-> SRTMap
-> ModuleSRTInfo
ModuleSRTInfo
{ thisModule :: Module
thisModule = Module
mod
, dedupSRTs :: Map (Set SRTEntry) SRTEntry
dedupSRTs = Map (Set SRTEntry) SRTEntry
forall k a. Map k a
Map.empty
, flatSRTs :: Map SRTEntry (Set SRTEntry)
flatSRTs = Map SRTEntry (Set SRTEntry)
forall k a. Map k a
Map.empty
, moduleSRTMap :: SRTMap
moduleSRTMap = SRTMap
forall k a. Map k a
Map.empty
}
data SomeLabel
= BlockLabel !Label
| DeclLabel CLabel
deriving (SomeLabel -> SomeLabel -> Bool
(SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> Bool) -> Eq SomeLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SomeLabel -> SomeLabel -> Bool
$c/= :: SomeLabel -> SomeLabel -> Bool
== :: SomeLabel -> SomeLabel -> Bool
$c== :: SomeLabel -> SomeLabel -> Bool
Eq, Eq SomeLabel
Eq SomeLabel
-> (SomeLabel -> SomeLabel -> Ordering)
-> (SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> SomeLabel)
-> (SomeLabel -> SomeLabel -> SomeLabel)
-> Ord SomeLabel
SomeLabel -> SomeLabel -> Bool
SomeLabel -> SomeLabel -> Ordering
SomeLabel -> SomeLabel -> SomeLabel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SomeLabel -> SomeLabel -> SomeLabel
$cmin :: SomeLabel -> SomeLabel -> SomeLabel
max :: SomeLabel -> SomeLabel -> SomeLabel
$cmax :: SomeLabel -> SomeLabel -> SomeLabel
>= :: SomeLabel -> SomeLabel -> Bool
$c>= :: SomeLabel -> SomeLabel -> Bool
> :: SomeLabel -> SomeLabel -> Bool
$c> :: SomeLabel -> SomeLabel -> Bool
<= :: SomeLabel -> SomeLabel -> Bool
$c<= :: SomeLabel -> SomeLabel -> Bool
< :: SomeLabel -> SomeLabel -> Bool
$c< :: SomeLabel -> SomeLabel -> Bool
compare :: SomeLabel -> SomeLabel -> Ordering
$ccompare :: SomeLabel -> SomeLabel -> Ordering
$cp1Ord :: Eq SomeLabel
Ord)
instance OutputableP env CLabel => OutputableP env SomeLabel where
pdoc :: env -> SomeLabel -> SDoc
pdoc env
env = \case
BlockLabel Label
l -> String -> SDoc
text String
"b:" SDoc -> SDoc -> SDoc
<+> env -> Label -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env Label
l
DeclLabel CLabel
l -> String -> SDoc
text String
"s:" SDoc -> SDoc -> SDoc
<+> env -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env CLabel
l
getBlockLabel :: SomeLabel -> Maybe Label
getBlockLabel :: SomeLabel -> Maybe Label
getBlockLabel (BlockLabel Label
l) = Label -> Maybe Label
forall a. a -> Maybe a
Just Label
l
getBlockLabel (DeclLabel CLabel
_) = Maybe Label
forall a. Maybe a
Nothing
getBlockLabels :: [SomeLabel] -> [Label]
getBlockLabels :: [SomeLabel] -> [Label]
getBlockLabels = (SomeLabel -> Maybe Label) -> [SomeLabel] -> [Label]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SomeLabel -> Maybe Label
getBlockLabel
getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
getLabelledBlocks Platform
platform CmmDecl
decl = case CmmDecl
decl of
CmmData Section
_ (CmmStaticsRaw CLabel
_ [CmmStatic]
_) -> []
CmmData Section
_ (CmmStatics CLabel
lbl CmmInfoTable
_ CostCentreStack
_ [CmmLit]
_) -> [ (CLabel -> SomeLabel
DeclLabel CLabel
lbl, Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
lbl) ]
CmmProc CmmTopInfo
top_info CLabel
_ [GlobalReg]
_ CmmGraph
_ -> [ (Label -> SomeLabel
BlockLabel Label
blockId, CAFLabel
caf_lbl)
| (Label
blockId, CmmInfoTable
info) <- LabelMap CmmInfoTable -> [(KeyOf LabelMap, CmmInfoTable)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)
, let rep :: SMRep
rep = CmmInfoTable -> SMRep
cit_rep CmmInfoTable
info
, Bool -> Bool
not (SMRep -> Bool
isStaticRep SMRep
rep) Bool -> Bool -> Bool
|| Bool -> Bool
not (SMRep -> Bool
isThunkRep SMRep
rep)
, let !caf_lbl :: CAFLabel
caf_lbl = Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
info)
]
depAnalSRTs
:: Platform
-> CAFEnv
-> Map CLabel CAFSet
-> [CmmDecl]
-> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
depAnalSRTs :: Platform
-> CAFEnv
-> Map CLabel CAFSet
-> [CmmDecl]
-> [SCC (SomeLabel, CAFLabel, CAFSet)]
depAnalSRTs Platform
platform CAFEnv
cafEnv Map CLabel CAFSet
cafEnv_static [CmmDecl]
decls =
String
-> SDoc
-> [SCC (SomeLabel, CAFLabel, CAFSet)]
-> [SCC (SomeLabel, CAFLabel, CAFSet)]
forall b. String -> SDoc -> b -> b
srtTrace String
"depAnalSRTs" (String -> SDoc
text String
"decls:" SDoc -> SDoc -> SDoc
<+> Platform -> [CmmDecl] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CmmDecl]
decls SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"nodes:" SDoc -> SDoc -> SDoc
<+> Platform -> [(SomeLabel, CAFLabel, CAFSet)] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ((Node SomeLabel (SomeLabel, CAFLabel, CAFSet)
-> (SomeLabel, CAFLabel, CAFSet))
-> [Node SomeLabel (SomeLabel, CAFLabel, CAFSet)]
-> [(SomeLabel, CAFLabel, CAFSet)]
forall a b. (a -> b) -> [a] -> [b]
map Node SomeLabel (SomeLabel, CAFLabel, CAFSet)
-> (SomeLabel, CAFLabel, CAFSet)
forall key payload. Node key payload -> payload
node_payload [Node SomeLabel (SomeLabel, CAFLabel, CAFSet)]
nodes) SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"graph:" SDoc -> SDoc -> SDoc
<+> Platform -> [SCC (SomeLabel, CAFLabel, CAFSet)] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [SCC (SomeLabel, CAFLabel, CAFSet)]
graph) [SCC (SomeLabel, CAFLabel, CAFSet)]
graph
where
labelledBlocks :: [(SomeLabel, CAFLabel)]
labelledBlocks :: [(SomeLabel, CAFLabel)]
labelledBlocks = (CmmDecl -> [(SomeLabel, CAFLabel)])
-> [CmmDecl] -> [(SomeLabel, CAFLabel)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
getLabelledBlocks Platform
platform) [CmmDecl]
decls
labelToBlock :: Map CAFLabel SomeLabel
labelToBlock :: Map CAFLabel SomeLabel
labelToBlock = (Map CAFLabel SomeLabel
-> (SomeLabel, CAFLabel) -> Map CAFLabel SomeLabel)
-> Map CAFLabel SomeLabel
-> [(SomeLabel, CAFLabel)]
-> Map CAFLabel SomeLabel
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map CAFLabel SomeLabel
m (SomeLabel
v,CAFLabel
k) -> CAFLabel
-> SomeLabel -> Map CAFLabel SomeLabel -> Map CAFLabel SomeLabel
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CAFLabel
k SomeLabel
v Map CAFLabel SomeLabel
m) Map CAFLabel SomeLabel
forall k a. Map k a
Map.empty [(SomeLabel, CAFLabel)]
labelledBlocks
nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
nodes :: [Node SomeLabel (SomeLabel, CAFLabel, CAFSet)]
nodes = [ (SomeLabel, CAFLabel, CAFSet)
-> SomeLabel
-> [SomeLabel]
-> Node SomeLabel (SomeLabel, CAFLabel, CAFSet)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode (SomeLabel
l,CAFLabel
lbl,CAFSet
cafs') SomeLabel
l
((CAFLabel -> Maybe SomeLabel) -> [CAFLabel] -> [SomeLabel]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((CAFLabel -> Map CAFLabel SomeLabel -> Maybe SomeLabel)
-> Map CAFLabel SomeLabel -> CAFLabel -> Maybe SomeLabel
forall a b c. (a -> b -> c) -> b -> a -> c
flip CAFLabel -> Map CAFLabel SomeLabel -> Maybe SomeLabel
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map CAFLabel SomeLabel
labelToBlock) (CAFSet -> [CAFLabel]
forall a. Set a -> [a]
Set.toList CAFSet
cafs'))
| (SomeLabel
l, CAFLabel
lbl) <- [(SomeLabel, CAFLabel)]
labelledBlocks
, Just (CAFSet
cafs :: Set CAFLabel) <-
[case SomeLabel
l of
BlockLabel Label
l -> KeyOf LabelMap -> CAFEnv -> Maybe CAFSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
KeyOf LabelMap
l CAFEnv
cafEnv
DeclLabel CLabel
cl -> CLabel -> Map CLabel CAFSet -> Maybe CAFSet
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CLabel
cl Map CLabel CAFSet
cafEnv_static]
, let cafs' :: CAFSet
cafs' = CAFLabel -> CAFSet -> CAFSet
forall a. Ord a => a -> Set a -> Set a
Set.delete CAFLabel
lbl CAFSet
cafs
]
graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
graph :: [SCC (SomeLabel, CAFLabel, CAFSet)]
graph = [Node SomeLabel (SomeLabel, CAFLabel, CAFSet)]
-> [SCC (SomeLabel, CAFLabel, CAFSet)]
forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd [Node SomeLabel (SomeLabel, CAFLabel, CAFSet)]
nodes
getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, CAFSet)]
getCAFs Platform
platform CAFEnv
cafEnv [CmmDecl]
decls =
[ (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g, Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
topLbl, CAFSet
cafs)
| CmmProc CmmTopInfo
top_info CLabel
topLbl [GlobalReg]
_ CmmGraph
g <- [CmmDecl]
decls
, Just CmmInfoTable
info <- [KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g) (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)]
, let rep :: SMRep
rep = CmmInfoTable -> SMRep
cit_rep CmmInfoTable
info
, SMRep -> Bool
isStaticRep SMRep
rep Bool -> Bool -> Bool
&& SMRep -> Bool
isThunkRep SMRep
rep
, Just CAFSet
cafs <- [KeyOf LabelMap -> CAFEnv -> Maybe CAFSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g) CAFEnv
cafEnv]
]
getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
getStaticFuns :: [CmmDecl] -> [(Label, CLabel)]
getStaticFuns [CmmDecl]
decls =
[ (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g, CLabel
lbl)
| CmmProc CmmTopInfo
top_info CLabel
_ [GlobalReg]
_ CmmGraph
g <- [CmmDecl]
decls
, Just CmmInfoTable
info <- [KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g) (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)]
, Just (Id
id, CostCentreStack
_) <- [CmmInfoTable -> Maybe (Id, CostCentreStack)
cit_clo CmmInfoTable
info]
, let rep :: SMRep
rep = CmmInfoTable -> SMRep
cit_rep CmmInfoTable
info
, SMRep -> Bool
isStaticRep SMRep
rep Bool -> Bool -> Bool
&& SMRep -> Bool
isFunRep SMRep
rep
, let !lbl :: CLabel
lbl = Name -> CafInfo -> CLabel
mkLocalClosureLabel (Id -> Name
idName Id
id) (Id -> CafInfo
idCafInfo Id
id)
]
type SRTMap = Map CAFLabel (Maybe SRTEntry)
srtMapNonCAFs :: SRTMap -> NonCaffySet
srtMapNonCAFs :: SRTMap -> NonCaffySet
srtMapNonCAFs SRTMap
srtMap =
NameSet -> NonCaffySet
NonCaffySet (NameSet -> NonCaffySet) -> NameSet -> NonCaffySet
forall a b. (a -> b) -> a -> b
$ [Name] -> NameSet
mkNameSet (((CAFLabel, Maybe SRTEntry) -> Maybe Name)
-> [(CAFLabel, Maybe SRTEntry)] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CAFLabel, Maybe SRTEntry) -> Maybe Name
forall a. (CAFLabel, Maybe a) -> Maybe Name
get_name (SRTMap -> [(CAFLabel, Maybe SRTEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList SRTMap
srtMap))
where
get_name :: (CAFLabel, Maybe a) -> Maybe Name
get_name (CAFLabel CLabel
l, Maybe a
Nothing) = CLabel -> Maybe Name
hasHaskellName CLabel
l
get_name (CAFLabel
_l, Just a
_srt_entry) = Maybe Name
forall a. Maybe a
Nothing
resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF Platform
platform SRTMap
srtMap lbl :: CAFLabel
lbl@(CAFLabel CLabel
l) =
String -> SDoc -> Maybe SRTEntry -> Maybe SRTEntry
forall b. String -> SDoc -> b -> b
srtTrace String
"resolveCAF" (SDoc
"l:" SDoc -> SDoc -> SDoc
<+> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
l SDoc -> SDoc -> SDoc
<+> SDoc
"resolved:" SDoc -> SDoc -> SDoc
<+> Platform -> Maybe SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Maybe SRTEntry
ret) Maybe SRTEntry
ret
where
ret :: Maybe SRTEntry
ret = Maybe SRTEntry -> CAFLabel -> SRTMap -> Maybe SRTEntry
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just (CLabel -> SRTEntry
SRTEntry (Platform -> CLabel -> CLabel
toClosureLbl Platform
platform CLabel
l))) CAFLabel
lbl SRTMap
srtMap
doSRTs
:: DynFlags
-> ModuleSRTInfo
-> [(CAFEnv, [CmmDecl])]
-> [(CAFSet, CmmDecl)]
-> IO (ModuleSRTInfo, [CmmDeclSRTs])
doSRTs :: DynFlags
-> ModuleSRTInfo
-> [(CAFEnv, [CmmDecl])]
-> [(CAFSet, CmmDecl)]
-> IO (ModuleSRTInfo, [CmmDeclSRTs])
doSRTs DynFlags
dflags ModuleSRTInfo
moduleSRTInfo [(CAFEnv, [CmmDecl])]
procs [(CAFSet, CmmDecl)]
data_ = do
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'u'
let profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
let static_data_env :: Map CLabel CAFSet
static_data_env :: Map CLabel CAFSet
static_data_env =
[(CLabel, CAFSet)] -> Map CLabel CAFSet
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CLabel, CAFSet)] -> Map CLabel CAFSet)
-> [(CLabel, CAFSet)] -> Map CLabel CAFSet
forall a b. (a -> b) -> a -> b
$
(((CAFSet, CmmDecl) -> (CLabel, CAFSet))
-> [(CAFSet, CmmDecl)] -> [(CLabel, CAFSet)])
-> [(CAFSet, CmmDecl)]
-> ((CAFSet, CmmDecl) -> (CLabel, CAFSet))
-> [(CLabel, CAFSet)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CAFSet, CmmDecl) -> (CLabel, CAFSet))
-> [(CAFSet, CmmDecl)] -> [(CLabel, CAFSet)]
forall a b. (a -> b) -> [a] -> [b]
map [(CAFSet, CmmDecl)]
data_ (((CAFSet, CmmDecl) -> (CLabel, CAFSet)) -> [(CLabel, CAFSet)])
-> ((CAFSet, CmmDecl) -> (CLabel, CAFSet)) -> [(CLabel, CAFSet)]
forall a b. (a -> b) -> a -> b
$
\(CAFSet
set, CmmDecl
decl) ->
case CmmDecl
decl of
CmmProc{} ->
String -> SDoc -> (CLabel, CAFSet)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doSRTs" (String -> SDoc
text String
"Proc in static data list:" SDoc -> SDoc -> SDoc
<+> Platform -> CmmDecl -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmDecl
decl)
CmmData Section
_ CmmStatics
static ->
case CmmStatics
static of
CmmStatics CLabel
lbl CmmInfoTable
_ CostCentreStack
_ [CmmLit]
_ -> (CLabel
lbl, CAFSet
set)
CmmStaticsRaw CLabel
lbl [CmmStatic]
_ -> (CLabel
lbl, CAFSet
set)
static_data :: Set CLabel
static_data :: Set CLabel
static_data = Map CLabel CAFSet -> Set CLabel
forall k a. Map k a -> Set k
Map.keysSet Map CLabel CAFSet
static_data_env
([CAFEnv]
proc_envs, [[CmmDecl]]
procss) = [(CAFEnv, [CmmDecl])] -> ([CAFEnv], [[CmmDecl]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CAFEnv, [CmmDecl])]
procs
cafEnv :: CAFEnv
cafEnv = [CAFEnv] -> CAFEnv
forall (map :: * -> *) a. IsMap map => [map a] -> map a
mapUnions [CAFEnv]
proc_envs
decls :: [CmmDecl]
decls = ((CAFSet, CmmDecl) -> CmmDecl) -> [(CAFSet, CmmDecl)] -> [CmmDecl]
forall a b. (a -> b) -> [a] -> [b]
map (CAFSet, CmmDecl) -> CmmDecl
forall a b. (a, b) -> b
snd [(CAFSet, CmmDecl)]
data_ [CmmDecl] -> [CmmDecl] -> [CmmDecl]
forall a. [a] -> [a] -> [a]
++ [[CmmDecl]] -> [CmmDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CmmDecl]]
procss
staticFuns :: LabelMap CLabel
staticFuns = [(KeyOf LabelMap, CLabel)] -> LabelMap CLabel
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([CmmDecl] -> [(Label, CLabel)]
getStaticFuns [CmmDecl]
decls)
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
let
sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
sccs :: [SCC (SomeLabel, CAFLabel, CAFSet)]
sccs = {-# SCC depAnalSRTs #-} Platform
-> CAFEnv
-> Map CLabel CAFSet
-> [CmmDecl]
-> [SCC (SomeLabel, CAFLabel, CAFSet)]
depAnalSRTs Platform
platform CAFEnv
cafEnv Map CLabel CAFSet
static_data_env [CmmDecl]
decls
cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
cafsWithSRTs :: [(Label, CAFLabel, CAFSet)]
cafsWithSRTs = Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, CAFSet)]
getCAFs Platform
platform CAFEnv
cafEnv [CmmDecl]
decls
String -> SDoc -> IO ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"doSRTs" (String -> SDoc
text String
"data:" SDoc -> SDoc -> SDoc
<+> Platform -> [(CAFSet, CmmDecl)] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [(CAFSet, CmmDecl)]
data_ SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"procs:" SDoc -> SDoc -> SDoc
<+> Platform -> [(CAFEnv, [CmmDecl])] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [(CAFEnv, [CmmDecl])]
procs SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"static_data_env:" SDoc -> SDoc -> SDoc
<+> Platform -> Map CLabel CAFSet -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Map CLabel CAFSet
static_data_env SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"sccs:" SDoc -> SDoc -> SDoc
<+> Platform -> [SCC (SomeLabel, CAFLabel, CAFSet)] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [SCC (SomeLabel, CAFLabel, CAFSet)]
sccs SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"cafsWithSRTs:" SDoc -> SDoc -> SDoc
<+> Platform -> [(Label, CAFLabel, CAFSet)] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [(Label, CAFLabel, CAFSet)]
cafsWithSRTs)
let result ::
[ ( [CmmDeclSRTs]
, [(Label, CLabel)]
, [(Label, [SRTEntry])]
, Bool
) ]
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
result, ModuleSRTInfo
moduleSRTInfo') =
UniqSupply
-> UniqSM
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)],
ModuleSRTInfo)
-> ([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])],
Bool)],
ModuleSRTInfo)
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)],
ModuleSRTInfo)
-> ([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])],
Bool)],
ModuleSRTInfo))
-> UniqSM
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)],
ModuleSRTInfo)
-> ([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])],
Bool)],
ModuleSRTInfo)
forall a b. (a -> b) -> a -> b
$
(StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
-> ModuleSRTInfo
-> UniqSM
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)],
ModuleSRTInfo))
-> ModuleSRTInfo
-> StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
-> UniqSM
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)],
ModuleSRTInfo)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
-> ModuleSRTInfo
-> UniqSM
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)],
ModuleSRTInfo)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ModuleSRTInfo
moduleSRTInfo (StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
-> UniqSM
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)],
ModuleSRTInfo))
-> StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
-> UniqSM
([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)],
ModuleSRTInfo)
forall a b. (a -> b) -> a -> b
$ do
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
nonCAFs <- (SCC (SomeLabel, CAFLabel, CAFSet)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool))
-> [SCC (SomeLabel, CAFLabel, CAFSet)]
-> StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags
-> LabelMap CLabel
-> Set CLabel
-> SCC (SomeLabel, CAFLabel, CAFSet)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
doSCC DynFlags
dflags LabelMap CLabel
staticFuns Set CLabel
static_data) [SCC (SomeLabel, CAFLabel, CAFSet)]
sccs
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
cAFs <- [(Label, CAFLabel, CAFSet)]
-> ((Label, CAFLabel, CAFSet)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool))
-> StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Label, CAFLabel, CAFSet)]
cafsWithSRTs (((Label, CAFLabel, CAFSet)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool))
-> StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)])
-> ((Label, CAFLabel, CAFSet)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool))
-> StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
forall a b. (a -> b) -> a -> b
$ \(Label
l, CAFLabel
cafLbl, CAFSet
cafs) ->
DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> CAFSet
-> Set CLabel
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [Label -> SomeLabel
BlockLabel Label
l] [CAFLabel
cafLbl]
Bool
True CAFSet
cafs Set CLabel
static_data
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
-> StateT
ModuleSRTInfo
UniqSM
[([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
nonCAFs [([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
-> [([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])],
Bool)]
-> [([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])],
Bool)]
forall a. [a] -> [a] -> [a]
++ [([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
cAFs)
([[CmmDeclSRTs]]
srt_declss, [[(Label, CLabel)]]
pairs, [[(Label, [SRTEntry])]]
funSRTs, [Bool]
has_caf_refs) = [([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
-> ([[CmmDeclSRTs]], [[(Label, CLabel)]], [[(Label, [SRTEntry])]],
[Bool])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)]
result
srt_decls :: [CmmDeclSRTs]
srt_decls = [[CmmDeclSRTs]] -> [CmmDeclSRTs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CmmDeclSRTs]]
srt_declss
let
srtFieldMap :: LabelMap CLabel
srtFieldMap = [(KeyOf LabelMap, CLabel)] -> LabelMap CLabel
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([[(Label, CLabel)]] -> [(Label, CLabel)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Label, CLabel)]]
pairs)
funSRTMap :: LabelMap [SRTEntry]
funSRTMap = [(KeyOf LabelMap, [SRTEntry])] -> LabelMap [SRTEntry]
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([[(Label, [SRTEntry])]] -> [(Label, [SRTEntry])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Label, [SRTEntry])]]
funSRTs)
has_caf_refs' :: Bool
has_caf_refs' = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
has_caf_refs
decls' :: [CmmDeclSRTs]
decls' =
(CmmDecl -> [CmmDeclSRTs]) -> [CmmDecl] -> [CmmDeclSRTs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Profile
-> LabelMap CLabel
-> LabelMap [SRTEntry]
-> Bool
-> CmmDecl
-> [CmmDeclSRTs]
updInfoSRTs Profile
profile LabelMap CLabel
srtFieldMap LabelMap [SRTEntry]
funSRTMap Bool
has_caf_refs') [CmmDecl]
decls
let srtMap_w_raws :: SRTMap
srtMap_w_raws =
(SRTMap -> (CAFSet, CmmDecl) -> SRTMap)
-> SRTMap -> [(CAFSet, CmmDecl)] -> SRTMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(SRTMap
srtMap :: SRTMap) (CAFSet
_, CmmDecl
decl) ->
case CmmDecl
decl of
CmmData Section
_ CmmStatics{} ->
SRTMap
srtMap
CmmData Section
_ (CmmStaticsRaw CLabel
lbl [CmmStatic]
_)
| CLabel -> Bool
isIdLabel CLabel
lbl Bool -> Bool -> Bool
&& Bool -> Bool
not (CLabel -> Bool
isTickyLabel CLabel
lbl) ->
CAFLabel -> Maybe SRTEntry -> SRTMap -> SRTMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
lbl) Maybe SRTEntry
forall a. Maybe a
Nothing SRTMap
srtMap
| Bool
otherwise ->
SRTMap
srtMap
CmmProc{} ->
String -> SDoc -> SRTMap
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doSRTs" (String -> SDoc
text String
"Found Proc in static data list:" SDoc -> SDoc -> SDoc
<+> Platform -> CmmDecl -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmDecl
decl))
(ModuleSRTInfo -> SRTMap
moduleSRTMap ModuleSRTInfo
moduleSRTInfo') [(CAFSet, CmmDecl)]
data_
(ModuleSRTInfo, [CmmDeclSRTs]) -> IO (ModuleSRTInfo, [CmmDeclSRTs])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleSRTInfo
moduleSRTInfo'{ moduleSRTMap :: SRTMap
moduleSRTMap = SRTMap
srtMap_w_raws }, [CmmDeclSRTs]
srt_decls [CmmDeclSRTs] -> [CmmDeclSRTs] -> [CmmDeclSRTs]
forall a. [a] -> [a] -> [a]
++ [CmmDeclSRTs]
decls')
doSCC
:: DynFlags
-> LabelMap CLabel
-> Set CLabel
-> SCC (SomeLabel, CAFLabel, Set CAFLabel)
-> StateT ModuleSRTInfo UniqSM
( [CmmDeclSRTs]
, [(Label, CLabel)]
, [(Label, [SRTEntry])]
, Bool
)
doSCC :: DynFlags
-> LabelMap CLabel
-> Set CLabel
-> SCC (SomeLabel, CAFLabel, CAFSet)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
doSCC DynFlags
dflags LabelMap CLabel
staticFuns Set CLabel
static_data (AcyclicSCC (SomeLabel
l, CAFLabel
cafLbl, CAFSet
cafs)) =
DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> CAFSet
-> Set CLabel
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [SomeLabel
l] [CAFLabel
cafLbl] Bool
False CAFSet
cafs Set CLabel
static_data
doSCC DynFlags
dflags LabelMap CLabel
staticFuns Set CLabel
static_data (CyclicSCC [(SomeLabel, CAFLabel, CAFSet)]
nodes) = do
let ([SomeLabel]
lbls, [CAFLabel]
caf_lbls, [CAFSet]
cafsets) = [(SomeLabel, CAFLabel, CAFSet)]
-> ([SomeLabel], [CAFLabel], [CAFSet])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(SomeLabel, CAFLabel, CAFSet)]
nodes
cafs :: CAFSet
cafs = [CAFSet] -> CAFSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [CAFSet]
cafsets
DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> CAFSet
-> Set CLabel
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [SomeLabel]
lbls [CAFLabel]
caf_lbls Bool
False CAFSet
cafs Set CLabel
static_data
oneSRT
:: DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> Set CAFLabel
-> Set CLabel
-> StateT ModuleSRTInfo UniqSM
( [CmmDeclSRTs]
, [(Label, CLabel)]
, [(Label, [SRTEntry])]
, Bool
)
oneSRT :: DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> CAFSet
-> Set CLabel
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [SomeLabel]
lbls [CAFLabel]
caf_lbls Bool
isCAF CAFSet
cafs Set CLabel
static_data = do
ModuleSRTInfo
topSRT <- StateT ModuleSRTInfo UniqSM ModuleSRTInfo
forall (m :: * -> *) s. Monad m => StateT s m s
get
let
this_mod :: Module
this_mod = ModuleSRTInfo -> Module
thisModule ModuleSRTInfo
topSRT
config :: NCGConfig
config = DynFlags -> Module -> NCGConfig
initNCGConfig DynFlags
dflags Module
this_mod
profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
srtMap :: SRTMap
srtMap = ModuleSRTInfo -> SRTMap
moduleSRTMap ModuleSRTInfo
topSRT
blockids :: [Label]
blockids = [SomeLabel] -> [Label]
getBlockLabels [SomeLabel]
lbls
maybeFunClosure :: Maybe (CLabel, Label)
otherFunLabels :: [CLabel]
(Maybe (CLabel, Label)
maybeFunClosure, [CLabel]
otherFunLabels) =
case [ (CLabel
l,Label
b) | Label
b <- [Label]
blockids, Just CLabel
l <- [KeyOf LabelMap -> LabelMap CLabel -> Maybe CLabel
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
KeyOf LabelMap
b LabelMap CLabel
staticFuns] ] of
[] -> (Maybe (CLabel, Label)
forall a. Maybe a
Nothing, [])
((CLabel
l,Label
b):[(CLabel, Label)]
xs) -> ((CLabel, Label) -> Maybe (CLabel, Label)
forall a. a -> Maybe a
Just (CLabel
l,Label
b), ((CLabel, Label) -> CLabel) -> [(CLabel, Label)] -> [CLabel]
forall a b. (a -> b) -> [a] -> [b]
map (CLabel, Label) -> CLabel
forall a b. (a, b) -> a
fst [(CLabel, Label)]
xs)
nonRec :: Set CAFLabel
nonRec :: CAFSet
nonRec = CAFSet
cafs CAFSet -> CAFSet -> CAFSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [CAFLabel] -> CAFSet
forall a. Ord a => [a] -> Set a
Set.fromList [CAFLabel]
caf_lbls
resolved :: [SRTEntry]
resolved :: [SRTEntry]
resolved = (CAFLabel -> Maybe SRTEntry) -> [CAFLabel] -> [SRTEntry]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF Platform
platform SRTMap
srtMap) (CAFSet -> [CAFLabel]
forall a. Set a -> [a]
Set.toList CAFSet
nonRec)
allBelow :: Set SRTEntry
allBelow =
[Set SRTEntry] -> Set SRTEntry
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Set SRTEntry
lbls | SRTEntry
caf <- [SRTEntry]
resolved
, Just Set SRTEntry
lbls <- [SRTEntry -> Map SRTEntry (Set SRTEntry) -> Maybe (Set SRTEntry)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SRTEntry
caf (ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
flatSRTs ModuleSRTInfo
topSRT)] ]
filtered0 :: Set SRTEntry
filtered0 = [SRTEntry] -> Set SRTEntry
forall a. Ord a => [a] -> Set a
Set.fromList [SRTEntry]
resolved Set SRTEntry -> Set SRTEntry -> Set SRTEntry
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set SRTEntry
allBelow
String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT:"
(String -> SDoc
text String
"srtMap:" SDoc -> SDoc -> SDoc
<+> Platform -> SRTMap -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform SRTMap
srtMap SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"nonRec:" SDoc -> SDoc -> SDoc
<+> Platform -> CAFSet -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CAFSet
nonRec SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"lbls:" SDoc -> SDoc -> SDoc
<+> Platform -> [SomeLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [SomeLabel]
lbls SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"caf_lbls:" SDoc -> SDoc -> SDoc
<+> Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"static_data:" SDoc -> SDoc -> SDoc
<+> Platform -> Set CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set CLabel
static_data SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"cafs:" SDoc -> SDoc -> SDoc
<+> Platform -> CAFSet -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CAFSet
cafs SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"blockids:" SDoc -> SDoc -> SDoc
<+> [Label] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Label]
blockids SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"maybeFunClosure:" SDoc -> SDoc -> SDoc
<+> Platform -> Maybe (CLabel, Label) -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Maybe (CLabel, Label)
maybeFunClosure SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"otherFunLabels:" SDoc -> SDoc -> SDoc
<+> Platform -> [CLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CLabel]
otherFunLabels SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"resolved:" SDoc -> SDoc -> SDoc
<+> Platform -> [SRTEntry] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [SRTEntry]
resolved SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"allBelow:" SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
allBelow SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"filtered0:" SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
filtered0)
let
isStaticFun :: Bool
isStaticFun = Maybe (CLabel, Label) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (CLabel, Label)
maybeFunClosure
updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap Maybe SRTEntry
srtEntry =
String
-> SDoc
-> StateT ModuleSRTInfo UniqSM ()
-> StateT ModuleSRTInfo UniqSM ()
forall b. String -> SDoc -> b -> b
srtTrace String
"updateSRTMap"
(Platform -> Maybe SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Maybe SRTEntry
srtEntry SDoc -> SDoc -> SDoc
<+> SDoc
"isCAF:" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
isCAF SDoc -> SDoc -> SDoc
<+>
SDoc
"isStaticFun:" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
isStaticFun) (StateT ModuleSRTInfo UniqSM () -> StateT ModuleSRTInfo UniqSM ())
-> StateT ModuleSRTInfo UniqSM () -> StateT ModuleSRTInfo UniqSM ()
forall a b. (a -> b) -> a -> b
$
Bool
-> StateT ModuleSRTInfo UniqSM () -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isCAF Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
isStaticFun Bool -> Bool -> Bool
|| Maybe SRTEntry -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SRTEntry
srtEntry)) (StateT ModuleSRTInfo UniqSM () -> StateT ModuleSRTInfo UniqSM ())
-> StateT ModuleSRTInfo UniqSM () -> StateT ModuleSRTInfo UniqSM ()
forall a b. (a -> b) -> a -> b
$
(ModuleSRTInfo -> ModuleSRTInfo) -> StateT ModuleSRTInfo UniqSM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((ModuleSRTInfo -> ModuleSRTInfo)
-> StateT ModuleSRTInfo UniqSM ())
-> (ModuleSRTInfo -> ModuleSRTInfo)
-> StateT ModuleSRTInfo UniqSM ()
forall a b. (a -> b) -> a -> b
$ \ModuleSRTInfo
state ->
let !srt_map :: SRTMap
srt_map =
(SRTMap -> CAFLabel -> SRTMap) -> SRTMap -> [CAFLabel] -> SRTMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\SRTMap
srt_map cafLbl :: CAFLabel
cafLbl@(CAFLabel CLabel
clbl) ->
if Bool -> Bool
not (CLabel -> Set CLabel -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member CLabel
clbl Set CLabel
static_data) Bool -> Bool -> Bool
|| Maybe SRTEntry -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SRTEntry
srtEntry then
CAFLabel -> Maybe SRTEntry -> SRTMap -> SRTMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CAFLabel
cafLbl Maybe SRTEntry
srtEntry SRTMap
srt_map
else
SRTMap
srt_map)
(ModuleSRTInfo -> SRTMap
moduleSRTMap ModuleSRTInfo
state)
[CAFLabel]
caf_lbls
in
ModuleSRTInfo
state{ moduleSRTMap :: SRTMap
moduleSRTMap = SRTMap
srt_map }
allStaticData :: Bool
allStaticData =
(CAFLabel -> Bool) -> [CAFLabel] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(CAFLabel CLabel
clbl) -> CLabel -> Set CLabel -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member CLabel
clbl Set CLabel
static_data) [CAFLabel]
caf_lbls
if Set SRTEntry -> Bool
forall a. Set a -> Bool
Set.null Set SRTEntry
filtered0 then do
String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT: empty" (Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls)
Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap Maybe SRTEntry
forall a. Maybe a
Nothing
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], [], Bool
False)
else do
let allBelow_funs :: Set SRTEntry
allBelow_funs =
[SRTEntry] -> Set SRTEntry
forall a. Ord a => [a] -> Set a
Set.fromList ((CLabel -> SRTEntry) -> [CLabel] -> [SRTEntry]
forall a b. (a -> b) -> [a] -> [b]
map (CLabel -> SRTEntry
SRTEntry (CLabel -> SRTEntry) -> (CLabel -> CLabel) -> CLabel -> SRTEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CLabel -> CLabel
toClosureLbl Platform
platform) [CLabel]
otherFunLabels)
let filtered :: Set SRTEntry
filtered = Set SRTEntry
filtered0 Set SRTEntry -> Set SRTEntry -> Set SRTEntry
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set SRTEntry
allBelow_funs
String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT" (String -> SDoc
text String
"filtered:" SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
filtered SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"allBelow_funs:" SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
allBelow_funs)
case Set SRTEntry -> [SRTEntry]
forall a. Set a -> [a]
Set.toList Set SRTEntry
filtered of
[] -> String
-> SDoc
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"oneSRT" SDoc
empty
[one :: SRTEntry
one@(SRTEntry CLabel
lbl)]
|
Bool -> Bool
not (NCGConfig -> CLabel -> Bool
labelDynamic NCGConfig
config CLabel
lbl)
Bool -> Bool -> Bool
&& (Bool -> Bool
not (OS -> Bool
osMachOTarget (OS -> Bool) -> OS -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> OS
platformOS (Platform -> OS) -> Platform -> OS
forall a b. (a -> b) -> a -> b
$ Profile -> Platform
profilePlatform Profile
profile)
Bool -> Bool -> Bool
|| Module -> CLabel -> Bool
isLocalCLabel Module
this_mod CLabel
lbl) -> do
case Maybe (CLabel, Label)
maybeFunClosure of
Just (CLabel
staticFunLbl,Label
staticFunBlock) ->
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(Label, CLabel)]
withLabels, [], Bool
True)
where
withLabels :: [(Label, CLabel)]
withLabels =
[ (Label
b, if Label
b Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
staticFunBlock then CLabel
lbl else CLabel
staticFunLbl)
| Label
b <- [Label]
blockids ]
Maybe (CLabel, Label)
Nothing -> do
String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT: one" (String -> SDoc
text String
"caf_lbls:" SDoc -> SDoc -> SDoc
<+> Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"one:" SDoc -> SDoc -> SDoc
<+> Platform -> SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform SRTEntry
one)
Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just SRTEntry
one)
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], (Label -> (Label, CLabel)) -> [Label] -> [(Label, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
lbl) [Label]
blockids, [], Bool
True)
[SRTEntry]
cafList | Bool
allStaticData ->
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], [], Bool -> Bool
not ([SRTEntry] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SRTEntry]
cafList))
[SRTEntry]
cafList ->
case Set SRTEntry -> Map (Set SRTEntry) SRTEntry -> Maybe SRTEntry
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Set SRTEntry
filtered (ModuleSRTInfo -> Map (Set SRTEntry) SRTEntry
dedupSRTs ModuleSRTInfo
topSRT) of
Just srtEntry :: SRTEntry
srtEntry@(SRTEntry CLabel
srtLbl) -> do
String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT [Common]" (Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls SDoc -> SDoc -> SDoc
<+> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
srtLbl)
Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just SRTEntry
srtEntry)
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], (Label -> (Label, CLabel)) -> [Label] -> [(Label, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
srtLbl) [Label]
blockids, [], Bool
True)
Maybe SRTEntry
Nothing -> do
([CmmDeclSRTs]
decls, [(Label, [SRTEntry])]
funSRTs, SRTEntry
srtEntry) <-
case Maybe (CLabel, Label)
maybeFunClosure of
Just (CLabel
fun,Label
block) ->
([CmmDeclSRTs], [(Label, [SRTEntry])], SRTEntry)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, [SRTEntry])], SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [], [(Label
block, [SRTEntry]
cafList)], CLabel -> SRTEntry
SRTEntry CLabel
fun )
Maybe (CLabel, Label)
Nothing -> do
([CmmDeclSRTs]
decls, SRTEntry
entry) <- UniqSM ([CmmDeclSRTs], SRTEntry)
-> StateT ModuleSRTInfo UniqSM ([CmmDeclSRTs], SRTEntry)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UniqSM ([CmmDeclSRTs], SRTEntry)
-> StateT ModuleSRTInfo UniqSM ([CmmDeclSRTs], SRTEntry))
-> UniqSM ([CmmDeclSRTs], SRTEntry)
-> StateT ModuleSRTInfo UniqSM ([CmmDeclSRTs], SRTEntry)
forall a b. (a -> b) -> a -> b
$ Profile -> [SRTEntry] -> UniqSM ([CmmDeclSRTs], SRTEntry)
buildSRTChain Profile
profile [SRTEntry]
cafList
([CmmDeclSRTs], [(Label, [SRTEntry])], SRTEntry)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, [SRTEntry])], SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmDeclSRTs]
decls, [], SRTEntry
entry)
Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just SRTEntry
srtEntry)
let allBelowThis :: Set SRTEntry
allBelowThis = Set SRTEntry -> Set SRTEntry -> Set SRTEntry
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set SRTEntry
allBelow Set SRTEntry
filtered
newFlatSRTs :: Map SRTEntry (Set SRTEntry)
newFlatSRTs = SRTEntry
-> Set SRTEntry
-> Map SRTEntry (Set SRTEntry)
-> Map SRTEntry (Set SRTEntry)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SRTEntry
srtEntry Set SRTEntry
allBelowThis (ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
flatSRTs ModuleSRTInfo
topSRT)
newDedupSRTs :: Map (Set SRTEntry) SRTEntry
newDedupSRTs = Set SRTEntry
-> SRTEntry
-> Map (Set SRTEntry) SRTEntry
-> Map (Set SRTEntry) SRTEntry
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Set SRTEntry
filtered SRTEntry
srtEntry (ModuleSRTInfo -> Map (Set SRTEntry) SRTEntry
dedupSRTs ModuleSRTInfo
topSRT)
(ModuleSRTInfo -> ModuleSRTInfo) -> StateT ModuleSRTInfo UniqSM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\ModuleSRTInfo
state -> ModuleSRTInfo
state{ dedupSRTs :: Map (Set SRTEntry) SRTEntry
dedupSRTs = Map (Set SRTEntry) SRTEntry
newDedupSRTs,
flatSRTs :: Map SRTEntry (Set SRTEntry)
flatSRTs = Map SRTEntry (Set SRTEntry)
newFlatSRTs })
String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT: new" (String -> SDoc
text String
"caf_lbls:" SDoc -> SDoc -> SDoc
<+> Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"filtered:" SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
filtered SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"srtEntry:" SDoc -> SDoc -> SDoc
<+> Platform -> SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform SRTEntry
srtEntry SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"newDedupSRTs:" SDoc -> SDoc -> SDoc
<+> Platform -> Map (Set SRTEntry) SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Map (Set SRTEntry) SRTEntry
newDedupSRTs SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"newFlatSRTs:" SDoc -> SDoc -> SDoc
<+> Platform -> Map SRTEntry (Set SRTEntry) -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Map SRTEntry (Set SRTEntry)
newFlatSRTs)
let SRTEntry CLabel
lbl = SRTEntry
srtEntry
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
-> StateT
ModuleSRTInfo
UniqSM
([CmmDeclSRTs], [(Label, CLabel)], [(Label, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmDeclSRTs]
decls, (Label -> (Label, CLabel)) -> [Label] -> [(Label, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
lbl) [Label]
blockids, [(Label, [SRTEntry])]
funSRTs, Bool
True)
buildSRTChain
:: Profile
-> [SRTEntry]
-> UniqSM
( [CmmDeclSRTs]
, SRTEntry
)
buildSRTChain :: Profile -> [SRTEntry] -> UniqSM ([CmmDeclSRTs], SRTEntry)
buildSRTChain Profile
_ [] = String -> UniqSM ([CmmDeclSRTs], SRTEntry)
forall a. String -> a
panic String
"buildSRT: empty"
buildSRTChain Profile
profile [SRTEntry]
cafSet =
case Int -> [SRTEntry] -> ([SRTEntry], [SRTEntry])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
mAX_SRT_SIZE [SRTEntry]
cafSet of
([SRTEntry]
these, []) -> do
(CmmDeclSRTs
decl,SRTEntry
lbl) <- Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
buildSRT Profile
profile [SRTEntry]
these
([CmmDeclSRTs], SRTEntry) -> UniqSM ([CmmDeclSRTs], SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmDeclSRTs
decl], SRTEntry
lbl)
([SRTEntry]
these,[SRTEntry]
those) -> do
([CmmDeclSRTs]
rest, SRTEntry
rest_lbl) <- Profile -> [SRTEntry] -> UniqSM ([CmmDeclSRTs], SRTEntry)
buildSRTChain Profile
profile ([SRTEntry] -> SRTEntry
forall a. [a] -> a
head [SRTEntry]
these SRTEntry -> [SRTEntry] -> [SRTEntry]
forall a. a -> [a] -> [a]
: [SRTEntry]
those)
(CmmDeclSRTs
decl,SRTEntry
lbl) <- Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
buildSRT Profile
profile (SRTEntry
rest_lbl SRTEntry -> [SRTEntry] -> [SRTEntry]
forall a. a -> [a] -> [a]
: [SRTEntry] -> [SRTEntry]
forall a. [a] -> [a]
tail [SRTEntry]
these)
([CmmDeclSRTs], SRTEntry) -> UniqSM ([CmmDeclSRTs], SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmDeclSRTs
declCmmDeclSRTs -> [CmmDeclSRTs] -> [CmmDeclSRTs]
forall a. a -> [a] -> [a]
:[CmmDeclSRTs]
rest, SRTEntry
lbl)
where
mAX_SRT_SIZE :: Int
mAX_SRT_SIZE = Int
16
buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
buildSRT Profile
profile [SRTEntry]
refs = do
Unique
id <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
let
lbl :: CLabel
lbl = Unique -> CLabel
mkSRTLabel Unique
id
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
srt_n_info :: CLabel
srt_n_info = Int -> CLabel
mkSRTInfoLabel ([SRTEntry] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SRTEntry]
refs)
fields :: [CmmLit]
fields =
Profile
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosure Profile
profile CLabel
srt_n_info CostCentreStack
dontCareCCS
[ CLabel -> CmmLit
CmmLabel CLabel
lbl | SRTEntry CLabel
lbl <- [SRTEntry]
refs ]
[]
[Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
0]
[]
(CmmDeclSRTs, SRTEntry) -> UniqSM (CmmDeclSRTs, SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return (Section -> CLabel -> [CmmLit] -> CmmDeclSRTs
forall (raw :: Bool) info stmt.
Section
-> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) CLabel
lbl [CmmLit]
fields, CLabel -> SRTEntry
SRTEntry CLabel
lbl)
updInfoSRTs
:: Profile
-> LabelMap CLabel
-> LabelMap [SRTEntry]
-> Bool
-> CmmDecl
-> [CmmDeclSRTs]
updInfoSRTs :: Profile
-> LabelMap CLabel
-> LabelMap [SRTEntry]
-> Bool
-> CmmDecl
-> [CmmDeclSRTs]
updInfoSRTs Profile
_ LabelMap CLabel
_ LabelMap [SRTEntry]
_ Bool
_ (CmmData Section
s (CmmStaticsRaw CLabel
lbl [CmmStatic]
statics))
= [Section -> GenCmmStatics 'True -> CmmDeclSRTs
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
s (CLabel -> [CmmStatic] -> GenCmmStatics 'True
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmStatic]
statics)]
updInfoSRTs Profile
profile LabelMap CLabel
_ LabelMap [SRTEntry]
_ Bool
caffy (CmmData Section
s (CmmStatics CLabel
lbl CmmInfoTable
itbl CostCentreStack
ccs [CmmLit]
payload))
= [Section -> GenCmmStatics 'True -> CmmDeclSRTs
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
s (CLabel -> [CmmStatic] -> GenCmmStatics 'True
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl ((CmmLit -> CmmStatic) -> [CmmLit] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map CmmLit -> CmmStatic
CmmStaticLit [CmmLit]
field_lits))]
where
caf_info :: CafInfo
caf_info = if Bool
caffy then CafInfo
MayHaveCafRefs else CafInfo
NoCafRefs
field_lits :: [CmmLit]
field_lits = Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields Profile
profile CmmInfoTable
itbl CostCentreStack
ccs CafInfo
caf_info [CmmLit]
payload
updInfoSRTs Profile
profile LabelMap CLabel
srt_env LabelMap [SRTEntry]
funSRTEnv Bool
caffy (CmmProc CmmTopInfo
top_info CLabel
top_l [GlobalReg]
live CmmGraph
g)
| Just (CmmInfoTable
_,CmmDeclSRTs
closure) <- Maybe (CmmInfoTable, CmmDeclSRTs)
maybeStaticClosure = [ CmmDeclSRTs
proc, CmmDeclSRTs
closure ]
| Bool
otherwise = [ CmmDeclSRTs
proc ]
where
caf_info :: CafInfo
caf_info = if Bool
caffy then CafInfo
MayHaveCafRefs else CafInfo
NoCafRefs
proc :: CmmDeclSRTs
proc = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDeclSRTs
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info { info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
newTopInfo } CLabel
top_l [GlobalReg]
live CmmGraph
g
newTopInfo :: LabelMap CmmInfoTable
newTopInfo = (KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable)
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey Label -> CmmInfoTable -> CmmInfoTable
KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable
updInfoTbl (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)
updInfoTbl :: Label -> CmmInfoTable -> CmmInfoTable
updInfoTbl Label
l CmmInfoTable
info_tbl
| Label
l Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g, Just (CmmInfoTable
inf, CmmDeclSRTs
_) <- Maybe (CmmInfoTable, CmmDeclSRTs)
maybeStaticClosure = CmmInfoTable
inf
| Bool
otherwise = CmmInfoTable
info_tbl { cit_srt :: Maybe CLabel
cit_srt = KeyOf LabelMap -> LabelMap CLabel -> Maybe CLabel
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
KeyOf LabelMap
l LabelMap CLabel
srt_env }
maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
maybeStaticClosure
| Just info_tbl :: CmmInfoTable
info_tbl@CmmInfoTable{Maybe (Id, CostCentreStack)
Maybe CLabel
ProfilingInfo
CLabel
SMRep
cit_prof :: CmmInfoTable -> ProfilingInfo
cit_clo :: Maybe (Id, CostCentreStack)
cit_srt :: Maybe CLabel
cit_prof :: ProfilingInfo
cit_rep :: SMRep
cit_lbl :: CLabel
cit_srt :: CmmInfoTable -> Maybe CLabel
cit_clo :: CmmInfoTable -> Maybe (Id, CostCentreStack)
cit_lbl :: CmmInfoTable -> CLabel
cit_rep :: CmmInfoTable -> SMRep
..} <-
KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g) (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)
, Just (Id
id, CostCentreStack
ccs) <- Maybe (Id, CostCentreStack)
cit_clo
, SMRep -> Bool
isStaticRep SMRep
cit_rep =
let
(CmmInfoTable
newInfo, [CmmLit]
srtEntries) = case KeyOf LabelMap -> LabelMap [SRTEntry] -> Maybe [SRTEntry]
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g) LabelMap [SRTEntry]
funSRTEnv of
Maybe [SRTEntry]
Nothing ->
(CmmInfoTable
info_tbl { cit_srt :: Maybe CLabel
cit_srt = KeyOf LabelMap -> LabelMap CLabel -> Maybe CLabel
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g) LabelMap CLabel
srt_env }, [])
Just [SRTEntry]
srtEntries -> String
-> SDoc -> (CmmInfoTable, [CmmLit]) -> (CmmInfoTable, [CmmLit])
forall b. String -> SDoc -> b -> b
srtTrace String
"maybeStaticFun" (Platform -> [CmmLit] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc (Profile -> Platform
profilePlatform Profile
profile) [CmmLit]
res)
(CmmInfoTable
info_tbl { cit_rep :: SMRep
cit_rep = SMRep
new_rep }, [CmmLit]
res)
where res :: [CmmLit]
res = [ CLabel -> CmmLit
CmmLabel CLabel
lbl | SRTEntry CLabel
lbl <- [SRTEntry]
srtEntries ]
fields :: [CmmLit]
fields = Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields Profile
profile CmmInfoTable
info_tbl CostCentreStack
ccs CafInfo
caf_info [CmmLit]
srtEntries
new_rep :: SMRep
new_rep = case SMRep
cit_rep of
HeapRep Bool
sta Int
ptrs Int
nptrs ClosureTypeInfo
ty ->
Bool -> Int -> Int -> ClosureTypeInfo -> SMRep
HeapRep Bool
sta (Int
ptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [CmmLit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmLit]
srtEntries) Int
nptrs ClosureTypeInfo
ty
SMRep
_other -> String -> SMRep
forall a. String -> a
panic String
"maybeStaticFun"
lbl :: CLabel
lbl = Name -> CafInfo -> CLabel
mkLocalClosureLabel (Id -> Name
idName Id
id) CafInfo
caf_info
in
(CmmInfoTable, CmmDeclSRTs) -> Maybe (CmmInfoTable, CmmDeclSRTs)
forall a. a -> Maybe a
Just (CmmInfoTable
newInfo, Section -> CLabel -> [CmmLit] -> CmmDeclSRTs
forall (raw :: Bool) info stmt.
Section
-> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) CLabel
lbl [CmmLit]
fields)
| Bool
otherwise = Maybe (CmmInfoTable, CmmDeclSRTs)
forall a. Maybe a
Nothing
srtTrace :: String -> SDoc -> b -> b
srtTrace :: String -> SDoc -> b -> b
srtTrace String
_ SDoc
_ b
b = b
b
srtTraceM :: Applicative f => String -> SDoc -> f ()
srtTraceM :: String -> SDoc -> f ()
srtTraceM String
str SDoc
doc = String -> SDoc -> f () -> f ()
forall b. String -> SDoc -> b -> b
srtTrace String
str SDoc
doc (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())