    {-# LANGUAGE GADTs #-}
    module GHC.Cmm.ContFlowOpt
        ( cmmCfgOpts
        , cmmCfgOptsProc
        , removeUnreachableBlocksProc
        , replaceLabels
        )
    where

    import GHC.Prelude hiding (succ, unzip, zip)

    import GHC.Cmm.Dataflow.Block hiding (blockConcat)
    import GHC.Cmm.Dataflow.Graph
    import GHC.Cmm.Dataflow.Label
    import GHC.Cmm.BlockId
    import GHC.Cmm
    import GHC.Cmm.Utils
    import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList)
    import GHC.Data.Maybe
    import GHC.Platform
    import GHC.Utils.Misc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    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
    -> GenGenCmmGraph LabelMap CmmNode
    -> GenGenCmmGraph LabelMap CmmNode
    cmmCfgOpts Bool
    split GenGenCmmGraph LabelMap CmmNode
    g = (GenGenCmmGraph LabelMap CmmNode, LabelMap Label)
    -> GenGenCmmGraph LabelMap CmmNode
    forall a b. (a, b) -> a
    fst (Bool
    -> GenGenCmmGraph LabelMap CmmNode
    -> (GenGenCmmGraph LabelMap CmmNode, LabelMap Label)
    blockConcat Bool
    split GenGenCmmGraph LabelMap CmmNode
    g)

    cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
    cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
    cmmCfgOptsProc Bool
    split (CmmProc GenCmmTopInfo LabelMap
    info CLabel
    lbl [GlobalRegUse]
    live GenGenCmmGraph LabelMap CmmNode
    g) = GenCmmTopInfo LabelMap
    -> CLabel
    -> [GlobalRegUse]
    -> GenGenCmmGraph LabelMap CmmNode
    -> CmmDecl
    forall d h g.
    h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
    CmmProc GenCmmTopInfo LabelMap
    info' CLabel
    lbl [GlobalRegUse]
    live GenGenCmmGraph LabelMap CmmNode
    g'
        where (GenGenCmmGraph LabelMap CmmNode
    g', LabelMap Label
    env) = Bool
    -> GenGenCmmGraph LabelMap CmmNode
    -> (GenGenCmmGraph LabelMap CmmNode, LabelMap Label)
    blockConcat Bool
    split GenGenCmmGraph LabelMap CmmNode
    g
              info' :: GenCmmTopInfo LabelMap
    info' = GenCmmTopInfo LabelMap
    info{ info_tbls = new_info_tbls }
              new_info_tbls :: LabelMap CmmInfoTable
    new_info_tbls = [(Label, CmmInfoTable)] -> LabelMap CmmInfoTable
    forall v. [(Label, v)] -> LabelMap v
    mapFromList (((Label, CmmInfoTable) -> (Label, CmmInfoTable))
    -> [(Label, CmmInfoTable)] -> [(Label, CmmInfoTable)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Label, CmmInfoTable) -> (Label, CmmInfoTable)
    upd_info (LabelMap CmmInfoTable -> [(Label, CmmInfoTable)]
    forall b. LabelMap b -> [(Label, b)]
    mapToList (GenCmmTopInfo LabelMap -> LabelMap CmmInfoTable
    forall (f :: * -> *). GenCmmTopInfo f -> f CmmInfoTable
    info_tbls GenCmmTopInfo LabelMap
    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 :: (Label, CmmInfoTable) -> (Label, CmmInfoTable)
    upd_info (Label
    k,CmmInfoTable
    info)
                 | Just Label
    k' <- Label -> LabelMap Label -> Maybe Label
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    k LabelMap Label
    env
                 = (Label
    k', if Label
    k' Label -> Label -> Bool
    forall a. Eq a => a -> a -> Bool
    == GenGenCmmGraph LabelMap CmmNode -> Label
    forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
    GenGenCmmGraph s n -> Label
    g_entry GenGenCmmGraph LabelMap CmmNode
    g'
                           then CmmInfoTable
    info
                           else CmmInfoTable
    info{ cit_lbl = infoTblLbl k' })
                 | Bool
    otherwise
                 = (Label
    k,CmmInfoTable
    info)
    cmmCfgOptsProc Bool
    _ CmmDecl
    top = CmmDecl
    top

    blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
    blockConcat :: Bool
    -> GenGenCmmGraph LabelMap CmmNode
    -> (GenGenCmmGraph LabelMap CmmNode, LabelMap Label)
    blockConcat Bool
    splitting_procs g :: GenGenCmmGraph LabelMap CmmNode
    g@CmmGraph { g_entry :: forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
    GenGenCmmGraph s n -> Label
    g_entry = Label
    entry_id }
      = (LabelMap Label
    -> GenGenCmmGraph LabelMap CmmNode
    -> GenGenCmmGraph LabelMap CmmNode
    replaceLabels LabelMap Label
    shortcut_map (GenGenCmmGraph LabelMap CmmNode
     -> GenGenCmmGraph LabelMap CmmNode)
    -> GenGenCmmGraph LabelMap CmmNode
    -> GenGenCmmGraph LabelMap CmmNode
    forall a b. (a -> b) -> a -> b
    $ Label -> LabelMap CmmBlock -> GenGenCmmGraph LabelMap CmmNode
    ofBlockMap Label
    new_entry LabelMap CmmBlock
    new_blocks, LabelMap Label
    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.
         (Label
    new_entry, LabelMap Label
    shortcut_map')
           | Just CmmBlock
    entry_blk <- Label -> LabelMap CmmBlock -> Maybe CmmBlock
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    entry_id LabelMap CmmBlock
    new_blocks
           , Just Label
    dest      <- CmmBlock -> Maybe Label
    canShortcut CmmBlock
    entry_blk
           = (Label
    dest, Label -> Label -> LabelMap Label -> LabelMap Label
    forall v. Label -> v -> LabelMap v -> LabelMap v
    mapInsert Label
    entry_id Label
    dest LabelMap Label
    shortcut_map)
           | Bool
    otherwise
           = (Label
    entry_id, LabelMap Label
    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 = GenGenCmmGraph LabelMap CmmNode -> [CmmBlock]
    revPostorder GenGenCmmGraph LabelMap CmmNode
    g
         blockmap :: LabelMap CmmBlock
    blockmap = (LabelMap CmmBlock -> CmmBlock -> LabelMap CmmBlock)
    -> LabelMap CmmBlock -> [CmmBlock] -> LabelMap CmmBlock
    forall b a. (b -> a -> b) -> b -> [a] -> b
    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 'Closed 'Closed
    -> LabelMap (block 'Closed 'Closed)
    -> LabelMap (block 'Closed 'Closed)
    addBlock) LabelMap CmmBlock
    forall (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *).
    Body' LabelMap 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 Label
    shortcut_map, LabelMap Int
    _) =
               (CmmBlock
     -> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
     -> (LabelMap CmmBlock, LabelMap Label, LabelMap Int))
    -> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
    -> [CmmBlock]
    -> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr CmmBlock
    -> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
    -> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
    maybe_concat (LabelMap CmmBlock
    blockmap, LabelMap Label
    forall v. LabelMap v
    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 = Label -> LabelMap Int -> LabelMap Int
    incPreds Label
    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 Label, LabelMap Int)
    -> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
    maybe_concat CmmBlock
    block (!LabelMap CmmBlock
    blocks, !LabelMap Label
    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 Label
    b' <- CmmNode 'Open 'Closed
    last
            , Label -> Bool
    hasOnePredecessor Label
    b'
            , Just CmmBlock
    blk' <- Label -> LabelMap CmmBlock -> Maybe CmmBlock
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    b' LabelMap CmmBlock
    blocks
            = let bid' :: Label
    bid' = CmmBlock -> Label
    forall (x :: Extensibility). Block CmmNode 'Closed x -> Label
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing 'Closed x -> Label
    entryLabel CmmBlock
    blk'
              in ( Label -> LabelMap CmmBlock -> LabelMap CmmBlock
    forall v. Label -> LabelMap v -> LabelMap v
    mapDelete Label
    bid' (LabelMap CmmBlock -> LabelMap CmmBlock)
    -> LabelMap CmmBlock -> LabelMap CmmBlock
    forall a b. (a -> b) -> a -> b
    $ Label -> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
    forall v. Label -> v -> LabelMap v -> LabelMap v
    mapInsert Label
    bid (Block CmmNode 'Closed 'Open -> CmmBlock -> CmmBlock
    splice Block CmmNode 'Closed 'Open
    head CmmBlock
    blk') LabelMap CmmBlock
    blocks
                 , LabelMap Label
    shortcut_map
                 , Label -> LabelMap Int -> LabelMap Int
    forall v. Label -> LabelMap v -> LabelMap v
    mapDelete Label
    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 Label
    b'   <- CmmNode 'Open 'Closed -> Maybe Label
    callContinuation_maybe CmmNode 'Open 'Closed
    last
            , Just CmmBlock
    blk' <- Label -> LabelMap CmmBlock -> Maybe CmmBlock
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    b' LabelMap CmmBlock
    blocks
            , Just Label
    dest <- CmmBlock -> Maybe Label
    canShortcut CmmBlock
    blk'
            = ( Label -> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
    forall v. Label -> v -> LabelMap v -> LabelMap v
    mapInsert Label
    bid (Block CmmNode 'Closed 'Open -> CmmNode 'Open 'Closed -> CmmBlock
    forall (n :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    Block n e 'Open -> n 'Open 'Closed -> Block n e 'Closed
    blockJoinTail Block CmmNode 'Closed 'Open
    head (Label -> CmmNode 'Open 'Closed
    update_cont Label
    dest)) LabelMap CmmBlock
    blocks
              , Label -> Label -> LabelMap Label -> LabelMap Label
    forall v. Label -> v -> LabelMap v -> LabelMap v
    mapInsert Label
    b' Label
    dest LabelMap Label
    shortcut_map
              , Label -> LabelMap Int -> LabelMap Int
    decPreds Label
    b' (LabelMap Int -> LabelMap Int) -> LabelMap Int -> LabelMap Int
    forall a b. (a -> b) -> a -> b
    $ Label -> LabelMap Int -> LabelMap Int
    incPreds Label
    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 Label
    Nothing <- CmmNode 'Open 'Closed -> Maybe Label
    callContinuation_maybe CmmNode 'Open 'Closed
    last
            = let oldSuccs :: [Label]
    oldSuccs = CmmNode 'Open 'Closed -> [Label]
    forall (e :: Extensibility). CmmNode e 'Closed -> [Label]
    forall (thing :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    NonLocal thing =>
    thing e 'Closed -> [Label]
    successors CmmNode 'Open 'Closed
    last
                  newSuccs :: [Label]
    newSuccs = CmmNode 'Open 'Closed -> [Label]
    forall (e :: Extensibility). CmmNode e 'Closed -> [Label]
    forall (thing :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    NonLocal thing =>
    thing e 'Closed -> [Label]
    successors CmmNode 'Open 'Closed
    rewrite_last
              in ( Label -> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
    forall v. Label -> v -> LabelMap v -> LabelMap v
    mapInsert Label
    bid (Block CmmNode 'Closed 'Open -> CmmNode 'Open 'Closed -> CmmBlock
    forall (n :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    Block n e 'Open -> n 'Open 'Closed -> Block n e 'Closed
    blockJoinTail Block CmmNode 'Closed 'Open
    head CmmNode 'Open 'Closed
    rewrite_last) LabelMap CmmBlock
    blocks
                 , LabelMap Label
    shortcut_map
                 , if [Label]
    oldSuccs [Label] -> [Label] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Label]
    newSuccs
                   then LabelMap Int
    backEdges
                   else (Label -> LabelMap Int -> LabelMap Int)
    -> LabelMap Int -> [Label] -> LabelMap Int
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Label -> LabelMap Int -> LabelMap Int
    incPreds ((Label -> LabelMap Int -> LabelMap Int)
    -> LabelMap Int -> [Label] -> LabelMap Int
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Label -> LabelMap Int -> LabelMap Int
    decPreds LabelMap Int
    backEdges [Label]
    oldSuccs) [Label]
    newSuccs )

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

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

              -- Attempts to shortcut successors of last node
              shortcut_last :: CmmNode 'Open 'Closed
    shortcut_last = (Label -> Label) -> CmmNode 'Open 'Closed -> CmmNode 'Open 'Closed
    mapSuccessors Label -> Label
    shortcut CmmNode 'Open 'Closed
    last
                where
                  shortcut :: Label -> Label
    shortcut Label
    l =
                     case Label -> LabelMap CmmBlock -> Maybe CmmBlock
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    l LabelMap CmmBlock
    blocks of
                       Just CmmBlock
    b | Just Label
    dest <- CmmBlock -> Maybe Label
    canShortcut CmmBlock
    b -> Label
    dest
                       Maybe CmmBlock
    _otherwise -> Label
    l

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

                -- See Note [Invert Cmm conditionals]
                | CmmCondBranch CmmExpr
    cond Label
    t Label
    f Maybe Bool
    l <- CmmNode 'Open 'Closed
    shortcut_last
                , Label -> Bool
    hasOnePredecessor Label
    t -- inverting will make t a fallthrough
                , Maybe Bool -> Bool
    likelyTrue Maybe Bool
    l Bool -> Bool -> Bool
    || (Label -> Int
    numPreds Label
    f Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    1)
                , Just CmmExpr
    cond' <- CmmExpr -> Maybe CmmExpr
    maybeInvertCmmExpr CmmExpr
    cond
                = CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
    CmmCondBranch CmmExpr
    cond' Label
    f Label
    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 'Open 'Closed
    shortcut_last
                , (Label
    t:[Label]
    ts) <- SwitchTargets -> [Label]
    switchTargetsToList SwitchTargets
    targets
                , (Label -> Bool) -> [Label] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Label -> Label -> Bool
    forall a. Eq a => a -> a -> Bool
    == Label
    t) [Label]
    ts
                = Label -> CmmNode 'Open 'Closed
    CmmBranch Label
    t

                | Bool
    otherwise
                = CmmNode 'Open 'Closed
    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 a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Bool -> Bool
    not

              -- Number of predecessors for a block
              numPreds :: Label -> Int
    numPreds Label
    bid = Label -> LabelMap Int -> Maybe Int
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    bid LabelMap Int
    backEdges Maybe Int -> Int -> Int
    forall a. Maybe a -> a -> a
    `orElse` Int
    0

              hasOnePredecessor :: Label -> Bool
    hasOnePredecessor Label
    b = Label -> Int
    numPreds Label
    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 that's 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 :: Label -> LabelMap Int -> LabelMap Int
    incPreds Label
    bid LabelMap Int
    edges = (Int -> Int -> Int) -> Label -> Int -> LabelMap Int -> LabelMap Int
    forall v. (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v
    mapInsertWith Int -> Int -> Int
    forall a. Num a => a -> a -> a
    (+) Label
    bid Int
    1 LabelMap Int
    edges
    decPreds :: Label -> LabelMap Int -> LabelMap Int
    decPreds Label
    bid LabelMap Int
    edges = case Label -> LabelMap Int -> Maybe Int
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    bid LabelMap Int
    edges of
                           Just Int
    preds | Int
    preds Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    1 -> Label -> Int -> LabelMap Int -> LabelMap Int
    forall v. Label -> v -> LabelMap v -> LabelMap v
    mapInsert Label
    bid (Int
    preds Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) LabelMap Int
    edges
                           Just Int
    _                 -> Label -> LabelMap Int -> LabelMap Int
    forall v. Label -> LabelMap v -> LabelMap v
    mapDelete Label
    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 Label
    canShortcut CmmBlock
    block
        | (CmmNode 'Closed 'Open
    _, Block CmmNode 'Open 'Open
    middle, CmmBranch Label
    dest) <- CmmBlock
    -> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Open,
        CmmNode 'Open 'Closed)
    forall (n :: Extensibility -> Extensibility -> *).
    Block n 'Closed 'Closed
    -> (n 'Closed 'Open, Block n 'Open 'Open, n 'Open 'Closed)
    blockSplit CmmBlock
    block
        , (CmmNode 'Open 'Open -> Bool) -> [CmmNode 'Open 'Open] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all CmmNode 'Open 'Open -> Bool
    forall {e :: Extensibility} {x :: Extensibility}.
    CmmNode e x -> Bool
    dont_care ([CmmNode 'Open 'Open] -> Bool) -> [CmmNode 'Open 'Open] -> Bool
    forall a b. (a -> b) -> a -> b
    $ Block CmmNode 'Open 'Open -> [CmmNode 'Open 'Open]
    forall (n :: Extensibility -> Extensibility -> *).
    Block n 'Open 'Open -> [n 'Open 'Open]
    blockToList Block CmmNode 'Open 'Open
    middle
        = Label -> Maybe Label
    forall a. a -> Maybe a
    Just Label
    dest
        | Bool
    otherwise
        = Maybe Label
    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 'Closed 'Open -> CmmBlock -> CmmBlock
    splice Block CmmNode 'Closed 'Open
    head CmmBlock
    rest = CmmNode 'Closed 'Open
    entry CmmNode 'Closed 'Open
    -> Block CmmNode 'Open 'Open -> Block CmmNode 'Closed 'Open
    forall (n :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    n 'Closed 'Open -> Block n 'Open x -> Block n 'Closed x
    `blockJoinHead` Block CmmNode 'Open 'Open
    code0 Block CmmNode 'Closed 'Open
    -> Block CmmNode 'Open 'Closed -> CmmBlock
    forall (n :: Extensibility -> Extensibility -> *)
           (e :: Extensibility) (x :: Extensibility).
    Block n e 'Open -> Block n 'Open x -> Block n e x
    `blockAppend` Block CmmNode 'Open 'Closed
    code1
      where (CmmEntry Label
    lbl CmmTickScope
    sc0, Block CmmNode 'Open 'Open
    code0) = Block CmmNode 'Closed 'Open
    -> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Open)
    forall (n :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    Block n 'Closed x -> (n 'Closed 'Open, Block n 'Open x)
    blockSplitHead Block CmmNode 'Closed 'Open
    head
            (CmmEntry Label
    _   CmmTickScope
    sc1, Block CmmNode 'Open 'Closed
    code1) = CmmBlock -> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Closed)
    forall (n :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    Block n 'Closed x -> (n 'Closed 'Open, Block n 'Open x)
    blockSplitHead CmmBlock
    rest
            entry :: CmmNode 'Closed 'Open
    entry = Label -> CmmTickScope -> CmmNode 'Closed 'Open
    CmmEntry Label
    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 'Open 'Closed -> Maybe Label
    callContinuation_maybe (CmmCall { cml_cont :: CmmNode 'Open 'Closed -> Maybe Label
    cml_cont = Just Label
    b }) = Label -> Maybe Label
    forall a. a -> Maybe a
    Just Label
    b
    callContinuation_maybe (CmmForeignCall { succ :: CmmNode 'Open 'Closed -> Label
    succ = Label
    b })   = Label -> Maybe Label
    forall a. a -> Maybe a
    Just Label
    b
    callContinuation_maybe CmmNode 'Open 'Closed
    _ = Maybe Label
    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 Label
    -> GenGenCmmGraph LabelMap CmmNode
    -> GenGenCmmGraph LabelMap CmmNode
    replaceLabels LabelMap Label
    env GenGenCmmGraph LabelMap CmmNode
    g
      | LabelMap Label -> Bool
    forall a. LabelMap a -> Bool
    mapNull LabelMap Label
    env = GenGenCmmGraph LabelMap CmmNode
    g
      | Bool
    otherwise   = GenGenCmmGraph LabelMap CmmNode -> GenGenCmmGraph LabelMap CmmNode
    replace_eid (GenGenCmmGraph LabelMap CmmNode
     -> GenGenCmmGraph LabelMap CmmNode)
    -> GenGenCmmGraph LabelMap CmmNode
    -> GenGenCmmGraph LabelMap CmmNode
    forall a b. (a -> b) -> a -> b
    $ (forall (e :: Extensibility) (x :: Extensibility).
     CmmNode e x -> CmmNode e x)
    -> GenGenCmmGraph LabelMap CmmNode
    -> GenGenCmmGraph LabelMap CmmNode
    mapGraphNodes1 CmmNode e x -> CmmNode e x
    forall (e :: Extensibility) (x :: Extensibility).
    CmmNode e x -> CmmNode e x
    txnode GenGenCmmGraph LabelMap CmmNode
    g
       where
         replace_eid :: GenGenCmmGraph LabelMap CmmNode -> GenGenCmmGraph LabelMap CmmNode
    replace_eid GenGenCmmGraph LabelMap CmmNode
    g = GenGenCmmGraph LabelMap CmmNode
    g {g_entry = lookup (g_entry g)}
         lookup :: Label -> Label
    lookup Label
    id = Label -> LabelMap Label -> Maybe Label
    forall a. Label -> LabelMap a -> Maybe a
    mapLookup Label
    id LabelMap Label
    env Maybe Label -> Label -> Label
    forall a. Maybe a -> a -> a
    `orElse` Label
    id

         txnode :: CmmNode e x -> CmmNode e x
         txnode :: forall (e :: Extensibility) (x :: Extensibility).
    CmmNode e x -> CmmNode e x
    txnode (CmmBranch Label
    bid) = Label -> CmmNode 'Open 'Closed
    CmmBranch (Label -> Label
    lookup Label
    bid)
         txnode (CmmCondBranch CmmExpr
    p Label
    t Label
    f Maybe Bool
    l) =
           CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
    mkCmmCondBranch (CmmExpr -> CmmExpr
    exp CmmExpr
    p) (Label -> Label
    lookup Label
    t) (Label -> Label
    lookup Label
    f) Maybe Bool
    l
         txnode (CmmSwitch CmmExpr
    e SwitchTargets
    ids) =
           CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
    CmmSwitch (CmmExpr -> CmmExpr
    exp CmmExpr
    e) ((Label -> Label) -> SwitchTargets -> SwitchTargets
    mapSwitchTargets Label -> Label
    lookup SwitchTargets
    ids)
         txnode (CmmCall CmmExpr
    t Maybe Label
    k [GlobalRegUse]
    rg Int
    a Int
    res Int
    r) =
           CmmExpr
    -> Maybe Label
    -> [GlobalRegUse]
    -> Int
    -> Int
    -> Int
    -> CmmNode 'Open 'Closed
    CmmCall (CmmExpr -> CmmExpr
    exp CmmExpr
    t) ((Label -> Label) -> Maybe Label -> Maybe Label
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM Label -> Label
    lookup Maybe Label
    k) [GlobalRegUse]
    rg Int
    a Int
    res Int
    r
         txnode fc :: CmmNode e x
    fc@CmmForeignCall{} =
           CmmNode e x
    fc{ args = map exp (args fc), succ = lookup (succ 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 Label
    bid))                = CmmLit -> CmmExpr
    CmmLit (Label -> CmmLit
    CmmBlock (Label -> Label
    lookup Label
    bid))
         exp (CmmStackSlot (Young Label
    id) Int
    i) = Area -> Int -> CmmExpr
    CmmStackSlot (Label -> Area
    Young (Label -> Label
    lookup Label
    id)) Int
    i
         exp CmmExpr
    e                                      = CmmExpr
    e

    mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
    mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
    mkCmmCondBranch CmmExpr
    p Label
    t Label
    f Maybe Bool
    l =
      if Label
    t Label -> Label -> Bool
    forall a. Eq a => a -> a -> Bool
    == Label
    f then Label -> CmmNode 'Open 'Closed
    CmmBranch Label
    t else CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
    CmmCondBranch CmmExpr
    p Label
    t Label
    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 a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr CmmBlock -> LabelMap Int -> LabelMap Int
    forall {v} {thing :: Extensibility -> Extensibility -> *}
           {e :: Extensibility}.
    (Num v, NonLocal thing) =>
    thing e 'Closed -> LabelMap v -> LabelMap v
    add_preds LabelMap Int
    forall v. LabelMap v
    mapEmpty [CmmBlock]
    blocks
      where
        add_preds :: thing e 'Closed -> LabelMap v -> LabelMap v
    add_preds thing e 'Closed
    block LabelMap v
    env = (Label -> LabelMap v -> LabelMap v)
    -> LabelMap v -> [Label] -> LabelMap v
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Label -> LabelMap v -> LabelMap v
    forall {v}. Num v => Label -> LabelMap v -> LabelMap v
    add LabelMap v
    env (thing e 'Closed -> [Label]
    forall (e :: Extensibility). thing e 'Closed -> [Label]
    forall (thing :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    NonLocal thing =>
    thing e 'Closed -> [Label]
    successors thing e 'Closed
    block)
          where add :: Label -> LabelMap v -> LabelMap v
    add Label
    lbl LabelMap v
    env = (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v
    forall v. (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v
    mapInsertWith v -> v -> v
    forall a. Num a => a -> a -> a
    (+) Label
    lbl v
    1 LabelMap v
    env

    -- Remove unreachable blocks from procs
    removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl
    removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl
    removeUnreachableBlocksProc Platform
    _ proc :: CmmDecl
    proc@(CmmProc GenCmmTopInfo LabelMap
    info CLabel
    lbl [GlobalRegUse]
    live GenGenCmmGraph LabelMap CmmNode
    g)
       | [CmmBlock]
    used_blocks [CmmBlock] -> Int -> Bool
    forall a. [a] -> Int -> Bool
    `lengthLessThan` LabelMap CmmBlock -> Int
    forall a. LabelMap a -> Int
    mapSize (GenGenCmmGraph LabelMap CmmNode -> LabelMap CmmBlock
    toBlockMap GenGenCmmGraph LabelMap CmmNode
    g)
       = GenCmmTopInfo LabelMap
    -> CLabel
    -> [GlobalRegUse]
    -> GenGenCmmGraph LabelMap CmmNode
    -> CmmDecl
    forall d h g.
    h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
    CmmProc GenCmmTopInfo LabelMap
    info' CLabel
    lbl [GlobalRegUse]
    live GenGenCmmGraph LabelMap CmmNode
    g'
       | Bool
    otherwise
       = CmmDecl
    proc
       where
         g' :: GenGenCmmGraph LabelMap CmmNode
    g'    = Label -> [CmmBlock] -> GenGenCmmGraph LabelMap CmmNode
    ofBlockList (GenGenCmmGraph LabelMap CmmNode -> Label
    forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
    GenGenCmmGraph s n -> Label
    g_entry GenGenCmmGraph LabelMap CmmNode
    g) [CmmBlock]
    used_blocks
         info' :: GenCmmTopInfo LabelMap
    info' = GenCmmTopInfo LabelMap
    info { info_tbls = keep_used (info_tbls 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
     -> Label -> CmmInfoTable -> LabelMap CmmInfoTable)
    -> LabelMap CmmInfoTable
    -> LabelMap CmmInfoTable
    -> LabelMap CmmInfoTable
    forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
    mapFoldlWithKey LabelMap CmmInfoTable
    -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
    keep LabelMap CmmInfoTable
    forall v. LabelMap v
    mapEmpty LabelMap CmmInfoTable
    bs

         keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
         keep :: LabelMap CmmInfoTable
    -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
    keep LabelMap CmmInfoTable
    env Label
    l CmmInfoTable
    i | Label
    l Label -> LabelSet -> Bool
    `setMember` LabelSet
    used_lbls = Label
    -> CmmInfoTable -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
    forall v. Label -> v -> LabelMap v -> LabelMap v
    mapInsert Label
    l CmmInfoTable
    i LabelMap CmmInfoTable
    env
                      | Bool
    otherwise               = LabelMap CmmInfoTable
    env

         used_blocks :: [CmmBlock]
         used_blocks :: [CmmBlock]
    used_blocks = GenGenCmmGraph LabelMap CmmNode -> [CmmBlock]
    revPostorder GenGenCmmGraph LabelMap CmmNode
    g

         used_lbls :: LabelSet
         used_lbls :: LabelSet
    used_lbls = [Label] -> LabelSet
    setFromList ([Label] -> LabelSet) -> [Label] -> LabelSet
    forall a b. (a -> b) -> a -> b
    $ (CmmBlock -> Label) -> [CmmBlock] -> [Label]
    forall a b. (a -> b) -> [a] -> [b]
    map CmmBlock -> Label
    forall (x :: Extensibility). Block CmmNode 'Closed x -> Label
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing 'Closed x -> Label
    entryLabel [CmmBlock]
    used_blocks
    removeUnreachableBlocksProc Platform
    platform data' :: CmmDecl
    data'@(CmmData Section
    _ GenCmmStatics 'False
    _) =
        String -> SDoc -> CmmDecl
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "removeUnreachableBlocksProc: passed data declaration instead of procedure" (Platform -> CmmDecl -> SDoc
    forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform CmmDecl
    data')