--
-- Copyright (c) 2018 Andreas Klebinger
--

{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}

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

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

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

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

    --Find backedges and update their weight
    , optimizeCFG )
where

#include "HsVersions.h"

import GhcPrelude

import BlockId
import Cmm ( RawCmmDecl, GenCmmDecl( .. ), CmmBlock, succ, g_entry
           , CmmGraph )
import CmmNode
import CmmUtils
import CmmSwitch
import Hoopl.Collections
import Hoopl.Label
import Hoopl.Block
import qualified Hoopl.Graph as G

import Util
import Digraph

import Outputable
-- DEBUGGING ONLY
--import Debug
--import OrdList
--import Debug.Trace
import PprCmm ()
import qualified DynFlags as D

import Data.List

-- import qualified Data.IntMap.Strict as M --TODO: LabelMap

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

newtype EdgeWeight
  = EdgeWeight Int
  deriving (EdgeWeight -> EdgeWeight -> Bool
(EdgeWeight -> EdgeWeight -> Bool)
-> (EdgeWeight -> EdgeWeight -> Bool) -> Eq EdgeWeight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeWeight -> EdgeWeight -> Bool
$c/= :: EdgeWeight -> EdgeWeight -> Bool
== :: EdgeWeight -> EdgeWeight -> Bool
$c== :: EdgeWeight -> EdgeWeight -> Bool
Eq,Eq EdgeWeight
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
min :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cmin :: EdgeWeight -> EdgeWeight -> EdgeWeight
max :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cmax :: EdgeWeight -> EdgeWeight -> EdgeWeight
>= :: EdgeWeight -> EdgeWeight -> Bool
$c>= :: EdgeWeight -> EdgeWeight -> Bool
> :: EdgeWeight -> EdgeWeight -> Bool
$c> :: EdgeWeight -> EdgeWeight -> Bool
<= :: EdgeWeight -> EdgeWeight -> Bool
$c<= :: EdgeWeight -> EdgeWeight -> Bool
< :: EdgeWeight -> EdgeWeight -> Bool
$c< :: EdgeWeight -> EdgeWeight -> Bool
compare :: EdgeWeight -> EdgeWeight -> Ordering
$ccompare :: EdgeWeight -> EdgeWeight -> Ordering
$cp1Ord :: Eq 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
enumFromThenTo :: EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight]
$cenumFromThenTo :: EdgeWeight -> EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFromTo :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
$cenumFromTo :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFromThen :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
$cenumFromThen :: EdgeWeight -> EdgeWeight -> [EdgeWeight]
enumFrom :: EdgeWeight -> [EdgeWeight]
$cenumFrom :: EdgeWeight -> [EdgeWeight]
fromEnum :: EdgeWeight -> Int
$cfromEnum :: EdgeWeight -> Int
toEnum :: Int -> EdgeWeight
$ctoEnum :: Int -> EdgeWeight
pred :: EdgeWeight -> EdgeWeight
$cpred :: EdgeWeight -> EdgeWeight
succ :: EdgeWeight -> EdgeWeight
$csucc :: EdgeWeight -> EdgeWeight
Enum,Integer -> EdgeWeight
EdgeWeight -> EdgeWeight
EdgeWeight -> EdgeWeight -> EdgeWeight
(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
fromInteger :: Integer -> EdgeWeight
$cfromInteger :: Integer -> EdgeWeight
signum :: EdgeWeight -> EdgeWeight
$csignum :: EdgeWeight -> EdgeWeight
abs :: EdgeWeight -> EdgeWeight
$cabs :: EdgeWeight -> EdgeWeight
negate :: EdgeWeight -> EdgeWeight
$cnegate :: EdgeWeight -> EdgeWeight
* :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c* :: EdgeWeight -> EdgeWeight -> EdgeWeight
- :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c- :: EdgeWeight -> EdgeWeight -> EdgeWeight
+ :: EdgeWeight -> EdgeWeight -> EdgeWeight
$c+ :: EdgeWeight -> EdgeWeight -> EdgeWeight
Num,Num EdgeWeight
Ord EdgeWeight
(Num EdgeWeight, Ord EdgeWeight) =>
(EdgeWeight -> Rational) -> Real EdgeWeight
EdgeWeight -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
toRational :: EdgeWeight -> Rational
$ctoRational :: EdgeWeight -> Rational
$cp2Real :: Ord EdgeWeight
$cp1Real :: Num EdgeWeight
Real,Enum EdgeWeight
Real EdgeWeight
(Real EdgeWeight, Enum EdgeWeight) =>
(EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight -> EdgeWeight)
-> (EdgeWeight -> EdgeWeight -> (EdgeWeight, EdgeWeight))
-> (EdgeWeight -> EdgeWeight -> (EdgeWeight, EdgeWeight))
-> (EdgeWeight -> Integer)
-> Integral EdgeWeight
EdgeWeight -> Integer
EdgeWeight -> EdgeWeight -> (EdgeWeight, EdgeWeight)
EdgeWeight -> EdgeWeight -> EdgeWeight
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: EdgeWeight -> Integer
$ctoInteger :: EdgeWeight -> Integer
divMod :: EdgeWeight -> EdgeWeight -> (EdgeWeight, EdgeWeight)
$cdivMod :: EdgeWeight -> EdgeWeight -> (EdgeWeight, EdgeWeight)
quotRem :: EdgeWeight -> EdgeWeight -> (EdgeWeight, EdgeWeight)
$cquotRem :: EdgeWeight -> EdgeWeight -> (EdgeWeight, EdgeWeight)
mod :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cmod :: EdgeWeight -> EdgeWeight -> EdgeWeight
div :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cdiv :: EdgeWeight -> EdgeWeight -> EdgeWeight
rem :: EdgeWeight -> EdgeWeight -> EdgeWeight
$crem :: EdgeWeight -> EdgeWeight -> EdgeWeight
quot :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cquot :: EdgeWeight -> EdgeWeight -> EdgeWeight
$cp2Integral :: Enum EdgeWeight
$cp1Integral :: Real EdgeWeight
Integral)

instance Outputable EdgeWeight where
  ppr :: EdgeWeight -> SDoc
ppr (EdgeWeight w :: Int
w) = Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
w

type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)

-- | A control flow graph where edges have been annotated with a weight.
type CFG = EdgeInfoMap EdgeInfo

data CfgEdge
  = CfgEdge
  { CfgEdge -> BlockId
edgeFrom :: !BlockId
  , CfgEdge -> BlockId
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 from1 :: BlockId
from1 to1 :: BlockId
to1 _) (CfgEdge from2 :: BlockId
from2 to2 :: BlockId
to2 _)
    = BlockId
from1 BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
from2 Bool -> Bool -> Bool
&& BlockId
to1 BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
to2

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

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

-- | 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
/= :: EdgeInfo -> EdgeInfo -> Bool
$c/= :: EdgeInfo -> EdgeInfo -> Bool
== :: EdgeInfo -> EdgeInfo -> Bool
$c== :: EdgeInfo -> EdgeInfo -> Bool
Eq)

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

-- Allow specialization
{-# INLINEABLE mkWeightInfo #-}
-- | Convenience function, generate edge info based
--   on weight not originating from cmm.
mkWeightInfo :: Integral n => n -> EdgeInfo
mkWeightInfo :: n -> EdgeInfo
mkWeightInfo = TransitionSource -> EdgeWeight -> EdgeInfo
EdgeInfo TransitionSource
AsmCodeGen (EdgeWeight -> EdgeInfo) -> (n -> EdgeWeight) -> n -> EdgeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | 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) -> BlockId -> BlockId -> CFG
adjustEdgeWeight cfg :: CFG
cfg f :: EdgeWeight -> EdgeWeight
f from :: BlockId
from to :: BlockId
to
  | Just info :: EdgeInfo
info <- BlockId -> BlockId -> CFG -> Maybe EdgeInfo
getEdgeInfo BlockId
from BlockId
to CFG
cfg
  , EdgeWeight
weight <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info
  = BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge BlockId
from BlockId
to (EdgeInfo
info { edgeWeight :: EdgeWeight
edgeWeight = EdgeWeight -> EdgeWeight
f EdgeWeight
weight}) CFG
cfg
  | Bool
otherwise = CFG
cfg

getCfgNodes :: CFG -> LabelSet
getCfgNodes :: CFG -> LabelSet
getCfgNodes m :: CFG
m = (KeyOf LabelMap -> LabelMap EdgeInfo -> LabelSet)
-> CFG -> LabelSet
forall (map :: * -> *) m a.
(IsMap map, Monoid m) =>
(KeyOf map -> a -> m) -> map a -> m
mapFoldMapWithKey (\k :: KeyOf LabelMap
k v :: LabelMap EdgeInfo
v -> [ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList (KeyOf LabelMap
BlockId
kBlockId -> [BlockId] -> [BlockId]
forall a. a -> [a] -> [a]
:LabelMap EdgeInfo -> [KeyOf LabelMap]
forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap EdgeInfo
v)) CFG
m

hasNode :: CFG -> BlockId -> Bool
hasNode :: CFG -> BlockId -> Bool
hasNode m :: CFG
m node :: BlockId
node = KeyOf LabelMap -> CFG -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
BlockId
node CFG
m Bool -> Bool -> Bool
|| (LabelMap EdgeInfo -> Bool) -> CFG -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (KeyOf LabelMap -> LabelMap EdgeInfo -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
BlockId
node) CFG
m

-- | Check if the nodes in the cfg and the set of blocks are the same.
--   In a case of a missmatch we panic and show the difference.
sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg m :: CFG
m blockSet :: LabelSet
blockSet msg :: 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 "Block list and cfg nodes don't match" (
            String -> SDoc
text "difference:" SDoc -> SDoc -> SDoc
<+> LabelSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelSet
diff SDoc -> SDoc -> SDoc
$$
            String -> SDoc
text "blocks:" SDoc -> SDoc -> SDoc
<+> LabelSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelSet
blockSet SDoc -> SDoc -> SDoc
$$
            String -> SDoc
text "cfg:" SDoc -> SDoc -> SDoc
<+> CFG -> SDoc
forall a. Outputable a => a -> SDoc
ppr CFG
m SDoc -> SDoc -> SDoc
$$
            SDoc
msg )
            Bool
False
    where
      cfgNodes :: LabelSet
cfgNodes = CFG -> LabelSet
getCfgNodes CFG
m :: LabelSet
      diff :: LabelSet
diff = (LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => set -> set -> set
setUnion LabelSet
cfgNodes LabelSet
blockSet) LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => set -> set -> set
`setDifference` (LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => set -> set -> set
setIntersection LabelSet
cfgNodes LabelSet
blockSet) :: LabelSet

-- | Filter the CFG with a custom function f.
--   Paramaeters are `f from to edgeInfo`
filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges f :: BlockId -> BlockId -> EdgeInfo -> Bool
f cfg :: CFG
cfg =
    (KeyOf LabelMap -> LabelMap EdgeInfo -> LabelMap EdgeInfo)
-> CFG -> CFG
forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey KeyOf LabelMap -> LabelMap EdgeInfo -> LabelMap EdgeInfo
BlockId -> LabelMap EdgeInfo -> LabelMap EdgeInfo
filterSources CFG
cfg
    where
      filterSources :: BlockId -> LabelMap EdgeInfo -> LabelMap EdgeInfo
filterSources from :: BlockId
from m :: LabelMap EdgeInfo
m =
        (KeyOf LabelMap -> EdgeInfo -> Bool)
-> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a.
IsMap map =>
(KeyOf map -> a -> Bool) -> map a -> map a
mapFilterWithKey (\to :: KeyOf LabelMap
to w :: EdgeInfo
w -> BlockId -> BlockId -> EdgeInfo -> Bool
f BlockId
from KeyOf LabelMap
BlockId
to EdgeInfo
w) LabelMap EdgeInfo
m


{- Note [Updating the CFG during shortcutting]

See Note [What is shortcutting] in the control flow optimization
code (CmmContFlowOpt.hs) for a slightly more in depth explanation on shortcutting.

In the native backend we shortcut jumps at the assembly level. (AsmCodeGen.hs)
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 layed out above.

-}
shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG
shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG
shortcutWeightMap cfg :: CFG
cfg cuts :: LabelMap (Maybe BlockId)
cuts =
  (CFG -> (BlockId, Maybe BlockId) -> CFG)
-> CFG -> [(BlockId, Maybe BlockId)] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> (BlockId, Maybe BlockId) -> CFG
applyMapping CFG
cfg ([(BlockId, Maybe BlockId)] -> CFG)
-> [(BlockId, Maybe BlockId)] -> CFG
forall a b. (a -> b) -> a -> b
$ LabelMap (Maybe BlockId) -> [(KeyOf LabelMap, Maybe BlockId)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap (Maybe BlockId)
cuts
    where
-- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]
      applyMapping :: CFG -> (BlockId,Maybe BlockId) -> CFG
      --Shortcut immediate
      applyMapping :: CFG -> (BlockId, Maybe BlockId) -> CFG
applyMapping m :: CFG
m (from :: BlockId
from, Nothing) =
        KeyOf LabelMap -> CFG -> CFG
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
from (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (LabelMap EdgeInfo -> LabelMap EdgeInfo) -> CFG -> CFG
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (KeyOf LabelMap -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
from) (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ CFG
m
      --Regular shortcut
      applyMapping m :: CFG
m (from :: BlockId
from, Just to :: BlockId
to) =
        let updatedMap :: CFG
            updatedMap :: CFG
updatedMap
              = (LabelMap EdgeInfo -> LabelMap EdgeInfo) -> CFG -> CFG
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo
shortcutEdge (BlockId
from,BlockId
to)) (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$
                (KeyOf LabelMap -> CFG -> CFG
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
from CFG
m :: CFG )
        --Sometimes we can shortcut multiple blocks like so:
        -- A -> B -> C -> D -> E => A -> E
        -- so we check for such chains.
        in case KeyOf LabelMap -> LabelMap (Maybe BlockId) -> Maybe (Maybe BlockId)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
to LabelMap (Maybe BlockId)
cuts of
            Nothing -> CFG
updatedMap
            Just dest :: Maybe BlockId
dest -> CFG -> (BlockId, Maybe BlockId) -> CFG
applyMapping CFG
updatedMap (BlockId
to, Maybe BlockId
dest)
      --Redirect edge from B to C
      shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo
      shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo
shortcutEdge (from :: BlockId
from, to :: BlockId
to) m :: LabelMap EdgeInfo
m =
        case KeyOf LabelMap -> LabelMap EdgeInfo -> Maybe EdgeInfo
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
from LabelMap EdgeInfo
m of
          Just info :: EdgeInfo
info -> KeyOf LabelMap
-> EdgeInfo -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
to EdgeInfo
info (LabelMap EdgeInfo -> LabelMap EdgeInfo)
-> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
from LabelMap EdgeInfo
m
          Nothing   -> LabelMap EdgeInfo
m

-- | 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 :: BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor node :: BlockId
node follower :: BlockId
follower cfg :: CFG
cfg
    = CFG -> CFG
updateEdges (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
addWeightEdge BlockId
node BlockId
follower EdgeWeight
uncondWeight (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ CFG
cfg
    where
        uncondWeight :: EdgeWeight
uncondWeight = Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> EdgeWeight) -> (DynFlags -> Int) -> DynFlags -> EdgeWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CfgWeights -> Int
D.uncondWeight (CfgWeights -> Int) -> (DynFlags -> CfgWeights) -> DynFlags -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       DynFlags -> CfgWeights
D.cfgWeightInfo (DynFlags -> EdgeWeight) -> DynFlags -> EdgeWeight
forall a b. (a -> b) -> a -> b
$ DynFlags
D.unsafeGlobalDynFlags
        targets :: [(BlockId, EdgeInfo)]
targets = CFG -> BlockId -> [(BlockId, EdgeInfo)]
getSuccessorEdges CFG
cfg BlockId
node
        successors :: [BlockId]
successors = ((BlockId, EdgeInfo) -> BlockId)
-> [(BlockId, EdgeInfo)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, EdgeInfo) -> BlockId
forall a b. (a, b) -> a
fst [(BlockId, 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 m :: CFG
m = (CFG -> BlockId -> CFG) -> CFG -> [BlockId] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((BlockId -> CFG -> CFG) -> CFG -> BlockId -> CFG
forall a b c. (a -> b -> c) -> b -> a -> c
flip (BlockId -> BlockId -> CFG -> CFG
delEdge BlockId
node)) CFG
m [BlockId]
successors
        addNewSuccs :: CFG -> CFG
addNewSuccs m :: CFG
m =
          (CFG -> (BlockId, EdgeInfo) -> CFG)
-> CFG -> [(BlockId, EdgeInfo)] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\m' :: CFG
m' (t :: BlockId
t,info :: EdgeInfo
info) -> BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge BlockId
follower BlockId
t EdgeInfo
info CFG
m') CFG
m [(BlockId, EdgeInfo)]
targets

-- | Adds a new edge, overwrites existing edges if present
addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge from :: BlockId
from to :: BlockId
to info :: EdgeInfo
info cfg :: CFG
cfg =
    (Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo))
-> KeyOf LabelMap -> CFG -> CFG
forall (map :: * -> *) a.
IsMap map =>
(Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAlter Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
addDest KeyOf LabelMap
BlockId
from CFG
cfg
    where
        addDest :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
addDest 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
$ KeyOf LabelMap -> EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton KeyOf LabelMap
BlockId
to EdgeInfo
info
        addDest (Just wm :: 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
$ KeyOf LabelMap
-> EdgeInfo -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
to EdgeInfo
info LabelMap EdgeInfo
wm

-- | 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 :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
addWeightEdge from :: BlockId
from to :: BlockId
to weight :: EdgeWeight
weight cfg :: CFG
cfg =
    BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge BlockId
from BlockId
to (EdgeWeight -> EdgeInfo
forall n. Integral n => n -> EdgeInfo
mkWeightInfo EdgeWeight
weight) CFG
cfg

delEdge :: BlockId -> BlockId -> CFG -> CFG
delEdge :: BlockId -> BlockId -> CFG -> CFG
delEdge from :: BlockId
from to :: BlockId
to m :: CFG
m =
    (Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo))
-> KeyOf LabelMap -> CFG -> CFG
forall (map :: * -> *) a.
IsMap map =>
(Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAlter Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
remDest KeyOf LabelMap
BlockId
from CFG
m
    where
        remDest :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
remDest Nothing = Maybe (LabelMap EdgeInfo)
forall a. Maybe a
Nothing
        remDest (Just wm :: 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
$ KeyOf LabelMap -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
to LabelMap EdgeInfo
wm

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

-- | Get successors of a given node with edge weights.
getSuccessorEdges :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
getSuccessorEdges :: CFG -> BlockId -> [(BlockId, EdgeInfo)]
getSuccessorEdges m :: CFG
m bid :: BlockId
bid = [(BlockId, EdgeInfo)]
-> (LabelMap EdgeInfo -> [(BlockId, EdgeInfo)])
-> Maybe (LabelMap EdgeInfo)
-> [(BlockId, EdgeInfo)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] LabelMap EdgeInfo -> [(BlockId, EdgeInfo)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (Maybe (LabelMap EdgeInfo) -> [(BlockId, EdgeInfo)])
-> Maybe (LabelMap EdgeInfo) -> [(BlockId, EdgeInfo)]
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> CFG -> Maybe (LabelMap EdgeInfo)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid CFG
m

getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo
getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo
getEdgeInfo from :: BlockId
from to :: BlockId
to m :: CFG
m
    | Just wm :: LabelMap EdgeInfo
wm <- KeyOf LabelMap -> CFG -> Maybe (LabelMap EdgeInfo)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
from CFG
m
    , Just info :: EdgeInfo
info <- KeyOf LabelMap -> LabelMap EdgeInfo -> Maybe EdgeInfo
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
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

reverseEdges :: CFG -> CFG
reverseEdges :: CFG -> CFG
reverseEdges cfg :: CFG
cfg = ((BlockId, BlockId, EdgeInfo) -> CFG -> CFG)
-> CFG -> [(BlockId, BlockId, EdgeInfo)] -> CFG
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (BlockId, BlockId, EdgeInfo) -> CFG -> CFG
add CFG
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [(BlockId, BlockId, EdgeInfo)]
flatElems
  where
    elems :: [(BlockId, [(BlockId, EdgeInfo)])]
elems = LabelMap [(BlockId, EdgeInfo)]
-> [(BlockId, [(BlockId, EdgeInfo)])]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (LabelMap [(BlockId, EdgeInfo)]
 -> [(BlockId, [(BlockId, EdgeInfo)])])
-> LabelMap [(BlockId, EdgeInfo)]
-> [(BlockId, [(BlockId, EdgeInfo)])]
forall a b. (a -> b) -> a -> b
$ (LabelMap EdgeInfo -> [(BlockId, EdgeInfo)])
-> CFG -> LabelMap [(BlockId, EdgeInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LabelMap EdgeInfo -> [(BlockId, EdgeInfo)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList CFG
cfg :: [(BlockId,[(BlockId,EdgeInfo)])]
    flatElems :: [(BlockId, BlockId, EdgeInfo)]
flatElems =
        ((BlockId, [(BlockId, EdgeInfo)])
 -> [(BlockId, BlockId, EdgeInfo)])
-> [(BlockId, [(BlockId, EdgeInfo)])]
-> [(BlockId, BlockId, EdgeInfo)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(from :: BlockId
from,ws :: [(BlockId, EdgeInfo)]
ws) -> ((BlockId, EdgeInfo) -> (BlockId, BlockId, EdgeInfo))
-> [(BlockId, EdgeInfo)] -> [(BlockId, BlockId, EdgeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\(to :: BlockId
to,info :: EdgeInfo
info) -> (BlockId
to,BlockId
from,EdgeInfo
info)) [(BlockId, EdgeInfo)]
ws ) [(BlockId, [(BlockId, EdgeInfo)])]
elems
    add :: (BlockId, BlockId, EdgeInfo) -> CFG -> CFG
add (to :: BlockId
to,from :: BlockId
from,info :: EdgeInfo
info) m :: CFG
m = BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge BlockId
to BlockId
from EdgeInfo
info CFG
m

-- | Returns a unordered list of all edges with info
infoEdgeList :: CFG -> [CfgEdge]
infoEdgeList :: CFG -> [CfgEdge]
infoEdgeList m :: CFG
m =
  (KeyOf LabelMap -> LabelMap EdgeInfo -> [CfgEdge])
-> CFG -> [CfgEdge]
forall (map :: * -> *) m a.
(IsMap map, Monoid m) =>
(KeyOf map -> a -> m) -> map a -> m
mapFoldMapWithKey
    (\from :: KeyOf LabelMap
from toMap :: LabelMap EdgeInfo
toMap ->
      ((BlockId, EdgeInfo) -> CfgEdge)
-> [(BlockId, EdgeInfo)] -> [CfgEdge]
forall a b. (a -> b) -> [a] -> [b]
map (\(to :: BlockId
to,info :: EdgeInfo
info) -> BlockId -> BlockId -> EdgeInfo -> CfgEdge
CfgEdge KeyOf LabelMap
BlockId
from BlockId
to EdgeInfo
info) (LabelMap EdgeInfo -> [(KeyOf LabelMap, EdgeInfo)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap EdgeInfo
toMap))
    CFG
m

-- | Unordered list of edges with weight as Tuple (from,to,weight)
weightedEdgeList :: CFG -> [(BlockId,BlockId,EdgeWeight)]
weightedEdgeList :: CFG -> [(BlockId, BlockId, EdgeWeight)]
weightedEdgeList m :: CFG
m =
  (KeyOf LabelMap
 -> LabelMap EdgeInfo -> [(BlockId, BlockId, EdgeWeight)])
-> CFG -> [(BlockId, BlockId, EdgeWeight)]
forall (map :: * -> *) m a.
(IsMap map, Monoid m) =>
(KeyOf map -> a -> m) -> map a -> m
mapFoldMapWithKey
    (\from :: KeyOf LabelMap
from toMap :: LabelMap EdgeInfo
toMap ->
      ((BlockId, EdgeInfo) -> (BlockId, BlockId, EdgeWeight))
-> [(BlockId, EdgeInfo)] -> [(BlockId, BlockId, EdgeWeight)]
forall a b. (a -> b) -> [a] -> [b]
map (\(to :: BlockId
to,info :: EdgeInfo
info) ->
        (KeyOf LabelMap
BlockId
from,BlockId
to, EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info)) (LabelMap EdgeInfo -> [(KeyOf LabelMap, EdgeInfo)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList LabelMap EdgeInfo
toMap))
    CFG
m
      --  (\(from, tos) -> map (\(to,info) -> (from,to, edgeWeight info)) tos )

-- | Returns a unordered list of all edges without weights
edgeList :: CFG -> [Edge]
edgeList :: CFG -> [(BlockId, BlockId)]
edgeList m :: CFG
m =
        (KeyOf LabelMap -> LabelMap EdgeInfo -> [(BlockId, BlockId)])
-> CFG -> [(BlockId, BlockId)]
forall (map :: * -> *) m a.
(IsMap map, Monoid m) =>
(KeyOf map -> a -> m) -> map a -> m
mapFoldMapWithKey (\from :: KeyOf LabelMap
from toMap :: LabelMap EdgeInfo
toMap -> (BlockId -> (BlockId, BlockId))
-> [BlockId] -> [(BlockId, BlockId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (KeyOf LabelMap
BlockId
from,) (LabelMap EdgeInfo -> [KeyOf LabelMap]
forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap EdgeInfo
toMap)) CFG
m

-- | Get successors of a given node without edge weights.
getSuccessors :: CFG -> BlockId -> [BlockId]
getSuccessors :: CFG -> BlockId -> [BlockId]
getSuccessors m :: CFG
m bid :: BlockId
bid
    | Just wm :: LabelMap EdgeInfo
wm <- KeyOf LabelMap -> CFG -> Maybe (LabelMap EdgeInfo)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid CFG
m
    = LabelMap EdgeInfo -> [KeyOf LabelMap]
forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap EdgeInfo
wm
    | Bool
otherwise = []

pprEdgeWeights :: CFG -> SDoc
pprEdgeWeights :: CFG -> SDoc
pprEdgeWeights m :: CFG
m =
    let edges :: [(BlockId, BlockId, EdgeWeight)]
edges = [(BlockId, BlockId, EdgeWeight)]
-> [(BlockId, BlockId, EdgeWeight)]
forall a. Ord a => [a] -> [a]
sort ([(BlockId, BlockId, EdgeWeight)]
 -> [(BlockId, BlockId, EdgeWeight)])
-> [(BlockId, BlockId, EdgeWeight)]
-> [(BlockId, BlockId, EdgeWeight)]
forall a b. (a -> b) -> a -> b
$ CFG -> [(BlockId, BlockId, EdgeWeight)]
weightedEdgeList CFG
m
        printEdge :: (a, a, a) -> SDoc
printEdge (from :: a
from, to :: a
to, weight :: a
weight)
            = String -> SDoc
text "\t" SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
from SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "->" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
to SDoc -> SDoc -> SDoc
<>
              String -> SDoc
text "[label=\"" SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
weight SDoc -> SDoc -> SDoc
<> String -> SDoc
text "\",weight=\"" SDoc -> SDoc -> SDoc
<>
              a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
weight SDoc -> SDoc -> SDoc
<> String -> SDoc
text "\"];\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 node :: a
node
            = String -> SDoc
text "\t" SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
node SDoc -> SDoc -> SDoc
<> String -> SDoc
text ";\n"
        getEdgeNodes :: (a, a, c) -> [a]
getEdgeNodes (from :: a
from, to :: a
to, _weight :: c
_weight) = [a
from,a
to]
        edgeNodes :: LabelSet
edgeNodes = [ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList ([ElemOf LabelSet] -> LabelSet) -> [ElemOf LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$ ((BlockId, BlockId, EdgeWeight) -> [BlockId])
-> [(BlockId, BlockId, EdgeWeight)] -> [BlockId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BlockId, BlockId, EdgeWeight) -> [BlockId]
forall a c. (a, a, c) -> [a]
getEdgeNodes [(BlockId, BlockId, EdgeWeight)]
edges :: LabelSet
        nodes :: [BlockId]
nodes = (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\n :: BlockId
n -> (Bool -> Bool
not (Bool -> Bool) -> (LabelSet -> Bool) -> LabelSet -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
n) LabelSet
edgeNodes) ([BlockId] -> [BlockId]) -> (CFG -> [BlockId]) -> CFG -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> [BlockId]
forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys (CFG -> [BlockId]) -> CFG -> [BlockId]
forall a b. (a -> b) -> a -> b
$ (LabelMap EdgeInfo -> Bool) -> CFG -> CFG
forall (map :: * -> *) a.
IsMap map =>
(a -> Bool) -> map a -> map a
mapFilter LabelMap EdgeInfo -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
m
    in
    String -> SDoc
text "digraph {\n" SDoc -> SDoc -> SDoc
<>
        ((SDoc -> SDoc -> SDoc) -> SDoc -> [SDoc] -> SDoc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SDoc -> SDoc -> SDoc
(<>) SDoc
empty (((BlockId, BlockId, EdgeWeight) -> SDoc)
-> [(BlockId, BlockId, EdgeWeight)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, BlockId, EdgeWeight) -> SDoc
forall a a a.
(Outputable a, Outputable a, Outputable a) =>
(a, a, a) -> SDoc
printEdge [(BlockId, BlockId, EdgeWeight)]
edges)) SDoc -> SDoc -> SDoc
<>
        ((SDoc -> SDoc -> SDoc) -> SDoc -> [SDoc] -> SDoc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SDoc -> SDoc -> SDoc
(<>) SDoc
empty ((BlockId -> SDoc) -> [BlockId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> SDoc
forall a. Outputable a => a -> SDoc
printNode [BlockId]
nodes)) SDoc -> SDoc -> SDoc
<>
    String -> SDoc
text "}\n"

{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible
updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> (BlockId, BlockId) -> CFG -> CFG
updateEdgeWeight f :: EdgeWeight -> EdgeWeight
f (from :: BlockId
from, to :: BlockId
to) cfg :: CFG
cfg
    | Just oldInfo :: EdgeInfo
oldInfo <- BlockId -> BlockId -> CFG -> Maybe EdgeInfo
getEdgeInfo BlockId
from BlockId
to CFG
cfg
    = let oldWeight :: EdgeWeight
oldWeight = EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
oldInfo
          newWeight :: EdgeWeight
newWeight = EdgeWeight -> EdgeWeight
f EdgeWeight
oldWeight
      in BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge BlockId
from BlockId
to (EdgeInfo
oldInfo {edgeWeight :: EdgeWeight
edgeWeight = EdgeWeight
newWeight}) CFG
cfg
    | Bool
otherwise
    = String -> CFG
forall a. String -> a
panic "Trying to update invalid edge"

-- from to oldWeight => newWeight
mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
mapWeights f :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
f cfg :: CFG
cfg =
  (CFG -> CfgEdge -> CFG) -> CFG -> [CfgEdge] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\cfg :: CFG
cfg (CfgEdge from :: BlockId
from to :: BlockId
to info :: EdgeInfo
info) ->
            let oldWeight :: EdgeWeight
oldWeight = EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info
                newWeight :: EdgeWeight
newWeight = BlockId -> BlockId -> EdgeWeight -> EdgeWeight
f BlockId
from BlockId
to EdgeWeight
oldWeight
            in BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge BlockId
from BlockId
to (EdgeInfo
info {edgeWeight :: EdgeWeight
edgeWeight = 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 :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG
addNodesBetween :: CFG -> [(BlockId, BlockId, BlockId)] -> CFG
addNodesBetween m :: CFG
m updates :: [(BlockId, BlockId, BlockId)]
updates =
  (CFG -> (BlockId, BlockId, BlockId, EdgeInfo) -> CFG)
-> CFG -> [(BlockId, BlockId, BlockId, EdgeInfo)] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'  CFG -> (BlockId, BlockId, BlockId, EdgeInfo) -> CFG
updateWeight CFG
m ([(BlockId, BlockId, BlockId, EdgeInfo)] -> CFG)
-> ([(BlockId, BlockId, BlockId)]
    -> [(BlockId, BlockId, BlockId, EdgeInfo)])
-> [(BlockId, BlockId, BlockId)]
-> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [(BlockId, BlockId, BlockId)]
-> [(BlockId, BlockId, BlockId, EdgeInfo)]
weightUpdates ([(BlockId, BlockId, BlockId)] -> CFG)
-> [(BlockId, BlockId, BlockId)] -> CFG
forall a b. (a -> b) -> a -> b
$ [(BlockId, BlockId, BlockId)]
updates
    where
      weight :: EdgeWeight
weight = Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> EdgeWeight) -> (DynFlags -> Int) -> DynFlags -> EdgeWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CfgWeights -> Int
D.uncondWeight (CfgWeights -> Int) -> (DynFlags -> CfgWeights) -> DynFlags -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                DynFlags -> CfgWeights
D.cfgWeightInfo (DynFlags -> EdgeWeight) -> DynFlags -> EdgeWeight
forall a b. (a -> b) -> a -> b
$ DynFlags
D.unsafeGlobalDynFlags
      -- 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 :: [(BlockId, BlockId, BlockId)]
-> [(BlockId, BlockId, BlockId, EdgeInfo)]
weightUpdates = ((BlockId, BlockId, BlockId)
 -> (BlockId, BlockId, BlockId, EdgeInfo))
-> [(BlockId, BlockId, BlockId)]
-> [(BlockId, BlockId, BlockId, EdgeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, BlockId, BlockId)
-> (BlockId, BlockId, BlockId, EdgeInfo)
getWeight
      getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo)
      getWeight :: (BlockId, BlockId, BlockId)
-> (BlockId, BlockId, BlockId, EdgeInfo)
getWeight (from :: BlockId
from,between :: BlockId
between,old :: BlockId
old)
        | Just edgeInfo :: EdgeInfo
edgeInfo <- BlockId -> BlockId -> CFG -> Maybe EdgeInfo
getEdgeInfo BlockId
from BlockId
old CFG
m
        = (BlockId
from,BlockId
between,BlockId
old,EdgeInfo
edgeInfo)
        | Bool
otherwise
        = String -> SDoc -> (BlockId, BlockId, BlockId, EdgeInfo)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "Can't find weight for edge that should have one" (
            String -> SDoc
text "triple" SDoc -> SDoc -> SDoc
<+> (BlockId, BlockId, BlockId) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (BlockId
from,BlockId
between,BlockId
old) SDoc -> SDoc -> SDoc
$$
            String -> SDoc
text "updates" SDoc -> SDoc -> SDoc
<+> [(BlockId, BlockId, BlockId)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(BlockId, BlockId, BlockId)]
updates )
      updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG
      updateWeight :: CFG -> (BlockId, BlockId, BlockId, EdgeInfo) -> CFG
updateWeight m :: CFG
m (from :: BlockId
from,between :: BlockId
between,old :: BlockId
old,edgeInfo :: EdgeInfo
edgeInfo)
        = BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge BlockId
from BlockId
between EdgeInfo
edgeInfo (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
addWeightEdge BlockId
between BlockId
old EdgeWeight
weight (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          BlockId -> BlockId -> CFG -> CFG
delEdge BlockId
from BlockId
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 how often execution will transer control
  along each edge as well as how much we gain by placing eg A before
  C.

  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 completly:
        * 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 :: D.CfgWeights -> RawCmmDecl -> CFG
getCfgProc :: CfgWeights -> RawCmmDecl -> CFG
getCfgProc _       (CmmData {}) = CFG
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
-- Sometimes GHC generates dummy procs which don't actually contain code.
-- But they might contain bottoms in some fields so we check for an empty
-- body first. In particular this happens with SplitObjs enabled.
getCfgProc weights :: CfgWeights
weights (CmmProc _info :: LabelMap CmmStatics
_info _lab :: CLabel
_lab _live :: [GlobalReg]
_live graph :: CmmGraph
graph)
  | [CmmBlock] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CmmGraph -> [CmmBlock]
toBlockList CmmGraph
graph) = CFG
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
  | Bool
otherwise                = CfgWeights -> CmmGraph -> CFG
getCfg CfgWeights
weights CmmGraph
graph

getCfg :: D.CfgWeights -> CmmGraph -> CFG
getCfg :: CfgWeights -> CmmGraph -> CFG
getCfg weights :: CfgWeights
weights graph :: CmmGraph
graph =
  (CFG -> ((BlockId, BlockId), EdgeInfo) -> CFG)
-> CFG -> [((BlockId, BlockId), EdgeInfo)] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFG -> ((BlockId, BlockId), EdgeInfo) -> CFG
insertEdge CFG
edgelessCfg ([((BlockId, BlockId), EdgeInfo)] -> CFG)
-> [((BlockId, BlockId), EdgeInfo)] -> CFG
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> [((BlockId, BlockId), EdgeInfo)])
-> [CmmBlock] -> [((BlockId, BlockId), EdgeInfo)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CmmBlock -> [((BlockId, BlockId), EdgeInfo)]
getBlockEdges [CmmBlock]
blocks
  where
    D.CFGWeights
            { uncondWeight :: CfgWeights -> Int
D.uncondWeight = Int
uncondWeight
            , condBranchWeight :: CfgWeights -> Int
D.condBranchWeight = Int
condBranchWeight
            , switchWeight :: CfgWeights -> Int
D.switchWeight = Int
switchWeight
            , callWeight :: CfgWeights -> Int
D.callWeight = Int
callWeight
            , likelyCondWeight :: CfgWeights -> Int
D.likelyCondWeight = Int
likelyCondWeight
            , unlikelyCondWeight :: CfgWeights -> Int
D.unlikelyCondWeight = Int
unlikelyCondWeight
            --  Last two are used in other places
            --, D.infoTablePenalty = infoTablePenalty
            --, D.backEdgeBonus = backEdgeBonus
            } = CfgWeights
weights
    -- Explicitly add all nodes to the cfg to ensure they are part of the
    -- CFG.
    edgelessCfg :: CFG
edgelessCfg = [(KeyOf LabelMap, LabelMap EdgeInfo)] -> CFG
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([(KeyOf LabelMap, LabelMap EdgeInfo)] -> CFG)
-> [(KeyOf LabelMap, LabelMap EdgeInfo)] -> CFG
forall a b. (a -> b) -> a -> b
$ [BlockId] -> [LabelMap EdgeInfo] -> [(BlockId, LabelMap EdgeInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((CmmBlock -> BlockId) -> [CmmBlock] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map CmmBlock -> BlockId
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
G.entryLabel [CmmBlock]
blocks) (LabelMap EdgeInfo -> [LabelMap EdgeInfo]
forall a. a -> [a]
repeat LabelMap EdgeInfo
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
    insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG
    insertEdge :: CFG -> ((BlockId, BlockId), EdgeInfo) -> CFG
insertEdge m :: CFG
m ((from :: BlockId
from,to :: BlockId
to),weight :: EdgeInfo
weight) =
      (Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo))
-> KeyOf LabelMap -> CFG -> CFG
forall (map :: * -> *) a.
IsMap map =>
(Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAlter Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
f KeyOf LabelMap
BlockId
from CFG
m
        where
          f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
          f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
f 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
$ KeyOf LabelMap -> EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton KeyOf LabelMap
BlockId
to EdgeInfo
weight
          f (Just destMap :: 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
$ KeyOf LabelMap
-> EdgeInfo -> LabelMap EdgeInfo -> LabelMap EdgeInfo
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
to EdgeInfo
weight LabelMap EdgeInfo
destMap
    getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)]
    getBlockEdges :: CmmBlock -> [((BlockId, BlockId), EdgeInfo)]
getBlockEdges block :: CmmBlock
block =
      case CmmNode O C
branch of
        CmmBranch dest :: BlockId
dest -> [BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
dest Int
uncondWeight]
        CmmCondBranch _c :: CmmExpr
_c t :: BlockId
t f :: BlockId
f l :: 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 ->
              [BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
f Int
condBranchWeight,   BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
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 ->
              [BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
f Int
unlikelyCondWeight, BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
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 ->
              [BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
f Int
likelyCondWeight,   BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
t Int
unlikelyCondWeight]
        (CmmSwitch _e :: CmmExpr
_e ids :: SwitchTargets
ids) ->
          let switchTargets :: [BlockId]
switchTargets = SwitchTargets -> [BlockId]
switchTargetsToList SwitchTargets
ids
              --Compiler performance hack - for very wide switches don't
              --consider targets for layout.
              adjustedWeight :: Int
adjustedWeight =
                if ([BlockId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockId]
switchTargets Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) then -1 else Int
switchWeight
          in (BlockId -> ((BlockId, BlockId), EdgeInfo))
-> [BlockId] -> [((BlockId, BlockId), EdgeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: BlockId
x -> BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
x Int
adjustedWeight) [BlockId]
switchTargets
        (CmmCall { cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just cont :: BlockId
cont})  -> [BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
cont Int
callWeight]
        (CmmForeignCall {succ :: CmmNode O C -> BlockId
Cmm.succ = BlockId
cont}) -> [BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge BlockId
cont Int
callWeight]
        (CmmCall { cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Maybe BlockId
Nothing })   -> []
        other :: CmmNode O C
other ->
            String
-> [((BlockId, BlockId), EdgeInfo)]
-> [((BlockId, BlockId), EdgeInfo)]
forall a. String -> a
panic "Foo" ([((BlockId, BlockId), EdgeInfo)]
 -> [((BlockId, BlockId), EdgeInfo)])
-> [((BlockId, BlockId), EdgeInfo)]
-> [((BlockId, BlockId), EdgeInfo)]
forall a b. (a -> b) -> a -> b
$
            ASSERT2(False, ppr "Unkown successor cause:" <>
              (ppr branch <+> text "=>" <> ppr (G.successors other)))
            (BlockId -> ((BlockId, BlockId), EdgeInfo))
-> [BlockId] -> [((BlockId, BlockId), EdgeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: BlockId
x -> ((BlockId
bid,BlockId
x),Int -> EdgeInfo
mkEdgeInfo 0)) ([BlockId] -> [((BlockId, BlockId), EdgeInfo)])
-> [BlockId] -> [((BlockId, BlockId), EdgeInfo)]
forall a b. (a -> b) -> a -> b
$ CmmNode O C -> [BlockId]
forall (thing :: * -> * -> *) e.
NonLocal thing =>
thing e C -> [BlockId]
G.successors CmmNode O C
other
      where
        bid :: BlockId
bid = CmmBlock -> BlockId
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
G.entryLabel CmmBlock
block
        mkEdgeInfo :: Int -> EdgeInfo
mkEdgeInfo = TransitionSource -> EdgeWeight -> EdgeInfo
EdgeInfo (CmmNode O C -> TransitionSource
CmmSource CmmNode O C
branch) (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 :: BlockId -> Int -> ((BlockId, BlockId), EdgeInfo)
mkEdge target :: BlockId
target weight :: Int
weight = ((BlockId
bid,BlockId
target), Int -> EdgeInfo
mkEdgeInfo Int
weight)
        branch :: CmmNode O C
branch = CmmBlock -> CmmNode O C
forall (n :: * -> * -> *) x. 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 :: BlockId -> CFG -> Edges
findBackEdges :: BlockId -> CFG -> [(BlockId, BlockId)]
findBackEdges root :: BlockId
root cfg :: CFG
cfg =
    --pprTraceIt "Backedges:" $
    (((BlockId, BlockId), EdgeType) -> (BlockId, BlockId))
-> [((BlockId, BlockId), EdgeType)] -> [(BlockId, BlockId)]
forall a b. (a -> b) -> [a] -> [b]
map ((BlockId, BlockId), EdgeType) -> (BlockId, BlockId)
forall a b. (a, b) -> a
fst ([((BlockId, BlockId), EdgeType)] -> [(BlockId, BlockId)])
-> ([((BlockId, BlockId), EdgeType)]
    -> [((BlockId, BlockId), EdgeType)])
-> [((BlockId, BlockId), EdgeType)]
-> [(BlockId, BlockId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (((BlockId, BlockId), EdgeType) -> Bool)
-> [((BlockId, BlockId), EdgeType)]
-> [((BlockId, BlockId), EdgeType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: ((BlockId, BlockId), EdgeType)
x -> ((BlockId, BlockId), EdgeType) -> EdgeType
forall a b. (a, b) -> b
snd ((BlockId, BlockId), EdgeType)
x EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
Backward) ([((BlockId, BlockId), EdgeType)] -> [(BlockId, BlockId)])
-> [((BlockId, BlockId), EdgeType)] -> [(BlockId, BlockId)]
forall a b. (a -> b) -> a -> b
$ [((BlockId, BlockId), EdgeType)]
typedEdges
  where
    edges :: [(BlockId, BlockId)]
edges = CFG -> [(BlockId, BlockId)]
edgeList CFG
cfg :: [(BlockId,BlockId)]
    getSuccs :: BlockId -> [BlockId]
getSuccs = CFG -> BlockId -> [BlockId]
getSuccessors CFG
cfg :: BlockId -> [BlockId]
    typedEdges :: [((BlockId, BlockId), EdgeType)]
typedEdges =
      BlockId
-> (BlockId -> [BlockId])
-> [(BlockId, BlockId)]
-> [((BlockId, BlockId), EdgeType)]
forall key.
Uniquable key =>
key -> (key -> [key]) -> [(key, key)] -> [((key, key), EdgeType)]
classifyEdges BlockId
root BlockId -> [BlockId]
getSuccs [(BlockId, BlockId)]
edges :: [((BlockId,BlockId),EdgeType)]


optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
optimizeCFG :: CfgWeights -> RawCmmDecl -> CFG -> CFG
optimizeCFG _ (CmmData {}) cfg :: CFG
cfg = CFG
cfg
optimizeCFG weights :: CfgWeights
weights (CmmProc info :: LabelMap CmmStatics
info _lab :: CLabel
_lab _live :: [GlobalReg]
_live graph :: CmmGraph
graph) cfg :: CFG
cfg =
    CFG -> CFG
favourFewerPreds  (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    LabelMap CmmStatics -> CFG -> CFG
forall a. LabelMap a -> CFG -> CFG
penalizeInfoTables LabelMap CmmStatics
info (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    BlockId -> CFG -> CFG
increaseBackEdgeWeight (CmmGraph -> BlockId
forall (n :: * -> * -> *). GenCmmGraph n -> BlockId
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 :: BlockId -> CFG -> CFG
increaseBackEdgeWeight root :: BlockId
root cfg :: CFG
cfg =
        let backedges :: [(BlockId, BlockId)]
backedges = BlockId -> CFG -> [(BlockId, BlockId)]
findBackEdges BlockId
root CFG
cfg
            update :: EdgeWeight -> EdgeWeight
update weight :: EdgeWeight
weight
              --Keep irrelevant edges irrelevant
              | EdgeWeight
weight EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = 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 (CfgWeights -> Int
D.backEdgeBonus CfgWeights
weights)
        in  (CFG -> (BlockId, BlockId) -> CFG)
-> CFG -> [(BlockId, BlockId)] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'  (\cfg :: CFG
cfg edge :: (BlockId, BlockId)
edge -> (EdgeWeight -> EdgeWeight) -> (BlockId, BlockId) -> CFG -> CFG
updateEdgeWeight EdgeWeight -> EdgeWeight
update (BlockId, BlockId)
edge CFG
cfg)
                    CFG
cfg [(BlockId, BlockId)]
backedges

    -- | Since we cant fall through info tables we penalize these.
    penalizeInfoTables :: LabelMap a -> CFG -> CFG
    penalizeInfoTables :: LabelMap a -> CFG -> CFG
penalizeInfoTables info :: LabelMap a
info cfg :: CFG
cfg =
        (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
mapWeights BlockId -> BlockId -> EdgeWeight -> EdgeWeight
fupdate CFG
cfg
      where
        fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
        fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
fupdate _ to :: BlockId
to weight :: EdgeWeight
weight
          | KeyOf LabelMap -> LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
BlockId
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
$ CfgWeights -> Int
D.infoTablePenalty CfgWeights
weights)
          | Bool
otherwise = EdgeWeight
weight


{- Note [Optimize for Fallthrough]

-}
    -- | If a block has two successors, favour the one with fewer
    -- predecessors. (As that one is more likely to become a fallthrough)
    favourFewerPreds :: CFG -> CFG
    favourFewerPreds :: CFG -> CFG
favourFewerPreds cfg :: CFG
cfg =
        let
            revCfg :: CFG
revCfg =
              CFG -> CFG
reverseEdges (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges
                              (\_from :: BlockId
_from -> BlockId -> EdgeInfo -> Bool
fallthroughTarget)  CFG
cfg

            predCount :: BlockId -> Int
predCount n :: BlockId
n = [(BlockId, EdgeInfo)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(BlockId, EdgeInfo)] -> Int) -> [(BlockId, EdgeInfo)] -> Int
forall a b. (a -> b) -> a -> b
$ CFG -> BlockId -> [(BlockId, EdgeInfo)]
getSuccessorEdges CFG
revCfg BlockId
n
            nodes :: LabelSet
nodes = CFG -> LabelSet
getCfgNodes CFG
cfg

            modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
            modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
modifiers preds1 :: Int
preds1 preds2 :: Int
preds2
              | Int
preds1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
preds2 = ( 1,-1)
              | Int
preds1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
preds2 = ( 0, 0)
              | Bool
otherwise        = (-1, 1)

            update :: CFG -> BlockId -> CFG
update cfg :: CFG
cfg node :: BlockId
node
              | [(s1 :: BlockId
s1,e1 :: EdgeInfo
e1),(s2 :: BlockId
s2,e2 :: EdgeInfo
e2)] <- CFG -> BlockId -> [(BlockId, EdgeInfo)]
getSuccessorEdges CFG
cfg BlockId
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
              , (mod1 :: EdgeWeight
mod1,mod2 :: EdgeWeight
mod2) <- Int -> Int -> (EdgeWeight, EdgeWeight)
modifiers (BlockId -> Int
predCount BlockId
s1) (BlockId -> Int
predCount BlockId
s2)
              = (\cfg' :: CFG
cfg' ->
                  (CFG -> (EdgeWeight -> EdgeWeight) -> BlockId -> BlockId -> CFG
adjustEdgeWeight CFG
cfg' (EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+EdgeWeight
mod2) BlockId
node BlockId
s2))
                  (CFG -> (EdgeWeight -> EdgeWeight) -> BlockId -> BlockId -> CFG
adjustEdgeWeight CFG
cfg  (EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+EdgeWeight
mod1) BlockId
node BlockId
s1)
              | Bool
otherwise
              = CFG
cfg
        in (CFG -> ElemOf LabelSet -> CFG) -> CFG -> LabelSet -> CFG
forall set b. IsSet set => (b -> ElemOf set -> b) -> b -> set -> b
setFoldl CFG -> ElemOf LabelSet -> CFG
CFG -> BlockId -> CFG
update CFG
cfg LabelSet
nodes
      where
        fallthroughTarget :: BlockId -> EdgeInfo -> Bool
        fallthroughTarget :: BlockId -> EdgeInfo -> Bool
fallthroughTarget to :: BlockId
to (EdgeInfo source :: TransitionSource
source _weight :: EdgeWeight
_weight)
          | KeyOf LabelMap -> LabelMap CmmStatics -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
BlockId
to LabelMap CmmStatics
info = Bool
False
          | TransitionSource
AsmCodeGen <- TransitionSource
source = Bool
True
          | CmmSource (CmmBranch {}) <- TransitionSource
source = Bool
True
          | CmmSource (CmmCondBranch {}) <- TransitionSource
source = Bool
True
          | Bool
otherwise = Bool
False

-- | Determine loop membership of blocks based on SCC analysis
--   Ideally we would replace this with a variant giving us loop
--   levels instead but the SCC code will do for now.
loopMembers :: CFG -> LabelMap Bool
loopMembers :: CFG -> LabelMap Bool
loopMembers cfg :: CFG
cfg =
    (LabelMap Bool -> SCC BlockId -> LabelMap Bool)
-> LabelMap Bool -> [SCC BlockId] -> LabelMap Bool
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((SCC BlockId -> LabelMap Bool -> LabelMap Bool)
-> LabelMap Bool -> SCC BlockId -> LabelMap Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip SCC BlockId -> LabelMap Bool -> LabelMap Bool
setLevel) LabelMap Bool
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [SCC BlockId]
sccs
  where
    mkNode :: BlockId -> Node BlockId BlockId
    mkNode :: BlockId -> Node BlockId BlockId
mkNode bid :: BlockId
bid = BlockId -> BlockId -> [BlockId] -> Node BlockId BlockId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode BlockId
bid BlockId
bid (CFG -> BlockId -> [BlockId]
getSuccessors CFG
cfg BlockId
bid)
    nodes :: [Node BlockId BlockId]
nodes = (BlockId -> Node BlockId BlockId)
-> [BlockId] -> [Node BlockId BlockId]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> Node BlockId BlockId
mkNode (LabelSet -> [BlockId]
forall set. IsSet set => set -> [ElemOf set]
setElems (LabelSet -> [BlockId]) -> LabelSet -> [BlockId]
forall a b. (a -> b) -> a -> b
$ CFG -> LabelSet
getCfgNodes CFG
cfg)

    sccs :: [SCC BlockId]
sccs = [Node BlockId BlockId] -> [SCC BlockId]
forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd [Node BlockId BlockId]
nodes

    setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
    setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
setLevel (AcyclicSCC bid :: BlockId
bid) m :: LabelMap Bool
m = KeyOf LabelMap -> Bool -> LabelMap Bool -> LabelMap Bool
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
bid Bool
False LabelMap Bool
m
    setLevel (CyclicSCC bids :: [BlockId]
bids) m :: LabelMap Bool
m = (LabelMap Bool -> BlockId -> LabelMap Bool)
-> LabelMap Bool -> [BlockId] -> LabelMap Bool
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\m :: LabelMap Bool
m k :: BlockId
k -> KeyOf LabelMap -> Bool -> LabelMap Bool -> LabelMap Bool
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
k Bool
True LabelMap Bool
m) LabelMap Bool
m [BlockId]
bids