{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.CmmToAsm.BlockLayout
( sequenceTop, backendMaintainsCfg)
where
import GHC.Prelude hiding (head, init, last, tail)
import qualified GHC.Prelude as Partial (head, tail)
import GHC.Platform
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Config
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Label
import GHC.Types.Unique.FM
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Data.List.SetOps (removeDups)
import GHC.Data.OrdList
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import Data.List (sortOn, sortBy, nub)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Foldable (toList)
import qualified Data.Set as Set
import Data.STRef
import Control.Monad.ST.Strict
import Control.Monad (foldM, unless)
import GHC.Data.UnionFind
import GHC.Types.Unique.DSM (UniqDSM)
neighbourOverlapp :: Int
neighbourOverlapp :: Int
neighbourOverlapp = Int
2
type FrontierMap = LabelMap ([BlockId],BlockChain)
newtype BlockChain
= BlockChain { BlockChain -> OrdList BlockId
chainBlocks :: (OrdList BlockId) }
instance Eq BlockChain where
BlockChain OrdList BlockId
b1 == :: BlockChain -> BlockChain -> Bool
== BlockChain OrdList BlockId
b2 = OrdList BlockId -> OrdList BlockId -> Bool
forall a. Eq a => OrdList a -> OrdList a -> Bool
strictlyEqOL OrdList BlockId
b1 OrdList BlockId
b2
instance Ord (BlockChain) where
(BlockChain OrdList BlockId
lbls1) compare :: BlockChain -> BlockChain -> Ordering
`compare` (BlockChain OrdList BlockId
lbls2)
= Bool -> Ordering -> Ordering
forall a. HasCallStack => Bool -> a -> a
assert (OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList OrdList BlockId
lbls1 [BlockId] -> [BlockId] -> Bool
forall a. Eq a => a -> a -> Bool
/= OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList OrdList BlockId
lbls2 Bool -> Bool -> Bool
|| OrdList BlockId
lbls1 OrdList BlockId -> OrdList BlockId -> Bool
forall a. Eq a => OrdList a -> OrdList a -> Bool
`strictlyEqOL` OrdList BlockId
lbls2) (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
OrdList BlockId -> OrdList BlockId -> Ordering
forall a. Ord a => OrdList a -> OrdList a -> Ordering
strictlyOrdOL OrdList BlockId
lbls1 OrdList BlockId
lbls2
instance Outputable (BlockChain) where
ppr :: BlockChain -> SDoc
ppr (BlockChain OrdList BlockId
blks) =
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Chain:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [BlockId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId
blks) )
chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b
chainFoldl :: forall b. (b -> BlockId -> b) -> b -> BlockChain -> b
chainFoldl b -> BlockId -> b
f b
z (BlockChain OrdList BlockId
blocks) = (b -> BlockId -> b) -> b -> OrdList BlockId -> b
forall b a. (b -> a -> b) -> b -> OrdList a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> BlockId -> b
f b
z OrdList BlockId
blocks
noDups :: [BlockChain] -> Bool
noDups :: [BlockChain] -> Bool
noDups [BlockChain]
chains =
let chainBlocks :: [BlockId]
chainBlocks = (BlockChain -> [BlockId]) -> [BlockChain] -> [BlockId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BlockChain -> [BlockId]
chainToBlocks [BlockChain]
chains :: [BlockId]
([BlockId]
_blocks, [NonEmpty BlockId]
dups) = (BlockId -> BlockId -> Ordering)
-> [BlockId] -> ([BlockId], [NonEmpty BlockId])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups BlockId -> BlockId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [BlockId]
chainBlocks
in if [NonEmpty BlockId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonEmpty BlockId]
dups then Bool
True
else String -> SDoc -> Bool -> Bool
forall a. String -> SDoc -> a -> a
pprTrace String
"Duplicates:" ([[BlockId]] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((NonEmpty BlockId -> [BlockId])
-> [NonEmpty BlockId] -> [[BlockId]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty BlockId -> [BlockId]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [NonEmpty BlockId]
dups) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"chains" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [BlockChain] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BlockChain]
chains ) Bool
False
inFront :: BlockId -> BlockChain -> Bool
inFront :: BlockId -> BlockChain -> Bool
inFront BlockId
bid (BlockChain OrdList BlockId
seq)
= OrdList BlockId -> BlockId
forall a. OrdList a -> a
headOL OrdList BlockId
seq BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
bid
chainSingleton :: BlockId -> BlockChain
chainSingleton :: BlockId -> BlockChain
chainSingleton BlockId
lbl
= OrdList BlockId -> BlockChain
BlockChain (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
lbl)
chainFromList :: [BlockId] -> BlockChain
chainFromList :: [BlockId] -> BlockChain
chainFromList = OrdList BlockId -> BlockChain
BlockChain (OrdList BlockId -> BlockChain)
-> ([BlockId] -> OrdList BlockId) -> [BlockId] -> BlockChain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BlockId] -> OrdList BlockId
forall a. [a] -> OrdList a
toOL
chainSnoc :: BlockChain -> BlockId -> BlockChain
chainSnoc :: BlockChain -> BlockId -> BlockChain
chainSnoc (BlockChain OrdList BlockId
blks) BlockId
lbl
= OrdList BlockId -> BlockChain
BlockChain (OrdList BlockId
blks OrdList BlockId -> BlockId -> OrdList BlockId
forall a. OrdList a -> a -> OrdList a
`snocOL` BlockId
lbl)
chainCons :: BlockId -> BlockChain -> BlockChain
chainCons :: BlockId -> BlockChain -> BlockChain
chainCons BlockId
lbl (BlockChain OrdList BlockId
blks)
= OrdList BlockId -> BlockChain
BlockChain (BlockId
lbl BlockId -> OrdList BlockId -> OrdList BlockId
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BlockId
blks)
chainConcat :: BlockChain -> BlockChain -> BlockChain
chainConcat :: BlockChain -> BlockChain -> BlockChain
chainConcat (BlockChain OrdList BlockId
blks1) (BlockChain OrdList BlockId
blks2)
= OrdList BlockId -> BlockChain
BlockChain (OrdList BlockId
blks1 OrdList BlockId -> OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BlockId
blks2)
chainToBlocks :: BlockChain -> [BlockId]
chainToBlocks :: BlockChain -> [BlockId]
chainToBlocks (BlockChain OrdList BlockId
blks) = OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL OrdList BlockId
blks
breakChainAt :: BlockId -> BlockChain
-> (BlockChain,BlockChain)
breakChainAt :: BlockId -> BlockChain -> (BlockChain, BlockChain)
breakChainAt BlockId
bid (BlockChain OrdList BlockId
blks)
| Bool -> Bool
not (BlockId
bid BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== [BlockId] -> BlockId
forall a. HasCallStack => [a] -> a
Partial.head [BlockId]
rblks)
= String -> (BlockChain, BlockChain)
forall a. HasCallStack => String -> a
panic String
"Block not in chain"
| Bool
otherwise
= (OrdList BlockId -> BlockChain
BlockChain ([BlockId] -> OrdList BlockId
forall a. [a] -> OrdList a
toOL [BlockId]
lblks),
OrdList BlockId -> BlockChain
BlockChain ([BlockId] -> OrdList BlockId
forall a. [a] -> OrdList a
toOL [BlockId]
rblks))
where
([BlockId]
lblks, [BlockId]
rblks) = (BlockId -> Bool) -> [BlockId] -> ([BlockId], [BlockId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\BlockId
lbl -> BlockId
lbl BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
bid) (OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL OrdList BlockId
blks)
takeR :: Int -> BlockChain -> [BlockId]
takeR :: Int -> BlockChain -> [BlockId]
takeR Int
n (BlockChain OrdList BlockId
blks) =
Int -> [BlockId] -> [BlockId]
forall a. Int -> [a] -> [a]
take Int
n ([BlockId] -> [BlockId])
-> (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOLReverse (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId
blks
takeL :: Int -> BlockChain -> [BlockId]
takeL :: Int -> BlockChain -> [BlockId]
takeL Int
n (BlockChain OrdList BlockId
blks) =
Int -> [BlockId] -> [BlockId]
forall a. Int -> [a] -> [a]
take Int
n ([BlockId] -> [BlockId])
-> (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId
blks
combineNeighbourhood :: [CfgEdge]
-> [BlockChain]
-> ([BlockChain], Set.Set (BlockId,BlockId))
combineNeighbourhood :: [CfgEdge] -> [BlockChain] -> ([BlockChain], Set (BlockId, BlockId))
combineNeighbourhood [CfgEdge]
edges [BlockChain]
chains
=
[CfgEdge]
-> FrontierMap
-> FrontierMap
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId))
applyEdges [CfgEdge]
edges FrontierMap
endFrontier FrontierMap
startFrontier (Set (BlockId, BlockId)
forall a. Set a
Set.empty)
where
endFrontier, startFrontier :: FrontierMap
endFrontier :: FrontierMap
endFrontier =
[(BlockId, ([BlockId], BlockChain))] -> FrontierMap
forall v. [(BlockId, v)] -> LabelMap v
mapFromList ([(BlockId, ([BlockId], BlockChain))] -> FrontierMap)
-> [(BlockId, ([BlockId], BlockChain))] -> FrontierMap
forall a b. (a -> b) -> a -> b
$ (BlockChain -> [(BlockId, ([BlockId], BlockChain))])
-> [BlockChain] -> [(BlockId, ([BlockId], BlockChain))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\BlockChain
chain ->
let ends :: [BlockId]
ends = BlockChain -> [BlockId]
getEnds BlockChain
chain :: [BlockId]
entry :: ([BlockId], BlockChain)
entry = ([BlockId]
ends,BlockChain
chain)
in (BlockId -> (BlockId, ([BlockId], BlockChain)))
-> [BlockId] -> [(BlockId, ([BlockId], BlockChain))]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> (BlockId
x,([BlockId], BlockChain)
entry)) [BlockId]
ends ) [BlockChain]
chains
startFrontier :: FrontierMap
startFrontier =
[(BlockId, ([BlockId], BlockChain))] -> FrontierMap
forall v. [(BlockId, v)] -> LabelMap v
mapFromList ([(BlockId, ([BlockId], BlockChain))] -> FrontierMap)
-> [(BlockId, ([BlockId], BlockChain))] -> FrontierMap
forall a b. (a -> b) -> a -> b
$ (BlockChain -> [(BlockId, ([BlockId], BlockChain))])
-> [BlockChain] -> [(BlockId, ([BlockId], BlockChain))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\BlockChain
chain ->
let front :: [BlockId]
front = BlockChain -> [BlockId]
getFronts BlockChain
chain
entry :: ([BlockId], BlockChain)
entry = ([BlockId]
front,BlockChain
chain)
in (BlockId -> (BlockId, ([BlockId], BlockChain)))
-> [BlockId] -> [(BlockId, ([BlockId], BlockChain))]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> (BlockId
x,([BlockId], BlockChain)
entry)) [BlockId]
front) [BlockChain]
chains
applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId)
-> ([BlockChain], Set.Set (BlockId,BlockId))
applyEdges :: [CfgEdge]
-> FrontierMap
-> FrontierMap
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId))
applyEdges [] FrontierMap
chainEnds FrontierMap
_chainFronts Set (BlockId, BlockId)
combined =
([BlockChain] -> [BlockChain]
forall a. Ord a => [a] -> [a]
ordNub ([BlockChain] -> [BlockChain]) -> [BlockChain] -> [BlockChain]
forall a b. (a -> b) -> a -> b
$ (([BlockId], BlockChain) -> BlockChain)
-> [([BlockId], BlockChain)] -> [BlockChain]
forall a b. (a -> b) -> [a] -> [b]
map ([BlockId], BlockChain) -> BlockChain
forall a b. (a, b) -> b
snd ([([BlockId], BlockChain)] -> [BlockChain])
-> [([BlockId], BlockChain)] -> [BlockChain]
forall a b. (a -> b) -> a -> b
$ FrontierMap -> [([BlockId], BlockChain)]
forall a. LabelMap a -> [a]
mapElems FrontierMap
chainEnds, Set (BlockId, BlockId)
combined)
applyEdges ((CfgEdge BlockId
from BlockId
to EdgeInfo
_w):[CfgEdge]
edges) FrontierMap
chainEnds FrontierMap
chainFronts Set (BlockId, BlockId)
combined
| Just ([BlockId]
c1_e,BlockChain
c1) <- BlockId -> FrontierMap -> Maybe ([BlockId], BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
from FrontierMap
chainEnds
, Just ([BlockId]
c2_f,BlockChain
c2) <- BlockId -> FrontierMap -> Maybe ([BlockId], BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
to FrontierMap
chainFronts
, BlockChain
c1 BlockChain -> BlockChain -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockChain
c2
= let newChain :: BlockChain
newChain = BlockChain -> BlockChain -> BlockChain
chainConcat BlockChain
c1 BlockChain
c2
newChainFrontier :: [BlockId]
newChainFrontier = BlockChain -> [BlockId]
getFronts BlockChain
newChain
newChainEnds :: [BlockId]
newChainEnds = BlockChain -> [BlockId]
getEnds BlockChain
newChain
newFronts :: FrontierMap
newFronts :: FrontierMap
newFronts =
let withoutOld :: FrontierMap
withoutOld =
(FrontierMap -> BlockId -> FrontierMap)
-> FrontierMap -> [BlockId] -> FrontierMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
b -> BlockId -> FrontierMap -> FrontierMap
forall v. BlockId -> LabelMap v -> LabelMap v
mapDelete BlockId
b FrontierMap
m :: FrontierMap) FrontierMap
chainFronts ([BlockId]
c2_f [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
++ BlockChain -> [BlockId]
getFronts BlockChain
c1)
entry :: ([BlockId], BlockChain)
entry =
([BlockId]
newChainFrontier,BlockChain
newChain)
in (FrontierMap -> BlockId -> FrontierMap)
-> FrontierMap -> [BlockId] -> FrontierMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
x -> BlockId -> ([BlockId], BlockChain) -> FrontierMap -> FrontierMap
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
x ([BlockId], BlockChain)
entry FrontierMap
m)
FrontierMap
withoutOld [BlockId]
newChainFrontier
newEnds :: FrontierMap
newEnds =
let withoutOld :: FrontierMap
withoutOld = (FrontierMap -> BlockId -> FrontierMap)
-> FrontierMap -> [BlockId] -> FrontierMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
b -> BlockId -> FrontierMap -> FrontierMap
forall v. BlockId -> LabelMap v -> LabelMap v
mapDelete BlockId
b FrontierMap
m) FrontierMap
chainEnds ([BlockId]
c1_e [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
++ BlockChain -> [BlockId]
getEnds BlockChain
c2)
entry :: ([BlockId], BlockChain)
entry = ([BlockId]
newChainEnds,BlockChain
newChain)
in (FrontierMap -> BlockId -> FrontierMap)
-> FrontierMap -> [BlockId] -> FrontierMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
x -> BlockId -> ([BlockId], BlockChain) -> FrontierMap -> FrontierMap
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
x ([BlockId], BlockChain)
entry FrontierMap
m)
FrontierMap
withoutOld [BlockId]
newChainEnds
in
[CfgEdge]
-> FrontierMap
-> FrontierMap
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId))
applyEdges [CfgEdge]
edges FrontierMap
newEnds FrontierMap
newFronts ((BlockId, BlockId)
-> Set (BlockId, BlockId) -> Set (BlockId, BlockId)
forall a. Ord a => a -> Set a -> Set a
Set.insert (BlockId
from,BlockId
to) Set (BlockId, BlockId)
combined)
| Bool
otherwise
= [CfgEdge]
-> FrontierMap
-> FrontierMap
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId))
applyEdges [CfgEdge]
edges FrontierMap
chainEnds FrontierMap
chainFronts Set (BlockId, BlockId)
combined
getFronts :: BlockChain -> [BlockId]
getFronts BlockChain
chain = Int -> BlockChain -> [BlockId]
takeL Int
neighbourOverlapp BlockChain
chain
getEnds :: BlockChain -> [BlockId]
getEnds BlockChain
chain = Int -> BlockChain -> [BlockId]
takeR Int
neighbourOverlapp BlockChain
chain
mergeChains :: [CfgEdge] -> [BlockChain]
-> (BlockChain)
mergeChains :: [CfgEdge] -> [BlockChain] -> BlockChain
mergeChains [CfgEdge]
edges [BlockChain]
chains
= (forall s. ST s BlockChain) -> BlockChain
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s BlockChain) -> BlockChain)
-> (forall s. ST s BlockChain) -> BlockChain
forall a b. (a -> b) -> a -> b
$ do
let addChain :: LabelMap (Point s BlockChain)
-> BlockChain -> ST s (LabelMap (Point s BlockChain))
addChain LabelMap (Point s BlockChain)
m0 BlockChain
chain = do
ref <- BlockChain -> ST s (Point s BlockChain)
forall a s. a -> ST s (Point s a)
fresh BlockChain
chain
return $ chainFoldl (\LabelMap (Point s BlockChain)
m' BlockId
b -> BlockId
-> Point s BlockChain
-> LabelMap (Point s BlockChain)
-> LabelMap (Point s BlockChain)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
b Point s BlockChain
ref LabelMap (Point s BlockChain)
m') m0 chain
chainMap' <- (LabelMap (Point s BlockChain)
-> BlockChain -> ST s (LabelMap (Point s BlockChain)))
-> LabelMap (Point s BlockChain)
-> [BlockChain]
-> ST s (LabelMap (Point s BlockChain))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\LabelMap (Point s BlockChain)
m0 BlockChain
c -> LabelMap (Point s BlockChain)
-> BlockChain -> ST s (LabelMap (Point s BlockChain))
forall {s}.
LabelMap (Point s BlockChain)
-> BlockChain -> ST s (LabelMap (Point s BlockChain))
addChain LabelMap (Point s BlockChain)
m0 BlockChain
c) LabelMap (Point s BlockChain)
forall v. LabelMap v
mapEmpty [BlockChain]
chains
merge edges chainMap'
where
merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
merge :: forall s.
[CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
merge [] LabelMap (Point s BlockChain)
chains = do
chains' <- (Point s BlockChain -> ST s BlockChain)
-> [Point s BlockChain] -> ST s [BlockChain]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Point s BlockChain -> ST s BlockChain
forall s a. Point s a -> ST s a
find ([Point s BlockChain] -> ST s [BlockChain])
-> ST s [Point s BlockChain] -> ST s [BlockChain]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([Point s BlockChain] -> [Point s BlockChain]
forall a. Eq a => [a] -> [a]
nub ([Point s BlockChain] -> [Point s BlockChain])
-> ST s [Point s BlockChain] -> ST s [Point s BlockChain]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Point s BlockChain -> ST s (Point s BlockChain))
-> [Point s BlockChain] -> ST s [Point s BlockChain]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Point s BlockChain -> ST s (Point s BlockChain)
forall s a. Point s a -> ST s (Point s a)
repr ([Point s BlockChain] -> ST s [Point s BlockChain])
-> [Point s BlockChain] -> ST s [Point s BlockChain]
forall a b. (a -> b) -> a -> b
$ LabelMap (Point s BlockChain) -> [Point s BlockChain]
forall a. LabelMap a -> [a]
mapElems LabelMap (Point s BlockChain)
chains)) :: ST s [BlockChain]
return $ foldl' chainConcat (Partial.head chains') (Partial.tail chains')
merge ((CfgEdge BlockId
from BlockId
to EdgeInfo
_):[CfgEdge]
edges) LabelMap (Point s BlockChain)
chains
= do
same <- Point s BlockChain -> Point s BlockChain -> ST s Bool
forall s a. Point s a -> Point s a -> ST s Bool
equivalent Point s BlockChain
cFrom Point s BlockChain
cTo
unless same $ do
cRight <- find cTo
cLeft <- find cFrom
new_point <- fresh (chainConcat cLeft cRight)
union cTo new_point
union cFrom new_point
merge edges chains
where
cFrom :: Point s BlockChain
cFrom = String -> Maybe (Point s BlockChain) -> Point s BlockChain
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"mergeChains:chainMap:from" (Maybe (Point s BlockChain) -> Point s BlockChain)
-> Maybe (Point s BlockChain) -> Point s BlockChain
forall a b. (a -> b) -> a -> b
$ BlockId
-> LabelMap (Point s BlockChain) -> Maybe (Point s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
from LabelMap (Point s BlockChain)
chains
cTo :: Point s BlockChain
cTo = String -> Maybe (Point s BlockChain) -> Point s BlockChain
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"mergeChains:chainMap:to" (Maybe (Point s BlockChain) -> Point s BlockChain)
-> Maybe (Point s BlockChain) -> Point s BlockChain
forall a b. (a -> b) -> a -> b
$ BlockId
-> LabelMap (Point s BlockChain) -> Maybe (Point s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
to LabelMap (Point s BlockChain)
chains
buildChains :: [CfgEdge] -> [BlockId]
-> ( LabelMap BlockChain
, Set.Set (BlockId, BlockId))
buildChains :: [CfgEdge]
-> [BlockId] -> (LabelMap BlockChain, Set (BlockId, BlockId))
buildChains [CfgEdge]
edges [BlockId]
blocks
= (forall s. ST s (LabelMap BlockChain, Set (BlockId, BlockId)))
-> (LabelMap BlockChain, Set (BlockId, BlockId))
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (LabelMap BlockChain, Set (BlockId, BlockId)))
-> (LabelMap BlockChain, Set (BlockId, BlockId)))
-> (forall s. ST s (LabelMap BlockChain, Set (BlockId, BlockId)))
-> (LabelMap BlockChain, Set (BlockId, BlockId))
forall a b. (a -> b) -> a -> b
$ LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext LabelSet
setEmpty LabelMap (STRef s BlockChain)
forall v. LabelMap v
mapEmpty LabelMap (STRef s BlockChain)
forall v. LabelMap v
mapEmpty [CfgEdge]
edges Set (BlockId, BlockId)
forall a. Set a
Set.empty
where
buildNext :: forall s. LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set.Set (BlockId, BlockId)
-> ST s ( LabelMap BlockChain
, Set.Set (BlockId, BlockId)
)
buildNext :: forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext LabelSet
placed LabelMap (STRef s BlockChain)
_chainStarts LabelMap (STRef s BlockChain)
chainEnds [] Set (BlockId, BlockId)
linked = do
ends' <- LabelMap (ST s BlockChain) -> ST s (LabelMap BlockChain)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => LabelMap (m a) -> m (LabelMap a)
sequence (LabelMap (ST s BlockChain) -> ST s (LabelMap BlockChain))
-> LabelMap (ST s BlockChain) -> ST s (LabelMap BlockChain)
forall a b. (a -> b) -> a -> b
$ (STRef s BlockChain -> ST s BlockChain)
-> LabelMap (STRef s BlockChain) -> LabelMap (ST s BlockChain)
forall a v. (a -> v) -> LabelMap a -> LabelMap v
mapMap STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef LabelMap (STRef s BlockChain)
chainEnds :: ST s (LabelMap BlockChain)
let unplaced = (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\BlockId
x -> Bool -> Bool
not (BlockId -> LabelSet -> Bool
setMember BlockId
x LabelSet
placed)) [BlockId]
blocks
singletons = (BlockId -> (BlockId, BlockChain))
-> [BlockId] -> [(BlockId, BlockChain)]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> (BlockId
x,BlockId -> BlockChain
chainSingleton BlockId
x)) [BlockId]
unplaced :: [(BlockId,BlockChain)]
return (foldl' (\LabelMap BlockChain
m (BlockId
k,BlockChain
v) -> BlockId -> BlockChain -> LabelMap BlockChain -> LabelMap BlockChain
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
k BlockChain
v LabelMap BlockChain
m) ends' singletons , linked)
buildNext LabelSet
placed LabelMap (STRef s BlockChain)
chainStarts LabelMap (STRef s BlockChain)
chainEnds (CfgEdge
edge:[CfgEdge]
todo) Set (BlockId, BlockId)
linked
| BlockId
from BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
to
= LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext LabelSet
placed LabelMap (STRef s BlockChain)
chainStarts LabelMap (STRef s BlockChain)
chainEnds [CfgEdge]
todo ((BlockId, BlockId)
-> Set (BlockId, BlockId) -> Set (BlockId, BlockId)
forall a. Ord a => a -> Set a -> Set a
Set.insert (BlockId
from,BlockId
to) Set (BlockId, BlockId)
linked)
| Bool -> Bool
not (BlockId -> Bool
alreadyPlaced BlockId
from) Bool -> Bool -> Bool
&&
Bool -> Bool
not (BlockId -> Bool
alreadyPlaced BlockId
to)
= do
chain' <- BlockChain -> ST s (STRef s BlockChain)
forall a s. a -> ST s (STRef s a)
newSTRef (BlockChain -> ST s (STRef s BlockChain))
-> BlockChain -> ST s (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ [BlockId] -> BlockChain
chainFromList [BlockId
from,BlockId
to]
buildNext
(setInsert to (setInsert from placed))
(mapInsert from chain' chainStarts)
(mapInsert to chain' chainEnds)
todo
(Set.insert (from,to) linked)
| (BlockId -> Bool
alreadyPlaced BlockId
from) Bool -> Bool -> Bool
&&
(BlockId -> Bool
alreadyPlaced BlockId
to)
, Just STRef s BlockChain
predChain <- BlockId
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
from LabelMap (STRef s BlockChain)
chainEnds
, Just STRef s BlockChain
succChain <- BlockId
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
to LabelMap (STRef s BlockChain)
chainStarts
, STRef s BlockChain
predChain STRef s BlockChain -> STRef s BlockChain -> Bool
forall a. Eq a => a -> a -> Bool
/= STRef s BlockChain
succChain
= STRef s BlockChain
-> STRef s BlockChain
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
fuseChain STRef s BlockChain
predChain STRef s BlockChain
succChain
| (BlockId -> Bool
alreadyPlaced BlockId
from) Bool -> Bool -> Bool
&&
(BlockId -> Bool
alreadyPlaced BlockId
to)
= LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext LabelSet
placed LabelMap (STRef s BlockChain)
chainStarts LabelMap (STRef s BlockChain)
chainEnds [CfgEdge]
todo Set (BlockId, BlockId)
linked
| Bool
otherwise
= ST s (LabelMap BlockChain, Set (BlockId, BlockId))
findChain
where
from :: BlockId
from = CfgEdge -> BlockId
edgeFrom CfgEdge
edge
to :: BlockId
to = CfgEdge -> BlockId
edgeTo CfgEdge
edge
alreadyPlaced :: BlockId -> Bool
alreadyPlaced BlockId
blkId = (BlockId -> LabelSet -> Bool
setMember BlockId
blkId LabelSet
placed)
fuseChain :: STRef s BlockChain -> STRef s BlockChain
-> ST s ( LabelMap BlockChain
, Set.Set (BlockId, BlockId)
)
fuseChain :: STRef s BlockChain
-> STRef s BlockChain
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
fuseChain STRef s BlockChain
fromRef STRef s BlockChain
toRef = do
fromChain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
fromRef
toChain <- readSTRef toRef
let newChain = BlockChain -> BlockChain -> BlockChain
chainConcat BlockChain
fromChain BlockChain
toChain
ref <- newSTRef newChain
let start = [BlockId] -> BlockId
forall a. HasCallStack => [a] -> a
Partial.head ([BlockId] -> BlockId) -> [BlockId] -> BlockId
forall a b. (a -> b) -> a -> b
$ Int -> BlockChain -> [BlockId]
takeL Int
1 BlockChain
newChain
let end = [BlockId] -> BlockId
forall a. HasCallStack => [a] -> a
Partial.head ([BlockId] -> BlockId) -> [BlockId] -> BlockId
forall a b. (a -> b) -> a -> b
$ Int -> BlockChain -> [BlockId]
takeR Int
1 BlockChain
newChain
buildNext
placed
(mapInsert start ref $ mapDelete to $ chainStarts)
(mapInsert end ref $ mapDelete from $ chainEnds)
todo
(Set.insert (from,to) linked)
findChain :: ST s ( LabelMap BlockChain
, Set.Set (BlockId, BlockId)
)
findChain :: ST s (LabelMap BlockChain, Set (BlockId, BlockId))
findChain
| BlockId -> Bool
alreadyPlaced BlockId
from
, Just STRef s BlockChain
predChain <- BlockId
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
from LabelMap (STRef s BlockChain)
chainEnds
= do
chain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
predChain
let newChain = BlockChain -> BlockId -> BlockChain
chainSnoc BlockChain
chain BlockId
to
writeSTRef predChain newChain
let chainEnds' = BlockId
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
to STRef s BlockChain
predChain (LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ BlockId
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall v. BlockId -> LabelMap v -> LabelMap v
mapDelete BlockId
from LabelMap (STRef s BlockChain)
chainEnds
buildNext (setInsert to placed) chainStarts chainEnds' todo (Set.insert (from,to) linked)
| BlockId -> Bool
alreadyPlaced BlockId
to
, Just STRef s BlockChain
succChain <- BlockId
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
to LabelMap (STRef s BlockChain)
chainStarts
= do
chain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
succChain
let newChain = BlockId
from BlockId -> BlockChain -> BlockChain
`chainCons` BlockChain
chain
writeSTRef succChain newChain
let chainStarts' = BlockId
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
from STRef s BlockChain
succChain (LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ BlockId
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall v. BlockId -> LabelMap v -> LabelMap v
mapDelete BlockId
to LabelMap (STRef s BlockChain)
chainStarts
buildNext (setInsert from placed) chainStarts' chainEnds todo (Set.insert (from,to) linked)
| Bool
otherwise
= do
let block :: BlockId
block = if BlockId -> Bool
alreadyPlaced BlockId
to then BlockId
from else BlockId
to
let newChain :: BlockChain
newChain = BlockId -> BlockChain
chainSingleton BlockId
block
ref <- BlockChain -> ST s (STRef s BlockChain)
forall a s. a -> ST s (STRef s a)
newSTRef BlockChain
newChain
buildNext (setInsert block placed) (mapInsert block ref chainStarts)
(mapInsert block ref chainEnds) todo (linked)
where
alreadyPlaced :: BlockId -> Bool
alreadyPlaced BlockId
blkId = (BlockId -> LabelSet -> Bool
setMember BlockId
blkId LabelSet
placed)
sequenceChain :: forall a i. Instruction i
=> LabelMap a
-> CFG
-> [GenBasicBlock i]
-> [GenBasicBlock i]
sequenceChain :: forall a i.
Instruction i =>
LabelMap a -> CFG -> [GenBasicBlock i] -> [GenBasicBlock i]
sequenceChain LabelMap a
_info CFG
_weights [] = []
sequenceChain LabelMap a
_info CFG
_weights [GenBasicBlock i
x] = [GenBasicBlock i
x]
sequenceChain LabelMap a
info CFG
weights blocks :: [GenBasicBlock i]
blocks@((BasicBlock BlockId
entry [i]
_):[GenBasicBlock i]
_) =
let directEdges :: [CfgEdge]
directEdges :: [CfgEdge]
directEdges = (CfgEdge -> CfgEdge -> Ordering) -> [CfgEdge] -> [CfgEdge]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((CfgEdge -> CfgEdge -> Ordering) -> CfgEdge -> CfgEdge -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip CfgEdge -> CfgEdge -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$ (CfgEdge -> Maybe CfgEdge) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CfgEdge -> Maybe CfgEdge
relevantWeight (CFG -> [CfgEdge]
infoEdgeList CFG
weights)
where
relevantWeight :: CfgEdge -> Maybe CfgEdge
relevantWeight :: CfgEdge -> Maybe CfgEdge
relevantWeight edge :: CfgEdge
edge@(CfgEdge BlockId
from BlockId
to EdgeInfo
edgeInfo)
| (EdgeInfo CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmCall {} } EdgeWeight
_) <- EdgeInfo
edgeInfo
= Maybe CfgEdge
forall a. Maybe a
Nothing
| BlockId -> LabelMap a -> Bool
forall a. BlockId -> LabelMap a -> Bool
mapMember BlockId
to LabelMap a
info
, EdgeWeight
w <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo
= CfgEdge -> Maybe CfgEdge
forall a. a -> Maybe a
Just (BlockId -> BlockId -> EdgeInfo -> CfgEdge
CfgEdge BlockId
from BlockId
to EdgeInfo
edgeInfo { edgeWeight = w/8 })
| (EdgeInfo CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmNode O C
exitNode } EdgeWeight
_) <- EdgeInfo
edgeInfo
, CmmNode O C -> Bool
forall {e :: Extensibility} {x :: Extensibility}.
CmmNode e x -> Bool
cantEliminate CmmNode O C
exitNode
, EdgeWeight
w <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo
= CfgEdge -> Maybe CfgEdge
forall a. a -> Maybe a
Just (BlockId -> BlockId -> EdgeInfo -> CfgEdge
CfgEdge BlockId
from BlockId
to EdgeInfo
edgeInfo { edgeWeight = w * 0.96875 })
| Bool
otherwise
= CfgEdge -> Maybe CfgEdge
forall a. a -> Maybe a
Just CfgEdge
edge
where
cantEliminate :: CmmNode e x -> Bool
cantEliminate CmmCondBranch {} = Bool
True
cantEliminate CmmSwitch {} = Bool
True
cantEliminate CmmNode e x
_ = Bool
False
blockMap :: LabelMap (GenBasicBlock i)
blockMap :: LabelMap (GenBasicBlock i)
blockMap
= (LabelMap (GenBasicBlock i)
-> GenBasicBlock i -> LabelMap (GenBasicBlock i))
-> LabelMap (GenBasicBlock i)
-> [GenBasicBlock i]
-> LabelMap (GenBasicBlock i)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LabelMap (GenBasicBlock i)
m blk :: GenBasicBlock i
blk@(BasicBlock BlockId
lbl [i]
_ins) ->
BlockId
-> GenBasicBlock i
-> LabelMap (GenBasicBlock i)
-> LabelMap (GenBasicBlock i)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
lbl GenBasicBlock i
blk LabelMap (GenBasicBlock i)
m)
LabelMap (GenBasicBlock i)
forall v. LabelMap v
mapEmpty [GenBasicBlock i]
blocks
(LabelMap BlockChain
builtChains, Set (BlockId, BlockId)
builtEdges)
= {-# SCC "buildChains" #-}
[CfgEdge]
-> [BlockId] -> (LabelMap BlockChain, Set (BlockId, BlockId))
buildChains [CfgEdge]
directEdges (LabelMap (GenBasicBlock i) -> [BlockId]
forall a. LabelMap a -> [BlockId]
mapKeys LabelMap (GenBasicBlock i)
blockMap)
rankedEdges :: [CfgEdge]
rankedEdges :: [CfgEdge]
rankedEdges =
(CfgEdge -> Bool) -> [CfgEdge] -> [CfgEdge]
forall a. (a -> Bool) -> [a] -> [a]
filter (\CfgEdge
edge -> Bool -> Bool
not ((BlockId, BlockId) -> Set (BlockId, BlockId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (CfgEdge -> BlockId
edgeFrom CfgEdge
edge,CfgEdge -> BlockId
edgeTo CfgEdge
edge) Set (BlockId, BlockId)
builtEdges)) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$
[CfgEdge]
directEdges
([BlockChain]
neighbourChains, Set (BlockId, BlockId)
combined)
= Bool
-> ([BlockChain], Set (BlockId, BlockId))
-> ([BlockChain], Set (BlockId, BlockId))
forall a. HasCallStack => Bool -> a -> a
assert ([BlockChain] -> Bool
noDups ([BlockChain] -> Bool) -> [BlockChain] -> Bool
forall a b. (a -> b) -> a -> b
$ LabelMap BlockChain -> [BlockChain]
forall a. LabelMap a -> [a]
mapElems LabelMap BlockChain
builtChains) (([BlockChain], Set (BlockId, BlockId))
-> ([BlockChain], Set (BlockId, BlockId)))
-> ([BlockChain], Set (BlockId, BlockId))
-> ([BlockChain], Set (BlockId, BlockId))
forall a b. (a -> b) -> a -> b
$
{-# SCC "groupNeighbourChains" #-}
[CfgEdge] -> [BlockChain] -> ([BlockChain], Set (BlockId, BlockId))
combineNeighbourhood [CfgEdge]
rankedEdges (LabelMap BlockChain -> [BlockChain]
forall a. LabelMap a -> [a]
mapElems LabelMap BlockChain
builtChains)
allEdges :: [CfgEdge]
allEdges :: [CfgEdge]
allEdges = {-# SCC allEdges #-}
(CfgEdge -> EdgeWeight) -> [CfgEdge] -> [CfgEdge]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (CfgEdge -> EdgeWeight
relevantWeight) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$ (CfgEdge -> Bool) -> [CfgEdge] -> [CfgEdge]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CfgEdge -> Bool) -> CfgEdge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CfgEdge -> Bool
deadEdge) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$ (CFG -> [CfgEdge]
infoEdgeList CFG
weights)
where
deadEdge :: CfgEdge -> Bool
deadEdge :: CfgEdge -> Bool
deadEdge (CfgEdge BlockId
from BlockId
to EdgeInfo
_) = let e :: (BlockId, BlockId)
e = (BlockId
from,BlockId
to) in (BlockId, BlockId) -> Set (BlockId, BlockId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (BlockId, BlockId)
e Set (BlockId, BlockId)
combined Bool -> Bool -> Bool
|| (BlockId, BlockId) -> Set (BlockId, BlockId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (BlockId, BlockId)
e Set (BlockId, BlockId)
builtEdges
relevantWeight :: CfgEdge -> EdgeWeight
relevantWeight :: CfgEdge -> EdgeWeight
relevantWeight (CfgEdge BlockId
_ BlockId
_ EdgeInfo
edgeInfo)
| EdgeInfo (CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmCall {}}) EdgeWeight
_ <- EdgeInfo
edgeInfo
= EdgeWeight
weightEdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Fractional a => a -> a -> a
/(EdgeWeight
64.0)
| Bool
otherwise
= EdgeWeight
weight
where
weight :: EdgeWeight
weight = EdgeWeight -> EdgeWeight
forall a. Num a => a -> a
negate (EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo)
masterChain :: BlockChain
masterChain =
{-# SCC "mergeChains" #-}
[CfgEdge] -> [BlockChain] -> BlockChain
mergeChains [CfgEdge]
allEdges [BlockChain]
neighbourChains
prepedChains :: [BlockChain]
prepedChains
| BlockId -> BlockChain -> Bool
inFront BlockId
entry BlockChain
masterChain
= [BlockChain
masterChain]
| (BlockChain
rest,BlockChain
entry) <- BlockId -> BlockChain -> (BlockChain, BlockChain)
breakChainAt BlockId
entry BlockChain
masterChain
= [BlockChain
entry,BlockChain
rest]
blockList :: [BlockId]
blockList
= Bool -> [BlockId] -> [BlockId]
forall a. HasCallStack => Bool -> a -> a
assert ([BlockChain] -> Bool
noDups [BlockChain
masterChain])
((OrdList BlockId -> [BlockId]) -> [OrdList BlockId] -> [BlockId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL ([OrdList BlockId] -> [BlockId]) -> [OrdList BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ (BlockChain -> OrdList BlockId)
-> [BlockChain] -> [OrdList BlockId]
forall a b. (a -> b) -> [a] -> [b]
map BlockChain -> OrdList BlockId
chainBlocks [BlockChain]
prepedChains)
chainPlaced :: LabelSet
chainPlaced = [BlockId] -> LabelSet
setFromList ([BlockId] -> LabelSet) -> [BlockId] -> LabelSet
forall a b. (a -> b) -> a -> b
$ [BlockId]
blockList :: LabelSet
unplaced :: [BlockId]
unplaced =
let blocks :: [BlockId]
blocks = LabelMap (GenBasicBlock i) -> [BlockId]
forall a. LabelMap a -> [BlockId]
mapKeys LabelMap (GenBasicBlock i)
blockMap
isPlaced :: BlockId -> Bool
isPlaced BlockId
b = BlockId -> LabelSet -> Bool
setMember (BlockId
b) LabelSet
chainPlaced
in (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\BlockId
block -> Bool -> Bool
not (BlockId -> Bool
isPlaced BlockId
block)) [BlockId]
blocks
placedBlocks :: [BlockId]
placedBlocks =
Bool -> [BlockId] -> [BlockId]
forall a. HasCallStack => Bool -> a -> a
assert ([BlockId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
unplaced) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$
if [BlockId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
unplaced then [BlockId]
blockList else [BlockId]
blockList [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
++ [BlockId]
unplaced
getBlock :: BlockId -> GenBasicBlock i
getBlock BlockId
bid = String -> Maybe (GenBasicBlock i) -> GenBasicBlock i
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"Block placement" (Maybe (GenBasicBlock i) -> GenBasicBlock i)
-> Maybe (GenBasicBlock i) -> GenBasicBlock i
forall a b. (a -> b) -> a -> b
$ BlockId -> LabelMap (GenBasicBlock i) -> Maybe (GenBasicBlock i)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
bid LabelMap (GenBasicBlock i)
blockMap
in
Bool -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. HasCallStack => Bool -> a -> a
assert ((BlockId -> Bool) -> [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\BlockId
bid -> BlockId -> LabelMap (GenBasicBlock i) -> Bool
forall a. BlockId -> LabelMap a -> Bool
mapMember BlockId
bid LabelMap (GenBasicBlock i)
blockMap) [BlockId]
placedBlocks) ([GenBasicBlock i] -> [GenBasicBlock i])
-> [GenBasicBlock i] -> [GenBasicBlock i]
forall a b. (a -> b) -> a -> b
$
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info ([GenBasicBlock i] -> [GenBasicBlock i])
-> [GenBasicBlock i] -> [GenBasicBlock i]
forall a b. (a -> b) -> a -> b
$ (BlockId -> GenBasicBlock i) -> [BlockId] -> [GenBasicBlock i]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> GenBasicBlock i
getBlock [BlockId]
placedBlocks
{-# SCC dropJumps #-}
dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
-> [GenBasicBlock i]
dropJumps :: forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
_ [] = []
dropJumps LabelMap a
info (BasicBlock BlockId
lbl [i]
ins:[GenBasicBlock i]
todo)
| Just NonEmpty i
ins <- [i] -> Maybe (NonEmpty i)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [i]
ins
, BasicBlock BlockId
nextLbl [i]
_ : [GenBasicBlock i]
_ <- [GenBasicBlock i]
todo
, i -> BlockId -> Bool
forall instr. Instruction instr => instr -> BlockId -> Bool
canFallthroughTo (NonEmpty i -> i
forall a. NonEmpty a -> a
NE.last NonEmpty i
ins) BlockId
nextLbl
, Bool -> Bool
not (BlockId -> LabelMap a -> Bool
forall a. BlockId -> LabelMap a -> Bool
mapMember BlockId
nextLbl LabelMap a
info)
= BlockId -> [i] -> GenBasicBlock i
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl (NonEmpty i -> [i]
forall a. NonEmpty a -> [a]
NE.init NonEmpty i
ins) GenBasicBlock i -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. a -> [a] -> [a]
: LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info [GenBasicBlock i]
todo
| Bool
otherwise
= BlockId -> [i] -> GenBasicBlock i
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl [i]
ins GenBasicBlock i -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. a -> [a] -> [a]
: LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info [GenBasicBlock i]
todo
sequenceTop
:: Instruction instr
=> NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> UniqDSM (NatCmmDecl statics instr)
sequenceTop :: forall instr statics jumpDest.
Instruction instr =>
NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> UniqDSM (NatCmmDecl statics instr)
sequenceTop NcgImpl statics instr jumpDest
_ Maybe CFG
_ top :: NatCmmDecl statics instr
top@(CmmData Section
_ statics
_) = NatCmmDecl statics instr -> UniqDSM (NatCmmDecl statics instr)
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NatCmmDecl statics instr
top
sequenceTop NcgImpl statics instr jumpDest
ncgImpl Maybe CFG
edgeWeights (CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalRegUse]
live (ListGraph [GenBasicBlock instr]
blocks)) = do
let config :: NCGConfig
config = NcgImpl statics instr jumpDest -> NCGConfig
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NCGConfig
ncgConfig NcgImpl statics instr jumpDest
ncgImpl
platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
seq_blocks :: [GenBasicBlock instr]
seq_blocks =
if
| NCGConfig -> Bool
ncgCfgBlockLayout NCGConfig
config
, Platform -> Bool
backendMaintainsCfg Platform
platform
, Just CFG
cfg <- Maybe CFG
edgeWeights
-> {-# SCC layoutBlocks #-} LabelMap RawCmmStatics
-> CFG -> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a i.
Instruction i =>
LabelMap a -> CFG -> [GenBasicBlock i] -> [GenBasicBlock i]
sequenceChain LabelMap RawCmmStatics
info CFG
cfg [GenBasicBlock instr]
blocks
| NCGConfig -> Bool
ncgCfgWeightlessLayout NCGConfig
config
Bool -> Bool -> Bool
|| Bool -> Bool
not (Platform -> Bool
backendMaintainsCfg Platform
platform)
-> {-# SCC layoutBlocks #-} Maybe CFG
-> LabelMap RawCmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks Maybe CFG
forall a. Maybe a
Nothing LabelMap RawCmmStatics
info [GenBasicBlock instr]
blocks
| Bool
otherwise
-> {-# SCC layoutBlocks #-} Maybe CFG
-> LabelMap RawCmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks Maybe CFG
edgeWeights LabelMap RawCmmStatics
info [GenBasicBlock instr]
blocks
far_blocks <- (NcgImpl statics instr jumpDest
-> Platform
-> LabelMap RawCmmStatics
-> [GenBasicBlock instr]
-> UniqDSM [GenBasicBlock instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Platform
-> LabelMap RawCmmStatics
-> [NatBasicBlock instr]
-> UniqDSM [NatBasicBlock instr]
ncgMakeFarBranches NcgImpl statics instr jumpDest
ncgImpl) Platform
platform LabelMap RawCmmStatics
info [GenBasicBlock instr]
seq_blocks
pure $ CmmProc info lbl live $ ListGraph far_blocks
sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a
-> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks :: forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks Maybe CFG
_edgeWeight LabelMap a
_ [] = []
sequenceBlocks Maybe CFG
edgeWeights LabelMap a
infos (GenBasicBlock inst
entry:[GenBasicBlock inst]
blocks) =
let entryNode :: Node BlockId (GenBasicBlock inst)
entryNode = Maybe CFG
-> GenBasicBlock inst -> Node BlockId (GenBasicBlock inst)
forall t.
Instruction t =>
Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
mkNode Maybe CFG
edgeWeights GenBasicBlock inst
entry
bodyNodes :: [Node BlockId (GenBasicBlock inst)]
bodyNodes = [Node BlockId (GenBasicBlock inst)]
-> [Node BlockId (GenBasicBlock inst)]
forall a. [a] -> [a]
reverse
([SCC (Node BlockId (GenBasicBlock inst))]
-> [Node BlockId (GenBasicBlock inst)]
forall a. [SCC a] -> [a]
flattenSCCs (Maybe CFG
-> [GenBasicBlock inst]
-> [SCC (Node BlockId (GenBasicBlock inst))]
forall instr.
Instruction instr =>
Maybe CFG
-> [NatBasicBlock instr]
-> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks Maybe CFG
edgeWeights [GenBasicBlock inst]
blocks))
in LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
infos ([GenBasicBlock inst] -> [GenBasicBlock inst])
-> ([Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst])
-> [Node BlockId (GenBasicBlock inst)]
-> [GenBasicBlock inst]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelMap a
-> [Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst]
forall i t1.
LabelMap i
-> [Node BlockId (GenBasicBlock t1)] -> [GenBasicBlock t1]
seqBlocks LabelMap a
infos ([Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst])
-> [Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst]
forall a b. (a -> b) -> a -> b
$ ( Node BlockId (GenBasicBlock inst)
entryNode Node BlockId (GenBasicBlock inst)
-> [Node BlockId (GenBasicBlock inst)]
-> [Node BlockId (GenBasicBlock inst)]
forall a. a -> [a] -> [a]
: [Node BlockId (GenBasicBlock inst)]
bodyNodes)
sccBlocks
:: Instruction instr
=> Maybe CFG -> [NatBasicBlock instr]
-> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks :: forall instr.
Instruction instr =>
Maybe CFG
-> [NatBasicBlock instr]
-> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks Maybe CFG
edgeWeights [NatBasicBlock instr]
blocks =
[Node BlockId (NatBasicBlock instr)]
-> [SCC (Node BlockId (NatBasicBlock instr))]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR
((NatBasicBlock instr -> Node BlockId (NatBasicBlock instr))
-> [NatBasicBlock instr] -> [Node BlockId (NatBasicBlock instr)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe CFG
-> NatBasicBlock instr -> Node BlockId (NatBasicBlock instr)
forall t.
Instruction t =>
Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
mkNode Maybe CFG
edgeWeights) [NatBasicBlock instr]
blocks)
mkNode :: (Instruction t)
=> Maybe CFG -> GenBasicBlock t
-> Node BlockId (GenBasicBlock t)
mkNode :: forall t.
Instruction t =>
Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
mkNode Maybe CFG
edgeWeights block :: GenBasicBlock t
block@(BasicBlock BlockId
id [t]
instrs) =
GenBasicBlock t
-> BlockId -> [BlockId] -> Node BlockId (GenBasicBlock t)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenBasicBlock t
block BlockId
id [BlockId]
outEdges
where
outEdges :: [BlockId]
outEdges :: [BlockId]
outEdges
= [BlockId]
successor
where
successor :: [BlockId]
successor
| Just [(BlockId, EdgeInfo)]
successors <- (CFG -> [(BlockId, EdgeInfo)])
-> Maybe CFG -> Maybe [(BlockId, EdgeInfo)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CFG -> BlockId -> [(BlockId, EdgeInfo)]
`getSuccEdgesSorted` BlockId
id)
Maybe CFG
edgeWeights
= case [(BlockId, EdgeInfo)]
successors of
[] -> []
((BlockId
target,EdgeInfo
info):[(BlockId, EdgeInfo)]
_)
| [(BlockId, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(BlockId, EdgeInfo)]
successors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
|| EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= EdgeWeight
0 -> []
| Bool
otherwise -> [BlockId
target]
| Just t
instr <- [t] -> Maybe t
forall a. [a] -> Maybe a
lastMaybe [t]
instrs
, [BlockId
one] <- t -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr t
instr
= [BlockId
one]
| Bool
otherwise = []
seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
-> [GenBasicBlock t1]
seqBlocks :: forall i t1.
LabelMap i
-> [Node BlockId (GenBasicBlock t1)] -> [GenBasicBlock t1]
seqBlocks LabelMap i
infos [Node BlockId (GenBasicBlock t1)]
blocks = UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable0 [BlockId]
todo0
where
pullable0 :: UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable0 = [(BlockId, (GenBasicBlock t1, [BlockId]))]
-> UniqFM BlockId (GenBasicBlock t1, [BlockId])
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [ (BlockId
i,(GenBasicBlock t1
b,[BlockId]
n)) | DigraphNode GenBasicBlock t1
b BlockId
i [BlockId]
n <- [Node BlockId (GenBasicBlock t1)]
blocks ]
todo0 :: [BlockId]
todo0 = (Node BlockId (GenBasicBlock t1) -> BlockId)
-> [Node BlockId (GenBasicBlock t1)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map Node BlockId (GenBasicBlock t1) -> BlockId
forall key payload. Node key payload -> key
node_key [Node BlockId (GenBasicBlock t1)]
blocks
placeNext :: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
_ [] = []
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable (BlockId
i:[BlockId]
rest)
| Just ((GenBasicBlock t1, [BlockId])
block, UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable') <- UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> BlockId
-> Maybe
((GenBasicBlock t1, [BlockId]),
UniqFM BlockId (GenBasicBlock t1, [BlockId]))
forall elt.
UniqFM BlockId elt -> BlockId -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable BlockId
i
= UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable' [BlockId]
rest (GenBasicBlock t1, [BlockId])
block
| Bool
otherwise
= UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
rest
place :: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo (GenBasicBlock t1
block,[])
= GenBasicBlock t1
block GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
place UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo (block :: GenBasicBlock t1
block@(BasicBlock BlockId
id [t1]
instrs),[BlockId
next])
| BlockId -> LabelMap i -> Bool
forall a. BlockId -> LabelMap a -> Bool
mapMember BlockId
next LabelMap i
infos
= GenBasicBlock t1
block GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
| Just ((GenBasicBlock t1, [BlockId])
nextBlock, UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable') <- UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> BlockId
-> Maybe
((GenBasicBlock t1, [BlockId]),
UniqFM BlockId (GenBasicBlock t1, [BlockId]))
forall elt.
UniqFM BlockId elt -> BlockId -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable BlockId
next
= BlockId -> [t1] -> GenBasicBlock t1
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [t1]
instrs GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable' [BlockId]
todo (GenBasicBlock t1, [BlockId])
nextBlock
| Bool
otherwise
= GenBasicBlock t1
block GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
place UniqFM BlockId (GenBasicBlock t1, [BlockId])
_ [BlockId]
_ (GenBasicBlock t1
_,[BlockId]
tooManyNextNodes)
= String -> SDoc -> [GenBasicBlock t1]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"seqBlocks" ([BlockId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BlockId]
tooManyNextNodes)
lookupDeleteUFM :: UniqFM BlockId elt -> BlockId
-> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM :: forall elt.
UniqFM BlockId elt -> BlockId -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM UniqFM BlockId elt
m BlockId
k = do
v <- UniqFM BlockId elt -> BlockId -> Maybe elt
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM BlockId elt
m BlockId
k
return (v, delFromUFM m k)
backendMaintainsCfg :: Platform -> Bool
backendMaintainsCfg :: Platform -> Bool
backendMaintainsCfg Platform
platform = case Platform -> Arch
platformArch Platform
platform of
Arch
ArchX86_64 -> Bool
True
Arch
_otherwise -> Bool
False