{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
module CmmProcPoint
( ProcPointSet, Status(..)
, callProcPoints, minimalProcPointSet
, splitAtProcPoints, procPointAnalysis
, attachContInfoTables
)
where
import GhcPrelude hiding (last, unzip, succ, zip)
import DynFlags
import BlockId
import CLabel
import Cmm
import PprCmm ()
import CmmUtils
import CmmInfo
import CmmLive
import CmmSwitch
import Data.List (sortBy)
import Maybes
import Control.Monad
import Outputable
import GHC.Platform
import UniqSupply
import Hoopl.Block
import Hoopl.Collections
import Hoopl.Dataflow
import Hoopl.Graph
import Hoopl.Label
type ProcPointSet = LabelSet
data Status
= ReachedBy ProcPointSet
| ProcPoint
instance Outputable Status where
ppr :: Status -> SDoc
ppr (ReachedBy ProcPointSet
ps)
| ProcPointSet -> Bool
forall set. IsSet set => set -> Bool
setNull ProcPointSet
ps = String -> SDoc
text String
"<not-reached>"
| Bool
otherwise = String -> SDoc
text String
"reached by" SDoc -> SDoc -> SDoc
<+>
([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
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 -> [ElemOf ProcPointSet]
forall set. IsSet set => set -> [ElemOf set]
setElems ProcPointSet
ps)
ppr Status
ProcPoint = String -> SDoc
text String
"<procpt>"
procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis ProcPointSet
procPoints cmmGraph :: CmmGraph
cmmGraph@(CmmGraph {g_graph :: forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Graph n C C
g_graph = Graph CmmNode C C
graph}) =
DataflowLattice Status
-> TransferFun Status
-> CmmGraph
-> LabelMap Status
-> LabelMap Status
forall f.
DataflowLattice f
-> TransferFun f -> CmmGraph -> FactBase f -> FactBase f
analyzeCmmFwd DataflowLattice Status
procPointLattice TransferFun 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 -> [ElemOf ProcPointSet]
forall set. IsSet set => set -> [ElemOf set]
setElems ProcPointSet
procPoints
, ElemOf ProcPointSet
Label
id ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
labelsInGraph
]
labelsInGraph :: ProcPointSet
labelsInGraph = Graph CmmNode C C -> ProcPointSet
forall (block :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n :: Extensibility -> Extensibility -> *) (e :: Extensibility)
(x :: Extensibility).
NonLocal (block n) =>
Graph' block n e x -> ProcPointSet
labelsDefined Graph CmmNode C C
graph
procPointTransfer :: TransferFun Status
procPointTransfer :: TransferFun Status
procPointTransfer CmmBlock
block LabelMap Status
facts =
let label :: Label
label = CmmBlock -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
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
$! ElemOf ProcPointSet -> ProcPointSet
forall set. IsSet set => ElemOf set -> set
setSingleton ElemOf ProcPointSet
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)) (CmmBlock -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors CmmBlock
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
forall set. IsSet set => set
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
forall set. IsSet set => set -> Int
setSize ProcPointSet
union Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ProcPointSet -> Int
forall set. IsSet set => set -> 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
forall set. IsSet set => set -> set -> set
setUnion ProcPointSet
p' ProcPointSet
p
callProcPoints :: CmmGraph -> ProcPointSet
callProcPoints :: CmmGraph -> ProcPointSet
callProcPoints CmmGraph
g = (ProcPointSet -> CmmBlock -> ProcPointSet)
-> ProcPointSet -> CmmGraph -> ProcPointSet
forall a. (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks ProcPointSet -> CmmBlock -> ProcPointSet
add (ElemOf ProcPointSet -> ProcPointSet
forall set. IsSet set => ElemOf set -> set
setSingleton (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g)) CmmGraph
g
where add :: LabelSet -> CmmBlock -> LabelSet
add :: ProcPointSet -> CmmBlock -> ProcPointSet
add ProcPointSet
set CmmBlock
b = case CmmBlock -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C
lastNode CmmBlock
b of
CmmCall {cml_cont :: CmmNode O C -> Maybe Label
cml_cont = Just Label
k} -> ElemOf ProcPointSet -> ProcPointSet -> ProcPointSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf ProcPointSet
Label
k ProcPointSet
set
CmmForeignCall {succ :: CmmNode O C -> Label
succ=Label
k} -> ElemOf ProcPointSet -> ProcPointSet -> ProcPointSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf ProcPointSet
Label
k ProcPointSet
set
CmmNode O C
_ -> ProcPointSet
set
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
-> UniqSM ProcPointSet
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> UniqSM ProcPointSet
minimalProcPointSet Platform
platform ProcPointSet
callProcPoints CmmGraph
g
= Platform
-> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
extendPPSet Platform
platform CmmGraph
g (CmmGraph -> [CmmBlock]
revPostorder CmmGraph
g) ProcPointSet
callProcPoints
extendPPSet
:: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
extendPPSet :: Platform
-> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
extendPPSet Platform
platform CmmGraph
g [CmmBlock]
blocks ProcPointSet
procPoints =
let env :: LabelMap Status
env = ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis ProcPointSet
procPoints CmmGraph
g
add :: ProcPointSet -> CmmBlock -> ProcPointSet
add ProcPointSet
pps CmmBlock
block = let id :: Label
id = CmmBlock -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block
in case KeyOf LabelMap -> LabelMap Status -> Maybe Status
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
id LabelMap Status
env of
Just Status
ProcPoint -> ElemOf ProcPointSet -> ProcPointSet -> ProcPointSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf ProcPointSet
Label
id ProcPointSet
pps
Maybe Status
_ -> ProcPointSet
pps
procPoints' :: ProcPointSet
procPoints' = (ProcPointSet -> CmmBlock -> ProcPointSet)
-> ProcPointSet -> CmmGraph -> ProcPointSet
forall a. (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks ProcPointSet -> CmmBlock -> ProcPointSet
add ProcPointSet
forall set. IsSet set => set
setEmpty CmmGraph
g
newPoints :: [Label]
newPoints = (CmmBlock -> Maybe Label) -> [CmmBlock] -> [Label]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CmmBlock -> Maybe Label
ppSuccessor [CmmBlock]
blocks
newPoint :: Maybe Label
newPoint = [Label] -> Maybe Label
forall a. [a] -> Maybe a
listToMaybe [Label]
newPoints
ppSuccessor :: CmmBlock -> Maybe Label
ppSuccessor CmmBlock
b =
let nreached :: Label -> Int
nreached Label
id = case KeyOf LabelMap -> LabelMap Status -> Maybe Status
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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
<+> CmmBlock -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmBlock
b) of
Status
ProcPoint -> Int
1
ReachedBy ProcPointSet
ps -> ProcPointSet -> Int
forall set. IsSet set => set -> Int
setSize ProcPointSet
ps
block_procpoints :: Int
block_procpoints = Label -> Int
nreached (CmmBlock -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
b)
newId :: Label -> Bool
newId Label
succ_id = Bool -> Bool
not (ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf ProcPointSet
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
$ CmmBlock -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors CmmBlock
b
in case Maybe Label
newPoint of
Just Label
id ->
if ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf ProcPointSet
Label
id ProcPointSet
procPoints'
then String -> UniqSM ProcPointSet
forall a. String -> a
panic String
"added old proc pt"
else Platform
-> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
extendPPSet Platform
platform CmmGraph
g [CmmBlock]
blocks (ElemOf ProcPointSet -> ProcPointSet -> ProcPointSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf ProcPointSet
Label
id ProcPointSet
procPoints')
Maybe Label
Nothing -> ProcPointSet -> UniqSM ProcPointSet
forall (m :: * -> *) a. Monad m => a -> m a
return ProcPointSet
procPoints'
splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints :: DynFlags
-> CLabel
-> ProcPointSet
-> ProcPointSet
-> LabelMap Status
-> CmmDecl
-> UniqSM [CmmDecl]
splitAtProcPoints DynFlags
dflags CLabel
entry_label ProcPointSet
callPPs ProcPointSet
procPoints LabelMap Status
procMap
(CmmProc (TopInfo {info_tbls :: CmmTopInfo -> LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
info_tbls})
CLabel
top_l [GlobalReg]
_ g :: CmmGraph
g@(CmmGraph {g_entry :: forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry=Label
entry})) =
do
let add_block
:: LabelMap (LabelMap CmmBlock)
-> CmmBlock
-> LabelMap (LabelMap CmmBlock)
add_block :: LabelMap (LabelMap CmmBlock)
-> CmmBlock -> LabelMap (LabelMap CmmBlock)
add_block LabelMap (LabelMap CmmBlock)
graphEnv CmmBlock
b =
case KeyOf LabelMap -> LabelMap Status -> Maybe Status
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
bid LabelMap Status
procMap of
Just Status
ProcPoint -> LabelMap (LabelMap CmmBlock)
-> KeyOf LabelMap
-> KeyOf LabelMap
-> CmmBlock
-> LabelMap (LabelMap CmmBlock)
forall (map :: * -> *) (map :: * -> *) a.
(IsMap map, IsMap map) =>
map (map a) -> KeyOf map -> KeyOf map -> a -> map (map a)
add LabelMap (LabelMap CmmBlock)
graphEnv KeyOf LabelMap
Label
bid KeyOf LabelMap
Label
bid CmmBlock
b
Just (ReachedBy ProcPointSet
set) ->
case ProcPointSet -> [ElemOf ProcPointSet]
forall set. IsSet set => set -> [ElemOf set]
setElems ProcPointSet
set of
[] -> LabelMap (LabelMap CmmBlock)
graphEnv
[ElemOf ProcPointSet
id] -> LabelMap (LabelMap CmmBlock)
-> KeyOf LabelMap
-> KeyOf LabelMap
-> CmmBlock
-> LabelMap (LabelMap CmmBlock)
forall (map :: * -> *) (map :: * -> *) a.
(IsMap map, IsMap map) =>
map (map a) -> KeyOf map -> KeyOf map -> a -> map (map a)
add LabelMap (LabelMap CmmBlock)
graphEnv KeyOf LabelMap
ElemOf ProcPointSet
id KeyOf LabelMap
Label
bid CmmBlock
b
[ElemOf ProcPointSet]
_ -> String -> LabelMap (LabelMap CmmBlock)
forall a. String -> a
panic String
"Each block should be reachable from only one ProcPoint"
Maybe Status
Nothing -> LabelMap (LabelMap CmmBlock)
graphEnv
where bid :: Label
bid = CmmBlock -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
b
add :: map (map a) -> KeyOf map -> KeyOf map -> a -> map (map a)
add map (map a)
graphEnv KeyOf map
procId KeyOf map
bid a
b = KeyOf map -> map a -> map (map a) -> map (map a)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf map
procId map a
graph' map (map a)
graphEnv
where graph :: map a
graph = KeyOf map -> map (map a) -> Maybe (map a)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf map
procId map (map a)
graphEnv Maybe (map a) -> map a -> map a
forall a. Maybe a -> a -> a
`orElse` map a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
graph' :: map a
graph' = KeyOf map -> a -> map a -> map a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf map
bid a
b map a
graph
let liveness :: BlockEntryLiveness GlobalReg
liveness = DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg
cmmGlobalLiveness DynFlags
dflags CmmGraph
g
let ppLiveness :: Label -> [GlobalReg]
ppLiveness Label
pp = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalReg -> Bool
isArgReg ([GlobalReg] -> [GlobalReg]) -> [GlobalReg] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$
RegSet GlobalReg -> [GlobalReg]
forall r. RegSet r -> [r]
regSetToList (RegSet GlobalReg -> [GlobalReg])
-> RegSet GlobalReg -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$
String -> Maybe (RegSet GlobalReg) -> RegSet GlobalReg
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"ppLiveness" (Maybe (RegSet GlobalReg) -> RegSet GlobalReg)
-> Maybe (RegSet GlobalReg) -> RegSet GlobalReg
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> BlockEntryLiveness GlobalReg -> Maybe (RegSet GlobalReg)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
pp BlockEntryLiveness GlobalReg
liveness
LabelMap (LabelMap CmmBlock)
graphEnv <- LabelMap (LabelMap CmmBlock)
-> UniqSM (LabelMap (LabelMap CmmBlock))
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap (LabelMap CmmBlock)
-> UniqSM (LabelMap (LabelMap CmmBlock)))
-> LabelMap (LabelMap CmmBlock)
-> UniqSM (LabelMap (LabelMap CmmBlock))
forall a b. (a -> b) -> a -> b
$ (LabelMap (LabelMap CmmBlock)
-> CmmBlock -> LabelMap (LabelMap CmmBlock))
-> LabelMap (LabelMap CmmBlock)
-> CmmGraph
-> LabelMap (LabelMap CmmBlock)
forall a. (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks LabelMap (LabelMap CmmBlock)
-> CmmBlock -> LabelMap (LabelMap CmmBlock)
add_block LabelMap (LabelMap CmmBlock)
forall (map :: * -> *) a. IsMap map => map a
mapEmpty CmmGraph
g
let add_label :: LabelMap (CLabel, Maybe CLabel)
-> Label -> LabelMap (CLabel, Maybe CLabel)
add_label LabelMap (CLabel, Maybe CLabel)
map Label
pp = KeyOf LabelMap
-> (CLabel, Maybe CLabel)
-> LabelMap (CLabel, Maybe CLabel)
-> LabelMap (CLabel, Maybe CLabel)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmmInfoTable -> CLabel
cit_lbl (KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
entry LabelMap CmmInfoTable
info_tbls))
| Bool
otherwise = (CLabel
block_lbl, Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf ProcPointSet
Label
pp ProcPointSet
callPPs) Maybe () -> Maybe CLabel -> Maybe CLabel
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)
procLabels = (LabelMap (CLabel, Maybe CLabel)
-> Label -> LabelMap (CLabel, Maybe CLabel))
-> LabelMap (CLabel, Maybe CLabel)
-> [Label]
-> LabelMap (CLabel, Maybe CLabel)
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 (map :: * -> *) a. IsMap map => map a
mapEmpty
((Label -> Bool) -> [Label] -> [Label]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Label -> LabelMap CmmBlock -> Bool)
-> LabelMap CmmBlock -> Label -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Label -> LabelMap CmmBlock -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember (CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g)) (ProcPointSet -> [ElemOf ProcPointSet]
forall set. IsSet set => set -> [ElemOf set]
setElems ProcPointSet
procPoints))
let add_jump_block
:: (LabelMap Label, [CmmBlock])
-> (Label, CLabel)
-> UniqSM (LabelMap Label, [CmmBlock])
add_jump_block :: (LabelMap Label, [CmmBlock])
-> (Label, CLabel) -> UniqSM (LabelMap Label, [CmmBlock])
add_jump_block (LabelMap Label
env, [CmmBlock]
bs) (Label
pp, CLabel
l) =
do Label
bid <- (Unique -> Label) -> UniqSM Unique -> UniqSM Label
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Unique -> Label
mkBlockId UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
let b :: CmmBlock
b = CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
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 :: [GlobalReg]
live = Label -> [GlobalReg]
ppLiveness Label
pp
jump :: CmmNode O C
jump = CmmExpr
-> Maybe Label -> [GlobalReg] -> Int -> Int -> Int -> CmmNode O C
CmmCall (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
l)) Maybe Label
forall a. Maybe a
Nothing [GlobalReg]
live Int
0 Int
0 Int
0
(LabelMap Label, [CmmBlock]) -> UniqSM (LabelMap Label, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyOf LabelMap -> Label -> LabelMap Label -> LabelMap Label
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
pp Label
bid LabelMap Label
env, CmmBlock
b CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: [CmmBlock]
bs)
add_jumps
:: LabelMap CmmGraph
-> (Label, LabelMap CmmBlock)
-> UniqSM (LabelMap CmmGraph)
add_jumps :: LabelMap CmmGraph
-> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)
add_jumps LabelMap CmmGraph
newGraphEnv (Label
ppId, LabelMap CmmBlock
blockEnv) =
do let needed_jumps :: [(Label, CLabel)]
needed_jumps =
(CmmBlock -> [(Label, CLabel)] -> [(Label, CLabel)])
-> [(Label, CLabel)] -> LabelMap CmmBlock -> [(Label, CLabel)]
forall (map :: * -> *) a b.
IsMap map =>
(a -> b -> b) -> b -> map a -> b
mapFoldr CmmBlock -> [(Label, CLabel)] -> [(Label, CLabel)]
add_if_branch_to_pp [] LabelMap CmmBlock
blockEnv
add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
add_if_branch_to_pp :: CmmBlock -> [(Label, CLabel)] -> [(Label, CLabel)]
add_if_branch_to_pp CmmBlock
block [(Label, CLabel)]
rst =
case CmmBlock -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C
lastNode CmmBlock
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 (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
jump_label :: Maybe CLabel -> CLabel -> CLabel
jump_label (Just CLabel
info_lbl) CLabel
_
| DynFlags -> Bool
tablesNextToCode DynFlags
dflags = CLabel
info_lbl
| Bool
otherwise = CLabel -> CLabel
toEntryLbl CLabel
info_lbl
jump_label Maybe CLabel
Nothing CLabel
block_lbl = CLabel
block_lbl
add_if_pp :: Label -> [(Label, CLabel)] -> [(Label, CLabel)]
add_if_pp Label
id [(Label, CLabel)]
rst = case KeyOf LabelMap
-> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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
(LabelMap Label
jumpEnv, [CmmBlock]
jumpBlocks) <-
((LabelMap Label, [CmmBlock])
-> (Label, CLabel) -> UniqSM (LabelMap Label, [CmmBlock]))
-> (LabelMap Label, [CmmBlock])
-> [(Label, CLabel)]
-> UniqSM (LabelMap Label, [CmmBlock])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (LabelMap Label, [CmmBlock])
-> (Label, CLabel) -> UniqSM (LabelMap Label, [CmmBlock])
add_jump_block (LabelMap Label
forall (map :: * -> *) a. IsMap map => map a
mapEmpty, []) [(Label, CLabel)]
needed_jumps
let b :: CmmBlock
b = String -> Maybe CmmBlock -> CmmBlock
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"block in env" (Maybe CmmBlock -> CmmBlock) -> Maybe CmmBlock -> CmmBlock
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
ppId LabelMap CmmBlock
blockEnv
blockEnv' :: LabelMap CmmBlock
blockEnv' = KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
ppId CmmBlock
b LabelMap CmmBlock
blockEnv
blockEnv'' :: LabelMap CmmBlock
blockEnv'' = CmmGraph -> LabelMap CmmBlock
toBlockMap (CmmGraph -> LabelMap CmmBlock) -> CmmGraph -> LabelMap CmmBlock
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 CmmBlock -> CmmGraph
ofBlockMap Label
ppId LabelMap CmmBlock
blockEnv'
blockEnv''' :: LabelMap CmmBlock
blockEnv''' = (LabelMap CmmBlock -> CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> [CmmBlock] -> LabelMap CmmBlock
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> CmmBlock -> LabelMap CmmBlock
forall a b c. (a -> b -> c) -> b -> a -> c
flip CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, HasDebugCallStack) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock) LabelMap CmmBlock
blockEnv'' [CmmBlock]
jumpBlocks
let g' :: CmmGraph
g' = Label -> LabelMap CmmBlock -> CmmGraph
ofBlockMap Label
ppId LabelMap CmmBlock
blockEnv'''
LabelMap CmmGraph -> UniqSM (LabelMap CmmGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyOf LabelMap
-> CmmGraph -> LabelMap CmmGraph -> LabelMap CmmGraph
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
ppId CmmGraph
g' LabelMap CmmGraph
newGraphEnv)
LabelMap CmmGraph
graphEnv <- (LabelMap CmmGraph
-> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph))
-> LabelMap CmmGraph
-> [(Label, LabelMap CmmBlock)]
-> UniqSM (LabelMap CmmGraph)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LabelMap CmmGraph
-> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)
add_jumps LabelMap CmmGraph
forall (map :: * -> *) a. IsMap map => map a
mapEmpty ([(Label, LabelMap CmmBlock)] -> UniqSM (LabelMap CmmGraph))
-> [(Label, LabelMap CmmBlock)] -> UniqSM (LabelMap CmmGraph)
forall a b. (a -> b) -> a -> b
$ LabelMap (LabelMap CmmBlock)
-> [(KeyOf LabelMap, LabelMap CmmBlock)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap (LabelMap CmmBlock)
graphEnv
let to_proc :: (Label, CmmGraph) -> CmmDecl
to_proc (Label
bid, CmmGraph
g)
| Label
bid Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
entry
= CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc (TopInfo :: LabelMap CmmInfoTable -> CmmStackInfo -> CmmTopInfo
TopInfo {info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
info_tbls,
stack_info :: CmmStackInfo
stack_info = CmmStackInfo
stack_info})
CLabel
top_l [GlobalReg]
live CmmGraph
g'
| Bool
otherwise
= case String -> Maybe (CLabel, Maybe CLabel) -> (CLabel, Maybe CLabel)
forall a. HasCallStack => 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
$ KeyOf LabelMap
-> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
bid LabelMap (CLabel, Maybe CLabel)
procLabels of
(CLabel
lbl, Just CLabel
info_lbl)
-> CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc (TopInfo :: LabelMap CmmInfoTable -> CmmStackInfo -> CmmTopInfo
TopInfo { info_tbls :: LabelMap CmmInfoTable
info_tbls = KeyOf LabelMap -> CmmInfoTable -> LabelMap CmmInfoTable
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g) (CLabel -> CmmInfoTable
mkEmptyContInfoTable CLabel
info_lbl)
, stack_info :: CmmStackInfo
stack_info=CmmStackInfo
stack_info})
CLabel
lbl [GlobalReg]
live CmmGraph
g'
(CLabel
lbl, Maybe CLabel
Nothing)
-> CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc (TopInfo :: LabelMap CmmInfoTable -> CmmStackInfo -> CmmTopInfo
TopInfo {info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
forall (map :: * -> *) a. IsMap map => map a
mapEmpty, stack_info :: CmmStackInfo
stack_info=CmmStackInfo
stack_info})
CLabel
lbl [GlobalReg]
live CmmGraph
g'
where
g' :: CmmGraph
g' = CmmGraph -> CmmGraph
replacePPIds CmmGraph
g
live :: [GlobalReg]
live = Label -> [GlobalReg]
ppLiveness (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g')
stack_info :: CmmStackInfo
stack_info = StackInfo :: Int -> Maybe Int -> Bool -> CmmStackInfo
StackInfo { arg_space :: Int
arg_space = Int
0
, updfr_space :: Maybe Int
updfr_space = Maybe Int
forall a. Maybe a
Nothing
, do_layout :: Bool
do_layout = Bool
True }
replacePPIds :: CmmGraph -> CmmGraph
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 KeyOf LabelMap
-> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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 (Int
_, LabelMap Int
block_order) =
((Int, LabelMap Int) -> CmmBlock -> (Int, LabelMap Int))
-> (Int, LabelMap Int) -> [CmmBlock] -> (Int, LabelMap Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, LabelMap Int) -> CmmBlock -> (Int, LabelMap Int)
forall a (map :: * -> *)
(thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
(Num a, IsMap map, NonLocal thing, KeyOf map ~ Label) =>
(a, map a) -> thing C x -> (a, map a)
add_block_num (Int
0::Int, LabelMap Int
forall (map :: * -> *) a. IsMap map => map a
mapEmpty :: LabelMap Int)
(CmmGraph -> [CmmBlock]
revPostorder CmmGraph
g)
add_block_num :: (a, map a) -> thing C x -> (a, map a)
add_block_num (a
i, map a
map) thing C x
block =
(a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, KeyOf map -> a -> map a -> map a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (thing C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
block) a
i map a
map)
sort_fn :: (Label, CmmGraph) -> (Label, CmmGraph) -> Ordering
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. HasCallStack => String -> Maybe a -> a
expectJust String
"block_order" (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> LabelMap Int -> Maybe Int
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
bid LabelMap Int
block_order)
(String -> Maybe Int -> Int
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"block_order" (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> LabelMap Int -> Maybe Int
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
bid' LabelMap Int
block_order)
[CmmDecl]
procs <- [CmmDecl] -> UniqSM [CmmDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmDecl] -> UniqSM [CmmDecl]) -> [CmmDecl] -> UniqSM [CmmDecl]
forall a b. (a -> b) -> a -> b
$ ((Label, CmmGraph) -> CmmDecl) -> [(Label, CmmGraph)] -> [CmmDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Label, CmmGraph) -> CmmDecl
to_proc ([(Label, CmmGraph)] -> [CmmDecl])
-> [(Label, CmmGraph)] -> [CmmDecl]
forall a b. (a -> b) -> a -> b
$ ((Label, CmmGraph) -> (Label, CmmGraph) -> Ordering)
-> [(Label, CmmGraph)] -> [(Label, CmmGraph)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Label, CmmGraph) -> (Label, CmmGraph) -> Ordering
sort_fn ([(Label, CmmGraph)] -> [(Label, CmmGraph)])
-> [(Label, CmmGraph)] -> [(Label, CmmGraph)]
forall a b. (a -> b) -> a -> b
$ LabelMap CmmGraph -> [(KeyOf LabelMap, CmmGraph)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap CmmGraph
graphEnv
[CmmDecl] -> UniqSM [CmmDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return
[CmmDecl]
procs
splitAtProcPoints DynFlags
_ CLabel
_ ProcPointSet
_ ProcPointSet
_ LabelMap Status
_ t :: CmmDecl
t@(CmmData Section
_ CmmStatics
_) = [CmmDecl] -> UniqSM [CmmDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [CmmDecl
t]
replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceBranches :: LabelMap Label -> CmmGraph -> CmmGraph
replaceBranches LabelMap Label
env CmmGraph
cmmg
= {-# SCC "replaceBranches" #-}
Label -> LabelMap CmmBlock -> CmmGraph
ofBlockMap (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
cmmg) (LabelMap CmmBlock -> CmmGraph) -> LabelMap CmmBlock -> CmmGraph
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> CmmBlock) -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a b. IsMap map => (a -> b) -> map a -> map b
mapMap CmmBlock -> CmmBlock
forall (x :: Extensibility). Block CmmNode x C -> Block CmmNode x C
f (LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> LabelMap CmmBlock
forall a b. (a -> b) -> a -> b
$ CmmGraph -> LabelMap CmmBlock
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 :: Maybe Label
cml_cont = Maybe Label
forall a. Maybe a
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Label -> Label
lookup (KeyOf LabelMap -> LabelMap Label -> Maybe Label
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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 CmmTopInfo
top_info CLabel
top_l [GlobalReg]
live CmmGraph
g)
= CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info{info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
info_tbls'} CLabel
top_l [GlobalReg]
live CmmGraph
g
where
info_tbls' :: LabelMap CmmInfoTable
info_tbls' = LabelMap CmmInfoTable
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
mapUnion (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info) (LabelMap CmmInfoTable -> LabelMap CmmInfoTable)
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall a b. (a -> b) -> a -> b
$
[(KeyOf LabelMap, CmmInfoTable)] -> LabelMap CmmInfoTable
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
Label
l, CLabel -> CmmInfoTable
mkEmptyContInfoTable (Label -> CLabel
infoTblLbl Label
l))
| Label
l <- ProcPointSet -> [ElemOf ProcPointSet]
forall set. IsSet set => set -> [ElemOf set]
setElems ProcPointSet
call_proc_points
, 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 ]
attachContInfoTables ProcPointSet
_ CmmDecl
other_decl
= CmmDecl
other_decl