{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmContFlowOpt
    ( cmmCfgOpts
    , cmmCfgOptsProc
    , removeUnreachableBlocksProc
    , replaceLabels
    )
where

import GhcPrelude hiding (succ, unzip, zip)

import Hoopl.Block
import Hoopl.Collections
import Hoopl.Graph
import Hoopl.Label
import BlockId
import Cmm
import CmmUtils
import CmmSwitch (mapSwitchTargets, switchTargetsToList)
import Maybes
import Panic
import Util

import Control.Monad


-- Note [What is shortcutting]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Consider this Cmm code:
--
-- L1: ...
--     goto L2;
-- L2: goto L3;
-- L3: ...
--
-- Here L2 is an empty block and contains only an unconditional branch
-- to L3. In this situation any block that jumps to L2 can jump
-- directly to L3:
--
-- L1: ...
--     goto L3;
-- L2: goto L3;
-- L3: ...
--
-- In this situation we say that we shortcut L2 to L3. One of
-- consequences of shortcutting is that some blocks of code may become
-- unreachable (in the example above this is true for L2).


-- Note [Control-flow optimisations]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- This optimisation does three things:
--
--   - If a block finishes in an unconditional branch to another block
--     and that is the only jump to that block we concatenate the
--     destination block at the end of the current one.
--
--   - If a block finishes in a call whose continuation block is a
--     goto, then we can shortcut the destination, making the
--     continuation block the destination of the goto - but see Note
--     [Shortcut call returns].
--
--   - For any block that is not a call we try to shortcut the
--     destination(s). Additionally, if a block ends with a
--     conditional branch we try to invert the condition.
--
-- Blocks are processed using postorder DFS traversal. A side effect
-- of determining traversal order with a graph search is elimination
-- of any blocks that are unreachable.
--
-- Transformations are improved by working from the end of the graph
-- towards the beginning, because we may be able to perform many
-- shortcuts in one go.


-- Note [Shortcut call returns]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We are going to maintain the "current" graph (LabelMap CmmBlock) as
-- we go, and also a mapping from BlockId to BlockId, representing
-- continuation labels that we have renamed.  This latter mapping is
-- important because we might shortcut a CmmCall continuation.  For
-- example:
--
--    Sp[0] = L
--    call g returns to L
--    L: goto M
--    M: ...
--
-- So when we shortcut the L block, we need to replace not only
-- the continuation of the call, but also references to L in the
-- code (e.g. the assignment Sp[0] = L):
--
--    Sp[0] = M
--    call g returns to M
--    M: ...
--
-- So we keep track of which labels we have renamed and apply the mapping
-- at the end with replaceLabels.


-- Note [Shortcut call returns and proc-points]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Consider this code that you might get from a recursive
-- let-no-escape:
--
--       goto L1
--      L1:
--       if (Hp > HpLim) then L2 else L3
--      L2:
--       call stg_gc_noregs returns to L4
--      L4:
--       goto L1
--      L3:
--       ...
--       goto L1
--
-- Then the control-flow optimiser shortcuts L4.  But that turns L1
-- into the call-return proc point, and every iteration of the loop
-- has to shuffle variables to and from the stack.  So we must *not*
-- shortcut L4.
--
-- Moreover not shortcutting call returns is probably fine.  If L4 can
-- concat with its branch target then it will still do so.  And we
-- save some compile time because we don't have to traverse all the
-- code in replaceLabels.
--
-- However, we probably do want to do this if we are splitting proc
-- points, because L1 will be a proc-point anyway, so merging it with
-- L4 reduces the number of proc points.  Unfortunately recursive
-- let-no-escapes won't generate very good code with proc-point
-- splitting on - we should probably compile them to explicitly use
-- the native calling convention instead.

cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts Bool
split CmmGraph
g = (CmmGraph, LabelMap BlockId) -> CmmGraph
forall a b. (a, b) -> a
fst (Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat Bool
split CmmGraph
g)

cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc Bool
split (CmmProc CmmTopInfo
info CLabel
lbl [GlobalReg]
live CmmGraph
g) = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
info' CLabel
lbl [GlobalReg]
live CmmGraph
g'
    where (CmmGraph
g', LabelMap BlockId
env) = Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat Bool
split CmmGraph
g
          info' :: CmmTopInfo
info' = CmmTopInfo
info{ info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
new_info_tbls }
          new_info_tbls :: LabelMap CmmInfoTable
new_info_tbls = [(KeyOf LabelMap, CmmInfoTable)] -> LabelMap CmmInfoTable
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList (((BlockId, CmmInfoTable) -> (BlockId, CmmInfoTable))
-> [(BlockId, CmmInfoTable)] -> [(BlockId, CmmInfoTable)]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, CmmInfoTable) -> (BlockId, CmmInfoTable)
upd_info (LabelMap CmmInfoTable -> [(KeyOf LabelMap, CmmInfoTable)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
info)))

          -- If we changed any labels, then we have to update the info tables
          -- too, except for the top-level info table because that might be
          -- referred to by other procs.
          upd_info :: (BlockId, CmmInfoTable) -> (BlockId, CmmInfoTable)
upd_info (BlockId
k,CmmInfoTable
info)
             | Just BlockId
k' <- KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
k LabelMap BlockId
env
             = (BlockId
k', if BlockId
k' BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g'
                       then CmmInfoTable
info
                       else CmmInfoTable
info{ cit_lbl :: CLabel
cit_lbl = BlockId -> CLabel
infoTblLbl BlockId
k' })
             | Bool
otherwise
             = (BlockId
k,CmmInfoTable
info)
cmmCfgOptsProc Bool
_ CmmDecl
top = CmmDecl
top


blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat Bool
splitting_procs g :: CmmGraph
g@CmmGraph { g_entry :: forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry = BlockId
entry_id }
  = (LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels LabelMap BlockId
shortcut_map (CmmGraph -> CmmGraph) -> CmmGraph -> CmmGraph
forall a b. (a -> b) -> a -> b
$ BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap BlockId
new_entry LabelMap CmmBlock
new_blocks, LabelMap BlockId
shortcut_map')
  where
     -- We might be able to shortcut the entry BlockId itself.
     -- Remember to update the shortcut_map, since we also have to
     -- update the info_tbls mapping now.
     (BlockId
new_entry, LabelMap BlockId
shortcut_map')
       | Just CmmBlock
entry_blk <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
entry_id LabelMap CmmBlock
new_blocks
       , Just BlockId
dest      <- CmmBlock -> Maybe BlockId
canShortcut CmmBlock
entry_blk
       = (BlockId
dest, KeyOf LabelMap -> BlockId -> LabelMap BlockId -> LabelMap BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
entry_id BlockId
dest LabelMap BlockId
shortcut_map)
       | Bool
otherwise
       = (BlockId
entry_id, LabelMap BlockId
shortcut_map)

     -- blocks are sorted in reverse postorder, but we want to go from the exit
     -- towards beginning, so we use foldr below.
     blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
g
     blockmap :: LabelMap CmmBlock
blockmap = (LabelMap CmmBlock -> CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> [CmmBlock] -> LabelMap CmmBlock
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> CmmBlock -> LabelMap CmmBlock
forall a b c. (a -> b -> c) -> b -> a -> c
flip CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, HasDebugCallStack) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock) LabelMap CmmBlock
forall (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *).
Body' block n
emptyBody [CmmBlock]
blocks

     -- Accumulator contains three components:
     --  * map of blocks in a graph
     --  * map of shortcut labels. See Note [Shortcut call returns]
     --  * map containing number of predecessors for each block. We discard
     --    it after we process all blocks.
     (LabelMap CmmBlock
new_blocks, LabelMap BlockId
shortcut_map, LabelMap Int
_) =
           (CmmBlock
 -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
 -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int))
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> [CmmBlock]
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
maybe_concat (LabelMap CmmBlock
blockmap, LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a
mapEmpty, LabelMap Int
initialBackEdges) [CmmBlock]
blocks

     -- Map of predecessors for initial graph. We increase number of
     -- predecessors for entry block by one to denote that it is
     -- target of a jump, even if no block in the current graph jumps
     -- to it.
     initialBackEdges :: LabelMap Int
initialBackEdges = BlockId -> LabelMap Int -> LabelMap Int
incPreds BlockId
entry_id ([CmmBlock] -> LabelMap Int
predMap [CmmBlock]
blocks)

     maybe_concat :: CmmBlock
                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
     maybe_concat :: CmmBlock
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
maybe_concat CmmBlock
block (!LabelMap CmmBlock
blocks, !LabelMap BlockId
shortcut_map, !LabelMap Int
backEdges)
        -- If:
        --   (1) current block ends with unconditional branch to b' and
        --   (2) it has exactly one predecessor (namely, current block)
        --
        -- Then:
        --   (1) append b' block at the end of current block
        --   (2) remove b' from the map of blocks
        --   (3) remove information about b' from predecessors map
        --
        -- Since we know that the block has only one predecessor we call
        -- mapDelete directly instead of calling decPreds.
        --
        -- Note that we always maintain an up-to-date list of predecessors, so
        -- we can ignore the contents of shortcut_map
        | CmmBranch BlockId
b' <- CmmNode O C
last
        , BlockId -> Bool
hasOnePredecessor BlockId
b'
        , Just CmmBlock
blk' <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
b' LabelMap CmmBlock
blocks
        = let bid' :: BlockId
bid' = CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
blk'
          in ( KeyOf LabelMap -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
bid' (LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> LabelMap CmmBlock
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
bid (Block CmmNode C O -> CmmBlock -> CmmBlock
splice Block CmmNode C O
head CmmBlock
blk') LabelMap CmmBlock
blocks
             , LabelMap BlockId
shortcut_map
             , KeyOf LabelMap -> LabelMap Int -> LabelMap Int
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
b' LabelMap Int
backEdges )

        -- If:
        --   (1) we are splitting proc points (see Note
        --       [Shortcut call returns and proc-points]) and
        --   (2) current block is a CmmCall or CmmForeignCall with
        --       continuation b' and
        --   (3) we can shortcut that continuation to dest
        -- Then:
        --   (1) we change continuation to point to b'
        --   (2) create mapping from b' to dest
        --   (3) increase number of predecessors of dest by 1
        --   (4) decrease number of predecessors of b' by 1
        --
        -- Later we will use replaceLabels to substitute all occurrences of b'
        -- with dest.
        | Bool
splitting_procs
        , Just BlockId
b'   <- CmmNode O C -> Maybe BlockId
callContinuation_maybe CmmNode O C
last
        , Just CmmBlock
blk' <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
b' LabelMap CmmBlock
blocks
        , Just BlockId
dest <- CmmBlock -> Maybe BlockId
canShortcut CmmBlock
blk'
        = ( KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
bid (Block CmmNode C O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
head (BlockId -> CmmNode O C
update_cont BlockId
dest)) LabelMap CmmBlock
blocks
          , KeyOf LabelMap -> BlockId -> LabelMap BlockId -> LabelMap BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
b' BlockId
dest LabelMap BlockId
shortcut_map
          , BlockId -> LabelMap Int -> LabelMap Int
decPreds BlockId
b' (LabelMap Int -> LabelMap Int) -> LabelMap Int -> LabelMap Int
forall a b. (a -> b) -> a -> b
$ BlockId -> LabelMap Int -> LabelMap Int
incPreds BlockId
dest LabelMap Int
backEdges )

        -- If:
        --   (1) a block does not end with a call
        -- Then:
        --   (1) if it ends with a conditional attempt to invert the
        --       conditional
        --   (2) attempt to shortcut all destination blocks
        --   (3) if new successors of a block are different from the old ones
        --       update the of predecessors accordingly
        --
        -- A special case of this is a situation when a block ends with an
        -- unconditional jump to a block that can be shortcut.
        | Maybe BlockId
Nothing <- CmmNode O C -> Maybe BlockId
callContinuation_maybe CmmNode O C
last
        = let oldSuccs :: [BlockId]
oldSuccs = CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last
              newSuccs :: [BlockId]
newSuccs = CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
rewrite_last
          in ( KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
bid (Block CmmNode C O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
head CmmNode O C
rewrite_last) LabelMap CmmBlock
blocks
             , LabelMap BlockId
shortcut_map
             , if [BlockId]
oldSuccs [BlockId] -> [BlockId] -> Bool
forall a. Eq a => a -> a -> Bool
== [BlockId]
newSuccs
               then LabelMap Int
backEdges
               else (BlockId -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [BlockId] -> LabelMap Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockId -> LabelMap Int -> LabelMap Int
incPreds ((BlockId -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [BlockId] -> LabelMap Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockId -> LabelMap Int -> LabelMap Int
decPreds LabelMap Int
backEdges [BlockId]
oldSuccs) [BlockId]
newSuccs )

        -- Otherwise don't do anything
        | Bool
otherwise
        = ( LabelMap CmmBlock
blocks, LabelMap BlockId
shortcut_map, LabelMap Int
backEdges )
        where
          (Block CmmNode C O
head, CmmNode O C
last) = CmmBlock -> (Block CmmNode C O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e C -> (Block n e O, n O C)
blockSplitTail CmmBlock
block
          bid :: BlockId
bid = CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block

          -- Changes continuation of a call to a specified label
          update_cont :: BlockId -> CmmNode O C
update_cont BlockId
dest =
              case CmmNode O C
last of
                CmmCall{}        -> CmmNode O C
last { cml_cont :: Maybe BlockId
cml_cont = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
dest }
                CmmForeignCall{} -> CmmNode O C
last { succ :: BlockId
succ = BlockId
dest }
                CmmNode O C
_                -> String -> CmmNode O C
forall a. String -> a
panic String
"Can't shortcut continuation."

          -- Attempts to shortcut successors of last node
          shortcut_last :: CmmNode O C
shortcut_last = (BlockId -> BlockId) -> CmmNode O C -> CmmNode O C
mapSuccessors BlockId -> BlockId
shortcut CmmNode O C
last
            where
              shortcut :: BlockId -> BlockId
shortcut BlockId
l =
                 case KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap CmmBlock
blocks of
                   Just CmmBlock
b | Just BlockId
dest <- CmmBlock -> Maybe BlockId
canShortcut CmmBlock
b -> BlockId
dest
                   Maybe CmmBlock
_otherwise -> BlockId
l

          rewrite_last :: CmmNode O C
rewrite_last
            -- Sometimes we can get rid of the conditional completely.
            | CmmCondBranch CmmExpr
_cond BlockId
t BlockId
f Maybe Bool
_l <- CmmNode O C
shortcut_last
            , BlockId
t BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
f
            = BlockId -> CmmNode O C
CmmBranch BlockId
t

            -- See Note [Invert Cmm conditionals]
            | CmmCondBranch CmmExpr
cond BlockId
t BlockId
f Maybe Bool
l <- CmmNode O C
shortcut_last
            , BlockId -> Bool
hasOnePredecessor BlockId
t -- inverting will make t a fallthrough
            , Maybe Bool -> Bool
likelyTrue Maybe Bool
l Bool -> Bool -> Bool
|| (BlockId -> Int
numPreds BlockId
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
            , Just CmmExpr
cond' <- CmmExpr -> Maybe CmmExpr
maybeInvertCmmExpr CmmExpr
cond
            = CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
cond' BlockId
f BlockId
t (Maybe Bool -> Maybe Bool
invertLikeliness Maybe Bool
l)

            -- If all jump destinations of a switch go to the
            -- same target eliminate the switch.
            | CmmSwitch CmmExpr
_expr SwitchTargets
targets <- CmmNode O C
shortcut_last
            , (BlockId
t:[BlockId]
ts) <- SwitchTargets -> [BlockId]
switchTargetsToList SwitchTargets
targets
            , (BlockId -> Bool) -> [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
t) [BlockId]
ts
            = BlockId -> CmmNode O C
CmmBranch BlockId
t

            | Bool
otherwise
            = CmmNode O C
shortcut_last

          likelyTrue :: Maybe Bool -> Bool
likelyTrue (Just Bool
True)   = Bool
True
          likelyTrue Maybe Bool
_             = Bool
False

          invertLikeliness :: Maybe Bool -> Maybe Bool
          invertLikeliness :: Maybe Bool -> Maybe Bool
invertLikeliness         = (Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not

          -- Number of predecessors for a block
          numPreds :: BlockId -> Int
numPreds BlockId
bid = KeyOf LabelMap -> LabelMap Int -> Maybe Int
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid LabelMap Int
backEdges Maybe Int -> Int -> Int
forall a. Maybe a -> a -> a
`orElse` Int
0

          hasOnePredecessor :: BlockId -> Bool
hasOnePredecessor BlockId
b = BlockId -> Int
numPreds BlockId
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1

{-
  Note [Invert Cmm conditionals]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  The native code generator always produces jumps to the true branch.
  Falling through to the false branch is however faster. So we try to
  arrange for that to happen.
  This means we invert the condition if:
  * The likely path will become a fallthrough.
  * We can't guarantee a fallthrough for the false branch but for the
    true branch.

  In some cases it's faster to avoid inverting when the false branch is likely.
  However determining when that is the case is neither easy nor cheap so for
  now we always invert as this produces smaller binaries and code that is
  equally fast on average. (On an i7-6700K)

  TODO:
  There is also the edge case when both branches have multiple predecessors.
  In this case we could assume that we will end up with a jump for BOTH
  branches. In this case it might be best to put the likely path in the true
  branch especially if there are large numbers of predecessors as this saves
  us the jump thats not taken. However I haven't tested this and as of early
  2018 we almost never generate cmm where this would apply.
-}

-- Functions for incrementing and decrementing number of predecessors. If
-- decrementing would set the predecessor count to 0, we remove entry from the
-- map.
-- Invariant: if a block has no predecessors it should be dropped from the
-- graph because it is unreachable. maybe_concat is constructed to maintain
-- that invariant, but calling replaceLabels may introduce unreachable blocks.
-- We rely on subsequent passes in the Cmm pipeline to remove unreachable
-- blocks.
incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
incPreds :: BlockId -> LabelMap Int -> LabelMap Int
incPreds BlockId
bid LabelMap Int
edges = (Int -> Int -> Int)
-> KeyOf LabelMap -> Int -> LabelMap Int -> LabelMap Int
forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) KeyOf LabelMap
BlockId
bid Int
1 LabelMap Int
edges
decPreds :: BlockId -> LabelMap Int -> LabelMap Int
decPreds BlockId
bid LabelMap Int
edges = case KeyOf LabelMap -> LabelMap Int -> Maybe Int
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid LabelMap Int
edges of
                       Just Int
preds | Int
preds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> KeyOf LabelMap -> Int -> LabelMap Int -> LabelMap Int
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
bid (Int
preds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) LabelMap Int
edges
                       Just Int
_                 -> KeyOf LabelMap -> LabelMap Int -> LabelMap Int
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
bid LabelMap Int
edges
                       Maybe Int
_                      -> LabelMap Int
edges


-- Checks if a block consists only of "goto dest". If it does than we return
-- "Just dest" label. See Note [What is shortcutting]
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut CmmBlock
block
    | (CmmNode C O
_, Block CmmNode O O
middle, CmmBranch BlockId
dest) <- CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
    , (CmmNode O O -> Bool) -> [CmmNode O O] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CmmNode O O -> Bool
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Bool
dont_care ([CmmNode O O] -> Bool) -> [CmmNode O O] -> Bool
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
middle
    = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
dest
    | Bool
otherwise
    = Maybe BlockId
forall a. Maybe a
Nothing
    where dont_care :: CmmNode e x -> Bool
dont_care CmmComment{} = Bool
True
          dont_care CmmTick{}    = Bool
True
          dont_care CmmNode e x
_other       = Bool
False

-- Concatenates two blocks. First one is assumed to be open on exit, the second
-- is assumed to be closed on entry (i.e. it has a label attached to it, which
-- the splice function removes by calling snd on result of blockSplitHead).
splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
splice Block CmmNode C O
head CmmBlock
rest = CmmNode C O
entry CmmNode C O -> Block CmmNode O O -> Block CmmNode C O
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n C O -> Block n O x -> Block n C x
`blockJoinHead` Block CmmNode O O
code0 Block CmmNode C O -> Block CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e O -> Block n O x -> Block n e x
`blockAppend` Block CmmNode O C
code1
  where (CmmEntry BlockId
lbl CmmTickScope
sc0, Block CmmNode O O
code0) = Block CmmNode C O -> (CmmNode C O, Block CmmNode O O)
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
Block n C x -> (n C O, Block n O x)
blockSplitHead Block CmmNode C O
head
        (CmmEntry BlockId
_   CmmTickScope
sc1, Block CmmNode O C
code1) = CmmBlock -> (CmmNode C O, Block CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
Block n C x -> (n C O, Block n O x)
blockSplitHead CmmBlock
rest
        entry :: CmmNode C O
entry = BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
lbl (CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes CmmTickScope
sc0 CmmTickScope
sc1)

-- If node is a call with continuation call return Just label of that
-- continuation. Otherwise return Nothing.
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
callContinuation_maybe (CmmCall { cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
b }) = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
b
callContinuation_maybe (CmmForeignCall { succ :: CmmNode O C -> BlockId
succ = BlockId
b })   = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
b
callContinuation_maybe CmmNode O C
_ = Maybe BlockId
forall a. Maybe a
Nothing


-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied LabelMap.
replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels LabelMap BlockId
env CmmGraph
g
  | LabelMap BlockId -> Bool
forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap BlockId
env = CmmGraph
g
  | Bool
otherwise   = CmmGraph -> CmmGraph
replace_eid (CmmGraph -> CmmGraph) -> CmmGraph -> CmmGraph
forall a b. (a -> b) -> a -> b
$ (forall (e :: Extensibility) (x :: Extensibility).
 CmmNode e x -> CmmNode e x)
-> CmmGraph -> CmmGraph
mapGraphNodes1 forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
txnode CmmGraph
g
   where
     replace_eid :: CmmGraph -> CmmGraph
replace_eid CmmGraph
g = CmmGraph
g {g_entry :: BlockId
g_entry = BlockId -> BlockId
lookup (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g)}
     lookup :: BlockId -> BlockId
lookup BlockId
id = KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
id LabelMap BlockId
env Maybe BlockId -> BlockId -> BlockId
forall a. Maybe a -> a -> a
`orElse` BlockId
id

     txnode :: CmmNode e x -> CmmNode e x
     txnode :: CmmNode e x -> CmmNode e x
txnode (CmmBranch BlockId
bid) = BlockId -> CmmNode O C
CmmBranch (BlockId -> BlockId
lookup BlockId
bid)
     txnode (CmmCondBranch CmmExpr
p BlockId
t BlockId
f Maybe Bool
l) =
       CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
mkCmmCondBranch (CmmExpr -> CmmExpr
exp CmmExpr
p) (BlockId -> BlockId
lookup BlockId
t) (BlockId -> BlockId
lookup BlockId
f) Maybe Bool
l
     txnode (CmmSwitch CmmExpr
e SwitchTargets
ids) =
       CmmExpr -> SwitchTargets -> CmmNode O C
CmmSwitch (CmmExpr -> CmmExpr
exp CmmExpr
e) ((BlockId -> BlockId) -> SwitchTargets -> SwitchTargets
mapSwitchTargets BlockId -> BlockId
lookup SwitchTargets
ids)
     txnode (CmmCall CmmExpr
t Maybe BlockId
k [GlobalReg]
rg Int
a Int
res Int
r) =
       CmmExpr
-> Maybe BlockId -> [GlobalReg] -> Int -> Int -> Int -> CmmNode O C
CmmCall (CmmExpr -> CmmExpr
exp CmmExpr
t) ((BlockId -> BlockId) -> Maybe BlockId -> Maybe BlockId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM BlockId -> BlockId
lookup Maybe BlockId
k) [GlobalReg]
rg Int
a Int
res Int
r
     txnode fc :: CmmNode e x
fc@CmmForeignCall{} =
       CmmNode e x
fc{ args :: [CmmExpr]
args = (CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> CmmExpr
exp (CmmNode O C -> [CmmExpr]
args CmmNode e x
CmmNode O C
fc), succ :: BlockId
succ = BlockId -> BlockId
lookup (CmmNode O C -> BlockId
succ CmmNode e x
CmmNode O C
fc) }
     txnode CmmNode e x
other = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep CmmExpr -> CmmExpr
exp CmmNode e x
other

     exp :: CmmExpr -> CmmExpr
     exp :: CmmExpr -> CmmExpr
exp (CmmLit (CmmBlock BlockId
bid))                = CmmLit -> CmmExpr
CmmLit (BlockId -> CmmLit
CmmBlock (BlockId -> BlockId
lookup BlockId
bid))
     exp (CmmStackSlot (Young BlockId
id) Int
i) = Area -> Int -> CmmExpr
CmmStackSlot (BlockId -> Area
Young (BlockId -> BlockId
lookup BlockId
id)) Int
i
     exp CmmExpr
e                                      = CmmExpr
e

mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
mkCmmCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
mkCmmCondBranch CmmExpr
p BlockId
t BlockId
f Maybe Bool
l =
  if BlockId
t BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
f then BlockId -> CmmNode O C
CmmBranch BlockId
t else CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
p BlockId
t BlockId
f Maybe Bool
l

-- Build a map from a block to its set of predecessors.
predMap :: [CmmBlock] -> LabelMap Int
predMap :: [CmmBlock] -> LabelMap Int
predMap [CmmBlock]
blocks = (CmmBlock -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [CmmBlock] -> LabelMap Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock -> LabelMap Int -> LabelMap Int
forall (map :: * -> *) a
       (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
(IsMap map, Num a, NonLocal thing, KeyOf map ~ BlockId) =>
thing e C -> map a -> map a
add_preds LabelMap Int
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [CmmBlock]
blocks
  where
    add_preds :: thing e C -> map a -> map a
add_preds thing e C
block map a
env = (BlockId -> map a -> map a) -> map a -> [BlockId] -> map a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockId -> map a -> map a
forall (map :: * -> *) a.
(IsMap map, Num a) =>
KeyOf map -> map a -> map a
add map a
env (thing e C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors thing e C
block)
      where add :: KeyOf map -> map a -> map a
add KeyOf map
lbl map a
env = (a -> a -> a) -> KeyOf map -> a -> map a -> map a
forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) KeyOf map
lbl a
1 map a
env

-- Removing unreachable blocks
removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
removeUnreachableBlocksProc proc :: CmmDecl
proc@(CmmProc CmmTopInfo
info CLabel
lbl [GlobalReg]
live CmmGraph
g)
   | [CmmBlock]
used_blocks [CmmBlock] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthLessThan` LabelMap CmmBlock -> Int
forall (map :: * -> *) a. IsMap map => map a -> Int
mapSize (CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g)
   = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
info' CLabel
lbl [GlobalReg]
live CmmGraph
g'
   | Bool
otherwise
   = CmmDecl
proc
   where
     g' :: CmmGraph
g'    = BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g) [CmmBlock]
used_blocks
     info' :: CmmTopInfo
info' = CmmTopInfo
info { info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable -> LabelMap CmmInfoTable
keep_used (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
info) }
             -- Remove any info_tbls for unreachable

     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
keep_used LabelMap CmmInfoTable
bs = (LabelMap CmmInfoTable
 -> KeyOf LabelMap -> CmmInfoTable -> LabelMap CmmInfoTable)
-> LabelMap CmmInfoTable
-> LabelMap CmmInfoTable
-> LabelMap CmmInfoTable
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey LabelMap CmmInfoTable
-> KeyOf LabelMap -> CmmInfoTable -> LabelMap CmmInfoTable
LabelMap CmmInfoTable
-> BlockId -> CmmInfoTable -> LabelMap CmmInfoTable
keep LabelMap CmmInfoTable
forall (map :: * -> *) a. IsMap map => map a
mapEmpty LabelMap CmmInfoTable
bs

     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
     keep :: LabelMap CmmInfoTable
-> BlockId -> CmmInfoTable -> LabelMap CmmInfoTable
keep LabelMap CmmInfoTable
env BlockId
l CmmInfoTable
i | ElemOf LabelSet
BlockId
l ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` LabelSet
used_lbls = KeyOf LabelMap
-> CmmInfoTable -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
l CmmInfoTable
i LabelMap CmmInfoTable
env
                  | Bool
otherwise               = LabelMap CmmInfoTable
env

     used_blocks :: [CmmBlock]
     used_blocks :: [CmmBlock]
used_blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
g

     used_lbls :: LabelSet
     used_lbls :: LabelSet
used_lbls = [ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList ([ElemOf LabelSet] -> LabelSet) -> [ElemOf LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> BlockId) -> [CmmBlock] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel [CmmBlock]
used_blocks