{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE TupleSections              #-}
--
-- Copyright (c) 2018 Andreas Klebinger
--

module GHC.CmmToAsm.CFG
    ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)
    , TransitionSource(..)

    --Modify the CFG
    , addWeightEdge, addEdge
    , delEdge
    , addNodesBetween, shortcutWeightMap
    , reverseEdges, filterEdges
    , addImmediateSuccessor
    , mkWeightInfo, adjustEdgeWeight, setEdgeWeight

    --Query the CFG
    , infoEdgeList, edgeList
    , getSuccessorEdges, getSuccessors
    , getSuccEdgesSorted
    , getEdgeInfo
    , getCfgNodes, hasNode

    -- Loop Information
    , loopMembers, loopLevels, loopInfo

    --Construction/Misc
    , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg

    --Find backedges and update their weight
    , optimizeCFG
    , mkGlobalWeights

     )
where

import GHC.Prelude
import GHC.Platform

import GHC.Cmm.BlockId
import GHC.Cmm as Cmm

import GHC.Cmm.Switch
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 GHC.Data.Word64Map.Strict (Word64Map)
import GHC.Data.Word64Set (Word64Set)
import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet)

import qualified Data.IntMap.Strict as IM
import qualified GHC.Data.Word64Map.Strict as WM
import qualified Data.Map as M
import qualified Data.IntSet as IS
import qualified GHC.Data.Word64Set as WS
import qualified Data.Set as S
import Data.Tree
import Data.Bifunctor

import GHC.Utils.Outputable
import GHC.Utils.Panic
-- DEBUGGING ONLY
--import GHC.Cmm.DebugBlock
--import GHC.Data.OrdList
--import GHC.Cmm.DebugBlock.Trace

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
import Data.Word

type Prob = Double

type Edge = (BlockId, BlockId)
type Edges = [Edge]

newtype EdgeWeight
  = EdgeWeight { EdgeWeight -> Double
weightToDouble :: Double }
  deriving (EdgeWeight -> EdgeWeight -> Bool
(EdgeWeight -> EdgeWeight -> Bool)
-> (EdgeWeight -> EdgeWeight -> Bool) -> Eq EdgeWeight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeWeight -> EdgeWeight -> Bool
== :: EdgeWeight -> EdgeWeight -> Bool
$c/= :: EdgeWeight -> EdgeWeight -> Bool
/= :: EdgeWeight -> EdgeWeight -> Bool
Eq,Eq EdgeWeight
Eq EdgeWeight =>
(EdgeWeight -> EdgeWeight -> Ordering)
-> (EdgeWeight -> EdgeWeight -> Bool)
-> (EdgeWeight -> EdgeWeight -> Bool)
-> (EdgeWeight -> EdgeWeight -> Bool)
-> (EdgeWeight -> EdgeWeight -> Bool)
-> (EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight -> EdgeWeight)
-> Ord 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
$ccompare :: EdgeWeight -> EdgeWeight -> Ordering
compare :: EdgeWeight -> EdgeWeight -> Ordering
$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
>= :: EdgeWeight -> EdgeWeight -> Bool
$cmax :: EdgeWeight -> EdgeWeight -> EdgeWeight
max :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cmin :: EdgeWeight -> EdgeWeight -> EdgeWeight
min :: EdgeWeight -> EdgeWeight -> EdgeWeight
Ord,Int -> EdgeWeight
EdgeWeight -> Int
EdgeWeight -> [EdgeWeight]
EdgeWeight -> EdgeWeight
EdgeWeight -> EdgeWeight -> [EdgeWeight]
EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight]
(EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight)
-> (Int -> EdgeWeight)
-> (EdgeWeight -> Int)
-> (EdgeWeight -> [EdgeWeight])
-> (EdgeWeight -> EdgeWeight -> [EdgeWeight])
-> (EdgeWeight -> EdgeWeight -> [EdgeWeight])
-> (EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight])
-> Enum 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
$csucc :: EdgeWeight -> EdgeWeight
succ :: EdgeWeight -> EdgeWeight
$cpred :: EdgeWeight -> EdgeWeight
pred :: EdgeWeight -> EdgeWeight
$ctoEnum :: Int -> EdgeWeight
toEnum :: Int -> EdgeWeight
$cfromEnum :: EdgeWeight -> Int
fromEnum :: EdgeWeight -> Int
$cenumFrom :: EdgeWeight -> [EdgeWeight]
enumFrom :: EdgeWeight -> [EdgeWeight]
$cenumFromThen :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFromThen :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
$cenumFromTo :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFromTo :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
$cenumFromThenTo :: EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFromThenTo :: EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight]
Enum,Integer -> EdgeWeight
EdgeWeight -> EdgeWeight
EdgeWeight -> EdgeWeight -> EdgeWeight
(EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight)
-> (Integer -> EdgeWeight)
-> Num EdgeWeight
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: EdgeWeight -> EdgeWeight -> EdgeWeight
+ :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c- :: EdgeWeight -> EdgeWeight -> EdgeWeight
- :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c* :: EdgeWeight -> EdgeWeight -> EdgeWeight
* :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cnegate :: EdgeWeight -> EdgeWeight
negate :: EdgeWeight -> EdgeWeight
$cabs :: EdgeWeight -> EdgeWeight
abs :: EdgeWeight -> EdgeWeight
$csignum :: EdgeWeight -> EdgeWeight
signum :: EdgeWeight -> EdgeWeight
$cfromInteger :: Integer -> EdgeWeight
fromInteger :: Integer -> EdgeWeight
Num,Num EdgeWeight
Ord EdgeWeight
(Num EdgeWeight, Ord EdgeWeight) =>
(EdgeWeight -> Rational) -> Real EdgeWeight
EdgeWeight -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: EdgeWeight -> Rational
toRational :: EdgeWeight -> Rational
Real,Num EdgeWeight
Num EdgeWeight =>
(EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight)
-> (Rational -> EdgeWeight)
-> Fractional EdgeWeight
Rational -> EdgeWeight
EdgeWeight -> EdgeWeight
EdgeWeight -> EdgeWeight -> EdgeWeight
forall a.
Num a =>
(a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
$c/ :: EdgeWeight -> EdgeWeight -> EdgeWeight
/ :: EdgeWeight -> EdgeWeight -> EdgeWeight
$crecip :: EdgeWeight -> EdgeWeight
recip :: EdgeWeight -> EdgeWeight
$cfromRational :: Rational -> EdgeWeight
fromRational :: Rational -> 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)

-- | A control flow graph where edges have been annotated with a weight.
-- Implemented as IntMap (IntMap \<edgeData>)
-- We must uphold the invariant that for each edge A -> B we must have:
-- A entry B in the outer map.
-- A entry B in the map we get when looking up A.
-- Maintaining this invariant is useful as any failed lookup now indicates
-- an actual error in code which might go unnoticed for a while
-- otherwise.
type CFG = EdgeInfoMap EdgeInfo

data CfgEdge
  = CfgEdge
  { CfgEdge -> Label
edgeFrom :: !BlockId
  , CfgEdge -> Label
edgeTo :: !BlockId
  , CfgEdge -> EdgeInfo
edgeInfo :: !EdgeInfo
  }

-- | Careful! Since we assume there is at most one edge from A to B
--   the Eq instance does not consider weight.
instance Eq CfgEdge where
  == :: CfgEdge -> CfgEdge -> Bool
(==) (CfgEdge Label
from1 Label
to1 EdgeInfo
_) (CfgEdge Label
from2 Label
to2 EdgeInfo
_)
    = Label
from1 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
from2 Bool -> Bool -> Bool
&& Label
to1 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
to2

-- | Edges are sorted ascending pointwise by weight, source and destination
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 EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
< EdgeWeight
weight2 Bool -> Bool -> Bool
|| EdgeWeight
weight1 EdgeWeight -> EdgeWeight -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeWeight
weight2 Bool -> Bool -> Bool
&& Label
from1 Label -> Label -> Bool
forall a. Ord a => a -> a -> Bool
< Label
from2 Bool -> Bool -> Bool
||
      EdgeWeight
weight1 EdgeWeight -> EdgeWeight -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeWeight
weight2 Bool -> Bool -> Bool
&& Label
from1 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
from2 Bool -> Bool -> Bool
&& Label
to1 Label -> Label -> Bool
forall a. Ord a => a -> a -> Bool
< Label
to2
    = Ordering
LT
    | Label
from1 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
from2 Bool -> Bool -> Bool
&& Label
to1 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
to2 Bool -> Bool -> Bool
&& EdgeWeight
weight1 EdgeWeight -> EdgeWeight -> Bool
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
forall doc. IsLine doc => doc -> doc
parens (Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
from1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> EdgeInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr EdgeInfo
edgeInfo SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
")->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
to1)

-- | Can we trace back a edge to a specific Cmm Node
-- or has it been introduced during assembly codegen. We use this to maintain
-- some information which would otherwise be lost during the
-- Cmm \<-> asm transition.
-- See also Note [Inverting conditions]
data TransitionSource
  = CmmSource { TransitionSource -> CmmNode O C
trans_cmmNode :: (CmmNode O C)
              , TransitionSource -> BranchInfo
trans_info :: BranchInfo }
  | AsmCodeGen
  deriving (TransitionSource -> TransitionSource -> Bool
(TransitionSource -> TransitionSource -> Bool)
-> (TransitionSource -> TransitionSource -> Bool)
-> Eq TransitionSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransitionSource -> TransitionSource -> Bool
== :: TransitionSource -> TransitionSource -> Bool
$c/= :: TransitionSource -> TransitionSource -> Bool
/= :: TransitionSource -> TransitionSource -> Bool
Eq)

data BranchInfo = NoInfo         -- ^ Unknown, but not heap or stack check.
                | HeapStackCheck -- ^ Heap or stack check
    deriving BranchInfo -> BranchInfo -> Bool
(BranchInfo -> BranchInfo -> Bool)
-> (BranchInfo -> BranchInfo -> Bool) -> Eq BranchInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BranchInfo -> BranchInfo -> Bool
== :: BranchInfo -> BranchInfo -> Bool
$c/= :: BranchInfo -> BranchInfo -> Bool
/= :: BranchInfo -> BranchInfo -> Bool
Eq

instance Outputable BranchInfo where
    ppr :: BranchInfo -> SDoc
ppr BranchInfo
NoInfo = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"regular"
    ppr BranchInfo
HeapStackCheck = String -> SDoc
forall doc. IsLine doc => String -> doc
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

-- | Information about edges
data EdgeInfo
  = EdgeInfo
  { EdgeInfo -> TransitionSource
transitionSource :: !TransitionSource
  , EdgeInfo -> EdgeWeight
edgeWeight :: !EdgeWeight
  } deriving (EdgeInfo -> EdgeInfo -> Bool
(EdgeInfo -> EdgeInfo -> Bool)
-> (EdgeInfo -> EdgeInfo -> Bool) -> Eq EdgeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeInfo -> EdgeInfo -> Bool
== :: EdgeInfo -> EdgeInfo -> Bool
$c/= :: EdgeInfo -> EdgeInfo -> Bool
/= :: EdgeInfo -> EdgeInfo -> Bool
Eq)

instance Outputable EdgeInfo where
  ppr :: EdgeInfo -> SDoc
ppr EdgeInfo
edgeInfo = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"weight:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> EdgeWeight -> SDoc
forall a. Outputable a => a -> SDoc
ppr (EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo)

-- | Convenience function, generate edge info based
--   on weight not originating from cmm.
mkWeightInfo :: EdgeWeight -> EdgeInfo
mkWeightInfo :: EdgeWeight -> EdgeInfo
mkWeightInfo = TransitionSource -> EdgeWeight -> EdgeInfo
EdgeInfo TransitionSource
AsmCodeGen

-- | Adjust the weight between the blocks using the given function.
--   If there is no such edge returns the original map.
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 = newWeight}) CFG
cfg
  | Bool
otherwise = CFG
cfg

-- | Set the weight between the blocks to the given weight.
--   If there is no such edge returns the original map.
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 = weight}) CFG
cfg
  | Bool
otherwise = CFG
cfg


getCfgNodes :: CFG -> [BlockId]
getCfgNodes :: CFG -> [Label]
getCfgNodes CFG
m =
    CFG -> [Label]
forall a. LabelMap a -> [Label]
mapKeys CFG
m

-- | Is this block part of this graph?
hasNode :: CFG -> BlockId -> Bool
hasNode :: CFG -> Label -> Bool
hasNode CFG
m Label
node =
  -- Check the invariant that each node must exist in the first map or not at all.
  Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool
found Bool -> Bool -> Bool
|| Bool -> Bool
not ((LabelMap EdgeInfo -> Bool) -> CFG -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Label -> LabelMap EdgeInfo -> Bool
forall a. Label -> LabelMap a -> Bool
mapMember Label
node) CFG
m))
  Bool
found
    where
      found :: Bool
found = Label -> CFG -> Bool
forall a. Label -> LabelMap a -> Bool
mapMember Label
node CFG
m



-- | Check if the nodes in the cfg and the set of blocks are the same.
--   In a case of a mismatch we panic and show the difference.
sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg CFG
m LabelSet
blockSet SDoc
msg
    | LabelSet
blockSet LabelSet -> LabelSet -> Bool
forall a. Eq a => a -> a -> Bool
== LabelSet
cfgNodes
    = Bool
True
    | Bool
otherwise =
        String -> SDoc -> Bool -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Block list and cfg nodes don't match" (
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"difference:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> LabelSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelSet
diff SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"blocks:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> LabelSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelSet
blockSet SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cfg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CFG -> SDoc
pprEdgeWeights CFG
m SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            SDoc
msg )
            Bool
False
    where
      cfgNodes :: LabelSet
cfgNodes = [Label] -> LabelSet
setFromList ([Label] -> LabelSet) -> [Label] -> LabelSet
forall a b. (a -> b) -> a -> b
$ CFG -> [Label]
getCfgNodes CFG
m :: LabelSet
      diff :: LabelSet
diff = (LabelSet -> LabelSet -> LabelSet
setUnion LabelSet
cfgNodes LabelSet
blockSet) LabelSet -> LabelSet -> LabelSet
`setDifference` (LabelSet -> LabelSet -> LabelSet
setIntersection LabelSet
cfgNodes LabelSet
blockSet) :: LabelSet

-- | Filter the CFG with a custom function f.
--   Parameters are `f from to edgeInfo`
filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges :: (Label -> Label -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges Label -> Label -> EdgeInfo -> Bool
f CFG
cfg =
    (Label -> LabelMap EdgeInfo -> LabelMap EdgeInfo) -> CFG -> CFG
forall a v. (Label -> a -> v) -> LabelMap a -> LabelMap v
mapMapWithKey Label -> LabelMap EdgeInfo -> LabelMap EdgeInfo
filterSources CFG
cfg
    where
      filterSources :: Label -> LabelMap EdgeInfo -> LabelMap EdgeInfo
filterSources Label
from LabelMap EdgeInfo
m =
        (Label -> EdgeInfo -> Bool)
-> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall v. (Label -> v -> Bool) -> LabelMap v -> LabelMap v
mapFilterWithKey (\Label
to EdgeInfo
w -> Label -> Label -> EdgeInfo -> Bool
f Label
from Label
to EdgeInfo
w) LabelMap EdgeInfo
m


{- Note [Updating the CFG during shortcutting]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Note [What is shortcutting] in the control flow optimization
code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting.

In the native backend we shortcut jumps at the assembly level. ("GHC.CmmToAsm")
This means we remove blocks containing only one jump from the code
and instead redirecting all jumps targeting this block to the deleted
blocks jump target.

However we want to have an accurate representation of control
flow in the CFG. So we add/remove edges accordingly to account
for the eliminated blocks and new edges.

If we shortcut A -> B -> C to A -> C:
* We delete edges A -> B and B -> C
* Replacing them with the edge A -> C

We also try to preserve jump weights while doing so.

Note that:
* The edge B -> C can't have interesting weights since
  the block B consists of a single unconditional jump without branching.
* We delete the edge A -> B and add the edge A -> C.
* The edge A -> B can be one of many edges originating from A so likely
  has edge weights we want to preserve.

For this reason we simply store the edge info from the original A -> B
edge and apply this information to the new edge A -> C.

Sometimes we have a scenario where jump target C is not represented by an
BlockId but an immediate value. I'm only aware of this happening without
tables next to code currently.

Then we go from A ---> B - -> IMM   to   A - -> IMM where the dashed arrows
are not stored in the CFG.

In that case we simply delete the edge A -> B.

In terms of implementation the native backend first builds a mapping
from blocks suitable for shortcutting to their jump targets.
Then it redirects all jump instructions to these blocks using the
built up mapping.
This function (shortcutWeightMap) takes the same mapping and
applies the mapping to the CFG in the way laid out above.

-}
shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG
shortcutWeightMap :: LabelMap (Maybe Label) -> CFG -> CFG
shortcutWeightMap LabelMap (Maybe Label)
cuts CFG
cfg
  | LabelMap (Maybe Label) -> Bool
forall a. LabelMap a -> Bool
mapNull LabelMap (Maybe Label)
cuts = CFG
cfg
  | Bool
otherwise = CFG
normalised_cfg
    where
      -- First take the cuts map and collapse any shortcuts, for example
      -- if the cuts map has A -> B and B -> C then we want to rewrite
      -- A -> C and B -> C directly.
      normalised_cuts_st :: forall s . ST s (LabelMap (Maybe BlockId))
      normalised_cuts_st :: forall s. ST s (LabelMap (Maybe Label))
normalised_cuts_st = do
        (null :: Point s (Maybe BlockId)) <- Maybe Label -> ST s (Point s (Maybe Label))
forall a s. a -> ST s (Point s a)
fresh Maybe Label
forall a. Maybe a
Nothing
        let cuts_list = LabelMap (Maybe Label) -> [(Label, Maybe Label)]
forall b. LabelMap b -> [(Label, b)]
mapToList LabelMap (Maybe Label)
cuts
        -- Create a unification variable for each of the nodes in a rewrite
        cuts_vars <- traverse (\Label
p -> (Label
p,) (Point s (Maybe Label) -> (Label, Point s (Maybe Label)))
-> ST s (Point s (Maybe Label))
-> ST s (Label, Point s (Maybe Label))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Label -> ST s (Point s (Maybe Label))
forall a s. a -> ST s (Point s a)
fresh (Label -> Maybe Label
forall a. a -> Maybe a
Just Label
p)) (concatMap (\(Label
a, Maybe Label
b) -> [Label
a] [Label] -> [Label] -> [Label]
forall a. [a] -> [a] -> [a]
++ [Label] -> (Label -> [Label]) -> Maybe Label -> [Label]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
:[]) Maybe Label
b) cuts_list)
        let cuts_map = [(Label, Point s (Maybe Label))]
-> LabelMap (Point s (Maybe Label))
forall v. [(Label, v)] -> LabelMap v
mapFromList [(Label, Point s (Maybe Label))]
cuts_vars :: LabelMap (Point s (Maybe BlockId))
        -- Then unify according to the rewrites in the cuts map
        mapM_ (\(Label
from, Maybe Label
to) -> String -> Maybe (Point s (Maybe Label)) -> Point s (Maybe Label)
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"shortcutWeightMap" (Label
-> LabelMap (Point s (Maybe Label))
-> Maybe (Point s (Maybe Label))
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
from LabelMap (Point s (Maybe Label))
cuts_map)
                              Point s (Maybe Label) -> Point s (Maybe Label) -> ST s ()
forall s a. Point s a -> Point s a -> ST s ()
`union` String -> Maybe (Point s (Maybe Label)) -> Point s (Maybe Label)
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"shortcutWeightMap" (Maybe (Point s (Maybe Label))
-> (Label -> Maybe (Point s (Maybe Label)))
-> Maybe Label
-> Maybe (Point s (Maybe Label))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Point s (Maybe Label) -> Maybe (Point s (Maybe Label))
forall a. a -> Maybe a
Just Point s (Maybe Label)
null) ((Label
 -> LabelMap (Point s (Maybe Label))
 -> Maybe (Point s (Maybe Label)))
-> LabelMap (Point s (Maybe Label))
-> Label
-> Maybe (Point s (Maybe Label))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Label
-> LabelMap (Point s (Maybe Label))
-> Maybe (Point s (Maybe Label))
forall a. Label -> LabelMap a -> Maybe a
mapLookup LabelMap (Point s (Maybe Label))
cuts_map) Maybe Label
to) ) cuts_list
        -- Then recover the unique representative, which is the result of following
        -- the chain to the end.
        mapM find cuts_map

      normalised_cuts :: LabelMap (Maybe Label)
normalised_cuts = (forall s. ST s (LabelMap (Maybe Label))) -> LabelMap (Maybe Label)
forall a. (forall s. ST s a) -> a
runST ST s (LabelMap (Maybe Label))
forall s. ST s (LabelMap (Maybe Label))
normalised_cuts_st

      cuts_domain :: LabelSet
      cuts_domain :: LabelSet
cuts_domain = [Label] -> LabelSet
setFromList ([Label] -> LabelSet) -> [Label] -> LabelSet
forall a b. (a -> b) -> a -> b
$ LabelMap (Maybe Label) -> [Label]
forall a. LabelMap a -> [Label]
mapKeys LabelMap (Maybe Label)
cuts

      -- The CFG is shortcutted using the normalised cuts map
      normalised_cfg :: CFG
      normalised_cfg :: CFG
normalised_cfg = (CFG -> Label -> LabelMap EdgeInfo -> CFG) -> CFG -> CFG -> CFG
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey CFG -> Label -> LabelMap EdgeInfo -> CFG
update_edge CFG
forall v. LabelMap v
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
        -- If the from edge is in the cuts map then delete the edge
        | Label -> LabelSet -> Bool
setMember Label
from LabelSet
cuts_domain = CFG
new_map
        -- Otherwise we are keeping the edge, but might have shortcutted some of
        -- the target nodes.
        | Bool
otherwise = Label -> LabelMap EdgeInfo -> CFG -> CFG
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
from ((LabelMap EdgeInfo -> Label -> EdgeInfo -> LabelMap EdgeInfo)
-> LabelMap EdgeInfo -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey LabelMap EdgeInfo -> Label -> EdgeInfo -> LabelMap EdgeInfo
forall a. LabelMap a -> Label -> a -> LabelMap a
update_from_edge LabelMap EdgeInfo
forall v. LabelMap v
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
        -- Edge is in the normalised cuts
        | Just Maybe Label
new_edge <- Label -> LabelMap (Maybe Label) -> Maybe (Maybe Label)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
to_edge LabelMap (Maybe Label)
normalised_cuts =
            case Maybe Label
new_edge of
              -- The result was Nothing, so edge is deleted
              Maybe Label
Nothing -> LabelMap a
new_map
              -- The new target for the edge, write it with the old edge_info.
              Just Label
new_to -> Label -> a -> LabelMap a -> LabelMap a
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
new_to a
edge_info LabelMap a
new_map
        -- Node wasn't in the cuts map, so just add it back
        | Bool
otherwise = Label -> a -> LabelMap a -> LabelMap a
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
to_edge a
edge_info LabelMap a
new_map


-- | Sometimes we insert a block which should unconditionally be executed
--   after a given block. This function updates the CFG for these cases.
--  So we get A -> B    => A -> A' -> B
--             \                  \
--              -> C    =>         -> C
--
addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor :: Weights -> Label -> Label -> CFG -> CFG
addImmediateSuccessor Weights
weights Label
node Label
follower CFG
cfg
    = CFG -> CFG
updateEdges (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
node Label
follower EdgeWeight
weight (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ CFG
cfg
    where
        weight :: EdgeWeight
weight = Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Weights -> Int
uncondWeight Weights
weights)
        targets :: [(Label, EdgeInfo)]
targets = HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
cfg Label
node
        successors :: [Label]
successors = ((Label, EdgeInfo) -> Label) -> [(Label, EdgeInfo)] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (Label, EdgeInfo) -> Label
forall a b. (a, b) -> a
fst [(Label, EdgeInfo)]
targets :: [BlockId]
        updateEdges :: CFG -> CFG
updateEdges = CFG -> CFG
addNewSuccs (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> CFG
remOldSuccs
        remOldSuccs :: CFG -> CFG
remOldSuccs CFG
m = (CFG -> Label -> CFG) -> CFG -> [Label] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Label -> CFG -> CFG) -> CFG -> Label -> CFG
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 =
          (CFG -> (Label, EdgeInfo) -> CFG)
-> CFG -> [(Label, EdgeInfo)] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
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

-- | Adds a new edge, overwrites existing edges if present
addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge :: Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
from Label
to EdgeInfo
info CFG
cfg =
    (Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo))
-> Label -> CFG -> CFG
forall v. (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v
mapAlter Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
addFromToEdge Label
from (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$
    (Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo))
-> Label -> CFG -> CFG
forall v. (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v
mapAlter Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
forall {v}. Maybe (LabelMap v) -> Maybe (LabelMap v)
addDestNode Label
to CFG
cfg
    where
        -- Simply insert the edge into the edge list.
        addFromToEdge :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
addFromToEdge Maybe (LabelMap EdgeInfo)
Nothing = LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo)
forall a. a -> Maybe a
Just (LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo))
-> LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo)
forall a b. (a -> b) -> a -> b
$ Label -> EdgeInfo -> LabelMap EdgeInfo
forall v. Label -> v -> LabelMap v
mapSingleton Label
to EdgeInfo
info
        addFromToEdge (Just LabelMap EdgeInfo
wm) = LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo)
forall a. a -> Maybe a
Just (LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo))
-> LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo)
forall a b. (a -> b) -> a -> b
$ Label -> EdgeInfo -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
to EdgeInfo
info LabelMap EdgeInfo
wm
        -- We must add the destination node explicitly
        addDestNode :: Maybe (LabelMap v) -> Maybe (LabelMap v)
addDestNode Maybe (LabelMap v)
Nothing = LabelMap v -> Maybe (LabelMap v)
forall a. a -> Maybe a
Just (LabelMap v -> Maybe (LabelMap v))
-> LabelMap v -> Maybe (LabelMap v)
forall a b. (a -> b) -> a -> b
$ LabelMap v
forall v. LabelMap v
mapEmpty
        addDestNode n :: Maybe (LabelMap v)
n@(Just LabelMap v
_) = Maybe (LabelMap v)
n


-- | Adds a edge with the given weight to the cfg
--   If there already existed an edge it is overwritten.
--   `addWeightEdge from to weight cfg`
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 =
    (LabelMap EdgeInfo -> LabelMap EdgeInfo) -> Label -> CFG -> CFG
forall v. (v -> v) -> Label -> LabelMap v -> LabelMap v
mapAdjust (Label -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall v. Label -> LabelMap v -> LabelMap v
mapDelete Label
to) Label
from CFG
m


-- | Destinations from bid ordered by weight (descending)
getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
getSuccEdgesSorted :: CFG -> Label -> [(Label, EdgeInfo)]
getSuccEdgesSorted CFG
m Label
bid =
    let destMap :: LabelMap EdgeInfo
destMap = LabelMap EdgeInfo -> Label -> CFG -> LabelMap EdgeInfo
forall a. a -> Label -> LabelMap a -> a
mapFindWithDefault LabelMap EdgeInfo
forall v. LabelMap v
mapEmpty Label
bid CFG
m
        cfgEdges :: [(Label, EdgeInfo)]
cfgEdges = LabelMap EdgeInfo -> [(Label, EdgeInfo)]
forall b. LabelMap b -> [(Label, b)]
mapToList LabelMap EdgeInfo
destMap
        sortedEdges :: [(Label, EdgeInfo)]
sortedEdges = ((Label, EdgeInfo) -> EdgeWeight)
-> [(Label, EdgeInfo)] -> [(Label, EdgeInfo)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (EdgeWeight -> EdgeWeight
forall a. Num a => a -> a
negate (EdgeWeight -> EdgeWeight)
-> ((Label, EdgeInfo) -> EdgeWeight)
-> (Label, EdgeInfo)
-> EdgeWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeInfo -> EdgeWeight
edgeWeight (EdgeInfo -> EdgeWeight)
-> ((Label, EdgeInfo) -> EdgeInfo)
-> (Label, EdgeInfo)
-> EdgeWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label, EdgeInfo) -> EdgeInfo
forall a b. (a, b) -> b
snd) [(Label, EdgeInfo)]
cfgEdges
    in  --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m)
        [(Label, EdgeInfo)]
sortedEdges

-- | Get successors of a given node with edge weights.
getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)]
getSuccessorEdges :: HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
m Label
bid = [(Label, EdgeInfo)]
-> (LabelMap EdgeInfo -> [(Label, EdgeInfo)])
-> Maybe (LabelMap EdgeInfo)
-> [(Label, EdgeInfo)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(Label, EdgeInfo)]
lookupError LabelMap EdgeInfo -> [(Label, EdgeInfo)]
forall b. LabelMap b -> [(Label, b)]
mapToList (Label -> CFG -> Maybe (LabelMap EdgeInfo)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
bid CFG
m)
  where
    lookupError :: [(Label, EdgeInfo)]
lookupError = String -> SDoc -> [(Label, EdgeInfo)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSuccessorEdges: Block does not exist" (SDoc -> [(Label, EdgeInfo)]) -> SDoc -> [(Label, EdgeInfo)]
forall a b. (a -> b) -> a -> b
$
                    Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
bid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 <- Label -> CFG -> Maybe (LabelMap EdgeInfo)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
from CFG
m
    , Just EdgeInfo
info <- Label -> LabelMap EdgeInfo -> Maybe EdgeInfo
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
to LabelMap EdgeInfo
wm
    = EdgeInfo -> Maybe EdgeInfo
forall a. a -> Maybe a
Just (EdgeInfo -> Maybe EdgeInfo) -> EdgeInfo -> Maybe EdgeInfo
forall a b. (a -> b) -> a -> b
$! EdgeInfo
info
    | Bool
otherwise
    = Maybe EdgeInfo
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 (EdgeInfo -> EdgeWeight) -> EdgeInfo -> EdgeWeight
forall a b. (a -> b) -> a -> b
$ String -> Maybe EdgeInfo -> EdgeInfo
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"Edgeweight for nonexisting block" (Maybe EdgeInfo -> EdgeInfo) -> Maybe EdgeInfo -> EdgeInfo
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 (EdgeInfo -> TransitionSource) -> EdgeInfo -> TransitionSource
forall a b. (a -> b) -> a -> b
$ String -> Maybe EdgeInfo -> EdgeInfo
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"Source info for nonexisting block" (Maybe EdgeInfo -> EdgeInfo) -> Maybe EdgeInfo -> EdgeInfo
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 = (CFG -> Label -> LabelMap EdgeInfo -> CFG) -> CFG -> CFG -> CFG
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey (\CFG
cfg Label
from LabelMap EdgeInfo
toMap -> CFG -> Label -> LabelMap EdgeInfo -> CFG
go (CFG -> Label -> CFG
addNode CFG
cfg Label
from) Label
from LabelMap EdgeInfo
toMap) CFG
forall v. LabelMap v
mapEmpty CFG
cfg
  where
    -- We must preserve nodes without outgoing edges!
    addNode :: CFG -> BlockId -> CFG
    addNode :: CFG -> Label -> CFG
addNode CFG
cfg Label
b = (LabelMap EdgeInfo -> LabelMap EdgeInfo -> LabelMap EdgeInfo)
-> Label -> LabelMap EdgeInfo -> CFG -> CFG
forall v. (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v
mapInsertWith LabelMap EdgeInfo -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall v. LabelMap v -> LabelMap v -> LabelMap v
mapUnion Label
b LabelMap EdgeInfo
forall v. LabelMap v
mapEmpty CFG
cfg
    go :: CFG -> BlockId -> (LabelMap EdgeInfo) -> CFG
    go :: CFG -> Label -> LabelMap EdgeInfo -> CFG
go CFG
cfg Label
from LabelMap EdgeInfo
toMap = (CFG -> Label -> EdgeInfo -> CFG)
-> CFG -> LabelMap EdgeInfo -> CFG
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey (\CFG
cfg Label
to EdgeInfo
info -> Label -> Label -> EdgeInfo -> CFG -> CFG
addEdge Label
to Label
from EdgeInfo
info CFG
cfg) CFG
cfg LabelMap EdgeInfo
toMap  :: CFG


-- | Returns a unordered list of all edges with info
infoEdgeList :: CFG -> [CfgEdge]
infoEdgeList :: CFG -> [CfgEdge]
infoEdgeList CFG
m =
    [(Label, LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
go (CFG -> [(Label, LabelMap EdgeInfo)]
forall b. LabelMap b -> [(Label, b)]
mapToList CFG
m) []
  where
    -- We avoid foldMap to avoid thunk buildup
    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 (LabelMap EdgeInfo -> [(Label, EdgeInfo)]
forall b. LabelMap b -> [(Label, b)]
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 CfgEdge -> [CfgEdge] -> [CfgEdge]
forall a. a -> [a] -> [a]
: [CfgEdge]
acc)

-- | Returns a unordered list of all edges without weights
edgeList :: CFG -> [Edge]
edgeList :: CFG -> [Edge]
edgeList CFG
m =
    [(Label, LabelMap EdgeInfo)] -> [Edge] -> [Edge]
go (CFG -> [(Label, LabelMap EdgeInfo)]
forall b. LabelMap b -> [(Label, b)]
mapToList CFG
m) []
  where
    -- We avoid foldMap to avoid thunk buildup
    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 (LabelMap EdgeInfo -> [Label]
forall a. LabelMap a -> [Label]
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) Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: [Edge]
acc)

-- | Get successors of a given node without edge weights.
getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId]
getSuccessors :: HasDebugCallStack => CFG -> Label -> [Label]
getSuccessors CFG
m Label
bid
    | Just LabelMap EdgeInfo
wm <- Label -> CFG -> Maybe (LabelMap EdgeInfo)
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
bid CFG
m
    = LabelMap EdgeInfo -> [Label]
forall a. LabelMap a -> [Label]
mapKeys LabelMap EdgeInfo
wm
    | Bool
otherwise = [Label]
lookupError
    where
      lookupError :: [Label]
lookupError = String -> SDoc -> [Label]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSuccessors: Block does not exist" (SDoc -> [Label]) -> SDoc -> [Label]
forall a b. (a -> b) -> a -> b
$
                    Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
bid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CFG -> SDoc
pprEdgeWeights CFG
m

pprEdgeWeights :: CFG -> SDoc
pprEdgeWeights :: CFG -> SDoc
pprEdgeWeights CFG
m =
    let edges :: [CfgEdge]
edges = [CfgEdge] -> [CfgEdge]
forall a. Ord a => [a] -> [a]
sort ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
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
forall doc. IsLine doc => String -> doc
text String
"\t" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
from SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
to SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[label=\"" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> EdgeWeight -> SDoc
forall a. Outputable a => a -> SDoc
ppr EdgeWeight
weight SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\",weight=\"" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
              EdgeWeight -> SDoc
forall a. Outputable a => a -> SDoc
ppr EdgeWeight
weight SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\"];\n"
        --for the case that there are no edges from/to this node.
        --This should rarely happen but it can save a lot of time
        --to immediately see it when it does.
        printNode :: a -> SDoc
printNode a
node
            = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\t" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
node SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
";\n"
        getEdgeNodes :: CfgEdge -> [Label]
getEdgeNodes (CfgEdge Label
from Label
to EdgeInfo
_) = [Label
from,Label
to]
        edgeNodes :: LabelSet
edgeNodes = [Label] -> LabelSet
setFromList ([Label] -> LabelSet) -> [Label] -> LabelSet
forall a b. (a -> b) -> a -> b
$ (CfgEdge -> [Label]) -> [CfgEdge] -> [Label]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CfgEdge -> [Label]
getEdgeNodes [CfgEdge]
edges :: LabelSet
        nodes :: [Label]
nodes = (Label -> Bool) -> [Label] -> [Label]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Label
n -> (Bool -> Bool
not (Bool -> Bool) -> (LabelSet -> Bool) -> LabelSet -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> LabelSet -> Bool
setMember Label
n) LabelSet
edgeNodes) ([Label] -> [Label]) -> (CFG -> [Label]) -> CFG -> [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> [Label]
forall a. LabelMap a -> [Label]
mapKeys (CFG -> [Label]) -> CFG -> [Label]
forall a b. (a -> b) -> a -> b
$ (LabelMap EdgeInfo -> Bool) -> CFG -> CFG
forall v. (v -> Bool) -> LabelMap v -> LabelMap v
mapFilter LabelMap EdgeInfo -> Bool
forall a. LabelMap a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
m
    in
    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"digraph {\n" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
        ((SDoc -> SDoc -> SDoc) -> SDoc -> [SDoc] -> SDoc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
(<>) SDoc
forall doc. IsOutput doc => doc
empty ((CfgEdge -> SDoc) -> [CfgEdge] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CfgEdge -> SDoc
printEdge [CfgEdge]
edges)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
        ((SDoc -> SDoc -> SDoc) -> SDoc -> [SDoc] -> SDoc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
(<>) SDoc
forall doc. IsOutput doc => doc
empty ((Label -> SDoc) -> [Label] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Label -> SDoc
forall a. Outputable a => a -> SDoc
printNode [Label]
nodes)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"}\n"

{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible
-- | Invariant: The edge **must** exist already in the graph.
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 = newWeight}) CFG
cfg
    | Bool
otherwise
    = String -> CFG
forall a. HasCallStack => String -> a
panic String
"Trying to update invalid edge"

-- from to oldWeight => newWeight
mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
mapWeights :: (Label -> Label -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
mapWeights Label -> Label -> EdgeWeight -> EdgeWeight
f CFG
cfg =
  (CFG -> CfgEdge -> CFG) -> CFG -> [CfgEdge] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
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 = newWeight}) CFG
cfg)
          CFG
cfg (CFG -> [CfgEdge]
infoEdgeList CFG
cfg)


-- | Insert a block in the control flow between two other blocks.
-- We pass a list of tuples (A,B,C) where
-- * A -> C: Old edge
-- * A -> B -> C : New Arc, where B is the new block.
-- It's possible that a block has two jumps to the same block
-- in the assembly code. However we still only store a single edge for
-- these cases.
-- We assign the old edge info to the edge A -> B and assign B -> C the
-- weight of an unconditional jump.
addNodesBetween :: Weights -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
addNodesBetween :: Weights -> CFG -> [(Label, Label, Label)] -> CFG
addNodesBetween Weights
weights CFG
m [(Label, Label, Label)]
updates =
  (CFG -> (Label, Label, Label, EdgeInfo) -> CFG)
-> CFG -> [(Label, Label, Label, EdgeInfo)] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'  CFG -> (Label, Label, Label, EdgeInfo) -> CFG
updateWeight CFG
m ([(Label, Label, Label, EdgeInfo)] -> CFG)
-> ([(Label, Label, Label)] -> [(Label, Label, Label, EdgeInfo)])
-> [(Label, Label, Label)]
-> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [(Label, Label, Label)] -> [(Label, Label, Label, EdgeInfo)]
weightUpdates ([(Label, Label, Label)] -> CFG) -> [(Label, Label, Label)] -> CFG
forall a b. (a -> b) -> a -> b
$ [(Label, Label, Label)]
updates
    where
      weight :: EdgeWeight
weight = Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Weights -> Int
uncondWeight Weights
weights)
      -- We might add two blocks for different jumps along a single
      -- edge. So we end up with edges:   A -> B -> C   ,   A -> D -> C
      -- in this case after applying the first update the weight for A -> C
      -- is no longer available. So we calculate future weights before updates.
      weightUpdates :: [(Label, Label, Label)] -> [(Label, Label, Label, EdgeInfo)]
weightUpdates = ((Label, Label, Label) -> (Label, Label, Label, EdgeInfo))
-> [(Label, Label, Label)] -> [(Label, Label, Label, EdgeInfo)]
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
        = String -> SDoc -> (Label, Label, Label, EdgeInfo)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Can't find weight for edge that should have one" (
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"triple" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Label, Label, Label) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Label
from,Label
between,Label
old) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"updates" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(Label, Label, Label)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Label, Label, Label)]
updates SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cfg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
between Label
old EdgeWeight
weight (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Label -> Label -> CFG -> CFG
delEdge Label
from Label
old (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ CFG
m

{-
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ~~~       Note [CFG Edge Weights]    ~~~
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  Edge weights assigned do not currently represent a specific
  cost model and rather just a ranking of which blocks should
  be placed next to each other given their connection type in
  the CFG.
  This is especially relevant if we whenever two blocks will
  jump to the same target.

                     A   B
                      \ /
                       C

  Should A or B be placed in front of C? The block layout algorithm
  decides this based on which edge (A,C)/(B,C) is heavier. So we
  make a educated guess on which branch should be preferred.

  We rank edges in this order:
  * Unconditional Control Transfer - They will always
    transfer control to their target. Unless there is a info table
    we can turn the jump into a fallthrough as well.
    We use 20k as default, so it's easy to spot if values have been
    modified but unlikely that we run into issues with overflow.
  * If branches (likely) - We assume branches marked as likely
    are taken more than 80% of the time.
    By ranking them below unconditional jumps we make sure we
    prefer the unconditional if there is a conditional and
    unconditional edge towards a block.
  * If branches (regular) - The false branch can potentially be turned
    into a fallthrough so we prefer it slightly over the true branch.
  * Unlikely branches - These can be assumed to be taken less than 20%
    of the time. So we given them one of the lowest priorities.
  * Switches - Switches at this level are implemented as jump tables
    so have a larger number of successors. So without more information
    we can only say that each individual successor is unlikely to be
    jumped to and we rank them accordingly.
  * Calls - We currently ignore calls completely:
        * By the time we return from a call there is a good chance
          that the address we return to has already been evicted from
          cache eliminating a main advantage sequential placement brings.
        * Calls always require a info table in front of their return
          address. This reduces the chance that we return to the same
          cache line further.

-}
-- | Generate weights for a Cmm proc based on some simple heuristics.
getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG
getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG
getCfgProc Platform
_        Weights
_       (CmmData {}) = CFG
forall v. LabelMap v
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 =
  (CFG -> (Edge, EdgeInfo) -> CFG)
-> CFG -> [(Edge, EdgeInfo)] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> (Edge, EdgeInfo) -> CFG
insertEdge CFG
edgelessCfg ([(Edge, EdgeInfo)] -> CFG) -> [(Edge, EdgeInfo)] -> CFG
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> [(Edge, EdgeInfo)])
-> [CmmBlock] -> [(Edge, EdgeInfo)]
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
            --  Last two are used in other places
            --, infoTablePenalty = infoTablePenalty
            --, backEdgeBonus = backEdgeBonus
            } = Weights
weights
    -- Explicitly add all nodes to the cfg to ensure they are part of the
    -- CFG.
    edgelessCfg :: CFG
edgelessCfg = [(Label, LabelMap EdgeInfo)] -> CFG
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, LabelMap EdgeInfo)] -> CFG)
-> [(Label, LabelMap EdgeInfo)] -> CFG
forall a b. (a -> b) -> a -> b
$ [Label] -> [LabelMap EdgeInfo] -> [(Label, LabelMap EdgeInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((CmmBlock -> Label) -> [CmmBlock] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
G.entryLabel [CmmBlock]
blocks) (LabelMap EdgeInfo -> [LabelMap EdgeInfo]
forall a. a -> [a]
repeat LabelMap EdgeInfo
forall v. LabelMap v
mapEmpty)
    insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG
    insertEdge :: CFG -> (Edge, EdgeInfo) -> CFG
insertEdge CFG
m ((Label
from,Label
to),EdgeInfo
weight) =
      (Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo))
-> Label -> CFG -> CFG
forall v. (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v
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 = LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo)
forall a. a -> Maybe a
Just (LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo))
-> LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo)
forall a b. (a -> b) -> a -> b
$ Label -> EdgeInfo -> LabelMap EdgeInfo
forall v. Label -> v -> LabelMap v
mapSingleton Label
to EdgeInfo
weight
          f (Just LabelMap EdgeInfo
destMap) = LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo)
forall a. a -> Maybe a
Just (LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo))
-> LabelMap EdgeInfo -> Maybe (LabelMap EdgeInfo)
forall a b. (a -> b) -> a -> b
$ Label -> EdgeInfo -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall v. Label -> v -> LabelMap v -> LabelMap v
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 Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe 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 Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe 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 Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe 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 = -- pprTrace "Info" (ppr branchInfo <+> ppr cond)
                         TransitionSource -> EdgeWeight -> EdgeInfo
EdgeInfo (CmmNode O C -> BranchInfo -> TransitionSource
CmmSource CmmNode O C
branch BranchInfo
branchInfo) (EdgeWeight -> EdgeInfo) -> (Int -> EdgeWeight) -> Int -> EdgeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> EdgeWeight
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 =
              Platform
-> (BranchInfo -> GlobalReg -> BranchInfo)
-> BranchInfo
-> CmmExpr
-> BranchInfo
forall b. Platform -> (b -> GlobalReg -> b) -> b -> CmmExpr -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed
                (String -> Platform
forall a. HasCallStack => String -> a
panic String
"GHC.CmmToAsm.CFG.getCfg: foldRegsUsed")
                (\BranchInfo
info GlobalReg
r -> if GlobalReg
r GlobalReg -> GlobalReg -> Bool
forall a. Eq a => a -> a -> Bool
== GlobalReg
SpLim Bool -> Bool -> Bool
|| GlobalReg
r GlobalReg -> GlobalReg -> Bool
forall a. Eq a => a -> a -> Bool
== GlobalReg
HpLim Bool -> Bool -> Bool
|| GlobalReg
r GlobalReg -> GlobalReg -> Bool
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
              --Compiler performance hack - for very wide switches don't
              --consider targets for layout.
              adjustedWeight :: Int
adjustedWeight =
                if ([Label] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Label]
switchTargets Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) then -Int
1 else Int
switchWeight
          in (Label -> (Edge, EdgeInfo)) -> [Label] -> [(Edge, EdgeInfo)]
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 ->
            String -> [(Edge, EdgeInfo)] -> [(Edge, EdgeInfo)]
forall a. HasCallStack => String -> a
panic String
"Foo" ([(Edge, EdgeInfo)] -> [(Edge, EdgeInfo)])
-> [(Edge, EdgeInfo)] -> [(Edge, EdgeInfo)]
forall a b. (a -> b) -> a -> b
$
            Bool -> SDoc -> [(Edge, EdgeInfo)] -> [(Edge, EdgeInfo)]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unknown successor cause:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
              (Platform -> CmmNode O C -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode O C
branch SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"=>" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> [Label] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (CmmNode O C -> [Label]
forall (e :: Extensibility). CmmNode e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
G.successors CmmNode O C
other))) ([(Edge, EdgeInfo)] -> [(Edge, EdgeInfo)])
-> [(Edge, EdgeInfo)] -> [(Edge, EdgeInfo)]
forall a b. (a -> b) -> a -> b
$
            (Label -> (Edge, EdgeInfo)) -> [Label] -> [(Edge, EdgeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\Label
x -> ((Label
bid,Label
x),Int -> EdgeInfo
mkEdgeInfo Int
0)) ([Label] -> [(Edge, EdgeInfo)]) -> [Label] -> [(Edge, EdgeInfo)]
forall a b. (a -> b) -> a -> b
$ CmmNode O C -> [Label]
forall (e :: Extensibility). CmmNode e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
G.successors CmmNode O C
other
      where
        bid :: Label
bid = CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
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) (EdgeWeight -> EdgeInfo) -> (Int -> EdgeWeight) -> Int -> EdgeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> EdgeWeight
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 = CmmBlock -> CmmNode O C
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]

--Find back edges by BFS
findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges
findBackEdges :: HasDebugCallStack => Label -> CFG -> [Edge]
findBackEdges Label
root CFG
cfg =
    --pprTraceIt "Backedges:" $
    ((Edge, EdgeType) -> Edge) -> [(Edge, EdgeType)] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (Edge, EdgeType) -> Edge
forall a b. (a, b) -> a
fst ([(Edge, EdgeType)] -> [Edge])
-> ([(Edge, EdgeType)] -> [(Edge, EdgeType)])
-> [(Edge, EdgeType)]
-> [Edge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ((Edge, EdgeType) -> Bool)
-> [(Edge, EdgeType)] -> [(Edge, EdgeType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Edge, EdgeType)
x -> (Edge, EdgeType) -> EdgeType
forall a b. (a, b) -> b
snd (Edge, EdgeType)
x EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
Backward) ([(Edge, EdgeType)] -> [Edge]) -> [(Edge, EdgeType)] -> [Edge]
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]
CFG -> Label -> [Label]
getSuccessors CFG
cfg :: BlockId -> [BlockId]
    typedEdges :: [(Edge, EdgeType)]
typedEdges =
      Label -> (Label -> [Label]) -> [Edge] -> [(Edge, EdgeType)]
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 (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
graph) else CFG -> CFG
forall a. a -> a
id) (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$
    Weights -> RawCmmDecl -> CFG -> CFG
optHsPatterns Weights
weights RawCmmDecl
proc (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ CFG
cfg

-- | Modify branch weights based on educated guess on
-- patterns GHC tends to produce and how they affect
-- performance.
--
-- Most importantly we penalize jumps across info tables.
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 #-}
    -- pprTrace "Initial:" (pprEdgeWeights cfg) $
    -- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $

    -- pprTrace "LoopInfo:" (ppr $ loopInfo cfg (g_entry graph)) $
    CFG -> CFG
favourFewerPreds  (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    LabelMap RawCmmStatics -> CFG -> CFG
forall a. LabelMap a -> CFG -> CFG
penalizeInfoTables LabelMap RawCmmStatics
info (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Label -> CFG -> CFG
increaseBackEdgeWeight (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
graph) (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ CFG
cfg
  where

    -- Increase the weight of all backedges in the CFG
    -- this helps to make loop jumpbacks the heaviest edges
    increaseBackEdgeWeight :: BlockId -> CFG -> CFG
    increaseBackEdgeWeight :: Label -> CFG -> CFG
increaseBackEdgeWeight Label
root CFG
cfg =
        let backedges :: [Edge]
backedges = HasDebugCallStack => Label -> CFG -> [Edge]
Label -> CFG -> [Edge]
findBackEdges Label
root CFG
cfg
            update :: EdgeWeight -> EdgeWeight
update EdgeWeight
weight
              --Keep irrelevant edges irrelevant
              | EdgeWeight
weight EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= EdgeWeight
0 = EdgeWeight
0
              | Bool
otherwise
              = EdgeWeight
weight EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+ Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Weights -> Int
backEdgeBonus Weights
weights)
        in  (CFG -> Edge -> CFG) -> CFG -> [Edge] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
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

    -- Since we cant fall through info tables we penalize these.
    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
          | Label -> LabelMap a -> Bool
forall a. Label -> LabelMap a -> Bool
mapMember Label
to LabelMap a
info
          = EdgeWeight
weight EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
- (Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> EdgeWeight) -> Int -> EdgeWeight
forall a b. (a -> b) -> a -> b
$ Weights -> Int
infoTablePenalty Weights
weights)
          | Bool
otherwise = EdgeWeight
weight

    -- If a block has two successors, favour the one with fewer
    -- predecessors and/or the one allowing fall through.
    favourFewerPreds :: CFG -> CFG
    favourFewerPreds :: CFG -> CFG
favourFewerPreds CFG
cfg =
        let
            revCfg :: CFG
revCfg =
              CFG -> CFG
reverseEdges (CFG -> CFG) -> CFG -> CFG
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 = [(Label, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Label, EdgeInfo)] -> Int) -> [(Label, EdgeInfo)] -> Int
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
preds2 = ( EdgeWeight
1,-EdgeWeight
1)
              | Int
preds1 Int -> Int -> Bool
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)]
CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
cfg Label
node
              , !EdgeWeight
w1 <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
e1
              , !EdgeWeight
w2 <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
e2
              --Only change the weights if there isn't already a ordering.
              , EdgeWeight
w1 EdgeWeight -> EdgeWeight -> Bool
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' (EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+EdgeWeight
mod2) Label
node Label
s2))
                    (CFG -> (EdgeWeight -> EdgeWeight) -> Label -> Label -> CFG
adjustEdgeWeight CFG
cfg  (EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+EdgeWeight
mod1) Label
node Label
s1)
              | Bool
otherwise
              = CFG
cfg
        in (CFG -> Label -> CFG) -> CFG -> [Label] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
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)
          | Label -> LabelMap RawCmmStatics -> Bool
forall a. Label -> LabelMap 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

-- | Convert block-local branch weights to global weights.
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))
Label -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
mkGlobalWeights Label
entry CFG
cfg
    cfg' :: CFG
cfg' = {-# SCC rewriteEdges #-}
            (CFG -> Label -> LabelMap Double -> CFG)
-> CFG -> LabelMap (LabelMap Double) -> CFG
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey
                (\CFG
cfg Label
from LabelMap Double
m ->
                    (CFG -> Label -> Double -> CFG) -> CFG -> LabelMap Double -> CFG
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey
                        (\CFG
cfg Label
to Double
w -> CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg (Double -> EdgeWeight
EdgeWeight Double
w) Label
from Label
to )
                        CFG
cfg LabelMap Double
m )
                CFG
cfg
                LabelMap (LabelMap Double)
globalEdgeWeights

-- | Determine loop membership of blocks based on SCC analysis
--   This is faster but only gives yes/no answers.
loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool
loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool
loopMembers CFG
cfg =
    (LabelMap Bool -> SCC Label -> LabelMap Bool)
-> LabelMap Bool -> [SCC Label] -> LabelMap Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((SCC Label -> LabelMap Bool -> LabelMap Bool)
-> LabelMap Bool -> SCC Label -> LabelMap Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip SCC Label -> LabelMap Bool -> LabelMap Bool
setLevel) LabelMap Bool
forall v. LabelMap v
mapEmpty [SCC Label]
sccs
  where
    mkNode :: BlockId -> Node BlockId BlockId
    mkNode :: Label -> Node Label Label
mkNode Label
bid = Label -> Label -> [Label] -> Node Label Label
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode Label
bid Label
bid (HasDebugCallStack => CFG -> Label -> [Label]
CFG -> Label -> [Label]
getSuccessors CFG
cfg Label
bid)
    nodes :: [Node Label Label]
nodes = (Label -> Node Label Label) -> [Label] -> [Node Label Label]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Node Label Label
mkNode (CFG -> [Label]
getCfgNodes CFG
cfg)

    sccs :: [SCC Label]
sccs = [Node Label Label] -> [SCC Label]
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 = Label -> Bool -> LabelMap Bool -> LabelMap Bool
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
bid Bool
False LabelMap Bool
m
    setLevel (CyclicSCC [Label]
bids) LabelMap Bool
m = (LabelMap Bool -> Label -> LabelMap Bool)
-> LabelMap Bool -> [Label] -> LabelMap Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LabelMap Bool
m Label
k -> Label -> Bool -> LabelMap Bool -> LabelMap Bool
forall v. Label -> v -> LabelMap v -> LabelMap v
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
CFG -> Label -> LoopInfo
loopInfo CFG
cfg Label
root

data LoopInfo = LoopInfo
  { LoopInfo -> [Edge]
liBackEdges :: [(Edge)] -- ^ List of back edges
  , LoopInfo -> LabelMap Int
liLevels :: LabelMap Int -- ^ BlockId -> LoopLevel mapping
  , LoopInfo -> [(Edge, LabelSet)]
liLoops :: [(Edge, LabelSet)] -- ^ (backEdge, loopBody), body includes header
  }

instance Outputable LoopInfo where
    ppr :: LoopInfo -> SDoc
ppr (LoopInfo [Edge]
_ LabelMap Int
_lvls [(Edge, LabelSet)]
loops) =
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Loops:(backEdge, bodyNodes)" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ ((Edge, LabelSet) -> SDoc) -> [(Edge, LabelSet)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Edge, LabelSet) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Edge, LabelSet)]
loops)

{-  Note [Determining the loop body]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Starting with the knowledge that:
    * head dominates the loop
    * `tail` -> `head` is a backedge

    We can determine all nodes by:
    * Deleting the loop head from the graph.
    * Collect all blocks which are reachable from the `tail`.

    We do so by performing bfs from the tail node towards the head.
 -}

-- | Determine loop membership of blocks based on Dominator analysis.
--   This is slower but gives loop levels instead of just loop membership.
--   However it only detects natural loops. Irreducible control flow is not
--   recognized even if it loops. But that is rare enough that we don't have
--   to care about that special case.
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 = [(Label, Int)] -> LabelMap Int
forall v. [(Label, v)] -> LabelMap v
mapFromList [(Label, Int)]
loopCounts
                              , liLoops :: [(Edge, LabelSet)]
liLoops = [(Edge, LabelSet)]
loopBodies }
  where
    revCfg :: CFG
revCfg = CFG -> CFG
reverseEdges CFG
cfg

    graph :: LabelMap LabelSet
graph = -- pprTrace "CFG - loopInfo" (pprEdgeWeights cfg) $
            (LabelMap EdgeInfo -> LabelSet) -> CFG -> LabelMap LabelSet
forall a b. (a -> b) -> LabelMap a -> LabelMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Label] -> LabelSet
setFromList ([Label] -> LabelSet)
-> (LabelMap EdgeInfo -> [Label]) -> LabelMap EdgeInfo -> LabelSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelMap EdgeInfo -> [Label]
forall a. LabelMap a -> [Label]
mapKeys ) CFG
cfg :: LabelMap LabelSet


    --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ...
    rooted :: (Word64, Word64Map Word64Set)
rooted = ( Label -> Word64
fromBlockId Label
root
              , LabelMap Word64Set -> Word64Map Word64Set
forall a. LabelMap a -> Word64Map a
toWord64Map (LabelMap Word64Set -> Word64Map Word64Set)
-> LabelMap Word64Set -> Word64Map Word64Set
forall a b. (a -> b) -> a -> b
$ (LabelSet -> Word64Set) -> LabelMap LabelSet -> LabelMap Word64Set
forall a b. (a -> b) -> LabelMap a -> LabelMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LabelSet -> Word64Set
toWord64Set LabelMap LabelSet
graph) :: (Word64, Word64Map Word64Set)
    tree :: Tree Label
tree = (Word64 -> Label) -> Tree Word64 -> Tree Label
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> Label
toBlockId (Tree Word64 -> Tree Label) -> Tree Word64 -> Tree Label
forall a b. (a -> b) -> a -> b
$ (Word64, Word64Map Word64Set) -> Tree Word64
Dom.domTree (Word64, Word64Map Word64Set)
rooted :: Tree BlockId

    -- Map from Nodes to their dominators
    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)]
    -- We can't recompute nodes from edges, there might be blocks not connected via edges.
    nodes :: [Label]
nodes = CFG -> [Label]
getCfgNodes CFG
cfg :: [BlockId]

    -- identify back edges
    isBackEdge :: Edge -> Bool
isBackEdge (Label
from,Label
to)
      | Just LabelSet
doms <- Label -> LabelMap LabelSet -> Maybe LabelSet
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
from LabelMap LabelSet
domMap
      , Label -> LabelSet -> Bool
setMember Label
to LabelSet
doms
      = Bool
True
      | Bool
otherwise = Bool
False

    -- See Note [Determining the loop body]
    -- Get the loop body associated with a back edge.
    findBody :: Edge -> (Edge, LabelSet)
findBody edge :: Edge
edge@(Label
tail, Label
head)
      = ( Edge
edge, Label -> LabelSet -> LabelSet
setInsert Label
head (LabelSet -> LabelSet) -> LabelSet -> LabelSet
forall a b. (a -> b) -> a -> b
$ LabelSet -> LabelSet -> LabelSet
go (Label -> LabelSet
setSingleton Label
tail) (Label -> LabelSet
setSingleton Label
tail) )
      where
        -- See Note [Determining the loop body]


        go :: LabelSet -> LabelSet -> LabelSet
        go :: LabelSet -> LabelSet -> LabelSet
go LabelSet
found LabelSet
current
          | LabelSet -> Bool
setNull LabelSet
current = LabelSet
found
          | Bool
otherwise = LabelSet -> LabelSet -> LabelSet
go  (LabelSet -> LabelSet -> LabelSet
setUnion LabelSet
newSuccessors LabelSet
found)
                            LabelSet
newSuccessors
          where
            -- Really predecessors, since we use the reversed cfg.
            newSuccessors :: LabelSet
newSuccessors = (Label -> Bool) -> LabelSet -> LabelSet
setFilter (\Label
n -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Label -> LabelSet -> Bool
setMember Label
n LabelSet
found) LabelSet
successors :: LabelSet
            successors :: LabelSet
successors = Label -> LabelSet -> LabelSet
setDelete Label
head (LabelSet -> LabelSet) -> LabelSet -> LabelSet
forall a b. (a -> b) -> a -> b
$ [LabelSet] -> LabelSet
setUnions ([LabelSet] -> LabelSet) -> [LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$ (Label -> LabelSet) -> [Label] -> [LabelSet]
forall a b. (a -> b) -> [a] -> [b]
map
                                      (\Label
x -> if Label
x Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
head then LabelSet
setEmpty else [Label] -> LabelSet
setFromList (HasDebugCallStack => CFG -> Label -> [Label]
CFG -> Label -> [Label]
getSuccessors CFG
revCfg Label
x))
                                      (LabelSet -> [Label]
setElems LabelSet
current) :: LabelSet

    backEdges :: [Edge]
backEdges = (Edge -> Bool) -> [Edge] -> [Edge]
forall a. (a -> Bool) -> [a] -> [a]
filter Edge -> Bool
isBackEdge [Edge]
edges
    loopBodies :: [(Edge, LabelSet)]
loopBodies = (Edge -> (Edge, LabelSet)) -> [Edge] -> [(Edge, LabelSet)]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> (Edge, LabelSet)
findBody [Edge]
backEdges :: [(Edge, LabelSet)]

    -- Block b is part of n loop bodies => loop nest level of n
    loopCounts :: [(Label, Int)]
loopCounts =
      let bodies :: [(Label, LabelSet)]
bodies = ((Edge, LabelSet) -> (Label, LabelSet))
-> [(Edge, LabelSet)] -> [(Label, LabelSet)]
forall a b. (a -> b) -> [a] -> [b]
map ((Edge -> Label) -> (Edge, LabelSet) -> (Label, LabelSet)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Edge -> Label
forall a b. (a, b) -> b
snd) [(Edge, LabelSet)]
loopBodies -- [(Header, Body)]
          loopCount :: Label -> Int
loopCount Label
n = [Label] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Label] -> Int) -> [Label] -> Int
forall a b. (a -> b) -> a -> b
$ [Label] -> [Label]
forall a. Eq a => [a] -> [a]
nub ([Label] -> [Label])
-> ([(Label, LabelSet)] -> [Label])
-> [(Label, LabelSet)]
-> [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Label, LabelSet) -> Label) -> [(Label, LabelSet)] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (Label, LabelSet) -> Label
forall a b. (a, b) -> a
fst ([(Label, LabelSet)] -> [Label])
-> ([(Label, LabelSet)] -> [(Label, LabelSet)])
-> [(Label, LabelSet)]
-> [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Label, LabelSet) -> Bool)
-> [(Label, LabelSet)] -> [(Label, LabelSet)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Label -> LabelSet -> Bool
setMember Label
n (LabelSet -> Bool)
-> ((Label, LabelSet) -> LabelSet) -> (Label, LabelSet) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label, LabelSet) -> LabelSet
forall a b. (a, b) -> b
snd) ([(Label, LabelSet)] -> [Label]) -> [(Label, LabelSet)] -> [Label]
forall a b. (a -> b) -> a -> b
$ [(Label, LabelSet)]
bodies
      in  (Label -> (Label, Int)) -> [Label] -> [(Label, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Label
n -> (Label
n, Label -> Int
loopCount Label
n)) ([Label] -> [(Label, Int)]) -> [Label] -> [(Label, Int)]
forall a b. (a -> b) -> a -> b
$ [Label]
nodes :: [(BlockId, Int)]

    toWord64Set :: LabelSet -> Word64Set
    toWord64Set :: LabelSet -> Word64Set
toWord64Set LabelSet
s = [Word64] -> Word64Set
WS.fromList ([Word64] -> Word64Set)
-> (LabelSet -> [Word64]) -> LabelSet -> Word64Set
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label -> Word64) -> [Label] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Word64
fromBlockId ([Label] -> [Word64])
-> (LabelSet -> [Label]) -> LabelSet -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelSet -> [Label]
setElems (LabelSet -> Word64Set) -> LabelSet -> Word64Set
forall a b. (a -> b) -> a -> b
$ LabelSet
s
    toWord64Map :: LabelMap a -> Word64Map a
    toWord64Map :: forall a. LabelMap a -> Word64Map a
toWord64Map LabelMap a
m = [(Word64, a)] -> Word64Map a
forall a. [(Word64, a)] -> Word64Map a
WM.fromList ([(Word64, a)] -> Word64Map a) -> [(Word64, a)] -> Word64Map a
forall a b. (a -> b) -> a -> b
$ ((Label, a) -> (Word64, a)) -> [(Label, a)] -> [(Word64, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Label
x,a
y) -> (Label -> Word64
fromBlockId Label
x,a
y)) ([(Label, a)] -> [(Word64, a)]) -> [(Label, a)] -> [(Word64, a)]
forall a b. (a -> b) -> a -> b
$ LabelMap a -> [(Label, a)]
forall b. LabelMap b -> [(Label, b)]
mapToList LabelMap a
m

    mkDomMap :: Tree BlockId -> LabelMap LabelSet
    mkDomMap :: Tree Label -> LabelMap LabelSet
mkDomMap Tree Label
root = [(Label, LabelSet)] -> LabelMap LabelSet
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, LabelSet)] -> LabelMap LabelSet)
-> [(Label, LabelSet)] -> LabelMap LabelSet
forall a b. (a -> b) -> a -> b
$ LabelSet -> Tree Label -> [(Label, LabelSet)]
go LabelSet
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 = (Tree Label -> Label) -> [Tree Label] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Tree Label -> Label
forall a. Tree a -> a
rootLabel [Tree Label]
leaves
                entries :: [(Label, LabelSet)]
entries = (Label -> (Label, LabelSet)) -> [Label] -> [(Label, LabelSet)]
forall a b. (a -> b) -> [a] -> [b]
map (\Label
x -> (Label
x,LabelSet
parents)) [Label]
nodes
            in  [(Label, LabelSet)]
entries [(Label, LabelSet)] -> [(Label, LabelSet)] -> [(Label, LabelSet)]
forall a. [a] -> [a] -> [a]
++ (Tree Label -> [(Label, LabelSet)])
-> [Tree Label] -> [(Label, LabelSet)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                            (\Tree Label
n -> LabelSet -> Tree Label -> [(Label, LabelSet)]
go (Label -> LabelSet -> LabelSet
setInsert (Tree Label -> Label
forall a. Tree a -> a
rootLabel Tree Label
n) LabelSet
parents) Tree Label
n)
                            [Tree Label]
leaves

    fromBlockId :: BlockId -> Word64
    fromBlockId :: Label -> Word64
fromBlockId = Unique -> Word64
getKey (Unique -> Word64) -> (Label -> Unique) -> Label -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Unique
forall a. Uniquable a => a -> Unique
getUnique

    toBlockId :: Word64 -> BlockId
    toBlockId :: Word64 -> Label
toBlockId = Unique -> Label
mkBlockId (Unique -> Label) -> (Word64 -> Unique) -> Word64 -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Unique
mkUniqueGrimily

-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
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 =
    (BlockNode C C -> Label) -> [BlockNode C C] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map BlockNode C C -> Label
fromNode ([BlockNode C C] -> [Label]) -> [BlockNode C C] -> [Label]
forall a b. (a -> b) -> a -> b
$ LabelMap (BlockNode C C) -> Label -> [BlockNode C C]
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 = (LabelMap (BlockNode C C) -> Label -> LabelMap (BlockNode C C))
-> LabelMap (BlockNode C C) -> [Label] -> LabelMap (BlockNode C C)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LabelMap (BlockNode C C)
m Label
n -> Label
-> BlockNode C C
-> LabelMap (BlockNode C C)
-> LabelMap (BlockNode C C)
forall v. Label -> v -> LabelMap v -> LabelMap v
mapInsert Label
n (Label -> BlockNode C C
toNode Label
n) LabelMap (BlockNode C C)
m) LabelMap (BlockNode C C)
forall v. LabelMap v
mapEmpty [Label]
nodes

    fromNode :: BlockNode C C -> BlockId
    fromNode :: BlockNode C C -> Label
fromNode (BN (Label, [Label])
x) = (Label, [Label]) -> Label
forall a b. (a, b) -> a
fst (Label, [Label])
x

    toNode :: BlockId -> BlockNode C C
    toNode :: Label -> BlockNode C C
toNode Label
bid =
        (Label, [Label]) -> BlockNode C C
forall (e :: Extensibility) (x :: Extensibility).
(Label, [Label]) -> BlockNode e x
BN (Label
bid,HasDebugCallStack => CFG -> Label -> [Label]
CFG -> Label -> [Label]
getSuccessors CFG
cfg (Label -> [Label]) -> Label -> [Label]
forall a b. (a -> b) -> a -> b
$ Label
bid)


-- | We take in a CFG which has on its edges weights which are
--   relative only to other edges originating from the same node.
--
--   We return a CFG for which each edge represents a GLOBAL weight.
--   This means edge weights are comparable across the whole graph.
--
--   For irreducible control flow results might be imprecise, otherwise they
--   are reliable.
--
--   The algorithm is based on the Paper
--   "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus
--   The only big change is that we go over the nodes in the body of loops in
--   reverse post order. Which is required for diamond control flow to work probably.
--
--   We also apply a few prediction heuristics (based on the same paper)
--
--   The returned result represents frequences.
--   For blocks it's the expected number of executions and
--   for edges is the number of traversals.

{-# 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
  | CFG -> Bool
forall a. LabelMap a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
localCfg = String -> (LabelMap Double, LabelMap (LabelMap Double))
forall a. HasCallStack => String -> a
panic String
"Error - Empty CFG"
  | Bool
otherwise
  = (LabelMap Double
blockFreqs', LabelMap (LabelMap Double)
edgeFreqs')
  where
    -- Calculate fixpoints
    (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' = [(Label, Double)] -> LabelMap Double
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, Double)] -> LabelMap Double)
-> [(Label, Double)] -> LabelMap Double
forall a b. (a -> b) -> a -> b
$ ((Int, Double) -> (Label, Double))
-> [(Int, Double)] -> [(Label, Double)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Label) -> (Int, Double) -> (Label, Double)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Label
fromVertex) (Array Int Double -> [(Int, Double)]
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' = (IntMap Double -> LabelMap Double)
-> LabelMap (IntMap Double) -> LabelMap (LabelMap Double)
forall a b. (a -> b) -> LabelMap a -> LabelMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IntMap Double -> LabelMap Double
forall x. IntMap x -> LabelMap x
fromVertexMap (LabelMap (IntMap Double) -> LabelMap (LabelMap Double))
-> LabelMap (IntMap Double) -> LabelMap (LabelMap Double)
forall a b. (a -> b) -> a -> b
$ IntMap (IntMap Double) -> LabelMap (IntMap Double)
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 = [(Label, x)] -> LabelMap x
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, x)] -> LabelMap x)
-> ([(Int, x)] -> [(Label, x)]) -> [(Int, x)] -> LabelMap x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, x) -> (Label, x)) -> [(Int, x)] -> [(Label, x)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Label) -> (Int, x) -> (Label, x)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Label
fromVertex) ([(Int, x)] -> LabelMap x) -> [(Int, x)] -> LabelMap x
forall a b. (a -> b) -> a -> b
$ IntMap x -> [(Int, x)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap x
m

    revOrder :: [Label]
revOrder = HasDebugCallStack => CFG -> Label -> [Label]
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
CFG -> Label -> LoopInfo
loopInfo CFG
localCfg Label
root

    revOrder' :: [Int]
revOrder' = (Label -> Int) -> [Label] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Int
toVertex [Label]
revOrder
    backEdges' :: [(Int, Int)]
backEdges' = (Edge -> (Int, Int)) -> [Edge] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Label -> Int) -> (Label -> Int) -> Edge -> (Int, Int)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
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' = ((Edge, LabelSet) -> (Int, [Int]))
-> [(Edge, LabelSet)] -> [(Int, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (Edge, LabelSet) -> (Int, [Int])
forall {a}. ((a, Label), LabelSet) -> (Int, [Int])
calcBody [(Edge, LabelSet)]
bodies

    estimatedCfg :: CFG
estimatedCfg = Label -> LoopInfo -> CFG -> CFG
staticBranchPrediction Label
root LoopInfo
loopResults CFG
localCfg
    -- Normalize the weights to probabilities and apply heuristics
    nodeProbs :: IntMap (IntMap Double)
nodeProbs = CFG -> (Label -> Int) -> IntMap (IntMap Double)
cfgEdgeProbabilities CFG
estimatedCfg Label -> Int
toVertex

    -- By mapping vertices to numbers in reverse post order we can bring any subset into reverse post
    -- order simply by sorting.
    -- TODO: The sort is redundant if we can guarantee that setElems returns elements ascending
    calcBody :: ((a, Label), LabelSet) -> (Int, [Int])
calcBody ((a, Label)
backedge, LabelSet
blocks) =
        (Label -> Int
toVertex (Label -> Int) -> Label -> Int
forall a b. (a -> b) -> a -> b
$ (a, Label) -> Label
forall a b. (a, b) -> b
snd (a, Label)
backedge, [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> ([Label] -> [Int]) -> [Label] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label -> Int) -> [Label] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Int
toVertex ([Label] -> [Int]) -> [Label] -> [Int]
forall a b. (a -> b) -> a -> b
$ (LabelSet -> [Label]
setElems LabelSet
blocks))

    vertexMapping :: LabelMap Int
vertexMapping = [(Label, Int)] -> LabelMap Int
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, Int)] -> LabelMap Int) -> [(Label, Int)] -> LabelMap Int
forall a b. (a -> b) -> a -> b
$ [Label] -> [Int] -> [(Label, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Label]
revOrder [Int
0..] :: LabelMap Int
    blockMapping :: Array Int Label
blockMapping = (Int, Int) -> [Label] -> Array Int Label
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0,LabelMap Int -> Int
forall a. LabelMap a -> Int
mapSize LabelMap Int
vertexMapping Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Label]
revOrder :: Array Int BlockId
    -- Map from blockId to indices starting at zero
    toVertex :: BlockId -> Int
    toVertex :: Label -> Int
toVertex   Label
blockId  = String -> Maybe Int -> Int
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mkGlobalWeights" (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Label -> LabelMap Int -> Maybe Int
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
blockId LabelMap Int
vertexMapping
    -- Map from indices starting at zero to blockIds
    fromVertex :: Int -> BlockId
    fromVertex :: Int -> Label
fromVertex Int
vertex   = Array Int Label
blockMapping Array Int Label -> Int -> Label
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
vertex

{- Note [Static Branch Prediction]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The work here has been based on the paper
"Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus.

The primary differences are that if we branch on the result of a heap
check we do not apply any of the heuristics.
The reason is simple: They look like loops in the control flow graph
but are usually never entered, and if at most once.

Currently implemented is a heuristic to predict that we do not exit
loops (lehPredicts) and one to predict that backedges are more likely
than any other edge.

The back edge case is special as it supersedes any other heuristic if it
applies.

Do NOT rely solely on nofib results for benchmarking this. I recommend at least
comparing megaparsec and container benchmarks. Nofib does not seem to have
many instances of "loopy" Cmm where these make a difference.

TODO:
* The paper containers more benchmarks which should be implemented.
* If we turn the likelihood on if/else branches into a probability
  instead of true/false we could implement this as a Cmm pass.
  + The complete Cmm code still exists and can be accessed by the heuristics
  + There is no chance of register allocation/codegen inserting branches/blocks
  + making the TransitionSource info wrong.
  + potential to use this information in CmmPasses.
  - Requires refactoring of all the code relying on the binary nature of likelihood.
  - Requires refactoring `loopInfo` to work on both, Cmm Graphs and the backend CFG.
-}

-- | Combination of target node id and information about the branch
--   we are looking at.
type TargetNodeInfo = (BlockId, EdgeInfo)


-- | Update branch weights based on certain heuristics.
-- See Note [Static Branch Prediction]
-- TODO: This should be combined with optimizeCFG
{-# 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 =
    -- pprTrace "staticEstimatesOn" (ppr (cfg)) $
    (CFG -> Label -> CFG) -> CFG -> [Label] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
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 = [Edge] -> Set Edge
forall a. Ord a => [a] -> Set a
S.fromList ([Edge] -> Set Edge) -> [Edge] -> Set Edge
forall a b. (a -> b) -> a -> b
$ [Edge]
l_backEdges
    -- Loops keyed by their back edge
    loops :: Map Edge LabelSet
loops = [(Edge, LabelSet)] -> Map Edge LabelSet
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Edge, LabelSet)] -> Map Edge LabelSet)
-> [(Edge, LabelSet)] -> Map Edge LabelSet
forall a b. (a -> b) -> a -> b
$ [(Edge, LabelSet)]
l_loops :: M.Map Edge LabelSet
    loopHeads :: Set Label
loopHeads = [Label] -> Set Label
forall a. Ord a => [a] -> Set a
S.fromList ([Label] -> Set Label) -> [Label] -> Set Label
forall a b. (a -> b) -> a -> b
$ (Edge -> Label) -> [Edge] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> Label
forall a b. (a, b) -> b
snd ([Edge] -> [Label]) -> [Edge] -> [Label]
forall a b. (a -> b) -> a -> b
$ Map Edge LabelSet -> [Edge]
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
        -- No successors, nothing to do.
        | [(Label, EdgeInfo)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Label, EdgeInfo)]
successors = CFG
cfg

        -- Mix of backedges and others:
        -- Always predict the backedges.
        | Bool -> Bool
not ([(Label, EdgeInfo)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Label, EdgeInfo)]
m) Bool -> Bool -> Bool
&& [(Label, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Label, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
successors
        -- Heap/Stack checks "loop", but only once.
        -- So we simply exclude any case involving them.
        , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((Label, EdgeInfo) -> Bool) -> [(Label, EdgeInfo)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TransitionSource -> Bool
isHeapOrStackCheck  (TransitionSource -> Bool)
-> ((Label, EdgeInfo) -> TransitionSource)
-> (Label, EdgeInfo)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeInfo -> TransitionSource
transitionSource (EdgeInfo -> TransitionSource)
-> ((Label, EdgeInfo) -> EdgeInfo)
-> (Label, EdgeInfo)
-> TransitionSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label, EdgeInfo) -> EdgeInfo
forall a b. (a, b) -> b
snd) [(Label, EdgeInfo)]
successors
        = let   loopChance :: [EdgeWeight]
loopChance = EdgeWeight -> [EdgeWeight]
forall a. a -> [a]
repeat (EdgeWeight -> [EdgeWeight]) -> EdgeWeight -> [EdgeWeight]
forall a b. (a -> b) -> a -> b
$! EdgeWeight
pred_LBH EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Fractional a => a -> a -> a
/ (Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> EdgeWeight) -> Int -> EdgeWeight
forall a b. (a -> b) -> a -> b
$ [(Label, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
m)
                exitChance :: [EdgeWeight]
exitChance = EdgeWeight -> [EdgeWeight]
forall a. a -> [a]
repeat (EdgeWeight -> [EdgeWeight]) -> EdgeWeight -> [EdgeWeight]
forall a b. (a -> b) -> a -> b
$! (EdgeWeight
1 EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
- EdgeWeight
pred_LBH) EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Fractional a => a -> a -> a
/ Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Label, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
not_m)
                updates :: [(Label, EdgeWeight)]
updates = [Label] -> [EdgeWeight] -> [(Label, EdgeWeight)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Label, EdgeInfo) -> Label) -> [(Label, EdgeInfo)] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (Label, EdgeInfo) -> Label
forall a b. (a, b) -> a
fst [(Label, EdgeInfo)]
m) [EdgeWeight]
loopChance [(Label, EdgeWeight)]
-> [(Label, EdgeWeight)] -> [(Label, EdgeWeight)]
forall a. [a] -> [a] -> [a]
++ [Label] -> [EdgeWeight] -> [(Label, EdgeWeight)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Label, EdgeInfo) -> Label) -> [(Label, EdgeInfo)] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (Label, EdgeInfo) -> Label
forall a b. (a, b) -> a
fst [(Label, EdgeInfo)]
not_m) [EdgeWeight]
exitChance
        in  -- pprTrace "mix" (ppr (node,successors)) $
            (CFG -> (Label, EdgeWeight) -> CFG)
-> CFG -> [(Label, EdgeWeight)] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
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

        -- For (regular) non-binary branches we keep the weights from the STG -> Cmm translation.
        | [(Label, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
successors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
2
        = CFG
cfg

        -- Only backedges - no need to adjust
        | [(Label, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Label, EdgeInfo)]
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        = CFG
cfg

        -- A regular binary branch, we can plug addition predictors in here.
        | [(Label
s1,EdgeInfo
s1_info),(Label
s2,EdgeInfo
s2_info)] <- [(Label, EdgeInfo)]
successors
        , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((Label, EdgeInfo) -> Bool) -> [(Label, EdgeInfo)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TransitionSource -> Bool
isHeapOrStackCheck  (TransitionSource -> Bool)
-> ((Label, EdgeInfo) -> TransitionSource)
-> (Label, EdgeInfo)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeInfo -> TransitionSource
transitionSource (EdgeInfo -> TransitionSource)
-> ((Label, EdgeInfo) -> EdgeInfo)
-> (Label, EdgeInfo)
-> TransitionSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label, EdgeInfo) -> EdgeInfo
forall a b. (a, b) -> b
snd) [(Label, EdgeInfo)]
successors
        = -- Normalize weights to total of 1
            let !w1 :: EdgeWeight
w1 = EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Ord a => a -> a -> a
max (EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
s1_info) (EdgeWeight
0)
                !w2 :: EdgeWeight
w2 = EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Ord a => a -> a -> a
max (EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
s2_info) (EdgeWeight
0)
                -- Of both weights are <= 0 we set both to 0.5
                normalizeWeight :: EdgeWeight -> EdgeWeight
normalizeWeight EdgeWeight
w = if EdgeWeight
w1 EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+ EdgeWeight
w2 EdgeWeight -> EdgeWeight -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeWeight
0 then EdgeWeight
0.5 else EdgeWeight
wEdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Fractional a => a -> a -> a
/(EdgeWeight
w1EdgeWeight -> EdgeWeight -> EdgeWeight
forall 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

                -- Figure out which heuristics apply to these successors
                heuristics :: [Maybe Double]
heuristics = ((((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double)
 -> Maybe Double)
-> [((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double]
-> [Maybe Double]
forall a b. (a -> b) -> [a] -> [b]
map ((((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double)
-> ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
forall a b. (a -> b) -> a -> b
$ ((Label
s1,EdgeInfo
s1_info),(Label
s2,EdgeInfo
s2_info)))
                            [((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
lehPredicts, ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
forall {b} {a}. b -> Maybe a
phPredicts, ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
ohPredicts, ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
forall {b} {a}. b -> Maybe a
ghPredicts, ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
forall {b} {a}. b -> Maybe a
lhhPredicts, ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
forall {b} {a}. b -> Maybe a
chPredicts
                            , ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
forall {b} {a}. b -> Maybe a
shPredicts, ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
forall {b} {a}. b -> Maybe a
rhPredicts]
                -- Apply result of a heuristic. Argument is the likelihood
                -- predicted for s1.
                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 EdgeWeight -> EdgeWeight -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeWeight
0 Bool -> Bool -> Bool
|| EdgeWeight
s2_old EdgeWeight -> EdgeWeight -> Bool
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 -- Predictions from heuristic
                        s1_prob :: EdgeWeight
s1_prob = Double -> EdgeWeight
EdgeWeight Double
s1_pred :: EdgeWeight
                        s2_prob :: EdgeWeight
s2_prob = EdgeWeight
1.0 EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
- EdgeWeight
s1_prob
                        -- Update
                        d :: EdgeWeight
d = (EdgeWeight
s1_old EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
* EdgeWeight
s1_prob) EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+ (EdgeWeight
s2_old EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
* EdgeWeight
s2_prob) :: EdgeWeight
                        s1_prob' :: EdgeWeight
s1_prob' = EdgeWeight
s1_old EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
* EdgeWeight
s1_prob EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Fractional a => a -> a -> a
/ EdgeWeight
d
                        !s2_prob' :: EdgeWeight
s2_prob' = EdgeWeight
s2_old EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
* EdgeWeight
s2_prob EdgeWeight -> EdgeWeight -> EdgeWeight
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  -- pprTrace "Applying heuristic!" (ppr (node,s1,s2) $$ ppr (s1_prob', s2_prob')) $
                        CFG -> EdgeWeight -> Label -> Label -> CFG
setEdgeWeight CFG
cfg_s1 EdgeWeight
s2_prob' Label
node Label
s2
                  where
                    -- Old weights
                    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
            -- pprTraceIt "RegularCfgResult" $
            (CFG -> Maybe Double -> CFG) -> CFG -> [Maybe Double] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> Maybe Double -> CFG
applyHeuristic CFG
cfg'' [Maybe Double]
heuristics

        -- Branch on heap/stack check
        | Bool
otherwise = CFG
cfg

      where
        -- Chance that loops are taken.
        pred_LBH :: EdgeWeight
pred_LBH = EdgeWeight
0.875
        -- successors
        successors :: [(Label, EdgeInfo)]
successors = HasDebugCallStack => CFG -> Label -> [(Label, EdgeInfo)]
CFG -> Label -> [(Label, EdgeInfo)]
getSuccessorEdges CFG
cfg Label
node
        -- backedges
        ([(Label, EdgeInfo)]
m,[(Label, EdgeInfo)]
not_m) = ((Label, EdgeInfo) -> Bool)
-> [(Label, EdgeInfo)]
-> ([(Label, EdgeInfo)], [(Label, EdgeInfo)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Label, EdgeInfo)
succ -> Edge -> Set Edge -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Label
node, (Label, EdgeInfo) -> Label
forall a b. (a, b) -> a
fst (Label, EdgeInfo)
succ) Set Edge
backedges) [(Label, EdgeInfo)]
successors

        -- Heuristics return nothing if they don't say anything about this branch
        -- or Just (prob_s1) where prob_s1 is the likelihood for s1 to be the
        -- taken branch. s1 is the branch in the true case.

        -- Loop exit heuristic.
        -- We are unlikely to leave a loop unless it's to enter another one.
        pred_LEH :: Double
pred_LEH = Double
0.75
        -- If and only if no successor is a loopheader,
        -- then we will likely not exit the current loop body.
        lehPredicts :: (TargetNodeInfo,TargetNodeInfo) -> Maybe Prob
        lehPredicts :: ((Label, EdgeInfo), (Label, EdgeInfo)) -> Maybe Double
lehPredicts ((Label
s1,EdgeInfo
_s1_info),(Label
s2,EdgeInfo
_s2_info))
          | Label -> Set Label -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Label
s1 Set Label
loopHeads Bool -> Bool -> Bool
|| Label -> Set Label -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Label
s2 Set Label
loopHeads
          = Maybe Double
forall a. Maybe a
Nothing

          | Bool
otherwise
          = --pprTrace "lehPredict:" (ppr $ compare s1Level s2Level) $
            case Maybe Int -> Maybe Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Maybe Int
s1Level Maybe Int
s2Level of
                Ordering
EQ -> Maybe Double
forall a. Maybe a
Nothing
                Ordering
LT -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
pred_LEH) --s1 exits to a shallower loop level (exits loop)
                Ordering
GT -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
pred_LEH)   --s1 exits to a deeper loop level
            where
                s1Level :: Maybe Int
s1Level = Label -> LabelMap Int -> Maybe Int
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
s1 LabelMap Int
loopLevels
                s2Level :: Maybe Int
s2Level = Label -> LabelMap Int -> Maybe Int
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
s2 LabelMap Int
loopLevels

        -- Comparing to a constant is unlikely to be equal.
        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 ((Label, EdgeInfo) -> Label
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 Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Bool
forall a. Maybe a
Nothing
            , CmmMachOp MachOp
mop [CmmExpr]
args <- CmmExpr
cond
            , MO_Eq {} <- MachOp
mop
            , Bool -> Bool
not ([CmmExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmExpr
x | x :: CmmExpr
x@CmmLit{} <- [CmmExpr]
args])
            = if (Label, EdgeInfo) -> Label
forall a b. (a, b) -> a
fst (Label, EdgeInfo)
s1 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
ltrue then Double -> Maybe Double
forall a. a -> Maybe a
Just Double
0.3 else Double -> Maybe Double
forall a. a -> Maybe a
Just Double
0.7

            | Bool
otherwise
            = Maybe Double
forall a. Maybe a
Nothing

        -- TODO: These are all the other heuristics from the paper.
        -- Not all will apply, for now we just stub them out as Nothing.
        phPredicts :: b -> Maybe a
phPredicts = Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing
        ghPredicts :: b -> Maybe a
ghPredicts = Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing
        lhhPredicts :: b -> Maybe a
lhhPredicts = Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing
        chPredicts :: b -> Maybe a
chPredicts = Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing
        shPredicts :: b -> Maybe a
shPredicts = Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing
        rhPredicts :: b -> Maybe a
rhPredicts = Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing

-- We normalize all edge weights as probabilities between 0 and 1.
-- Ignoring rounding errors all outgoing edges sum up to 1.
cfgEdgeProbabilities :: CFG -> (BlockId -> Int) -> IM.IntMap (IM.IntMap Prob)
cfgEdgeProbabilities :: CFG -> (Label -> Int) -> IntMap (IntMap Double)
cfgEdgeProbabilities CFG
cfg Label -> Int
toVertex
    = (IntMap (IntMap Double)
 -> Label -> LabelMap EdgeInfo -> IntMap (IntMap Double))
-> IntMap (IntMap Double) -> CFG -> IntMap (IntMap Double)
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey IntMap (IntMap Double)
-> Label -> LabelMap EdgeInfo -> IntMap (IntMap Double)
foldEdges IntMap (IntMap Double)
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 -> Int
-> IntMap Double
-> IntMap (IntMap Double)
-> IntMap (IntMap Double)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = (IntMap Double -> Label -> EdgeInfo -> IntMap Double)
-> IntMap Double -> LabelMap EdgeInfo -> IntMap Double
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey (\IntMap Double
m Label
k EdgeInfo
_ -> Int -> Double -> IntMap Double -> IntMap Double
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Label -> Int
toVertex Label
k) Double
1.0 IntMap Double
m) IntMap Double
forall a. IntMap a
IM.empty LabelMap EdgeInfo
weightMap
        | Bool
otherwise = (IntMap Double -> Label -> EdgeInfo -> IntMap Double)
-> IntMap Double -> LabelMap EdgeInfo -> IntMap Double
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey (\IntMap Double
m Label
k EdgeInfo
_ -> Int -> Double -> IntMap Double -> IntMap Double
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Label -> Int
toVertex Label
k) (Label -> Double
normalWeight Label
k) IntMap Double
m) IntMap Double
forall a. IntMap a
IM.empty LabelMap EdgeInfo
weightMap
      where
        edgeCount :: Int
edgeCount = LabelMap EdgeInfo -> Int
forall a. LabelMap a -> Int
mapSize LabelMap EdgeInfo
weightMap
        -- Negative weights are generally allowed but are mapped to zero.
        -- We then check if there is at least one non-zero edge and if not
        -- assign uniform weights to all branches.
        minWeight :: Double
minWeight = Double
0 :: Prob
        weightMap' :: LabelMap Double
weightMap' = (EdgeInfo -> Double) -> LabelMap EdgeInfo -> LabelMap Double
forall a b. (a -> b) -> LabelMap a -> LabelMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\EdgeInfo
w -> Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (EdgeWeight -> Double
weightToDouble (EdgeWeight -> Double)
-> (EdgeInfo -> EdgeWeight) -> EdgeInfo -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeInfo -> EdgeWeight
edgeWeight (EdgeInfo -> Double) -> EdgeInfo -> Double
forall a b. (a -> b) -> a -> b
$ EdgeInfo
w) Double
minWeight) LabelMap EdgeInfo
weightMap
        totalWeight :: Double
totalWeight = LabelMap Double -> Double
forall a. Num a => LabelMap a -> a
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 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0
         = Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
edgeCount
         | Just Double
w <- Label -> LabelMap Double -> Maybe Double
forall a. Label -> LabelMap a -> Maybe a
mapLookup Label
bid LabelMap Double
weightMap'
         = Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
totalWeight
         | Bool
otherwise = String -> Double
forall a. HasCallStack => String -> a
panic String
"impossible"

-- This is the fixpoint algorithm from
--   "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus
-- The adaption to Haskell is my own.
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 s. ST s (Array Int Double, IntMap (IntMap Double)))
-> (Array Int Double, IntMap (IntMap Double))
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Array Int Double, IntMap (IntMap Double)))
 -> (Array Int Double, IntMap (IntMap Double)))
-> (forall s. ST s (Array Int Double, IntMap (IntMap Double)))
-> (Array Int Double, IntMap (IntMap Double))
forall a b. (a -> b) -> a -> b
$ do
    visitedNodes <- (Int, Int) -> Bool -> ST s (STUArray s Int Bool)
forall i. Ix i => (i, i) -> Bool -> ST s (STUArray s i Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
nodeCountInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Bool
False :: ST s (STUArray s Int Bool)
    blockFreqs <- newArray (0,nodeCount-1) 0.0 :: ST s (STUArray s Int Double)
    edgeProbs <- newSTRef graph
    edgeBackProbs <- newSTRef graph

    -- let traceArray a = do
    --       vs <- forM [0..nodeCount-1] $ \i -> readArray a i >>= (\v -> return (i,v))
          -- trace ("array: " ++ show vs) $ return ()

    let  -- See #1600, we need to inline or unboxing makes perf worse.
        -- {-# INLINE getFreq #-}
        {-# INLINE visited #-}
        visited Int
b = STUArray s Int Bool -> Int -> ST s Bool
forall i. Ix i => STUArray s i Bool -> Int -> ST s Bool
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
b = STUArray s Int Double -> Int -> ST s Double
forall i. Ix i => STUArray s i Double -> Int -> ST s Double
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 :: forall s. Int -> Double -> ST s ()
        setFreq Int
b Double
f = STUArray s Int Double -> Int -> Double -> ST s ()
forall i. Ix i => STUArray s i Double -> Int -> Double -> ST s ()
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 :: forall s. Node -> ST s ()
        setVisited Int
b = STUArray s Int Bool -> Int -> Bool -> ST s ()
forall i. Ix i => STUArray s i Bool -> Int -> Bool -> ST s ()
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
        -- Frequency/probability that edge is taken.
        getProb' STRef s (IntMap (IntMap b))
arr Int
b1 Int
b2 = STRef s (IntMap (IntMap b)) -> ST s (IntMap (IntMap b))
forall s a. STRef s a -> ST s a
readSTRef STRef s (IntMap (IntMap b))
arr ST s (IntMap (IntMap b)) -> (IntMap (IntMap b) -> ST s b) -> ST s b
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            (\IntMap (IntMap b)
graph ->
                b -> ST s b
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ST s b)
-> (Maybe (IntMap b) -> b) -> Maybe (IntMap b) -> ST s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe (String -> b
forall a. HasCallStack => String -> a
error String
"getFreq 1") (Maybe b -> b)
-> (Maybe (IntMap b) -> Maybe b) -> Maybe (IntMap b) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        Int -> IntMap b -> Maybe b
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b2 (IntMap b -> Maybe b)
-> (Maybe (IntMap b) -> IntMap b) -> Maybe (IntMap b) -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        IntMap b -> Maybe (IntMap b) -> IntMap b
forall a. a -> Maybe a -> a
fromMaybe (String -> IntMap b
forall a. HasCallStack => String -> a
error String
"getFreq 2") (Maybe (IntMap b) -> ST s b) -> Maybe (IntMap b) -> ST s b
forall a b. (a -> b) -> a -> b
$
                        (Int -> IntMap (IntMap b) -> Maybe (IntMap b)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b1 IntMap (IntMap b)
graph)
            )
        setProb' STRef s (IntMap (IntMap a))
arr Int
b1 Int
b2 a
prob = do
          g <- STRef s (IntMap (IntMap a)) -> ST s (IntMap (IntMap a))
forall s a. STRef s a -> ST s a
readSTRef STRef s (IntMap (IntMap a))
arr
          let !m = IntMap a -> Maybe (IntMap a) -> IntMap a
forall a. a -> Maybe a -> a
fromMaybe (String -> IntMap a
forall a. HasCallStack => String -> a
error String
"Foo") (Maybe (IntMap a) -> IntMap a) -> Maybe (IntMap a) -> IntMap a
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (IntMap a) -> Maybe (IntMap a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b1 IntMap (IntMap a)
g
              !m' = Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
b2 a
prob IntMap a
m
          writeSTRef arr $! (IM.insert b1 m' g)

        getEdgeFreq Int
b1 Int
b2 = STRef s (IntMap (IntMap Double)) -> Int -> Int -> ST s Double
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
b1 Int
b2 = STRef s (IntMap (IntMap Double)) -> Int -> Int -> Double -> ST s ()
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
b1 Int
b2 = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (String -> Double
forall a. HasCallStack => String -> a
error String
"getProb") (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ do
            m' <- Int -> IntMap (IntMap Double) -> Maybe (IntMap Double)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b1 IntMap (IntMap Double)
graph
            IM.lookup b2 m'

        getBackProb Int
b1 Int
b2 = STRef s (IntMap (IntMap Double)) -> Int -> Int -> ST s Double
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
b1 Int
b2 = STRef s (IntMap (IntMap Double)) -> Int -> Int -> Double -> ST s ()
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 :: Node -> ST s ()
        calcOutFreqs Int
bhead Int
block = do
          !f <- Int -> ST s Double
getFreq Int
block
          forM (successors block) $ \Int
bi -> do
            let !prob :: Double
prob = Int -> Int -> Double
getProb Int
block Int
bi
            let !succFreq :: Double
succFreq = Double
f Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
prob
            Int -> Int -> Double -> ST s ()
setEdgeFreq Int
block Int
bi Double
succFreq
            -- traceM $ "SetOut: " ++ show (block, bi, f, prob, succFreq)
            Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
bi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bhead) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Double -> ST s ()
setBackProb Int
block Int
bi Double
succFreq


    let propFreq Int
block Int
head = do
            -- traceM ("prop:" ++ show (block,head))
            -- traceShowM block

            !v <- Int -> ST s Bool
visited Int
block
            if v then
                return () --Dont look at nodes twice
            else if block == head then
                setFreq block 1.0 -- Loop header frequency is always 1
            else do
                let preds = IntSet -> [Int]
IS.elems (IntSet -> [Int]) -> IntSet -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> IntSet
predecessors Int
block
                irreducible <- (fmap or) $ forM preds $ \Int
bp -> do
                    !bp_visited <- Int -> ST s Bool
visited Int
bp
                    let bp_backedge = Int -> Int -> Bool
isBackEdge Int
bp Int
block
                    return (not bp_visited && not bp_backedge)

                if irreducible
                then return () -- Rare we don't care
                else do
                    setFreq block 0
                    !cycleProb <- sum <$> (forM preds $ \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
                                !f <- Int -> ST s Double
getFreq Int
block
                                !prob <- getEdgeFreq pred block
                                setFreq block $! f + prob
                                return 0)
                    -- traceM $ "cycleProb:" ++ show cycleProb
                    let limit = Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
512 -- Paper uses 1 - epsilon, but this works.
                                          -- determines how large likelyhoods in loops can grow.
                    !cycleProb <- return $ min cycleProb limit -- <- return $ if cycleProb > limit then limit else cycleProb
                    -- traceM $ "cycleProb:" ++ show cycleProb

                    !f <- getFreq block
                    setFreq block (f / (1.0 - cycleProb))

            setVisited block
            calcOutFreqs head block

    -- Loops, by nesting, inner to outer
    forM_ loops $ \(Int
head, [Int]
body) -> do
        [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
nodeCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] (\Int
i -> STUArray s Int Bool -> Int -> Bool -> ST s ()
forall i. Ix i => STUArray s i Bool -> Int -> Bool -> ST s ()
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) -- Mark all nodes as visited.
        [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
body (\Int
i -> STUArray s Int Bool -> Int -> Bool -> ST s ()
forall i. Ix i => STUArray s i Bool -> Int -> Bool -> ST s ()
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) -- Mark all blocks reachable from head as not visited
        [Int] -> (Int -> ST s [()]) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
body ((Int -> ST s [()]) -> ST s ()) -> (Int -> ST s [()]) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
block -> Int -> Int -> ST s [()]
propFreq Int
block Int
head

    -- After dealing with all loops, deal with non-looping parts of the CFG
    forM_ [0 .. nodeCount - 1] (\Int
i -> STUArray s Int Bool -> Int -> Bool -> ST s ()
forall i. Ix i => STUArray s i Bool -> Int -> Bool -> ST s ()
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) -- Everything in revPostOrder is reachable
    forM_ revPostOrder $ \Int
block -> Int -> Int -> ST s [()]
propFreq Int
block ([Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
revPostOrder)

    -- trace ("Final freqs:") $ return ()
    -- let freqString = pprFreqs freqs
    -- trace (unlines freqString) $ return ()
    -- trace (pprFre) $ return ()
    graph' <- readSTRef edgeProbs
    freqs' <- unsafeFreeze  blockFreqs

    return (freqs', graph')
  where
    -- How can these lookups fail? Consider the CFG [A -> B]
    predecessors :: Int -> IS.IntSet
    predecessors :: Int -> IntSet
predecessors Int
b = IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
IS.empty (Maybe IntSet -> IntSet) -> Maybe IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$ Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
b IntMap IntSet
revGraph
    successors :: Int -> [Int]
    successors :: Int -> [Int]
successors Int
b = [Int] -> Maybe [Int] -> [Int]
forall a. a -> Maybe a -> a
fromMaybe (String -> Int -> IntMap (IntMap Double) -> [Int]
forall {a} {a}.
Outputable a =>
String -> a -> IntMap (IntMap Double) -> a
lookupError String
"succ" Int
b IntMap (IntMap Double)
graph)(Maybe [Int] -> [Int]) -> Maybe [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ IntMap Double -> [Int]
forall a. IntMap a -> [Int]
IM.keys (IntMap Double -> [Int]) -> Maybe (IntMap Double) -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IntMap (IntMap Double) -> Maybe (IntMap Double)
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 = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic (String
"Lookup error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) (SDoc -> a) -> SDoc -> a
forall a b. (a -> b) -> a -> b
$
                            ( String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"node" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
b SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"graph" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                                [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((Int, IntMap Double) -> SDoc) -> [(Int, IntMap Double)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
k,IntMap Double
m) -> (Int, IntMap Double) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int
k,IntMap Double
m :: IM.IntMap Double)) ([(Int, IntMap Double)] -> [SDoc])
-> [(Int, IntMap Double)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ IntMap (IntMap Double) -> [(Int, IntMap Double)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (IntMap Double)
g)
                            )

    nodeCount :: Int
nodeCount = (Int -> IntMap Double -> Int)
-> Int -> IntMap (IntMap Double) -> Int
forall a b. (a -> b -> a) -> a -> IntMap b -> a
IM.foldl' (\Int
count IntMap Double
toMap -> (Int -> Int -> Double -> Int) -> Int -> IntMap Double -> Int
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' Int -> Int -> Double -> Int
countTargets (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) IntMap Double
toMap) Int
0 IntMap (IntMap Double)
graph
      where
        countTargets :: Int -> Int -> Double -> Int
countTargets = (\Int
count Int
k Double
_ -> Int -> Int
countNode Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count )
        countNode :: Int -> Int
countNode Int
n = if Int -> IntMap (IntMap Double) -> Bool
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 = (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Int
from,Int
to) Set (Int, Int)
backEdgeSet
    backEdgeSet :: Set (Int, Int)
backEdgeSet = [(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
S.fromList [(Int, Int)]
backEdges

    revGraph :: IntMap IntSet
    revGraph :: IntMap IntSet
revGraph = (IntMap IntSet -> Int -> IntMap Double -> IntMap IntSet)
-> IntMap IntSet -> IntMap (IntMap Double) -> IntMap IntSet
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' (\IntMap IntSet
m Int
from IntMap Double
toMap -> IntMap IntSet -> Int -> IntMap Double -> IntMap IntSet
forall {b}. IntMap IntSet -> Int -> IntMap b -> IntMap IntSet
addEdges IntMap IntSet
m Int
from IntMap Double
toMap) IntMap IntSet
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 = (IntMap IntSet -> Int -> b -> IntMap IntSet)
-> IntMap IntSet -> IntMap b -> IntMap IntSet
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 = (IntSet -> IntSet -> IntSet)
-> Int -> IntSet -> IntMap IntSet -> IntMap IntSet
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