{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE GADTs #-}
module GHC.Cmm.ProcPoint
( ProcPointSet, Status(..)
, callProcPoints, minimalProcPointSet
, splitAtProcPoints, procPointAnalysis
, attachContInfoTables
)
where
import GHC.Prelude hiding (last, unzip, succ, zip)
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Info
import GHC.Cmm.Liveness
import GHC.Cmm.Switch
import Data.List (sortBy)
import GHC.Data.Maybe
import Control.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Types.Unique.DSM
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
type ProcPointSet = LabelSet
data Status
= ReachedBy ProcPointSet
| ProcPoint
instance Outputable Status where
ppr :: Status -> SDoc
ppr (ReachedBy ProcPointSet
ps)
| ProcPointSet -> Bool
setNull ProcPointSet
ps = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<not-reached>"
| Bool
otherwise = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"reached by" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (Label -> SDoc) -> [Label] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Label] -> [SDoc]) -> [Label] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ProcPointSet -> [Label]
setElems ProcPointSet
ps)
ppr Status
ProcPoint = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<procpt>"
procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis ProcPointSet
procPoints cmmGraph :: CmmGraph
cmmGraph@(CmmGraph {g_graph :: forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Graph' s Block n C C
g_graph = Graph' LabelMap Block CmmNode C C
graph}) =
DataflowLattice Status
-> TransferFun' CmmNode Status
-> CmmGraph
-> LabelMap Status
-> LabelMap Status
forall (node :: Extensibility -> Extensibility -> *) f.
NonLocal node =>
DataflowLattice f
-> TransferFun' node f
-> GenCmmGraph node
-> FactBase f
-> FactBase f
analyzeCmmFwd DataflowLattice Status
procPointLattice TransferFun' CmmNode Status
procPointTransfer CmmGraph
cmmGraph LabelMap Status
initProcPoints
where
initProcPoints :: LabelMap Status
initProcPoints =
DataflowLattice Status -> [(Label, Status)] -> LabelMap Status
forall f. DataflowLattice f -> [(Label, f)] -> FactBase f
mkFactBase
DataflowLattice Status
procPointLattice
[ (Label
id, Status
ProcPoint)
| Label
id <- ProcPointSet -> [Label]
setElems ProcPointSet
procPoints
, Label
id Label -> ProcPointSet -> Bool
`setMember` ProcPointSet
labelsInGraph
]
labelsInGraph :: ProcPointSet
labelsInGraph = Graph' LabelMap Block CmmNode C C -> ProcPointSet
forall (block :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n :: Extensibility -> Extensibility -> *) (e :: Extensibility)
(x :: Extensibility).
NonLocal (block n) =>
Graph' LabelMap block n e x -> ProcPointSet
labelsDefined Graph' LabelMap Block CmmNode C C
graph
procPointTransfer :: TransferFun Status
procPointTransfer :: TransferFun' CmmNode Status
procPointTransfer Block CmmNode C C
block LabelMap Status
facts =
let label :: Label
label = Block CmmNode C C -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
block
!fact :: Status
fact = case DataflowLattice Status -> Label -> LabelMap Status -> Status
forall f. DataflowLattice f -> Label -> FactBase f -> f
getFact DataflowLattice Status
procPointLattice Label
label LabelMap Status
facts of
Status
ProcPoint -> ProcPointSet -> Status
ReachedBy (ProcPointSet -> Status) -> ProcPointSet -> Status
forall a b. (a -> b) -> a -> b
$! Label -> ProcPointSet
setSingleton Label
label
Status
f -> Status
f
result :: [(Label, Status)]
result = (Label -> (Label, Status)) -> [Label] -> [(Label, Status)]
forall a b. (a -> b) -> [a] -> [b]
map (\Label
id -> (Label
id, Status
fact)) (Block CmmNode C C -> [Label]
forall (e :: Extensibility). Block CmmNode e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors Block CmmNode C C
block)
in DataflowLattice Status -> [(Label, Status)] -> LabelMap Status
forall f. DataflowLattice f -> [(Label, f)] -> FactBase f
mkFactBase DataflowLattice Status
procPointLattice [(Label, Status)]
result
procPointLattice :: DataflowLattice Status
procPointLattice :: DataflowLattice Status
procPointLattice = Status -> JoinFun Status -> DataflowLattice Status
forall a. a -> JoinFun a -> DataflowLattice a
DataflowLattice Status
unreached JoinFun Status
add_to
where
unreached :: Status
unreached = ProcPointSet -> Status
ReachedBy ProcPointSet
setEmpty
add_to :: JoinFun Status
add_to (OldFact Status
ProcPoint) NewFact Status
_ = Status -> JoinedFact Status
forall a. a -> JoinedFact a
NotChanged Status
ProcPoint
add_to OldFact Status
_ (NewFact Status
ProcPoint) = Status -> JoinedFact Status
forall a. a -> JoinedFact a
Changed Status
ProcPoint
add_to (OldFact (ReachedBy ProcPointSet
p)) (NewFact (ReachedBy ProcPointSet
p'))
| ProcPointSet -> Int
setSize ProcPointSet
union Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ProcPointSet -> Int
setSize ProcPointSet
p = Status -> JoinedFact Status
forall a. a -> JoinedFact a
Changed (ProcPointSet -> Status
ReachedBy ProcPointSet
union)
| Bool
otherwise = Status -> JoinedFact Status
forall a. a -> JoinedFact a
NotChanged (ProcPointSet -> Status
ReachedBy ProcPointSet
p)
where
union :: ProcPointSet
union = ProcPointSet -> ProcPointSet -> ProcPointSet
setUnion ProcPointSet
p' ProcPointSet
p
callProcPoints :: CmmGraph -> ProcPointSet
callProcPoints :: CmmGraph -> ProcPointSet
callProcPoints CmmGraph
g = (ProcPointSet -> Block CmmNode C C -> ProcPointSet)
-> ProcPointSet -> CmmGraph -> ProcPointSet
forall a. (a -> Block CmmNode C C -> a) -> a -> CmmGraph -> a
foldlGraphBlocks ProcPointSet -> Block CmmNode C C -> ProcPointSet
add (Label -> ProcPointSet
setSingleton (CmmGraph -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry CmmGraph
g)) CmmGraph
g
where add :: LabelSet -> CmmBlock -> LabelSet
add :: ProcPointSet -> Block CmmNode C C -> ProcPointSet
add ProcPointSet
set Block CmmNode C C
b = case Block CmmNode C C -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C
lastNode Block CmmNode C C
b of
CmmCall {cml_cont :: CmmNode O C -> Maybe Label
cml_cont = Just Label
k} -> Label -> ProcPointSet -> ProcPointSet
setInsert Label
k ProcPointSet
set
CmmForeignCall {succ :: CmmNode O C -> Label
succ=Label
k} -> Label -> ProcPointSet -> ProcPointSet
setInsert Label
k ProcPointSet
set
CmmNode O C
_ -> ProcPointSet
set
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
-> UniqDSM ProcPointSet
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> UniqDSM ProcPointSet
minimalProcPointSet Platform
platform ProcPointSet
callProcPoints CmmGraph
g
= Platform
-> CmmGraph
-> [Block CmmNode C C]
-> ProcPointSet
-> UniqDSM ProcPointSet
extendPPSet Platform
platform CmmGraph
g (CmmGraph -> [Block CmmNode C C]
revPostorder CmmGraph
g) ProcPointSet
callProcPoints
extendPPSet
:: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqDSM ProcPointSet
extendPPSet :: Platform
-> CmmGraph
-> [Block CmmNode C C]
-> ProcPointSet
-> UniqDSM ProcPointSet
extendPPSet Platform
platform CmmGraph
g [Block CmmNode C C]
blocks ProcPointSet
procPoints =
let env :: LabelMap Status
env = ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis ProcPointSet
procPoints CmmGraph
g
add :: ProcPointSet -> Block CmmNode C C -> ProcPointSet
add ProcPointSet
pps Block CmmNode C C
block = let id :: Label
id = Block CmmNode C C -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
block
in case Label -> LabelMap Status -> Maybe Status
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
id LabelMap Status
env of
Just Status
ProcPoint -> Label -> ProcPointSet -> ProcPointSet
setInsert Label
id ProcPointSet
pps
Maybe Status
_ -> ProcPointSet
pps
procPoints' :: ProcPointSet
procPoints' = (ProcPointSet -> Block CmmNode C C -> ProcPointSet)
-> ProcPointSet -> CmmGraph -> ProcPointSet
forall a. (a -> Block CmmNode C C -> a) -> a -> CmmGraph -> a
foldlGraphBlocks ProcPointSet -> Block CmmNode C C -> ProcPointSet
add ProcPointSet
setEmpty CmmGraph
g
newPoints :: [Label]
newPoints = (Block CmmNode C C -> Maybe Label)
-> [Block CmmNode C C] -> [Label]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Block CmmNode C C -> Maybe Label
ppSuccessor [Block CmmNode C C]
blocks
newPoint :: Maybe Label
newPoint = [Label] -> Maybe Label
forall a. [a] -> Maybe a
listToMaybe [Label]
newPoints
ppSuccessor :: Block CmmNode C C -> Maybe Label
ppSuccessor Block CmmNode C C
b =
let nreached :: Label -> Int
nreached Label
id = case Label -> LabelMap Status -> Maybe Status
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
id LabelMap Status
env Maybe Status -> Status -> Status
forall a. Maybe a -> a -> a
`orElse`
String -> SDoc -> Status
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"no ppt" (Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> Block CmmNode C C -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Block CmmNode C C
b) of
Status
ProcPoint -> Int
1
ReachedBy ProcPointSet
ps -> ProcPointSet -> Int
setSize ProcPointSet
ps
block_procpoints :: Int
block_procpoints = Label -> Int
nreached (Block CmmNode C C -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
b)
newId :: Label -> Bool
newId Label
succ_id = Bool -> Bool
not (Label -> ProcPointSet -> Bool
setMember Label
succ_id ProcPointSet
procPoints') Bool -> Bool -> Bool
&&
Label -> Int
nreached Label
succ_id Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
block_procpoints
in [Label] -> Maybe Label
forall a. [a] -> Maybe a
listToMaybe ([Label] -> Maybe Label) -> [Label] -> Maybe Label
forall a b. (a -> b) -> a -> b
$ (Label -> Bool) -> [Label] -> [Label]
forall a. (a -> Bool) -> [a] -> [a]
filter Label -> Bool
newId ([Label] -> [Label]) -> [Label] -> [Label]
forall a b. (a -> b) -> a -> b
$ Block CmmNode C C -> [Label]
forall (e :: Extensibility). Block CmmNode e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors Block CmmNode C C
b
in case Maybe Label
newPoint of
Just Label
id ->
if Label -> ProcPointSet -> Bool
setMember Label
id ProcPointSet
procPoints'
then String -> UniqDSM ProcPointSet
forall a. HasCallStack => String -> a
panic String
"added old proc pt"
else Platform
-> CmmGraph
-> [Block CmmNode C C]
-> ProcPointSet
-> UniqDSM ProcPointSet
extendPPSet Platform
platform CmmGraph
g [Block CmmNode C C]
blocks (Label -> ProcPointSet -> ProcPointSet
setInsert Label
id ProcPointSet
procPoints')
Maybe Label
Nothing -> ProcPointSet -> UniqDSM ProcPointSet
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcPointSet
procPoints'
splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl
-> UniqDSM [CmmDecl]
splitAtProcPoints :: Platform
-> CLabel
-> ProcPointSet
-> ProcPointSet
-> LabelMap Status
-> CmmDecl
-> UniqDSM [CmmDecl]
splitAtProcPoints Platform
_ CLabel
_ ProcPointSet
_ ProcPointSet
_ LabelMap Status
_ t :: CmmDecl
t@(CmmData Section
_ CmmStatics
_) = [CmmDecl] -> UniqDSM [CmmDecl]
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [CmmDecl
t]
splitAtProcPoints Platform
platform CLabel
entry_label ProcPointSet
callPPs ProcPointSet
procPoints LabelMap Status
procMap CmmDecl
cmmProc = do
let (CmmProc (TopInfo {info_tbls :: forall (f :: * -> *). GenCmmTopInfo f -> f CmmInfoTable
info_tbls = LabelMap CmmInfoTable
info_tbls}) CLabel
top_l [GlobalRegUse]
_ g :: CmmGraph
g@(CmmGraph {g_entry :: forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry=Label
entry})) = CmmDecl
cmmProc
let add :: LabelMap (LabelMap v)
-> Label -> Label -> v -> LabelMap (LabelMap v)
add LabelMap (LabelMap v)
graphEnv Label
procId Label
bid v
b = Label
-> LabelMap v -> LabelMap (LabelMap v) -> LabelMap (LabelMap v)
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
procId LabelMap v
graph' LabelMap (LabelMap v)
graphEnv
where
graph' :: LabelMap v
graph' = Label -> v -> LabelMap v -> LabelMap v
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
bid v
b LabelMap v
graph
graph :: LabelMap v
graph = Label -> LabelMap (LabelMap v) -> Maybe (LabelMap v)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
procId LabelMap (LabelMap v)
graphEnv Maybe (LabelMap v) -> LabelMap v -> LabelMap v
forall a. Maybe a -> a -> a
`orElse` LabelMap v
forall v. LabelMap v
mapEmpty
let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock)
add_block :: LabelMap (LabelMap (Block CmmNode C C))
-> Block CmmNode C C -> LabelMap (LabelMap (Block CmmNode C C))
add_block LabelMap (LabelMap (Block CmmNode C C))
graphEnv Block CmmNode C C
b =
case Label -> LabelMap Status -> Maybe Status
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
bid LabelMap Status
procMap of
Just Status
ProcPoint -> LabelMap (LabelMap (Block CmmNode C C))
-> Label
-> Label
-> Block CmmNode C C
-> LabelMap (LabelMap (Block CmmNode C C))
forall {v}.
LabelMap (LabelMap v)
-> Label -> Label -> v -> LabelMap (LabelMap v)
add LabelMap (LabelMap (Block CmmNode C C))
graphEnv Label
bid Label
bid Block CmmNode C C
b
Just (ReachedBy ProcPointSet
set) ->
case ProcPointSet -> [Label]
setElems ProcPointSet
set of
[] -> LabelMap (LabelMap (Block CmmNode C C))
graphEnv
[Label
id] -> LabelMap (LabelMap (Block CmmNode C C))
-> Label
-> Label
-> Block CmmNode C C
-> LabelMap (LabelMap (Block CmmNode C C))
forall {v}.
LabelMap (LabelMap v)
-> Label -> Label -> v -> LabelMap (LabelMap v)
add LabelMap (LabelMap (Block CmmNode C C))
graphEnv Label
id Label
bid Block CmmNode C C
b
[Label]
_ -> String -> LabelMap (LabelMap (Block CmmNode C C))
forall a. HasCallStack => String -> a
panic String
"Each block should be reachable from only one ProcPoint"
Maybe Status
Nothing -> LabelMap (LabelMap (Block CmmNode C C))
graphEnv
where
bid :: Label
bid = Block CmmNode C C -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
b
let liveness :: BlockEntryLiveness GlobalRegUse
liveness = Platform -> CmmGraph -> BlockEntryLiveness GlobalRegUse
cmmGlobalLiveness Platform
platform CmmGraph
g
let ppLiveness :: Label -> [GlobalRegUse]
ppLiveness Label
pp = (GlobalRegUse -> Bool) -> [GlobalRegUse] -> [GlobalRegUse]
forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalReg -> Bool
isArgReg (GlobalReg -> Bool)
-> (GlobalRegUse -> GlobalReg) -> GlobalRegUse -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRegUse -> GlobalReg
globalRegUse_reg) ([GlobalRegUse] -> [GlobalRegUse])
-> [GlobalRegUse] -> [GlobalRegUse]
forall a b. (a -> b) -> a -> b
$ RegSet GlobalRegUse -> [GlobalRegUse]
forall r. RegSet r -> [r]
regSetToList (RegSet GlobalRegUse -> [GlobalRegUse])
-> RegSet GlobalRegUse -> [GlobalRegUse]
forall a b. (a -> b) -> a -> b
$
String -> Maybe (RegSet GlobalRegUse) -> RegSet GlobalRegUse
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"ppLiveness" (Maybe (RegSet GlobalRegUse) -> RegSet GlobalRegUse)
-> Maybe (RegSet GlobalRegUse) -> RegSet GlobalRegUse
forall a b. (a -> b) -> a -> b
$ Label
-> BlockEntryLiveness GlobalRegUse -> Maybe (RegSet GlobalRegUse)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
pp BlockEntryLiveness GlobalRegUse
liveness
graphEnv <- LabelMap (LabelMap (Block CmmNode C C))
-> UniqDSM (LabelMap (LabelMap (Block CmmNode C C)))
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap (LabelMap (Block CmmNode C C))
-> UniqDSM (LabelMap (LabelMap (Block CmmNode C C))))
-> LabelMap (LabelMap (Block CmmNode C C))
-> UniqDSM (LabelMap (LabelMap (Block CmmNode C C)))
forall a b. (a -> b) -> a -> b
$ (LabelMap (LabelMap (Block CmmNode C C))
-> Block CmmNode C C -> LabelMap (LabelMap (Block CmmNode C C)))
-> LabelMap (LabelMap (Block CmmNode C C))
-> CmmGraph
-> LabelMap (LabelMap (Block CmmNode C C))
forall a. (a -> Block CmmNode C C -> a) -> a -> CmmGraph -> a
foldlGraphBlocks LabelMap (LabelMap (Block CmmNode C C))
-> Block CmmNode C C -> LabelMap (LabelMap (Block CmmNode C C))
add_block LabelMap (LabelMap (Block CmmNode C C))
forall v. LabelMap v
mapEmpty CmmGraph
g
let add_label LabelMap (CLabel, Maybe CLabel)
map Label
pp = Label
-> (CLabel, Maybe CLabel)
-> LabelMap (CLabel, Maybe CLabel)
-> LabelMap (CLabel, Maybe CLabel)
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
pp (CLabel, Maybe CLabel)
lbls LabelMap (CLabel, Maybe CLabel)
map
where lbls :: (CLabel, Maybe CLabel)
lbls | Label
pp Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
entry = (CLabel
entry_label, (CmmInfoTable -> CLabel) -> Maybe CmmInfoTable -> Maybe CLabel
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmmInfoTable -> CLabel
cit_lbl (Label -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
entry LabelMap CmmInfoTable
info_tbls))
| Bool
otherwise = (CLabel
block_lbl, Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Label -> ProcPointSet -> Bool
setMember Label
pp ProcPointSet
callPPs) Maybe () -> Maybe CLabel -> Maybe CLabel
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
info_table_lbl)
where block_lbl :: CLabel
block_lbl = Label -> CLabel
blockLbl Label
pp
info_table_lbl :: CLabel
info_table_lbl = Label -> CLabel
infoTblLbl Label
pp
procLabels :: LabelMap (CLabel, Maybe CLabel)
procLabels = (LabelMap (CLabel, Maybe CLabel)
-> Label -> LabelMap (CLabel, Maybe CLabel))
-> LabelMap (CLabel, Maybe CLabel)
-> [Label]
-> LabelMap (CLabel, Maybe CLabel)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LabelMap (CLabel, Maybe CLabel)
-> Label -> LabelMap (CLabel, Maybe CLabel)
add_label LabelMap (CLabel, Maybe CLabel)
forall v. LabelMap v
mapEmpty
((Label -> Bool) -> [Label] -> [Label]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Label -> LabelMap (Block CmmNode C C) -> Bool)
-> LabelMap (Block CmmNode C C) -> Label -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Label -> LabelMap (Block CmmNode C C) -> Bool
forall a. Label -> LabelMap a -> Bool
mapMember (CmmGraph -> LabelMap (Block CmmNode C C)
toBlockMap CmmGraph
g)) (ProcPointSet -> [Label]
setElems ProcPointSet
procPoints))
let add_jump_block :: (LabelMap Label, [CmmBlock])
-> (Label, CLabel)
-> UniqDSM (LabelMap Label, [CmmBlock])
add_jump_block (LabelMap Label
env, [Block CmmNode C C]
bs) (Label
pp, CLabel
l) = do
bid <- (Unique -> Label) -> UniqDSM Unique -> UniqDSM Label
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Unique -> Label
mkBlockId UniqDSM Unique
getUniqueDSM
let b = CmmNode C O
-> Block CmmNode O O -> CmmNode O C -> Block CmmNode C C
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin (Label -> CmmTickScope -> CmmNode C O
CmmEntry Label
bid CmmTickScope
GlobalScope) Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock CmmNode O C
jump
live = Label -> [GlobalRegUse]
ppLiveness Label
pp
jump = CmmExpr
-> Maybe Label
-> [GlobalRegUse]
-> Int
-> Int
-> Int
-> CmmNode O C
CmmCall (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
l)) Maybe Label
forall a. Maybe a
Nothing [GlobalRegUse]
live Int
0 Int
0 Int
0
return (mapInsert pp bid env, b : bs)
let tablesNextToCode = Platform -> Bool
platformTablesNextToCode Platform
platform
let jump_label (Just CLabel
info_lbl) CLabel
_
| Bool
tablesNextToCode = CLabel
info_lbl
| Bool
otherwise = Platform -> CLabel -> CLabel
toEntryLbl Platform
platform CLabel
info_lbl
jump_label Maybe CLabel
Nothing CLabel
block_lbl = CLabel
block_lbl
let add_if_pp Label
id [(Label, CLabel)]
rst =
case Label
-> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
id LabelMap (CLabel, Maybe CLabel)
procLabels of
Just (CLabel
lbl, Maybe CLabel
mb_info_lbl) -> (Label
id, Maybe CLabel -> CLabel -> CLabel
jump_label Maybe CLabel
mb_info_lbl CLabel
lbl) (Label, CLabel) -> [(Label, CLabel)] -> [(Label, CLabel)]
forall a. a -> [a] -> [a]
: [(Label, CLabel)]
rst
Maybe (CLabel, Maybe CLabel)
Nothing -> [(Label, CLabel)]
rst
let add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
add_if_branch_to_pp Block CmmNode C C
block [(Label, CLabel)]
rst =
case Block CmmNode C C -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C
lastNode Block CmmNode C C
block of
CmmBranch Label
id -> Label -> [(Label, CLabel)] -> [(Label, CLabel)]
add_if_pp Label
id [(Label, CLabel)]
rst
CmmCondBranch CmmExpr
_ Label
ti Label
fi Maybe Bool
_ -> Label -> [(Label, CLabel)] -> [(Label, CLabel)]
add_if_pp Label
ti (Label -> [(Label, CLabel)] -> [(Label, CLabel)]
add_if_pp Label
fi [(Label, CLabel)]
rst)
CmmSwitch CmmExpr
_ SwitchTargets
ids -> (Label -> [(Label, CLabel)] -> [(Label, CLabel)])
-> [(Label, CLabel)] -> [Label] -> [(Label, CLabel)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Label -> [(Label, CLabel)] -> [(Label, CLabel)]
add_if_pp [(Label, CLabel)]
rst ([Label] -> [(Label, CLabel)]) -> [Label] -> [(Label, CLabel)]
forall a b. (a -> b) -> a -> b
$ SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
ids
CmmNode O C
_ -> [(Label, CLabel)]
rst
let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqDSM (LabelMap CmmGraph)
add_jumps LabelMap CmmGraph
newGraphEnv (Label
ppId, LabelMap (Block CmmNode C C)
blockEnv) = do
let needed_jumps :: [(Label, CLabel)]
needed_jumps = (Block CmmNode C C -> [(Label, CLabel)] -> [(Label, CLabel)])
-> [(Label, CLabel)]
-> LabelMap (Block CmmNode C C)
-> [(Label, CLabel)]
forall a b. (a -> b -> b) -> b -> LabelMap a -> b
mapFoldr Block CmmNode C C -> [(Label, CLabel)] -> [(Label, CLabel)]
add_if_branch_to_pp [] LabelMap (Block CmmNode C C)
blockEnv
(jumpEnv, jumpBlocks) <-
((LabelMap Label, [Block CmmNode C C])
-> (Label, CLabel)
-> UniqDSM (LabelMap Label, [Block CmmNode C C]))
-> (LabelMap Label, [Block CmmNode C C])
-> [(Label, CLabel)]
-> UniqDSM (LabelMap Label, [Block CmmNode C C])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (LabelMap Label, [Block CmmNode C C])
-> (Label, CLabel) -> UniqDSM (LabelMap Label, [Block CmmNode C C])
add_jump_block (LabelMap Label
forall v. LabelMap v
mapEmpty, []) [(Label, CLabel)]
needed_jumps
let b = String -> Maybe (Block CmmNode C C) -> Block CmmNode C C
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"block in env" (Maybe (Block CmmNode C C) -> Block CmmNode C C)
-> Maybe (Block CmmNode C C) -> Block CmmNode C C
forall a b. (a -> b) -> a -> b
$ Label -> LabelMap (Block CmmNode C C) -> Maybe (Block CmmNode C C)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
ppId LabelMap (Block CmmNode C C)
blockEnv
blockEnv' = Label
-> Block CmmNode C C
-> LabelMap (Block CmmNode C C)
-> LabelMap (Block CmmNode C C)
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
ppId Block CmmNode C C
b LabelMap (Block CmmNode C C)
blockEnv
blockEnv'' = CmmGraph -> LabelMap (Block CmmNode C C)
toBlockMap (CmmGraph -> LabelMap (Block CmmNode C C))
-> CmmGraph -> LabelMap (Block CmmNode C C)
forall a b. (a -> b) -> a -> b
$ LabelMap Label -> CmmGraph -> CmmGraph
replaceBranches LabelMap Label
jumpEnv (CmmGraph -> CmmGraph) -> CmmGraph -> CmmGraph
forall a b. (a -> b) -> a -> b
$ Label -> LabelMap (Block CmmNode C C) -> CmmGraph
ofBlockMap Label
ppId LabelMap (Block CmmNode C C)
blockEnv'
blockEnv''' = (LabelMap (Block CmmNode C C)
-> Block CmmNode C C -> LabelMap (Block CmmNode C C))
-> LabelMap (Block CmmNode C C)
-> [Block CmmNode C C]
-> LabelMap (Block CmmNode C C)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Block CmmNode C C
-> LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C))
-> LabelMap (Block CmmNode C C)
-> Block CmmNode C C
-> LabelMap (Block CmmNode C C)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Block CmmNode C C
-> LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C)
forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, HasDebugCallStack) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock) LabelMap (Block CmmNode C C)
blockEnv'' [Block CmmNode C C]
jumpBlocks
let g' = Label -> LabelMap (Block CmmNode C C) -> CmmGraph
ofBlockMap Label
ppId LabelMap (Block CmmNode C C)
blockEnv'''
return (mapInsert ppId g' newGraphEnv)
graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
let to_proc (Label
bid, CmmGraph
g)
| Label
bid Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
entry
= GenCmmTopInfo LabelMap
-> CLabel -> [GlobalRegUse] -> CmmGraph -> CmmDecl
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc (TopInfo {info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
info_tbls,
stack_info :: CmmStackInfo
stack_info = CmmStackInfo
stack_info})
CLabel
top_l [GlobalRegUse]
live CmmGraph
g'
| Bool
otherwise
= case String -> Maybe (CLabel, Maybe CLabel) -> (CLabel, Maybe CLabel)
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"pp label" (Maybe (CLabel, Maybe CLabel) -> (CLabel, Maybe CLabel))
-> Maybe (CLabel, Maybe CLabel) -> (CLabel, Maybe CLabel)
forall a b. (a -> b) -> a -> b
$ Label
-> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
bid LabelMap (CLabel, Maybe CLabel)
procLabels of
(CLabel
lbl, Just CLabel
info_lbl)
-> GenCmmTopInfo LabelMap
-> CLabel -> [GlobalRegUse] -> CmmGraph -> CmmDecl
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc (TopInfo { info_tbls :: LabelMap CmmInfoTable
info_tbls = Label -> CmmInfoTable -> LabelMap CmmInfoTable
forall v. Label -> v -> LabelMap v
mapSingleton (CmmGraph -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry CmmGraph
g) (CLabel -> CmmInfoTable
mkEmptyContInfoTable CLabel
info_lbl)
, stack_info :: CmmStackInfo
stack_info=CmmStackInfo
stack_info})
CLabel
lbl [GlobalRegUse]
live CmmGraph
g'
(CLabel
lbl, Maybe CLabel
Nothing)
-> GenCmmTopInfo LabelMap
-> CLabel -> [GlobalRegUse] -> CmmGraph -> CmmDecl
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc (TopInfo {info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
forall v. LabelMap v
mapEmpty, stack_info :: CmmStackInfo
stack_info=CmmStackInfo
stack_info})
CLabel
lbl [GlobalRegUse]
live CmmGraph
g'
where
g' :: CmmGraph
g' = CmmGraph -> CmmGraph
replacePPIds CmmGraph
g
live :: [GlobalRegUse]
live = Label -> [GlobalRegUse]
ppLiveness (CmmGraph -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry CmmGraph
g')
stack_info :: CmmStackInfo
stack_info = StackInfo { arg_space :: Int
arg_space = Int
0
, do_layout :: Bool
do_layout = Bool
True }
replacePPIds CmmGraph
g = {-# SCC "replacePPIds" #-}
(CmmNode C O -> CmmNode C O, CmmNode O O -> CmmNode O O,
CmmNode O C -> CmmNode O C)
-> CmmGraph -> CmmGraph
mapGraphNodes (CmmNode C O -> CmmNode C O
forall a. a -> a
id, (CmmExpr -> CmmExpr) -> CmmNode O O -> CmmNode O O
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp CmmExpr -> CmmExpr
repl, (CmmExpr -> CmmExpr) -> CmmNode O C -> CmmNode O C
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp CmmExpr -> CmmExpr
repl) CmmGraph
g
where repl :: CmmExpr -> CmmExpr
repl e :: CmmExpr
e@(CmmLit (CmmBlock Label
bid)) =
case Label
-> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
bid LabelMap (CLabel, Maybe CLabel)
procLabels of
Just (CLabel
_, Just CLabel
info_lbl) -> CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
info_lbl)
Maybe (CLabel, Maybe CLabel)
_ -> CmmExpr
e
repl CmmExpr
e = CmmExpr
e
let add_block_num (v
i, LabelMap v
map) thing C x
block =
(v
i v -> v -> v
forall a. Num a => a -> a -> a
+ v
1, Label -> v -> LabelMap v -> LabelMap v
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert (thing C x -> Label
forall (x :: Extensibility). thing C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
block) v
i LabelMap v
map)
let (_, block_order) =
foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
(revPostorder g)
let sort_fn (Label
bid, CmmGraph
_) (Label
bid', CmmGraph
_) =
Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (String -> Maybe Int -> Int
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"block_order" (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Label -> LabelMap Int -> Maybe Int
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
bid LabelMap Int
block_order)
(String -> Maybe Int -> Int
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"block_order" (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Label -> LabelMap Int -> Maybe Int
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
bid' LabelMap Int
block_order)
return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceBranches :: LabelMap Label -> CmmGraph -> CmmGraph
replaceBranches LabelMap Label
env CmmGraph
cmmg
= {-# SCC "replaceBranches" #-}
Label -> LabelMap (Block CmmNode C C) -> CmmGraph
ofBlockMap (CmmGraph -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry CmmGraph
cmmg) (LabelMap (Block CmmNode C C) -> CmmGraph)
-> LabelMap (Block CmmNode C C) -> CmmGraph
forall a b. (a -> b) -> a -> b
$ (Block CmmNode C C -> Block CmmNode C C)
-> LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C)
forall a v. (a -> v) -> LabelMap a -> LabelMap v
mapMap Block CmmNode C C -> Block CmmNode C C
forall {x :: Extensibility}. Block CmmNode x C -> Block CmmNode x C
f (LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C))
-> LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C)
forall a b. (a -> b) -> a -> b
$ CmmGraph -> LabelMap (Block CmmNode C C)
toBlockMap CmmGraph
cmmg
where
f :: Block CmmNode x C -> Block CmmNode x C
f Block CmmNode x C
block = Block CmmNode x C -> CmmNode O C -> Block CmmNode x C
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C -> Block n x C
replaceLastNode Block CmmNode x C
block (CmmNode O C -> Block CmmNode x C)
-> CmmNode O C -> Block CmmNode x C
forall a b. (a -> b) -> a -> b
$ CmmNode O C -> CmmNode O C
last (Block CmmNode x C -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C
lastNode Block CmmNode x C
block)
last :: CmmNode O C -> CmmNode O C
last :: CmmNode O C -> CmmNode O C
last (CmmBranch Label
id) = Label -> CmmNode O C
CmmBranch (Label -> Label
lookup Label
id)
last (CmmCondBranch CmmExpr
e Label
ti Label
fi Maybe Bool
l) = CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
e (Label -> Label
lookup Label
ti) (Label -> Label
lookup Label
fi) Maybe Bool
l
last (CmmSwitch CmmExpr
e SwitchTargets
ids) = CmmExpr -> SwitchTargets -> CmmNode O C
CmmSwitch CmmExpr
e ((Label -> Label) -> SwitchTargets -> SwitchTargets
mapSwitchTargets Label -> Label
lookup SwitchTargets
ids)
last l :: CmmNode O C
l@(CmmCall {}) = CmmNode O C
l { cml_cont = Nothing }
last l :: CmmNode O C
l@(CmmForeignCall {}) = CmmNode O C
l
lookup :: Label -> Label
lookup Label
id = (Label -> Label) -> Maybe Label -> Maybe Label
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Label -> Label
lookup (Label -> LabelMap Label -> Maybe Label
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
id LabelMap Label
env) Maybe Label -> Label -> Label
forall a. Maybe a -> a -> a
`orElse` Label
id
attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
attachContInfoTables ProcPointSet
call_proc_points (CmmProc GenCmmTopInfo LabelMap
top_info CLabel
top_l [GlobalRegUse]
live CmmGraph
g)
= GenCmmTopInfo LabelMap
-> CLabel -> [GlobalRegUse] -> CmmGraph -> CmmDecl
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc GenCmmTopInfo LabelMap
top_info{info_tbls = info_tbls'} CLabel
top_l [GlobalRegUse]
live CmmGraph
g
where
info_tbls' :: LabelMap CmmInfoTable
info_tbls' = LabelMap CmmInfoTable
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall v. LabelMap v -> LabelMap v -> LabelMap v
mapUnion (GenCmmTopInfo LabelMap -> LabelMap CmmInfoTable
forall (f :: * -> *). GenCmmTopInfo f -> f CmmInfoTable
info_tbls GenCmmTopInfo LabelMap
top_info) (LabelMap CmmInfoTable -> LabelMap CmmInfoTable)
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall a b. (a -> b) -> a -> b
$
[(Label, CmmInfoTable)] -> LabelMap CmmInfoTable
forall v. [(Label, v)] -> LabelMap v
mapFromList [ (Label
l, CLabel -> CmmInfoTable
mkEmptyContInfoTable (Label -> CLabel
infoTblLbl Label
l))
| Label
l <- ProcPointSet -> [Label]
setElems ProcPointSet
call_proc_points
, Label
l Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
/= CmmGraph -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry CmmGraph
g ]
attachContInfoTables ProcPointSet
_ CmmDecl
other_decl
= CmmDecl
other_decl