{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
module GHC.CmmToAsm.CFG
( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)
, TransitionSource(..)
, addWeightEdge, addEdge
, delEdge
, addNodesBetween, shortcutWeightMap
, reverseEdges, filterEdges
, addImmediateSuccessor
, mkWeightInfo, adjustEdgeWeight, setEdgeWeight
, infoEdgeList, edgeList
, getSuccessorEdges, getSuccessors
, getSuccEdgesSorted
, getEdgeInfo
, getCfgNodes, hasNode
, loopMembers, loopLevels, loopInfo
, getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg
, optimizeCFG
, mkGlobalWeights
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm as Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Block
import qualified GHC.Cmm.Dataflow.Graph as G
import GHC.Utils.Misc
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Types.Unique
import qualified GHC.CmmToAsm.CFG.Dominators as Dom
import GHC.CmmToAsm.CFG.Weight
import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet)
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import qualified Data.IntSet as IS
import qualified Data.Set as S
import Data.Tree
import Data.Bifunctor
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Cmm.Ppr ()
import Data.List (sort, nub, partition)
import Data.STRef.Strict
import Control.Monad.ST
import Data.Array.MArray
import Data.Array.ST
import Data.Array.IArray
import Data.Array.Unsafe (unsafeFreeze)
import Data.Array.Base (unsafeRead, unsafeWrite)
import Control.Monad
import GHC.Data.UnionFind
type Prob = Double
type Edge = (BlockId, BlockId)
type Edges = [Edge]
newtype EdgeWeight
= EdgeWeight { EdgeWeight -> Double
weightToDouble :: Double }
deriving (EdgeWeight -> EdgeWeight -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeWeight -> EdgeWeight -> Bool
$c/= :: EdgeWeight -> EdgeWeight -> Bool
== :: EdgeWeight -> EdgeWeight -> Bool
$c== :: EdgeWeight -> EdgeWeight -> Bool
Eq,Eq EdgeWeight
EdgeWeight -> EdgeWeight -> Bool
EdgeWeight -> EdgeWeight -> Ordering
EdgeWeight -> EdgeWeight -> EdgeWeight
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cmin :: EdgeWeight -> EdgeWeight -> EdgeWeight
max :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cmax :: EdgeWeight -> EdgeWeight -> EdgeWeight
>= :: EdgeWeight -> EdgeWeight -> Bool
$c>= :: EdgeWeight -> EdgeWeight -> Bool
> :: EdgeWeight -> EdgeWeight -> Bool
$c> :: EdgeWeight -> EdgeWeight -> Bool
<= :: EdgeWeight -> EdgeWeight -> Bool
$c<= :: EdgeWeight -> EdgeWeight -> Bool
< :: EdgeWeight -> EdgeWeight -> Bool
$c< :: EdgeWeight -> EdgeWeight -> Bool
compare :: EdgeWeight -> EdgeWeight -> Ordering
$ccompare :: EdgeWeight -> EdgeWeight -> Ordering
Ord,Int -> EdgeWeight
EdgeWeight -> Int
EdgeWeight -> [EdgeWeight]
EdgeWeight -> EdgeWeight
EdgeWeight -> EdgeWeight -> [EdgeWeight]
EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight]
$cenumFromThenTo :: EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFromTo :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
$cenumFromTo :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFromThen :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
$cenumFromThen :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFrom :: EdgeWeight -> [EdgeWeight]
$cenumFrom :: EdgeWeight -> [EdgeWeight]
fromEnum :: EdgeWeight -> Int
$cfromEnum :: EdgeWeight -> Int
toEnum :: Int -> EdgeWeight
$ctoEnum :: Int -> EdgeWeight
pred :: EdgeWeight -> EdgeWeight
$cpred :: EdgeWeight -> EdgeWeight
succ :: EdgeWeight -> EdgeWeight
$csucc :: EdgeWeight -> EdgeWeight
Enum,Integer -> EdgeWeight
EdgeWeight -> EdgeWeight
EdgeWeight -> EdgeWeight -> EdgeWeight
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> EdgeWeight
$cfromInteger :: Integer -> EdgeWeight
signum :: EdgeWeight -> EdgeWeight
$csignum :: EdgeWeight -> EdgeWeight
abs :: EdgeWeight -> EdgeWeight
$cabs :: EdgeWeight -> EdgeWeight
negate :: EdgeWeight -> EdgeWeight
$cnegate :: EdgeWeight -> EdgeWeight
* :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c* :: EdgeWeight -> EdgeWeight -> EdgeWeight
- :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c- :: EdgeWeight -> EdgeWeight -> EdgeWeight
+ :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c+ :: EdgeWeight -> EdgeWeight -> EdgeWeight
Num,Num EdgeWeight
Ord EdgeWeight
EdgeWeight -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: EdgeWeight -> Rational
$ctoRational :: EdgeWeight -> Rational
Real,Num EdgeWeight
Rational -> EdgeWeight
EdgeWeight -> EdgeWeight
EdgeWeight -> EdgeWeight -> EdgeWeight
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> EdgeWeight
$cfromRational :: Rational -> EdgeWeight
recip :: EdgeWeight -> EdgeWeight
$crecip :: EdgeWeight -> EdgeWeight
/ :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c/ :: EdgeWeight -> EdgeWeight -> EdgeWeight
Fractional)
instance Outputable EdgeWeight where
ppr :: EdgeWeight -> SDoc
ppr (EdgeWeight Double
w) = Int -> Double -> SDoc
doublePrec Int
5 Double
w
type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)
type CFG = EdgeInfoMap EdgeInfo
data CfgEdge
= CfgEdge
{ CfgEdge -> Label
edgeFrom :: !BlockId
, CfgEdge -> Label
edgeTo :: !BlockId
, CfgEdge -> EdgeInfo
edgeInfo :: !EdgeInfo
}
instance Eq CfgEdge where
== :: CfgEdge -> CfgEdge -> Bool
(==) (CfgEdge Label
from1 Label
to1 EdgeInfo
_) (CfgEdge Label
from2 Label
to2 EdgeInfo
_)
= Label
from1 forall a. Eq a => a -> a -> Bool
== Label
from2 Bool -> Bool -> Bool
&& Label
to1 forall a. Eq a => a -> a -> Bool
== Label
to2
instance Ord CfgEdge where
compare :: CfgEdge -> CfgEdge -> Ordering
compare (CfgEdge Label
from1 Label
to1 (EdgeInfo {edgeWeight :: EdgeInfo -> EdgeWeight
edgeWeight = EdgeWeight
weight1}))
(CfgEdge Label
from2 Label
to2 (EdgeInfo {edgeWeight :: EdgeInfo -> EdgeWeight
edgeWeight = EdgeWeight
weight2}))
| EdgeWeight
weight1 forall a. Ord a => a -> a -> Bool
< EdgeWeight
weight2 Bool -> Bool -> Bool
|| EdgeWeight
weight1 forall a. Eq a => a -> a -> Bool
== EdgeWeight
weight2 Bool -> Bool -> Bool
&& Label
from1 forall a. Ord a => a -> a -> Bool
< Label
from2 Bool -> Bool -> Bool
||
EdgeWeight
weight1 forall a. Eq a => a -> a -> Bool
== EdgeWeight
weight2 Bool -> Bool -> Bool
&& Label
from1 forall a. Eq a => a -> a -> Bool
== Label
from2 Bool -> Bool -> Bool
&& Label
to1 forall a. Ord a => a -> a -> Bool
< Label
to2
= Ordering
LT
| Label
from1 forall a. Eq a => a -> a -> Bool
== Label
from2 Bool -> Bool -> Bool
&& Label
to1 forall a. Eq a => a -> a -> Bool
== Label
to2 Bool -> Bool -> Bool
&& EdgeWeight
weight1 forall a. Eq a => a -> a -> Bool
== EdgeWeight
weight2
= Ordering
EQ
| Bool
otherwise
= Ordering
GT
instance Outputable CfgEdge where
ppr :: CfgEdge -> SDoc
ppr (CfgEdge Label
from1 Label
to1 EdgeInfo
edgeInfo)
= SDoc -> SDoc
parens (forall a. Outputable a => a -> SDoc
ppr Label
from1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"-(" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr EdgeInfo
edgeInfo SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
")->" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Label
to1)
data TransitionSource
= CmmSource { TransitionSource -> CmmNode O C
trans_cmmNode :: (CmmNode O C)
, TransitionSource -> BranchInfo
trans_info :: BranchInfo }
| AsmCodeGen
deriving (TransitionSource -> TransitionSource -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransitionSource -> TransitionSource -> Bool
$c/= :: TransitionSource -> TransitionSource -> Bool
== :: TransitionSource -> TransitionSource -> Bool
$c== :: TransitionSource -> TransitionSource -> Bool
Eq)
data BranchInfo = NoInfo
| HeapStackCheck
deriving BranchInfo -> BranchInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BranchInfo -> BranchInfo -> Bool
$c/= :: BranchInfo -> BranchInfo -> Bool
== :: BranchInfo -> BranchInfo -> Bool
$c== :: BranchInfo -> BranchInfo -> Bool
Eq
instance Outputable BranchInfo where
ppr :: BranchInfo -> SDoc
ppr BranchInfo
NoInfo = String -> SDoc
text String
"regular"
ppr BranchInfo
HeapStackCheck = String -> SDoc
text String
"heap/stack"
isHeapOrStackCheck :: TransitionSource -> Bool
isHeapOrStackCheck :: TransitionSource -> Bool
isHeapOrStackCheck (CmmSource { trans_info :: TransitionSource -> BranchInfo
trans_info = BranchInfo
HeapStackCheck}) = Bool
True
isHeapOrStackCheck TransitionSource
_ = Bool
False
data EdgeInfo
= EdgeInfo
{ EdgeInfo -> TransitionSource
transitionSource :: !TransitionSource
, EdgeInfo -> EdgeWeight
edgeWeight :: !EdgeWeight
} deriving (EdgeInfo -> EdgeInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeInfo -> EdgeInfo -> Bool
$c/= :: EdgeInfo -> EdgeInfo -> Bool
== :: EdgeInfo -> EdgeInfo -> Bool
$c== :: EdgeInfo -> EdgeInfo -> Bool
Eq)
instance Outputable EdgeInfo where
ppr :: EdgeInfo -> SDoc
ppr EdgeInfo
edgeInfo = String -> SDoc
text String
"weight:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo)
mkWeightInfo :: EdgeWeight -> EdgeInfo
mkWeightInfo :: EdgeWeight -> EdgeInfo
mkWeightInfo = TransitionSource -> EdgeWeight -> EdgeInfo
EdgeInfo TransitionSource
AsmCodeGen
adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight)
-> BlockId -> BlockId -> CFG
adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight) -> Label -> Label -> CFG
adjustEdgeWeight CFG
cfg EdgeWeight -> EdgeWeight
f Label
from Label
to
| Just EdgeInfo
info <- Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
from Label
to CFG
cfg
, !EdgeWeight
weight <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info
, !EdgeWeight
newWeight <- EdgeWeight -> EdgeWeight
f EdgeWeight
weight
= Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
from Label
to (EdgeInfo
info { edgeWeight :: EdgeWeight
edgeWeight = EdgeWeight
newWeight}) CFG
cfg
| Bool
otherwise = CFG
cfg
setEdgeWeight :: CFG -> EdgeWeight
-> BlockId -> BlockId -> CFG
setEdgeWeight :: CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg !EdgeWeight
weight Label
from Label
to
| Just EdgeInfo
info <- Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
from Label
to CFG
cfg
= Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
from Label
to (EdgeInfo
info { edgeWeight :: EdgeWeight
edgeWeight = EdgeWeight
weight}) CFG
cfg
| Bool
otherwise = CFG
cfg
getCfgNodes :: CFG -> [BlockId]
getCfgNodes :: CFG -> [Label]
getCfgNodes CFG
m =
forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys CFG
m
hasNode :: CFG -> BlockId -> Bool
hasNode :: CFG -> Label -> Bool
hasNode CFG
m Label
node =
ASSERT( found || not (any (mapMember node) m))
Bool
found
where
found :: Bool
found = forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember Label
node CFG
m
sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg CFG
m LabelSet
blockSet SDoc
msg
| LabelSet
blockSet forall a. Eq a => a -> a -> Bool
== LabelSet
cfgNodes
= Bool
True
| Bool
otherwise =
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Block list and cfg nodes don't match" (
String -> SDoc
text String
"difference:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LabelSet
diff SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"blocks:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LabelSet
blockSet SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"cfg:" SDoc -> SDoc -> SDoc
<+> CFG -> SDoc
pprEdgeWeights CFG
m SDoc -> SDoc -> SDoc
$$
SDoc
msg )
Bool
False
where
cfgNodes :: LabelSet
cfgNodes = forall set. IsSet set => [ElemOf set] -> set
setFromList forall a b. (a -> b) -> a -> b
$ CFG -> [Label]
getCfgNodes CFG
m :: LabelSet
diff :: LabelSet
diff = (forall set. IsSet set => set -> set -> set
setUnion LabelSet
cfgNodes LabelSet
blockSet) forall set. IsSet set => set -> set -> set
`setDifference` (forall set. IsSet set => set -> set -> set
setIntersection LabelSet
cfgNodes LabelSet
blockSet) :: LabelSet
filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges :: (Label -> Label -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges Label -> Label -> EdgeInfo -> Bool
f CFG
cfg =
forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey Label -> LabelMap EdgeInfo -> LabelMap EdgeInfo
filterSources CFG
cfg
where
filterSources :: Label -> LabelMap EdgeInfo -> LabelMap EdgeInfo
filterSources Label
from LabelMap EdgeInfo
m =
forall (map :: * -> *) a.
IsMap map =>
(KeyOf map -> a -> Bool) -> map a -> map a
mapFilterWithKey (\KeyOf LabelMap
to EdgeInfo
w -> Label -> Label -> EdgeInfo -> Bool
f Label
from KeyOf LabelMap
to EdgeInfo
w) LabelMap EdgeInfo
m
shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG
shortcutWeightMap :: LabelMap (Maybe Label) -> CFG -> CFG
shortcutWeightMap LabelMap (Maybe Label)
cuts CFG
cfg
| forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap (Maybe Label)
cuts = CFG
cfg
| Bool
otherwise = CFG
normalised_cfg
where
normalised_cuts_st :: forall s . ST s (LabelMap (Maybe BlockId))
normalised_cuts_st :: forall s. ST s (LabelMap (Maybe Label))
normalised_cuts_st = do
(Point s (Maybe Label)
null :: Point s (Maybe BlockId)) <- forall a s. a -> ST s (Point s a)
fresh forall a. Maybe a
Nothing
let cuts_list :: [(KeyOf LabelMap, Maybe Label)]
cuts_list = forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap (Maybe Label)
cuts
[(Label, Point s (Maybe Label))]
cuts_vars <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Label
p -> (Label
p,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. a -> ST s (Point s a)
fresh (forall a. a -> Maybe a
Just Label
p)) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Label
a, Maybe Label
b) -> [Label
a] forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) Maybe Label
b) [(KeyOf LabelMap, Maybe Label)]
cuts_list)
let cuts_map :: LabelMap (Point s (Maybe Label))
cuts_map = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [(Label, Point s (Maybe Label))]
cuts_vars :: LabelMap (Point s (Maybe BlockId))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Label
from, Maybe Label
to) -> forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"shortcutWeightMap" (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
from LabelMap (Point s (Maybe Label))
cuts_map)
forall s a. Point s a -> Point s a -> ST s ()
`union` forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"shortcutWeightMap" (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just Point s (Maybe Label)
null) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup LabelMap (Point s (Maybe Label))
cuts_map) Maybe Label
to) ) [(KeyOf LabelMap, Maybe Label)]
cuts_list
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s a. Point s a -> ST s a
find LabelMap (Point s (Maybe Label))
cuts_map
normalised_cuts :: LabelMap (Maybe Label)
normalised_cuts = forall a. (forall s. ST s a) -> a
runST forall s. ST s (LabelMap (Maybe Label))
normalised_cuts_st
cuts_domain :: LabelSet
cuts_domain :: LabelSet
cuts_domain = forall set. IsSet set => [ElemOf set] -> set
setFromList forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap (Maybe Label)
cuts
normalised_cfg :: CFG
normalised_cfg :: CFG
normalised_cfg = forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey CFG -> Label -> LabelMap EdgeInfo -> CFG
update_edge forall (map :: * -> *) a. IsMap map => map a
mapEmpty CFG
cfg
update_edge :: CFG -> Label -> LabelMap EdgeInfo -> CFG
update_edge :: CFG -> Label -> LabelMap EdgeInfo -> CFG
update_edge CFG
new_map Label
from LabelMap EdgeInfo
edge_map
| forall set. IsSet set => ElemOf set -> set -> Bool
setMember Label
from LabelSet
cuts_domain = CFG
new_map
| Bool
otherwise = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
from (forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey forall a. LabelMap a -> Label -> a -> LabelMap a
update_from_edge forall (map :: * -> *) a. IsMap map => map a
mapEmpty LabelMap EdgeInfo
edge_map) CFG
new_map
update_from_edge :: LabelMap a -> Label -> a -> LabelMap a
update_from_edge :: forall a. LabelMap a -> Label -> a -> LabelMap a
update_from_edge LabelMap a
new_map Label
to_edge a
edge_info
| Just Maybe Label
new_edge <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
to_edge LabelMap (Maybe Label)
normalised_cuts =
case Maybe Label
new_edge of
Maybe Label
Nothing -> LabelMap a
new_map
Just Label
new_to -> forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
new_to a
edge_info LabelMap a
new_map
| Bool
otherwise = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
to_edge a
edge_info LabelMap a
new_map
addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor :: Weights -> Label -> Label -> CFG -> CFG
addImmediateSuccessor Weights
weights Label
node Label
follower CFG
cfg
= CFG -> CFG
updateEdges forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
node Label
follower EdgeWeight
weight forall a b. (a -> b) -> a -> b
$ CFG
cfg
where
weight :: EdgeWeight
weight = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Weights -> Int
uncondWeight Weights
weights)
targets :: [(Label, EdgeInfo)]
targets = HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
cfg Label
node
successors :: [Label]
successors = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Label, EdgeInfo)]
targets :: [BlockId]
updateEdges :: CFG -> CFG
updateEdges = CFG -> CFG
addNewSuccs forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> CFG
remOldSuccs
remOldSuccs :: CFG -> CFG
remOldSuccs CFG
m = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Label -> Label -> CFG -> CFG
delEdge Label
node)) CFG
m [Label]
successors
addNewSuccs :: CFG -> CFG
addNewSuccs CFG
m =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CFG
m' (Label
t,EdgeInfo
info) -> Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
follower Label
t EdgeInfo
info CFG
m') CFG
m [(Label, EdgeInfo)]
targets
addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge :: Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
from Label
to EdgeInfo
info CFG
cfg =
forall (map :: * -> *) a.
IsMap map =>
(Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAlter Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
addFromToEdge Label
from forall a b. (a -> b) -> a -> b
$
forall (map :: * -> *) a.
IsMap map =>
(Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAlter forall {map :: * -> *} {a}.
IsMap map =>
Maybe (map a) -> Maybe (map a)
addDestNode Label
to CFG
cfg
where
addFromToEdge :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
addFromToEdge Maybe (LabelMap EdgeInfo)
Nothing = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton Label
to EdgeInfo
info
addFromToEdge (Just LabelMap EdgeInfo
wm) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
to EdgeInfo
info LabelMap EdgeInfo
wm
addDestNode :: Maybe (map a) -> Maybe (map a)
addDestNode Maybe (map a)
Nothing = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => map a
mapEmpty
addDestNode n :: Maybe (map a)
n@(Just map a
_) = Maybe (map a)
n
addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
addWeightEdge :: Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
from Label
to EdgeWeight
weight CFG
cfg =
Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
from Label
to (EdgeWeight -> EdgeInfo
mkWeightInfo EdgeWeight
weight) CFG
cfg
delEdge :: BlockId -> BlockId -> CFG -> CFG
delEdge :: Label -> Label -> CFG -> CFG
delEdge Label
from Label
to CFG
m =
forall (map :: * -> *) a.
IsMap map =>
(Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAlter Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
remDest Label
from CFG
m
where
remDest :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
remDest Maybe (LabelMap EdgeInfo)
Nothing = forall a. Maybe a
Nothing
remDest (Just LabelMap EdgeInfo
wm) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete Label
to LabelMap EdgeInfo
wm
getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
getSuccEdgesSorted :: CFG -> Label -> [(Label, EdgeInfo)]
getSuccEdgesSorted CFG
m Label
bid =
let destMap :: LabelMap EdgeInfo
destMap = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault forall (map :: * -> *) a. IsMap map => map a
mapEmpty Label
bid CFG
m
cfgEdges :: [(KeyOf LabelMap, EdgeInfo)]
cfgEdges = forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap EdgeInfo
destMap
sortedEdges :: [(Label, EdgeInfo)]
sortedEdges = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (forall a. Num a => a -> a
negate forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeInfo -> EdgeWeight
edgeWeight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(KeyOf LabelMap, EdgeInfo)]
cfgEdges
in
[(Label, EdgeInfo)]
sortedEdges
getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)]
getSuccessorEdges :: HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
m Label
bid = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(Label, EdgeInfo)]
lookupError forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
bid CFG
m)
where
lookupError :: [(Label, EdgeInfo)]
lookupError = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSuccessorEdges: Block does not exist" forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
ppr Label
bid SDoc -> SDoc -> SDoc
<+> CFG -> SDoc
pprEdgeWeights CFG
m
getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo
getEdgeInfo :: Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
from Label
to CFG
m
| Just LabelMap EdgeInfo
wm <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
from CFG
m
, Just EdgeInfo
info <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
to LabelMap EdgeInfo
wm
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! EdgeInfo
info
| Bool
otherwise
= forall a. Maybe a
Nothing
getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight
getEdgeWeight :: CFG -> Label -> Label -> EdgeWeight
getEdgeWeight CFG
cfg Label
from Label
to =
EdgeInfo -> EdgeWeight
edgeWeight forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"Edgeweight for noexisting block" forall a b. (a -> b) -> a -> b
$
Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
from Label
to CFG
cfg
getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource
getTransitionSource :: Label -> Label -> CFG -> TransitionSource
getTransitionSource Label
from Label
to CFG
cfg = EdgeInfo -> TransitionSource
transitionSource forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"Source info for noexisting block" forall a b. (a -> b) -> a -> b
$
Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
from Label
to CFG
cfg
reverseEdges :: CFG -> CFG
reverseEdges :: CFG -> CFG
reverseEdges CFG
cfg = forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey (\CFG
cfg KeyOf LabelMap
from LabelMap EdgeInfo
toMap -> CFG -> Label -> LabelMap EdgeInfo -> CFG
go (CFG -> Label -> CFG
addNode CFG
cfg KeyOf LabelMap
from) KeyOf LabelMap
from LabelMap EdgeInfo
toMap) forall (map :: * -> *) a. IsMap map => map a
mapEmpty CFG
cfg
where
addNode :: CFG -> BlockId -> CFG
addNode :: CFG -> Label -> CFG
addNode CFG
cfg Label
b = forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
mapUnion Label
b forall (map :: * -> *) a. IsMap map => map a
mapEmpty CFG
cfg
go :: CFG -> BlockId -> (LabelMap EdgeInfo) -> CFG
go :: CFG -> Label -> LabelMap EdgeInfo -> CFG
go CFG
cfg Label
from LabelMap EdgeInfo
toMap = forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey (\CFG
cfg KeyOf LabelMap
to EdgeInfo
info -> Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge KeyOf LabelMap
to Label
from EdgeInfo
info CFG
cfg) CFG
cfg LabelMap EdgeInfo
toMap :: CFG
infoEdgeList :: CFG -> [CfgEdge]
infoEdgeList :: CFG -> [CfgEdge]
infoEdgeList CFG
m =
[(Label, LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go (forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList CFG
m) []
where
go :: [(BlockId,LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go :: [(Label, LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go [] [CfgEdge]
acc = [CfgEdge]
acc
go ((Label
from,LabelMap EdgeInfo
toMap):[(Label, LabelMap EdgeInfo)]
xs) [CfgEdge]
acc
= [(Label, LabelMap EdgeInfo)]
-> Label -> [(Label, EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go' [(Label, LabelMap EdgeInfo)]
xs Label
from (forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap EdgeInfo
toMap) [CfgEdge]
acc
go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [(BlockId,EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go' :: [(Label, LabelMap EdgeInfo)]
-> Label -> [(Label, EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go' [(Label, LabelMap EdgeInfo)]
froms Label
_ [] [CfgEdge]
acc = [(Label, LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go [(Label, LabelMap EdgeInfo)]
froms [CfgEdge]
acc
go' [(Label, LabelMap EdgeInfo)]
froms Label
from ((Label
to,EdgeInfo
info):[(Label, EdgeInfo)]
tos) [CfgEdge]
acc
= [(Label, LabelMap EdgeInfo)]
-> Label -> [(Label, EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go' [(Label, LabelMap EdgeInfo)]
froms Label
from [(Label, EdgeInfo)]
tos (Label -> Label -> EdgeInfo -> CfgEdge
CfgEdge Label
from Label
to EdgeInfo
info forall a. a -> [a] -> [a]
: [CfgEdge]
acc)
edgeList :: CFG -> [Edge]
edgeList :: CFG -> [Edge]
edgeList CFG
m =
[(Label, LabelMap EdgeInfo)] -> [Edge] -> [Edge]
go (forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList CFG
m) []
where
go :: [(BlockId,LabelMap EdgeInfo)] -> [Edge] -> [Edge]
go :: [(Label, LabelMap EdgeInfo)] -> [Edge] -> [Edge]
go [] [Edge]
acc = [Edge]
acc
go ((Label
from,LabelMap EdgeInfo
toMap):[(Label, LabelMap EdgeInfo)]
xs) [Edge]
acc
= [(Label, LabelMap EdgeInfo)]
-> Label -> [Label] -> [Edge] -> [Edge]
go' [(Label, LabelMap EdgeInfo)]
xs Label
from (forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap EdgeInfo
toMap) [Edge]
acc
go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [BlockId] -> [Edge] -> [Edge]
go' :: [(Label, LabelMap EdgeInfo)]
-> Label -> [Label] -> [Edge] -> [Edge]
go' [(Label, LabelMap EdgeInfo)]
froms Label
_ [] [Edge]
acc = [(Label, LabelMap EdgeInfo)] -> [Edge] -> [Edge]
go [(Label, LabelMap EdgeInfo)]
froms [Edge]
acc
go' [(Label, LabelMap EdgeInfo)]
froms Label
from (Label
to:[Label]
tos) [Edge]
acc
= [(Label, LabelMap EdgeInfo)]
-> Label -> [Label] -> [Edge] -> [Edge]
go' [(Label, LabelMap EdgeInfo)]
froms Label
from [Label]
tos ((Label
from,Label
to) forall a. a -> [a] -> [a]
: [Edge]
acc)
getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId]
getSuccessors :: HasDebugCallStack => CFG -> Label -> [Label]
getSuccessors CFG
m Label
bid
| Just LabelMap EdgeInfo
wm <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
bid CFG
m
= forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap EdgeInfo
wm
| Bool
otherwise = [Label]
lookupError
where
lookupError :: [Label]
lookupError = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSuccessors: Block does not exist" forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
ppr Label
bid SDoc -> SDoc -> SDoc
<+> CFG -> SDoc
pprEdgeWeights CFG
m
pprEdgeWeights :: CFG -> SDoc
pprEdgeWeights :: CFG -> SDoc
pprEdgeWeights CFG
m =
let edges :: [CfgEdge]
edges = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ CFG -> [CfgEdge]
infoEdgeList CFG
m :: [CfgEdge]
printEdge :: CfgEdge -> SDoc
printEdge (CfgEdge Label
from Label
to (EdgeInfo { edgeWeight :: EdgeInfo -> EdgeWeight
edgeWeight = EdgeWeight
weight }))
= String -> SDoc
text String
"\t" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Label
from SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"->" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Label
to SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"[label=\"" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr EdgeWeight
weight SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"\",weight=\"" SDoc -> SDoc -> SDoc
<>
forall a. Outputable a => a -> SDoc
ppr EdgeWeight
weight SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"\"];\n"
printNode :: a -> SDoc
printNode a
node
= String -> SDoc
text String
"\t" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr a
node SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
";\n"
getEdgeNodes :: CfgEdge -> [Label]
getEdgeNodes (CfgEdge Label
from Label
to EdgeInfo
_) = [Label
from,Label
to]
edgeNodes :: LabelSet
edgeNodes = forall set. IsSet set => [ElemOf set] -> set
setFromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CfgEdge -> [Label]
getEdgeNodes [CfgEdge]
edges :: LabelSet
nodes :: [Label]
nodes = forall a. (a -> Bool) -> [a] -> [a]
filter (\Label
n -> (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall set. IsSet set => ElemOf set -> set -> Bool
setMember Label
n) LabelSet
edgeNodes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
(a -> Bool) -> map a -> map a
mapFilter forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
m
in
String -> SDoc
text String
"digraph {\n" SDoc -> SDoc -> SDoc
<>
(forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SDoc -> SDoc -> SDoc
(<>) SDoc
empty (forall a b. (a -> b) -> [a] -> [b]
map CfgEdge -> SDoc
printEdge [CfgEdge]
edges)) SDoc -> SDoc -> SDoc
<>
(forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SDoc -> SDoc -> SDoc
(<>) SDoc
empty (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
printNode [Label]
nodes)) SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"}\n"
{-# INLINE updateEdgeWeight #-}
updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
updateEdgeWeight EdgeWeight -> EdgeWeight
f (Label
from, Label
to) CFG
cfg
| Just EdgeInfo
oldInfo <- Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
from Label
to CFG
cfg
= let !oldWeight :: EdgeWeight
oldWeight = EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
oldInfo
!newWeight :: EdgeWeight
newWeight = EdgeWeight -> EdgeWeight
f EdgeWeight
oldWeight
in Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
from Label
to (EdgeInfo
oldInfo {edgeWeight :: EdgeWeight
edgeWeight = EdgeWeight
newWeight}) CFG
cfg
| Bool
otherwise
= forall a. String -> a
panic String
"Trying to update invalid edge"
mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
mapWeights :: (Label -> Label -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
mapWeights Label -> Label -> EdgeWeight -> EdgeWeight
f CFG
cfg =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CFG
cfg (CfgEdge Label
from Label
to EdgeInfo
info) ->
let oldWeight :: EdgeWeight
oldWeight = EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info
newWeight :: EdgeWeight
newWeight = Label -> Label -> EdgeWeight -> EdgeWeight
f Label
from Label
to EdgeWeight
oldWeight
in Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
from Label
to (EdgeInfo
info {edgeWeight :: EdgeWeight
edgeWeight = EdgeWeight
newWeight}) CFG
cfg)
CFG
cfg (CFG -> [CfgEdge]
infoEdgeList CFG
cfg)
addNodesBetween :: Weights -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
addNodesBetween :: Weights -> CFG -> [(Label, Label, Label)] -> CFG
addNodesBetween Weights
weights CFG
m [(Label, Label, Label)]
updates =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> (Label, Label, Label, EdgeInfo) -> CFG
updateWeight CFG
m forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[(Label, Label, Label)] -> [(Label, Label, Label, EdgeInfo)]
weightUpdates forall a b. (a -> b) -> a -> b
$ [(Label, Label, Label)]
updates
where
weight :: EdgeWeight
weight = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Weights -> Int
uncondWeight Weights
weights)
weightUpdates :: [(Label, Label, Label)] -> [(Label, Label, Label, EdgeInfo)]
weightUpdates = forall a b. (a -> b) -> [a] -> [b]
map (Label, Label, Label) -> (Label, Label, Label, EdgeInfo)
getWeight
getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo)
getWeight :: (Label, Label, Label) -> (Label, Label, Label, EdgeInfo)
getWeight (Label
from,Label
between,Label
old)
| Just EdgeInfo
edgeInfo <- Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
from Label
old CFG
m
= (Label
from,Label
between,Label
old,EdgeInfo
edgeInfo)
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Can't find weight for edge that should have one" (
String -> SDoc
text String
"triple" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Label
from,Label
between,Label
old) SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"updates" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [(Label, Label, Label)]
updates SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"cfg:" SDoc -> SDoc -> SDoc
<+> CFG -> SDoc
pprEdgeWeights CFG
m )
updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG
updateWeight :: CFG -> (Label, Label, Label, EdgeInfo) -> CFG
updateWeight CFG
m (Label
from,Label
between,Label
old,EdgeInfo
edgeInfo)
= Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
from Label
between EdgeInfo
edgeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
between Label
old EdgeWeight
weight forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Label -> Label -> CFG -> CFG
delEdge Label
from Label
old forall a b. (a -> b) -> a -> b
$ CFG
m
getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG
getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG
getCfgProc Platform
_ Weights
_ (CmmData {}) = forall (map :: * -> *) a. IsMap map => map a
mapEmpty
getCfgProc Platform
platform Weights
weights (CmmProc LabelMap RawCmmStatics
_info CLabel
_lab [GlobalReg]
_live CmmGraph
graph) = Platform -> Weights -> CmmGraph -> CFG
getCfg Platform
platform Weights
weights CmmGraph
graph
getCfg :: Platform -> Weights -> CmmGraph -> CFG
getCfg :: Platform -> Weights -> CmmGraph -> CFG
getCfg Platform
platform Weights
weights CmmGraph
graph =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> (Edge, EdgeInfo) -> CFG
insertEdge CFG
edgelessCfg forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CmmBlock -> [(Edge, EdgeInfo)]
getBlockEdges [CmmBlock]
blocks
where
Weights
{ uncondWeight :: Weights -> Int
uncondWeight = Int
uncondWeight
, condBranchWeight :: Weights -> Int
condBranchWeight = Int
condBranchWeight
, switchWeight :: Weights -> Int
switchWeight = Int
switchWeight
, callWeight :: Weights -> Int
callWeight = Int
callWeight
, likelyCondWeight :: Weights -> Int
likelyCondWeight = Int
likelyCondWeight
, unlikelyCondWeight :: Weights -> Int
unlikelyCondWeight = Int
unlikelyCondWeight
} = Weights
weights
edgelessCfg :: CFG
edgelessCfg = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
G.entryLabel [CmmBlock]
blocks) (forall a. a -> [a]
repeat forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG
insertEdge :: CFG -> (Edge, EdgeInfo) -> CFG
insertEdge CFG
m ((Label
from,Label
to),EdgeInfo
weight) =
forall (map :: * -> *) a.
IsMap map =>
(Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAlter Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
f Label
from CFG
m
where
f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
f Maybe (LabelMap EdgeInfo)
Nothing = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton Label
to EdgeInfo
weight
f (Just LabelMap EdgeInfo
destMap) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
to EdgeInfo
weight LabelMap EdgeInfo
destMap
getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)]
getBlockEdges :: CmmBlock -> [(Edge, EdgeInfo)]
getBlockEdges CmmBlock
block =
case CmmNode O C
branch of
CmmBranch Label
dest -> [Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
dest Int
uncondWeight]
CmmCondBranch CmmExpr
cond Label
t Label
f Maybe Bool
l
| Maybe Bool
l forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing ->
[Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
f Int
condBranchWeight, Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
t Int
condBranchWeight]
| Maybe Bool
l forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True ->
[Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
f Int
unlikelyCondWeight, Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
t Int
likelyCondWeight]
| Maybe Bool
l forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
False ->
[Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
f Int
likelyCondWeight, Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
t Int
unlikelyCondWeight]
where
mkEdgeInfo :: Int -> EdgeInfo
mkEdgeInfo =
TransitionSource -> EdgeWeight -> EdgeInfo
EdgeInfo (CmmNode O C -> BranchInfo -> TransitionSource
CmmSource CmmNode O C
branch BranchInfo
branchInfo) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
mkEdge :: Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
target Int
weight = ((Label
bid,Label
target), Int -> EdgeInfo
mkEdgeInfo Int
weight)
branchInfo :: BranchInfo
branchInfo =
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed
(forall a. String -> a
panic String
"GHC.CmmToAsm.CFG.getCfg: foldRegsUsed")
(\BranchInfo
info GlobalReg
r -> if GlobalReg
r forall a. Eq a => a -> a -> Bool
== GlobalReg
SpLim Bool -> Bool -> Bool
|| GlobalReg
r forall a. Eq a => a -> a -> Bool
== GlobalReg
HpLim Bool -> Bool -> Bool
|| GlobalReg
r forall a. Eq a => a -> a -> Bool
== GlobalReg
BaseReg
then BranchInfo
HeapStackCheck else BranchInfo
info)
BranchInfo
NoInfo CmmExpr
cond
(CmmSwitch CmmExpr
_e SwitchTargets
ids) ->
let switchTargets :: [Label]
switchTargets = SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
ids
adjustedWeight :: Int
adjustedWeight =
if (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Label]
switchTargets forall a. Ord a => a -> a -> Bool
> Int
10) then -Int
1 else Int
switchWeight
in forall a b. (a -> b) -> [a] -> [b]
map (\Label
x -> Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
x Int
adjustedWeight) [Label]
switchTargets
(CmmCall { cml_cont :: CmmNode O C -> Maybe Label
cml_cont = Just Label
cont}) -> [Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
cont Int
callWeight]
(CmmForeignCall {succ :: CmmNode O C -> Label
Cmm.succ = Label
cont}) -> [Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
cont Int
callWeight]
(CmmCall { cml_cont :: CmmNode O C -> Maybe Label
cml_cont = Maybe Label
Nothing }) -> []
CmmNode O C
other ->
forall a. String -> a
panic String
"Foo" forall a b. (a -> b) -> a -> b
$
ASSERT2(False, ppr "Unknown successor cause:" <>
(pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other)))
forall a b. (a -> b) -> [a] -> [b]
map (\Label
x -> ((Label
bid,Label
x),Int -> EdgeInfo
mkEdgeInfo Int
0)) forall a b. (a -> b) -> a -> b
$ forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
G.successors CmmNode O C
other
where
bid :: Label
bid = forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
G.entryLabel CmmBlock
block
mkEdgeInfo :: Int -> EdgeInfo
mkEdgeInfo = TransitionSource -> EdgeWeight -> EdgeInfo
EdgeInfo (CmmNode O C -> BranchInfo -> TransitionSource
CmmSource CmmNode O C
branch BranchInfo
NoInfo) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
mkEdge :: Label -> Int -> (Edge, EdgeInfo)
mkEdge Label
target Int
weight = ((Label
bid,Label
target), Int -> EdgeInfo
mkEdgeInfo Int
weight)
branch :: CmmNode O C
branch = forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C
lastNode CmmBlock
block :: CmmNode O C
blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
graph :: [CmmBlock]
findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges
findBackEdges :: HasDebugCallStack => Label -> CFG -> [Edge]
findBackEdges Label
root CFG
cfg =
forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Edge, EdgeType)
x -> forall a b. (a, b) -> b
snd (Edge, EdgeType)
x forall a. Eq a => a -> a -> Bool
== EdgeType
Backward) forall a b. (a -> b) -> a -> b
$ [(Edge, EdgeType)]
typedEdges
where
edges :: [Edge]
edges = CFG -> [Edge]
edgeList CFG
cfg :: [(BlockId,BlockId)]
getSuccs :: Label -> [Label]
getSuccs = HasDebugCallStack => CFG -> Label -> [Label]
getSuccessors CFG
cfg :: BlockId -> [BlockId]
typedEdges :: [(Edge, EdgeType)]
typedEdges =
forall key.
Uniquable key =>
key -> (key -> [key]) -> [(key, key)] -> [((key, key), EdgeType)]
classifyEdges Label
root Label -> [Label]
getSuccs [Edge]
edges :: [((BlockId,BlockId),EdgeType)]
optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG
optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG
optimizeCFG Bool
_ Weights
_ (CmmData {}) CFG
cfg = CFG
cfg
optimizeCFG Bool
doStaticPred Weights
weights proc :: RawCmmDecl
proc@(CmmProc LabelMap RawCmmStatics
_info CLabel
_lab [GlobalReg]
_live CmmGraph
graph) CFG
cfg =
(if Bool
doStaticPred then Label -> CFG -> CFG
staticPredCfg (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
graph) else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
Weights -> RawCmmDecl -> CFG -> CFG
optHsPatterns Weights
weights RawCmmDecl
proc forall a b. (a -> b) -> a -> b
$ CFG
cfg
optHsPatterns :: Weights -> RawCmmDecl -> CFG -> CFG
optHsPatterns :: Weights -> RawCmmDecl -> CFG -> CFG
optHsPatterns Weights
_ (CmmData {}) CFG
cfg = CFG
cfg
optHsPatterns Weights
weights (CmmProc LabelMap RawCmmStatics
info CLabel
_lab [GlobalReg]
_live CmmGraph
graph) CFG
cfg =
{-# SCC optHsPatterns #-}
CFG -> CFG
favourFewerPreds forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. LabelMap a -> CFG -> CFG
penalizeInfoTables LabelMap RawCmmStatics
info forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Label -> CFG -> CFG
increaseBackEdgeWeight (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
graph) forall a b. (a -> b) -> a -> b
$ CFG
cfg
where
increaseBackEdgeWeight :: BlockId -> CFG -> CFG
increaseBackEdgeWeight :: Label -> CFG -> CFG
increaseBackEdgeWeight Label
root CFG
cfg =
let backedges :: [Edge]
backedges = HasDebugCallStack => Label -> CFG -> [Edge]
findBackEdges Label
root CFG
cfg
update :: EdgeWeight -> EdgeWeight
update EdgeWeight
weight
| EdgeWeight
weight forall a. Ord a => a -> a -> Bool
<= EdgeWeight
0 = EdgeWeight
0
| Bool
otherwise
= EdgeWeight
weight forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Weights -> Int
backEdgeBonus Weights
weights)
in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CFG
cfg Edge
edge -> (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
updateEdgeWeight EdgeWeight -> EdgeWeight
update Edge
edge CFG
cfg)
CFG
cfg [Edge]
backedges
penalizeInfoTables :: LabelMap a -> CFG -> CFG
penalizeInfoTables :: forall a. LabelMap a -> CFG -> CFG
penalizeInfoTables LabelMap a
info CFG
cfg =
(Label -> Label -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
mapWeights Label -> Label -> EdgeWeight -> EdgeWeight
fupdate CFG
cfg
where
fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
fupdate :: Label -> Label -> EdgeWeight -> EdgeWeight
fupdate Label
_ Label
to EdgeWeight
weight
| forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember Label
to LabelMap a
info
= EdgeWeight
weight forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Weights -> Int
infoTablePenalty Weights
weights)
| Bool
otherwise = EdgeWeight
weight
favourFewerPreds :: CFG -> CFG
favourFewerPreds :: CFG -> CFG
favourFewerPreds CFG
cfg =
let
revCfg :: CFG
revCfg =
CFG -> CFG
reverseEdges forall a b. (a -> b) -> a -> b
$ (Label -> Label -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges
(\Label
_from -> Label -> EdgeInfo -> Bool
fallthroughTarget) CFG
cfg
predCount :: Label -> Int
predCount Label
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
revCfg Label
n
nodes :: [Label]
nodes = CFG -> [Label]
getCfgNodes CFG
cfg
modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
modifiers Int
preds1 Int
preds2
| Int
preds1 forall a. Ord a => a -> a -> Bool
< Int
preds2 = ( EdgeWeight
1,-EdgeWeight
1)
| Int
preds1 forall a. Eq a => a -> a -> Bool
== Int
preds2 = ( EdgeWeight
0, EdgeWeight
0)
| Bool
otherwise = (-EdgeWeight
1, EdgeWeight
1)
update :: CFG -> BlockId -> CFG
update :: CFG -> Label -> CFG
update CFG
cfg Label
node
| [(Label
s1,EdgeInfo
e1),(Label
s2,EdgeInfo
e2)] <- HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
cfg Label
node
, !EdgeWeight
w1 <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
e1
, !EdgeWeight
w2 <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
e2
, EdgeWeight
w1 forall a. Eq a => a -> a -> Bool
== EdgeWeight
w2
, (EdgeWeight
mod1,EdgeWeight
mod2) <- Int -> Int -> (EdgeWeight, EdgeWeight)
modifiers (Label -> Int
predCount Label
s1) (Label -> Int
predCount Label
s2)
= (\CFG
cfg' ->
(CFG -> (EdgeWeight -> EdgeWeight) -> Label -> Label -> CFG
adjustEdgeWeight CFG
cfg' (forall a. Num a => a -> a -> a
+EdgeWeight
mod2) Label
node Label
s2))
(CFG -> (EdgeWeight -> EdgeWeight) -> Label -> Label -> CFG
adjustEdgeWeight CFG
cfg (forall a. Num a => a -> a -> a
+EdgeWeight
mod1) Label
node Label
s1)
| Bool
otherwise
= CFG
cfg
in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> Label -> CFG
update CFG
cfg [Label]
nodes
where
fallthroughTarget :: BlockId -> EdgeInfo -> Bool
fallthroughTarget :: Label -> EdgeInfo -> Bool
fallthroughTarget Label
to (EdgeInfo TransitionSource
source EdgeWeight
_weight)
| forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember Label
to LabelMap RawCmmStatics
info = Bool
False
| TransitionSource
AsmCodeGen <- TransitionSource
source = Bool
True
| CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmBranch {} } <- TransitionSource
source = Bool
True
| CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmCondBranch {} } <- TransitionSource
source = Bool
True
| Bool
otherwise = Bool
False
staticPredCfg :: BlockId -> CFG -> CFG
staticPredCfg :: Label -> CFG -> CFG
staticPredCfg Label
entry CFG
cfg = CFG
cfg'
where
(LabelMap Double
_, LabelMap (LabelMap Double)
globalEdgeWeights) = {-# SCC mkGlobalWeights #-}
HasDebugCallStack =>
Label -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
mkGlobalWeights Label
entry CFG
cfg
cfg' :: CFG
cfg' = {-# SCC rewriteEdges #-}
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey
(\CFG
cfg KeyOf LabelMap
from LabelMap Double
m ->
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey
(\CFG
cfg KeyOf LabelMap
to Double
w -> CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg (Double -> EdgeWeight
EdgeWeight Double
w) KeyOf LabelMap
from KeyOf LabelMap
to )
CFG
cfg LabelMap Double
m )
CFG
cfg
LabelMap (LabelMap Double)
globalEdgeWeights
loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool
loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool
loopMembers CFG
cfg =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip SCC Label -> LabelMap Bool -> LabelMap Bool
setLevel) forall (map :: * -> *) a. IsMap map => map a
mapEmpty [SCC Label]
sccs
where
mkNode :: BlockId -> Node BlockId BlockId
mkNode :: Label -> Node Label Label
mkNode Label
bid = forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode Label
bid Label
bid (HasDebugCallStack => CFG -> Label -> [Label]
getSuccessors CFG
cfg Label
bid)
nodes :: [Node Label Label]
nodes = forall a b. (a -> b) -> [a] -> [b]
map Label -> Node Label Label
mkNode (CFG -> [Label]
getCfgNodes CFG
cfg)
sccs :: [SCC Label]
sccs = forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd [Node Label Label]
nodes
setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
setLevel :: SCC Label -> LabelMap Bool -> LabelMap Bool
setLevel (AcyclicSCC Label
bid) LabelMap Bool
m = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
bid Bool
False LabelMap Bool
m
setLevel (CyclicSCC [Label]
bids) LabelMap Bool
m = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LabelMap Bool
m Label
k -> forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
k Bool
True LabelMap Bool
m) LabelMap Bool
m [Label]
bids
loopLevels :: CFG -> BlockId -> LabelMap Int
loopLevels :: CFG -> Label -> LabelMap Int
loopLevels CFG
cfg Label
root = LoopInfo -> LabelMap Int
liLevels LoopInfo
loopInfos
where
loopInfos :: LoopInfo
loopInfos = HasDebugCallStack => CFG -> Label -> LoopInfo
loopInfo CFG
cfg Label
root
data LoopInfo = LoopInfo
{ LoopInfo -> [Edge]
liBackEdges :: [(Edge)]
, LoopInfo -> LabelMap Int
liLevels :: LabelMap Int
, LoopInfo -> [(Edge, LabelSet)]
liLoops :: [(Edge, LabelSet)]
}
instance Outputable LoopInfo where
ppr :: LoopInfo -> SDoc
ppr (LoopInfo [Edge]
_ LabelMap Int
_lvls [(Edge, LabelSet)]
loops) =
String -> SDoc
text String
"Loops:(backEdge, bodyNodes)" SDoc -> SDoc -> SDoc
$$
([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [(Edge, LabelSet)]
loops)
loopInfo :: HasDebugCallStack => CFG -> BlockId -> LoopInfo
loopInfo :: HasDebugCallStack => CFG -> Label -> LoopInfo
loopInfo CFG
cfg Label
root = LoopInfo { liBackEdges :: [Edge]
liBackEdges = [Edge]
backEdges
, liLevels :: LabelMap Int
liLevels = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [(Label, Int)]
loopCounts
, liLoops :: [(Edge, LabelSet)]
liLoops = [(Edge, LabelSet)]
loopBodies }
where
revCfg :: CFG
revCfg = CFG -> CFG
reverseEdges CFG
cfg
graph :: LabelMap LabelSet
graph =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall set. IsSet set => [ElemOf set] -> set
setFromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys ) CFG
cfg :: LabelMap LabelSet
rooted :: (Int, IntMap IntSet)
rooted = ( Label -> Int
fromBlockId Label
root
, forall a. LabelMap a -> IntMap a
toIntMap forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LabelSet -> IntSet
toIntSet LabelMap LabelSet
graph) :: (Int, IntMap IntSet)
tree :: Tree Label
tree = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Label
toBlockId forall a b. (a -> b) -> a -> b
$ (Int, IntMap IntSet) -> Tree Int
Dom.domTree (Int, IntMap IntSet)
rooted :: Tree BlockId
domMap :: LabelMap LabelSet
domMap :: LabelMap LabelSet
domMap = Tree Label -> LabelMap LabelSet
mkDomMap Tree Label
tree
edges :: [Edge]
edges = CFG -> [Edge]
edgeList CFG
cfg :: [(BlockId, BlockId)]
nodes :: [Label]
nodes = CFG -> [Label]
getCfgNodes CFG
cfg :: [BlockId]
isBackEdge :: Edge -> Bool
isBackEdge (Label
from,Label
to)
| Just LabelSet
doms <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
from LabelMap LabelSet
domMap
, forall set. IsSet set => ElemOf set -> set -> Bool
setMember Label
to LabelSet
doms
= Bool
True
| Bool
otherwise = Bool
False
findBody :: Edge -> (Edge, LabelSet)
findBody edge :: Edge
edge@(Label
tail, Label
head)
= ( Edge
edge, forall set. IsSet set => ElemOf set -> set -> set
setInsert Label
head forall a b. (a -> b) -> a -> b
$ LabelSet -> LabelSet -> LabelSet
go (forall set. IsSet set => ElemOf set -> set
setSingleton Label
tail) (forall set. IsSet set => ElemOf set -> set
setSingleton Label
tail) )
where
go :: LabelSet -> LabelSet -> LabelSet
go :: LabelSet -> LabelSet -> LabelSet
go LabelSet
found LabelSet
current
| forall set. IsSet set => set -> Bool
setNull LabelSet
current = LabelSet
found
| Bool
otherwise = LabelSet -> LabelSet -> LabelSet
go (forall set. IsSet set => set -> set -> set
setUnion LabelSet
newSuccessors LabelSet
found)
LabelSet
newSuccessors
where
newSuccessors :: LabelSet
newSuccessors = forall set. IsSet set => (ElemOf set -> Bool) -> set -> set
setFilter (\ElemOf LabelSet
n -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
n LabelSet
found) LabelSet
successors :: LabelSet
successors :: LabelSet
successors = forall set. IsSet set => ElemOf set -> set -> set
setDelete Label
head forall a b. (a -> b) -> a -> b
$ forall set. IsSet set => [set] -> set
setUnions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
(\Label
x -> if Label
x forall a. Eq a => a -> a -> Bool
== Label
head then forall set. IsSet set => set
setEmpty else forall set. IsSet set => [ElemOf set] -> set
setFromList (HasDebugCallStack => CFG -> Label -> [Label]
getSuccessors CFG
revCfg Label
x))
(forall set. IsSet set => set -> [ElemOf set]
setElems LabelSet
current) :: LabelSet
backEdges :: [Edge]
backEdges = forall a. (a -> Bool) -> [a] -> [a]
filter Edge -> Bool
isBackEdge [Edge]
edges
loopBodies :: [(Edge, LabelSet)]
loopBodies = forall a b. (a -> b) -> [a] -> [b]
map Edge -> (Edge, LabelSet)
findBody [Edge]
backEdges :: [(Edge, LabelSet)]
loopCounts :: [(Label, Int)]
loopCounts =
let bodies :: [(Label, LabelSet)]
bodies = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a, b) -> b
snd) [(Edge, LabelSet)]
loopBodies
loopCount :: Label -> Int
loopCount Label
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall set. IsSet set => ElemOf set -> set -> Bool
setMember Label
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ [(Label, LabelSet)]
bodies
in forall a b. (a -> b) -> [a] -> [b]
map (\Label
n -> (Label
n, Label -> Int
loopCount Label
n)) forall a b. (a -> b) -> a -> b
$ [Label]
nodes :: [(BlockId, Int)]
toIntSet :: LabelSet -> IntSet
toIntSet :: LabelSet -> IntSet
toIntSet LabelSet
s = [Int] -> IntSet
IS.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Label -> Int
fromBlockId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall set. IsSet set => set -> [ElemOf set]
setElems forall a b. (a -> b) -> a -> b
$ LabelSet
s
toIntMap :: LabelMap a -> IntMap a
toIntMap :: forall a. LabelMap a -> IntMap a
toIntMap LabelMap a
m = forall a. [(Int, a)] -> IntMap a
IM.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Label
x,a
y) -> (Label -> Int
fromBlockId Label
x,a
y)) forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap a
m
mkDomMap :: Tree BlockId -> LabelMap LabelSet
mkDomMap :: Tree Label -> LabelMap LabelSet
mkDomMap Tree Label
root = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ LabelSet -> Tree Label -> [(Label, LabelSet)]
go forall set. IsSet set => set
setEmpty Tree Label
root
where
go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)]
go :: LabelSet -> Tree Label -> [(Label, LabelSet)]
go LabelSet
parents (Node Label
lbl [])
= [(Label
lbl, LabelSet
parents)]
go LabelSet
parents (Node Label
_ [Tree Label]
leaves)
= let nodes :: [Label]
nodes = forall a b. (a -> b) -> [a] -> [b]
map forall a. Tree a -> a
rootLabel [Tree Label]
leaves
entries :: [(Label, LabelSet)]
entries = forall a b. (a -> b) -> [a] -> [b]
map (\Label
x -> (Label
x,LabelSet
parents)) [Label]
nodes
in [(Label, LabelSet)]
entries forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
(\Tree Label
n -> LabelSet -> Tree Label -> [(Label, LabelSet)]
go (forall set. IsSet set => ElemOf set -> set -> set
setInsert (forall a. Tree a -> a
rootLabel Tree Label
n) LabelSet
parents) Tree Label
n)
[Tree Label]
leaves
fromBlockId :: BlockId -> Int
fromBlockId :: Label -> Int
fromBlockId = Unique -> Int
getKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Uniquable a => a -> Unique
getUnique
toBlockId :: Int -> BlockId
toBlockId :: Int -> Label
toBlockId = Unique -> Label
mkBlockId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Unique
mkUniqueGrimily
newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId])
instance G.NonLocal (BlockNode) where
entryLabel :: forall (x :: Extensibility). BlockNode C x -> Label
entryLabel (BN (Label
lbl,[Label]
_)) = Label
lbl
successors :: forall (e :: Extensibility). BlockNode e C -> [Label]
successors (BN (Label
_,[Label]
succs)) = [Label]
succs
revPostorderFrom :: HasDebugCallStack => CFG -> BlockId -> [BlockId]
revPostorderFrom :: HasDebugCallStack => CFG -> Label -> [Label]
revPostorderFrom CFG
cfg Label
root =
forall a b. (a -> b) -> [a] -> [b]
map BlockNode C C -> Label
fromNode forall a b. (a -> b) -> a -> b
$ forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> Label -> [block C C]
G.revPostorderFrom LabelMap (BlockNode C C)
hooplGraph Label
root
where
nodes :: [Label]
nodes = CFG -> [Label]
getCfgNodes CFG
cfg
hooplGraph :: LabelMap (BlockNode C C)
hooplGraph = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LabelMap (BlockNode C C)
m Label
n -> forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
n (Label -> BlockNode C C
toNode Label
n) LabelMap (BlockNode C C)
m) forall (map :: * -> *) a. IsMap map => map a
mapEmpty [Label]
nodes
fromNode :: BlockNode C C -> BlockId
fromNode :: BlockNode C C -> Label
fromNode (BN (Label, [Label])
x) = forall a b. (a, b) -> a
fst (Label, [Label])
x
toNode :: BlockId -> BlockNode C C
toNode :: Label -> BlockNode C C
toNode Label
bid =
forall (e :: Extensibility) (x :: Extensibility).
(Label, [Label]) -> BlockNode e x
BN (Label
bid,HasDebugCallStack => CFG -> Label -> [Label]
getSuccessors CFG
cfg forall a b. (a -> b) -> a -> b
$ Label
bid)
{-# NOINLINE mkGlobalWeights #-}
{-# SCC mkGlobalWeights #-}
mkGlobalWeights :: HasDebugCallStack => BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
mkGlobalWeights :: HasDebugCallStack =>
Label -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
mkGlobalWeights Label
root CFG
localCfg
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
localCfg = forall a. String -> a
panic String
"Error - Empty CFG"
| Bool
otherwise
= (LabelMap Double
blockFreqs', LabelMap (LabelMap Double)
edgeFreqs')
where
(Array Int Double
blockFreqs, IntMap (IntMap Double)
edgeFreqs) = IntMap (IntMap Double)
-> [(Int, Int)]
-> [(Int, [Int])]
-> [Int]
-> (Array Int Double, IntMap (IntMap Double))
calcFreqs IntMap (IntMap Double)
nodeProbs [(Int, Int)]
backEdges' [(Int, [Int])]
bodies' [Int]
revOrder'
blockFreqs' :: LabelMap Double
blockFreqs' = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Label
fromVertex) (forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs Array Int Double
blockFreqs) :: LabelMap Double
edgeFreqs' :: LabelMap (LabelMap Double)
edgeFreqs' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall x. IntMap x -> LabelMap x
fromVertexMap forall a b. (a -> b) -> a -> b
$ forall x. IntMap x -> LabelMap x
fromVertexMap IntMap (IntMap Double)
edgeFreqs
fromVertexMap :: IM.IntMap x -> LabelMap x
fromVertexMap :: forall x. IntMap x -> LabelMap x
fromVertexMap IntMap x
m = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Label
fromVertex) forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [(Int, a)]
IM.toList IntMap x
m
revOrder :: [Label]
revOrder = HasDebugCallStack => CFG -> Label -> [Label]
revPostorderFrom CFG
localCfg Label
root :: [BlockId]
loopResults :: LoopInfo
loopResults@(LoopInfo [Edge]
backedges LabelMap Int
_levels [(Edge, LabelSet)]
bodies) = HasDebugCallStack => CFG -> Label -> LoopInfo
loopInfo CFG
localCfg Label
root
revOrder' :: [Int]
revOrder' = forall a b. (a -> b) -> [a] -> [b]
map Label -> Int
toVertex [Label]
revOrder
backEdges' :: [(Int, Int)]
backEdges' = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Label -> Int
toVertex Label -> Int
toVertex) [Edge]
backedges
bodies' :: [(Int, [Int])]
bodies' = forall a b. (a -> b) -> [a] -> [b]
map forall {set} {a}.
(ElemOf set ~ Label, IsSet set) =>
((a, Label), set) -> (Int, [Int])
calcBody [(Edge, LabelSet)]
bodies
estimatedCfg :: CFG
estimatedCfg = Label -> LoopInfo -> CFG -> CFG
staticBranchPrediction Label
root LoopInfo
loopResults CFG
localCfg
nodeProbs :: IntMap (IntMap Double)
nodeProbs = CFG -> (Label -> Int) -> IntMap (IntMap Double)
cfgEdgeProbabilities CFG
estimatedCfg Label -> Int
toVertex
calcBody :: ((a, Label), set) -> (Int, [Int])
calcBody ((a, Label)
backedge, set
blocks) =
(Label -> Int
toVertex forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (a, Label)
backedge, forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Label -> Int
toVertex forall a b. (a -> b) -> a -> b
$ (forall set. IsSet set => set -> [ElemOf set]
setElems set
blocks))
vertexMapping :: LabelMap Int
vertexMapping = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Label]
revOrder [Int
0..] :: LabelMap Int
blockMapping :: Array Int Label
blockMapping = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0,forall (map :: * -> *) a. IsMap map => map a -> Int
mapSize LabelMap Int
vertexMapping forall a. Num a => a -> a -> a
- Int
1) [Label]
revOrder :: Array Int BlockId
toVertex :: BlockId -> Int
toVertex :: Label -> Int
toVertex Label
blockId = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mkGlobalWeights" forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
blockId LabelMap Int
vertexMapping
fromVertex :: Int -> BlockId
fromVertex :: Int -> Label
fromVertex Int
vertex = Array Int Label
blockMapping forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
vertex
type TargetNodeInfo = (BlockId, EdgeInfo)
{-# SCC staticBranchPrediction #-}
staticBranchPrediction :: BlockId -> LoopInfo -> CFG -> CFG
staticBranchPrediction :: Label -> LoopInfo -> CFG -> CFG
staticBranchPrediction Label
_root (LoopInfo [Edge]
l_backEdges LabelMap Int
loopLevels [(Edge, LabelSet)]
l_loops) CFG
cfg =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> Label -> CFG
update CFG
cfg [Label]
nodes
where
nodes :: [Label]
nodes = CFG -> [Label]
getCfgNodes CFG
cfg
backedges :: Set Edge
backedges = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ [Edge]
l_backEdges
loops :: Map Edge LabelSet
loops = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ [(Edge, LabelSet)]
l_loops :: M.Map Edge LabelSet
loopHeads :: Set Label
loopHeads = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map Edge LabelSet
loops
update :: CFG -> BlockId -> CFG
update :: CFG -> Label -> CFG
update CFG
cfg Label
node
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Label, EdgeInfo)]
successors = CFG
cfg
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Label, EdgeInfo)]
m) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
m forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
successors
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TransitionSource -> Bool
isHeapOrStackCheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeInfo -> TransitionSource
transitionSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Label, EdgeInfo)]
successors
= let loopChance :: [EdgeWeight]
loopChance = forall a. a -> [a]
repeat forall a b. (a -> b) -> a -> b
$! EdgeWeight
pred_LBH forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
m)
exitChance :: [EdgeWeight]
exitChance = forall a. a -> [a]
repeat forall a b. (a -> b) -> a -> b
$! (EdgeWeight
1 forall a. Num a => a -> a -> a
- EdgeWeight
pred_LBH) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
not_m)
updates :: [(Label, EdgeWeight)]
updates = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Label, EdgeInfo)]
m) [EdgeWeight]
loopChance forall a. [a] -> [a] -> [a]
++ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Label, EdgeInfo)]
not_m) [EdgeWeight]
exitChance
in
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CFG
cfg (Label
to,EdgeWeight
weight) -> CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg EdgeWeight
weight Label
node Label
to) CFG
cfg [(Label, EdgeWeight)]
updates
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
successors forall a. Eq a => a -> a -> Bool
/= Int
2
= CFG
cfg
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
m forall a. Ord a => a -> a -> Bool
> Int
0
= CFG
cfg
| [(Label
s1,EdgeInfo
s1_info),(Label
s2,EdgeInfo
s2_info)] <- [(Label, EdgeInfo)]
successors
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TransitionSource -> Bool
isHeapOrStackCheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeInfo -> TransitionSource
transitionSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Label, EdgeInfo)]
successors
=
let !w1 :: EdgeWeight
w1 = forall a. Ord a => a -> a -> a
max (EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
s1_info) (EdgeWeight
0)
!w2 :: EdgeWeight
w2 = forall a. Ord a => a -> a -> a
max (EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
s2_info) (EdgeWeight
0)
normalizeWeight :: EdgeWeight -> EdgeWeight
normalizeWeight EdgeWeight
w = if EdgeWeight
w1 forall a. Num a => a -> a -> a
+ EdgeWeight
w2 forall a. Eq a => a -> a -> Bool
== EdgeWeight
0 then EdgeWeight
0.5 else EdgeWeight
wforall a. Fractional a => a -> a -> a
/(EdgeWeight
w1forall a. Num a => a -> a -> a
+EdgeWeight
w2)
!cfg' :: CFG
cfg' = CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg (EdgeWeight -> EdgeWeight
normalizeWeight EdgeWeight
w1) Label
node Label
s1
!cfg'' :: CFG
cfg'' = CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg' (EdgeWeight -> EdgeWeight
normalizeWeight EdgeWeight
w2) Label
node Label
s2
heuristics :: [Maybe Double]
heuristics = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ ((Label
s1,EdgeInfo
s1_info),(Label
s2,EdgeInfo
s2_info)))
[((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
lehPredicts, forall {b} {a}. b -> Maybe a
phPredicts, ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
ohPredicts, forall {b} {a}. b -> Maybe a
ghPredicts, forall {b} {a}. b -> Maybe a
lhhPredicts, forall {b} {a}. b -> Maybe a
chPredicts
, forall {b} {a}. b -> Maybe a
shPredicts, forall {b} {a}. b -> Maybe a
rhPredicts]
applyHeuristic :: CFG -> Maybe Prob -> CFG
applyHeuristic :: CFG -> Maybe Double -> CFG
applyHeuristic CFG
cfg Maybe Double
Nothing = CFG
cfg
applyHeuristic CFG
cfg (Just (Double
s1_pred :: Double))
| EdgeWeight
s1_old forall a. Eq a => a -> a -> Bool
== EdgeWeight
0 Bool -> Bool -> Bool
|| EdgeWeight
s2_old forall a. Eq a => a -> a -> Bool
== EdgeWeight
0 Bool -> Bool -> Bool
||
TransitionSource -> Bool
isHeapOrStackCheck (EdgeInfo -> TransitionSource
transitionSource EdgeInfo
s1_info) Bool -> Bool -> Bool
||
TransitionSource -> Bool
isHeapOrStackCheck (EdgeInfo -> TransitionSource
transitionSource EdgeInfo
s2_info)
= CFG
cfg
| Bool
otherwise =
let
s1_prob :: EdgeWeight
s1_prob = Double -> EdgeWeight
EdgeWeight Double
s1_pred :: EdgeWeight
s2_prob :: EdgeWeight
s2_prob = EdgeWeight
1.0 forall a. Num a => a -> a -> a
- EdgeWeight
s1_prob
d :: EdgeWeight
d = (EdgeWeight
s1_old forall a. Num a => a -> a -> a
* EdgeWeight
s1_prob) forall a. Num a => a -> a -> a
+ (EdgeWeight
s2_old forall a. Num a => a -> a -> a
* EdgeWeight
s2_prob) :: EdgeWeight
s1_prob' :: EdgeWeight
s1_prob' = EdgeWeight
s1_old forall a. Num a => a -> a -> a
* EdgeWeight
s1_prob forall a. Fractional a => a -> a -> a
/ EdgeWeight
d
!s2_prob' :: EdgeWeight
s2_prob' = EdgeWeight
s2_old forall a. Num a => a -> a -> a
* EdgeWeight
s2_prob forall a. Fractional a => a -> a -> a
/ EdgeWeight
d
!cfg_s1 :: CFG
cfg_s1 = CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg EdgeWeight
s1_prob' Label
node Label
s1
in
CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg_s1 EdgeWeight
s2_prob' Label
node Label
s2
where
s1_old :: EdgeWeight
s1_old = CFG -> Label -> Label -> EdgeWeight
getEdgeWeight CFG
cfg Label
node Label
s1
s2_old :: EdgeWeight
s2_old = CFG -> Label -> Label -> EdgeWeight
getEdgeWeight CFG
cfg Label
node Label
s2
in
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> Maybe Double -> CFG
applyHeuristic CFG
cfg'' [Maybe Double]
heuristics
| Bool
otherwise = CFG
cfg
where
pred_LBH :: EdgeWeight
pred_LBH = EdgeWeight
0.875
successors :: [(Label, EdgeInfo)]
successors = HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
cfg Label
node
([(Label, EdgeInfo)]
m,[(Label, EdgeInfo)]
not_m) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Label, EdgeInfo)
succ -> forall a. Ord a => a -> Set a -> Bool
S.member (Label
node, forall a b. (a, b) -> a
fst (Label, EdgeInfo)
succ) Set Edge
backedges) [(Label, EdgeInfo)]
successors
pred_LEH :: Double
pred_LEH = Double
0.75
lehPredicts :: (TargetNodeInfo,TargetNodeInfo) -> Maybe Prob
lehPredicts :: ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
lehPredicts ((Label
s1,EdgeInfo
_s1_info),(Label
s2,EdgeInfo
_s2_info))
| forall a. Ord a => a -> Set a -> Bool
S.member Label
s1 Set Label
loopHeads Bool -> Bool -> Bool
|| forall a. Ord a => a -> Set a -> Bool
S.member Label
s2 Set Label
loopHeads
= forall a. Maybe a
Nothing
| Bool
otherwise
=
case forall a. Ord a => a -> a -> Ordering
compare Maybe Int
s1Level Maybe Int
s2Level of
Ordering
EQ -> forall a. Maybe a
Nothing
Ordering
LT -> forall a. a -> Maybe a
Just (Double
1forall a. Num a => a -> a -> a
-Double
pred_LEH)
Ordering
GT -> forall a. a -> Maybe a
Just (Double
pred_LEH)
where
s1Level :: Maybe Int
s1Level = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
s1 LabelMap Int
loopLevels
s2Level :: Maybe Int
s2Level = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
s2 LabelMap Int
loopLevels
ohPredicts :: ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
ohPredicts ((Label, EdgeInfo)
s1,(Label, EdgeInfo)
_s2)
| CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmNode O C
src1 } <- Label -> Label -> CFG -> TransitionSource
getTransitionSource Label
node (forall a b. (a, b) -> a
fst (Label, EdgeInfo)
s1) CFG
cfg
, CmmCondBranch CmmExpr
cond Label
ltrue Label
_lfalse Maybe Bool
likely <- CmmNode O C
src1
, Maybe Bool
likely forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing
, CmmMachOp MachOp
mop [CmmExpr]
args <- CmmExpr
cond
, MO_Eq {} <- MachOp
mop
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmExpr
x | x :: CmmExpr
x@CmmLit{} <- [CmmExpr]
args])
= if forall a b. (a, b) -> a
fst (Label, EdgeInfo)
s1 forall a. Eq a => a -> a -> Bool
== Label
ltrue then forall a. a -> Maybe a
Just Double
0.3 else forall a. a -> Maybe a
Just Double
0.7
| Bool
otherwise
= forall a. Maybe a
Nothing
phPredicts :: b -> Maybe a
phPredicts = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
ghPredicts :: b -> Maybe a
ghPredicts = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
lhhPredicts :: b -> Maybe a
lhhPredicts = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
chPredicts :: b -> Maybe a
chPredicts = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
shPredicts :: b -> Maybe a
shPredicts = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
rhPredicts :: b -> Maybe a
rhPredicts = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
cfgEdgeProbabilities :: CFG -> (BlockId -> Int) -> IM.IntMap (IM.IntMap Prob)
cfgEdgeProbabilities :: CFG -> (Label -> Int) -> IntMap (IntMap Double)
cfgEdgeProbabilities CFG
cfg Label -> Int
toVertex
= forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey IntMap (IntMap Double)
-> Label -> LabelMap EdgeInfo -> IntMap (IntMap Double)
foldEdges forall a. IntMap a
IM.empty CFG
cfg
where
foldEdges :: IntMap (IntMap Double)
-> Label -> LabelMap EdgeInfo -> IntMap (IntMap Double)
foldEdges = (\IntMap (IntMap Double)
m Label
from LabelMap EdgeInfo
toMap -> forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Label -> Int
toVertex Label
from) (LabelMap EdgeInfo -> IntMap Double
normalize LabelMap EdgeInfo
toMap) IntMap (IntMap Double)
m)
normalize :: (LabelMap EdgeInfo) -> (IM.IntMap Prob)
normalize :: LabelMap EdgeInfo -> IntMap Double
normalize LabelMap EdgeInfo
weightMap
| Int
edgeCount forall a. Ord a => a -> a -> Bool
<= Int
1 = forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey (\IntMap Double
m KeyOf LabelMap
k EdgeInfo
_ -> forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Label -> Int
toVertex KeyOf LabelMap
k) Double
1.0 IntMap Double
m) forall a. IntMap a
IM.empty LabelMap EdgeInfo
weightMap
| Bool
otherwise = forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey (\IntMap Double
m KeyOf LabelMap
k EdgeInfo
_ -> forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Label -> Int
toVertex KeyOf LabelMap
k) (Label -> Double
normalWeight KeyOf LabelMap
k) IntMap Double
m) forall a. IntMap a
IM.empty LabelMap EdgeInfo
weightMap
where
edgeCount :: Int
edgeCount = forall (map :: * -> *) a. IsMap map => map a -> Int
mapSize LabelMap EdgeInfo
weightMap
minWeight :: Double
minWeight = Double
0 :: Prob
weightMap' :: LabelMap Double
weightMap' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\EdgeInfo
w -> forall a. Ord a => a -> a -> a
max (EdgeWeight -> Double
weightToDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeInfo -> EdgeWeight
edgeWeight forall a b. (a -> b) -> a -> b
$ EdgeInfo
w) Double
minWeight) LabelMap EdgeInfo
weightMap
totalWeight :: Double
totalWeight = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum LabelMap Double
weightMap'
normalWeight :: BlockId -> Prob
normalWeight :: Label -> Double
normalWeight Label
bid
| Double
totalWeight forall a. Eq a => a -> a -> Bool
== Double
0
= Double
1.0 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
edgeCount
| Just Double
w <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
bid LabelMap Double
weightMap'
= Double
wforall a. Fractional a => a -> a -> a
/Double
totalWeight
| Bool
otherwise = forall a. String -> a
panic String
"impossible"
calcFreqs :: IM.IntMap (IM.IntMap Prob) -> [(Int,Int)] -> [(Int, [Int])] -> [Int]
-> (Array Int Double, IM.IntMap (IM.IntMap Prob))
calcFreqs :: IntMap (IntMap Double)
-> [(Int, Int)]
-> [(Int, [Int])]
-> [Int]
-> (Array Int Double, IntMap (IntMap Double))
calcFreqs IntMap (IntMap Double)
graph [(Int, Int)]
backEdges [(Int, [Int])]
loops [Int]
revPostOrder = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
STUArray s Int Bool
visitedNodes <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
nodeCountforall a. Num a => a -> a -> a
-Int
1) Bool
False :: ST s (STUArray s Int Bool)
STUArray s Int Double
blockFreqs <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
nodeCountforall a. Num a => a -> a -> a
-Int
1) Double
0.0 :: ST s (STUArray s Int Double)
STRef s (IntMap (IntMap Double))
edgeProbs <- forall a s. a -> ST s (STRef s a)
newSTRef IntMap (IntMap Double)
graph
STRef s (IntMap (IntMap Double))
edgeBackProbs <- forall a s. a -> ST s (STRef s a)
newSTRef IntMap (IntMap Double)
graph
let
{-# INLINE visited #-}
visited :: Int -> ST s Bool
visited Int
b = forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead STUArray s Int Bool
visitedNodes Int
b
getFreq :: Int -> ST s Double
getFreq Int
b = forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead STUArray s Int Double
blockFreqs Int
b
setFreq :: Int -> Double -> ST s ()
setFreq Int
b Double
f = forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite STUArray s Int Double
blockFreqs Int
b Double
f
setVisited :: Int -> ST s ()
setVisited Int
b = forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite STUArray s Int Bool
visitedNodes Int
b Bool
True
getProb' :: STRef s (IntMap (IntMap b)) -> Int -> Int -> ST s b
getProb' STRef s (IntMap (IntMap b))
arr Int
b1 Int
b2 = forall s a. STRef s a -> ST s a
readSTRef STRef s (IntMap (IntMap b))
arr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(\IntMap (IntMap b)
graph ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"getFreq 1") forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b2 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"getFreq 2") forall a b. (a -> b) -> a -> b
$
(forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b1 IntMap (IntMap b)
graph)
)
setProb' :: STRef s (IntMap (IntMap a)) -> Int -> Int -> a -> ST s ()
setProb' STRef s (IntMap (IntMap a))
arr Int
b1 Int
b2 a
prob = do
IntMap (IntMap a)
g <- forall s a. STRef s a -> ST s a
readSTRef STRef s (IntMap (IntMap a))
arr
let !m :: IntMap a
m = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Foo") forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b1 IntMap (IntMap a)
g
!m' :: IntMap a
m' = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
b2 a
prob IntMap a
m
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (IntMap (IntMap a))
arr forall a b. (a -> b) -> a -> b
$! (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
b1 IntMap a
m' IntMap (IntMap a)
g)
getEdgeFreq :: Int -> Int -> ST s Double
getEdgeFreq Int
b1 Int
b2 = forall {s} {b}. STRef s (IntMap (IntMap b)) -> Int -> Int -> ST s b
getProb' STRef s (IntMap (IntMap Double))
edgeProbs Int
b1 Int
b2
setEdgeFreq :: Int -> Int -> Double -> ST s ()
setEdgeFreq Int
b1 Int
b2 = forall {s} {a}.
STRef s (IntMap (IntMap a)) -> Int -> Int -> a -> ST s ()
setProb' STRef s (IntMap (IntMap Double))
edgeProbs Int
b1 Int
b2
getProb :: Int -> Int -> Double
getProb Int
b1 Int
b2 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"getProb") forall a b. (a -> b) -> a -> b
$ do
IntMap Double
m' <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b1 IntMap (IntMap Double)
graph
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b2 IntMap Double
m'
getBackProb :: Int -> Int -> ST s Double
getBackProb Int
b1 Int
b2 = forall {s} {b}. STRef s (IntMap (IntMap b)) -> Int -> Int -> ST s b
getProb' STRef s (IntMap (IntMap Double))
edgeBackProbs Int
b1 Int
b2
setBackProb :: Int -> Int -> Double -> ST s ()
setBackProb Int
b1 Int
b2 = forall {s} {a}.
STRef s (IntMap (IntMap a)) -> Int -> Int -> a -> ST s ()
setProb' STRef s (IntMap (IntMap Double))
edgeBackProbs Int
b1 Int
b2
let
calcOutFreqs :: Int -> Int -> ST s [()]
calcOutFreqs Int
bhead Int
block = do
!Double
f <- Int -> ST s Double
getFreq Int
block
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Int -> [Int]
successors Int
block) forall a b. (a -> b) -> a -> b
$ \Int
bi -> do
let !prob :: Double
prob = Int -> Int -> Double
getProb Int
block Int
bi
let !succFreq :: Double
succFreq = Double
f forall a. Num a => a -> a -> a
* Double
prob
Int -> Int -> Double -> ST s ()
setEdgeFreq Int
block Int
bi Double
succFreq
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
bi forall a. Eq a => a -> a -> Bool
== Int
bhead) forall a b. (a -> b) -> a -> b
$ Int -> Int -> Double -> ST s ()
setBackProb Int
block Int
bi Double
succFreq
let propFreq :: Int -> Int -> ST s [()]
propFreq Int
block Int
head = do
!Bool
v <- Int -> ST s Bool
visited Int
block
if Bool
v then
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else if Int
block forall a. Eq a => a -> a -> Bool
== Int
head then
Int -> Double -> ST s ()
setFreq Int
block Double
1.0
else do
let preds :: [Int]
preds = IntSet -> [Int]
IS.elems forall a b. (a -> b) -> a -> b
$ Int -> IntSet
predecessors Int
block
Bool
irreducible <- (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
or) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
preds forall a b. (a -> b) -> a -> b
$ \Int
bp -> do
!Bool
bp_visited <- Int -> ST s Bool
visited Int
bp
let bp_backedge :: Bool
bp_backedge = Int -> Int -> Bool
isBackEdge Int
bp Int
block
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
bp_visited Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
bp_backedge)
if Bool
irreducible
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
Int -> Double -> ST s ()
setFreq Int
block Double
0
!Double
cycleProb <- forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
preds forall a b. (a -> b) -> a -> b
$ \Int
pred -> do
if Int -> Int -> Bool
isBackEdge Int
pred Int
block
then
Int -> Int -> ST s Double
getBackProb Int
pred Int
block
else do
!Double
f <- Int -> ST s Double
getFreq Int
block
!Double
prob <- Int -> Int -> ST s Double
getEdgeFreq Int
pred Int
block
Int -> Double -> ST s ()
setFreq Int
block forall a b. (a -> b) -> a -> b
$! Double
f forall a. Num a => a -> a -> a
+ Double
prob
forall (m :: * -> *) a. Monad m => a -> m a
return Double
0)
let limit :: Double
limit = Double
1 forall a. Num a => a -> a -> a
- Double
1forall a. Fractional a => a -> a -> a
/Double
512
!Double
cycleProb <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min Double
cycleProb Double
limit
!Double
f <- Int -> ST s Double
getFreq Int
block
Int -> Double -> ST s ()
setFreq Int
block (Double
f forall a. Fractional a => a -> a -> a
/ (Double
1.0 forall a. Num a => a -> a -> a
- Double
cycleProb))
Int -> ST s ()
setVisited Int
block
Int -> Int -> ST s [()]
calcOutFreqs Int
head Int
block
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, [Int])]
loops forall a b. (a -> b) -> a -> b
$ \(Int
head, [Int]
body) -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
nodeCount forall a. Num a => a -> a -> a
- Int
1] (\Int
i -> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite STUArray s Int Bool
visitedNodes Int
i Bool
True)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
body (\Int
i -> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite STUArray s Int Bool
visitedNodes Int
i Bool
False)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
body forall a b. (a -> b) -> a -> b
$ \Int
block -> Int -> Int -> ST s [()]
propFreq Int
block Int
head
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
nodeCount forall a. Num a => a -> a -> a
- Int
1] (\Int
i -> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite STUArray s Int Bool
visitedNodes Int
i Bool
False)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
revPostOrder forall a b. (a -> b) -> a -> b
$ \Int
block -> Int -> Int -> ST s [()]
propFreq Int
block (forall a. [a] -> a
head [Int]
revPostOrder)
IntMap (IntMap Double)
graph' <- forall s a. STRef s a -> ST s a
readSTRef STRef s (IntMap (IntMap Double))
edgeProbs
Array Int Double
freqs' <- forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze STUArray s Int Double
blockFreqs
forall (m :: * -> *) a. Monad m => a -> m a
return (Array Int Double
freqs', IntMap (IntMap Double)
graph')
where
predecessors :: Int -> IS.IntSet
predecessors :: Int -> IntSet
predecessors Int
b = forall a. a -> Maybe a -> a
fromMaybe IntSet
IS.empty forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b IntMap IntSet
revGraph
successors :: Int -> [Int]
successors :: Int -> [Int]
successors Int
b = forall a. a -> Maybe a -> a
fromMaybe (forall {a} {a}.
Outputable a =>
String -> a -> IntMap (IntMap Double) -> a
lookupError String
"succ" Int
b IntMap (IntMap Double)
graph)forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [Int]
IM.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b IntMap (IntMap Double)
graph
lookupError :: String -> a -> IntMap (IntMap Double) -> a
lookupError String
s a
b IntMap (IntMap Double)
g = forall a. HasCallStack => String -> SDoc -> a
pprPanic (String
"Lookup error " forall a. [a] -> [a] -> [a]
++ String
s) forall a b. (a -> b) -> a -> b
$
( String -> SDoc
text String
"node" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr a
b SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"graph" SDoc -> SDoc -> SDoc
<+>
[SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (\(Int
k,IntMap Double
m) -> forall a. Outputable a => a -> SDoc
ppr (Int
k,IntMap Double
m :: IM.IntMap Double)) forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (IntMap Double)
g)
)
nodeCount :: Int
nodeCount = forall a b. (a -> b -> a) -> a -> IntMap b -> a
IM.foldl' (\Int
count IntMap Double
toMap -> forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' Int -> Int -> Double -> Int
countTargets Int
count IntMap Double
toMap) (forall a. IntMap a -> Int
IM.size IntMap (IntMap Double)
graph) IntMap (IntMap Double)
graph
where
countTargets :: Int -> Int -> Double -> Int
countTargets = (\Int
count Int
k Double
_ -> Int -> Int
countNode Int
k forall a. Num a => a -> a -> a
+ Int
count )
countNode :: Int -> Int
countNode Int
n = if forall a. Int -> IntMap a -> Bool
IM.member Int
n IntMap (IntMap Double)
graph then Int
0 else Int
1
isBackEdge :: Int -> Int -> Bool
isBackEdge Int
from Int
to = forall a. Ord a => a -> Set a -> Bool
S.member (Int
from,Int
to) Set (Int, Int)
backEdgeSet
backEdgeSet :: Set (Int, Int)
backEdgeSet = forall a. Ord a => [a] -> Set a
S.fromList [(Int, Int)]
backEdges
revGraph :: IntMap IntSet
revGraph :: IntMap IntSet
revGraph = forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' (\IntMap IntSet
m Int
from IntMap Double
toMap -> forall {b}. IntMap IntSet -> Int -> IntMap b -> IntMap IntSet
addEdges IntMap IntSet
m Int
from IntMap Double
toMap) forall a. IntMap a
IM.empty IntMap (IntMap Double)
graph
where
addEdges :: IntMap IntSet -> Int -> IntMap b -> IntMap IntSet
addEdges IntMap IntSet
m0 Int
from IntMap b
toMap = forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' (\IntMap IntSet
m Int
k b
_ -> IntMap IntSet -> Int -> Int -> IntMap IntSet
addEdge IntMap IntSet
m Int
from Int
k) IntMap IntSet
m0 IntMap b
toMap
addEdge :: IntMap IntSet -> Int -> Int -> IntMap IntSet
addEdge IntMap IntSet
m0 Int
from Int
to = forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
IS.union Int
to (Int -> IntSet
IS.singleton Int
from) IntMap IntSet
m0