    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE DisambiguateRecordFields #-}
    {-# LANGUAGE GADTs #-}

    {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

    module GHC.Cmm.ProcPoint
        ( ProcPointSet, Status(..)
        , callProcPoints, minimalProcPointSet
        , splitAtProcPoints, procPointAnalysis
        , attachContInfoTables
        )
    where

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

    import GHC.Cmm.BlockId
    import GHC.Cmm.CLabel
    import GHC.Cmm
    import GHC.Cmm.Ppr () -- For Outputable instances
    import GHC.Cmm.Utils
    import GHC.Cmm.Info
    import GHC.Cmm.Liveness
    import GHC.Cmm.Switch
    import Data.List (sortBy)
    import GHC.Data.Maybe
    import Control.Monad
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Platform
    import GHC.Types.Unique.Supply
    import GHC.Cmm.Dataflow.Block
    import GHC.Cmm.Dataflow.Collections
    import GHC.Cmm.Dataflow
    import GHC.Cmm.Dataflow.Graph
    import GHC.Cmm.Dataflow.Label

    -- Compute a minimal set of proc points for a control-flow graph.

    -- Determine a protocol for each proc point (which live variables will
    -- be passed as arguments and which will be on the stack).

    {-
    A proc point is a basic block that, after CPS transformation, will
    start a new function.  The entry block of the original function is a
    proc point, as is the continuation of each function call.
    A third kind of proc point arises if we want to avoid copying code.
    Suppose we have code like the following:

      f() {
        if (...) { ..1..; call foo(); ..2..}
        else     { ..3..; call bar(); ..4..}
        x = y + z;
        return x;
      }

    The statement 'x = y + z' can be reached from two different proc
    points: the continuations of foo() and bar().  We would prefer not to
    put a copy in each continuation; instead we would like 'x = y + z' to
    be the start of a new procedure to which the continuations can jump:

      f_cps () {
        if (...) { ..1..; push k_foo; jump foo_cps(); }
        else     { ..3..; push k_bar; jump bar_cps(); }
      }
      k_foo() { ..2..; jump k_join(y, z); }
      k_bar() { ..4..; jump k_join(y, z); }
      k_join(y, z) { x = y + z; return x; }

    You might think then that a criterion to make a node a proc point is
    that it is directly reached by two distinct proc points.  (Note
    [Direct reachability].)  But this criterion is a bit too simple; for
    example, 'return x' is also reached by two proc points, yet there is
    no point in pulling it out of k_join.  A good criterion would be to
    say that a node should be made a proc point if it is reached by a set
    of proc points that is different than its immediate dominator.  NR
    believes this criterion can be shown to produce a minimum set of proc
    points, and given a dominator tree, the proc points can be chosen in
    time linear in the number of blocks.  Lacking a dominator analysis,
    however, we turn instead to an iterative solution, starting with no
    proc points and adding them according to these rules:

      1. The entry block is a proc point.
      2. The continuation of a call is a proc point.
      3. A node is a proc point if it is directly reached by more proc
         points than one of its predecessors.

    Because we don't understand the problem very well, we apply rule 3 at
    most once per iteration, then recompute the reachability information.
    (See Note [No simple dataflow].)  The choice of the new proc point is
    arbitrary, and I don't know if the choice affects the final solution,
    so I don't know if the number of proc points chosen is the
    minimum---but the set will be minimal.

    Note [Proc-point analysis]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~

    Given a specified set of proc-points (a set of block-ids), "proc-point
    analysis" figures out, for every block, which proc-point it belongs to.
    All the blocks belonging to proc-point P will constitute a single
    top-level C procedure.

    A non-proc-point block B "belongs to" a proc-point P iff B is
    reachable from P without going through another proc-point.

    Invariant: a block B should belong to at most one proc-point; if it
    belongs to two, that's a bug.

    Note [Non-existing proc-points]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    On some architectures it might happen that the list of proc-points
    computed before stack layout pass will be invalidated by the stack
    layout. This will happen if stack layout removes from the graph
    blocks that were determined to be proc-points. Later on in the pipeline
    we use list of proc-points to perform [Proc-point analysis], but
    if a proc-point does not exist anymore then we will get compiler panic.
    See #8205.
    -}

    type ProcPointSet = LabelSet

    data Status
      = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
      | ProcPoint               -- this block is itself a proc point

    instance Outputable Status where
      ppr :: Status -> SDoc
    ppr (ReachedBy ProcPointSet
    ps)
          | ProcPointSet -> Bool
    forall set. IsSet set => set -> Bool
    setNull ProcPointSet
    ps = String -> SDoc
    text String
    "<not-reached>"
          | Bool
    otherwise = String -> SDoc
    text String
    "reached by" SDoc -> SDoc -> SDoc
    <+>
                        ([SDoc] -> SDoc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
    forall a b. (a -> b) -> a -> b
    $ (BlockId -> SDoc) -> [BlockId] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map BlockId -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ([BlockId] -> [SDoc]) -> [BlockId] -> [SDoc]
    forall a b. (a -> b) -> a -> b
    $ ProcPointSet -> [ElemOf ProcPointSet]
    forall set. IsSet set => set -> [ElemOf set]
    setElems ProcPointSet
    ps)
      ppr Status
    ProcPoint = String -> SDoc
    text String
    "<procpt>"

    --------------------------------------------------
    -- Proc point analysis

    -- Once you know what the proc-points are, figure out
    -- what proc-points each block is reachable from
    -- See Note [Proc-point analysis]
    procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
    procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
    procPointAnalysis ProcPointSet
    procPoints cmmGraph :: CmmGraph
    cmmGraph@(CmmGraph {g_graph :: forall (n :: Extensibility -> Extensibility -> *).
    GenCmmGraph n -> Graph n C C
    g_graph = Graph CmmNode C C
    graph}) =
        DataflowLattice Status
    -> TransferFun Status
    -> CmmGraph
    -> LabelMap Status
    -> LabelMap Status
    forall f.
    DataflowLattice f
    -> TransferFun f -> CmmGraph -> FactBase f -> FactBase f
    analyzeCmmFwd DataflowLattice Status
    procPointLattice TransferFun Status
    procPointTransfer CmmGraph
    cmmGraph LabelMap Status
    initProcPoints
      where
        initProcPoints :: LabelMap Status
    initProcPoints =
            DataflowLattice Status -> [(BlockId, Status)] -> LabelMap Status
    forall f. DataflowLattice f -> [(BlockId, f)] -> FactBase f
    mkFactBase
                DataflowLattice Status
    procPointLattice
                [ (BlockId
    id, Status
    ProcPoint)
                | BlockId
    id <- ProcPointSet -> [ElemOf ProcPointSet]
    forall set. IsSet set => set -> [ElemOf set]
    setElems ProcPointSet
    procPoints
                -- See Note [Non-existing proc-points]
                , ElemOf ProcPointSet
    BlockId
    id ElemOf ProcPointSet -> ProcPointSet -> Bool
    forall set. IsSet set => ElemOf set -> set -> Bool
    `setMember` ProcPointSet
    labelsInGraph
                ]
        labelsInGraph :: ProcPointSet
    labelsInGraph = Graph CmmNode C C -> ProcPointSet
    forall (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *) (e :: Extensibility)
           (x :: Extensibility).
    NonLocal (block n) =>
    Graph' block n e x -> ProcPointSet
    labelsDefined Graph CmmNode C C
    graph

    procPointTransfer :: TransferFun Status
    procPointTransfer :: TransferFun Status
    procPointTransfer Block CmmNode C C
    block LabelMap Status
    facts =
        let label :: BlockId
    label = Block CmmNode C C -> BlockId
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> BlockId
    entryLabel Block CmmNode C C
    block
            !fact :: Status
    fact = case DataflowLattice Status -> BlockId -> LabelMap Status -> Status
    forall f. DataflowLattice f -> BlockId -> FactBase f -> f
    getFact DataflowLattice Status
    procPointLattice BlockId
    label LabelMap Status
    facts of
                Status
    ProcPoint -> ProcPointSet -> Status
    ReachedBy (ProcPointSet -> Status) -> ProcPointSet -> Status
    forall a b. (a -> b) -> a -> b
    $! ElemOf ProcPointSet -> ProcPointSet
    forall set. IsSet set => ElemOf set -> set
    setSingleton ElemOf ProcPointSet
    BlockId
    label
                Status
    f -> Status
    f
            result :: [(BlockId, Status)]
    result = (BlockId -> (BlockId, Status)) -> [BlockId] -> [(BlockId, Status)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\BlockId
    id -> (BlockId
    id, Status
    fact)) (Block CmmNode C C -> [BlockId]
    forall (thing :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    NonLocal thing =>
    thing e C -> [BlockId]
    successors Block CmmNode C C
    block)
        in DataflowLattice Status -> [(BlockId, Status)] -> LabelMap Status
    forall f. DataflowLattice f -> [(BlockId, f)] -> FactBase f
    mkFactBase DataflowLattice Status
    procPointLattice [(BlockId, Status)]
    result

    procPointLattice :: DataflowLattice Status
    procPointLattice :: DataflowLattice Status
    procPointLattice = Status -> JoinFun Status -> DataflowLattice Status
    forall a. a -> JoinFun a -> DataflowLattice a
    DataflowLattice Status
    unreached JoinFun Status
    add_to
      where
        unreached :: Status
    unreached = ProcPointSet -> Status
    ReachedBy ProcPointSet
    forall set. IsSet set => set
    setEmpty
        add_to :: JoinFun Status
    add_to (OldFact Status
    ProcPoint) NewFact Status
    _ = Status -> JoinedFact Status
    forall a. a -> JoinedFact a
    NotChanged Status
    ProcPoint
        add_to OldFact Status
    _ (NewFact Status
    ProcPoint) = Status -> JoinedFact Status
    forall a. a -> JoinedFact a
    Changed Status
    ProcPoint -- because of previous case
        add_to (OldFact (ReachedBy ProcPointSet
    p)) (NewFact (ReachedBy ProcPointSet
    p'))
            | ProcPointSet -> Int
    forall set. IsSet set => set -> Int
    setSize ProcPointSet
    union Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > ProcPointSet -> Int
    forall set. IsSet set => set -> Int
    setSize ProcPointSet
    p = Status -> JoinedFact Status
    forall a. a -> JoinedFact a
    Changed (ProcPointSet -> Status
    ReachedBy ProcPointSet
    union)
            | Bool
    otherwise = Status -> JoinedFact Status
    forall a. a -> JoinedFact a
    NotChanged (ProcPointSet -> Status
    ReachedBy ProcPointSet
    p)
          where
            union :: ProcPointSet
    union = ProcPointSet -> ProcPointSet -> ProcPointSet
    forall set. IsSet set => set -> set -> set
    setUnion ProcPointSet
    p' ProcPointSet
    p

    ----------------------------------------------------------------------

    -- It is worth distinguishing two sets of proc points: those that are
    -- induced by calls in the original graph and those that are
    -- introduced because they're reachable from multiple proc points.
    --
    -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
    callProcPoints      :: CmmGraph -> ProcPointSet
    callProcPoints :: CmmGraph -> ProcPointSet
    callProcPoints CmmGraph
    g = (ProcPointSet -> Block CmmNode C C -> ProcPointSet)
    -> ProcPointSet -> CmmGraph -> ProcPointSet
    forall a. (a -> Block CmmNode C C -> a) -> a -> CmmGraph -> a
    foldlGraphBlocks ProcPointSet -> Block CmmNode C C -> ProcPointSet
    add (ElemOf ProcPointSet -> ProcPointSet
    forall set. IsSet set => ElemOf set -> set
    setSingleton (CmmGraph -> BlockId
    forall (n :: Extensibility -> Extensibility -> *).
    GenCmmGraph n -> BlockId
    g_entry CmmGraph
    g)) CmmGraph
    g
      where add :: LabelSet -> CmmBlock -> LabelSet
            add :: ProcPointSet -> Block CmmNode C C -> ProcPointSet
    add ProcPointSet
    set Block CmmNode C C
    b = case Block CmmNode C C -> CmmNode O C
    forall (n :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    Block n x C -> n O C
    lastNode Block CmmNode C C
    b of
                          CmmCall {cml_cont :: CmmNode O C -> Maybe BlockId
    cml_cont = Just BlockId
    k} -> ElemOf ProcPointSet -> ProcPointSet -> ProcPointSet
    forall set. IsSet set => ElemOf set -> set -> set
    setInsert ElemOf ProcPointSet
    BlockId
    k ProcPointSet
    set
                          CmmForeignCall {succ :: CmmNode O C -> BlockId
    succ=BlockId
    k}     -> ElemOf ProcPointSet -> ProcPointSet -> ProcPointSet
    forall set. IsSet set => ElemOf set -> set -> set
    setInsert ElemOf ProcPointSet
    BlockId
    k ProcPointSet
    set
                          CmmNode O C
    _ -> ProcPointSet
    set

    minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
                        -> UniqSM ProcPointSet
    -- Given the set of successors of calls (which must be proc-points)
    -- figure out the minimal set of necessary proc-points
    minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> UniqSM ProcPointSet
    minimalProcPointSet Platform
    platform ProcPointSet
    callProcPoints CmmGraph
    g
      = Platform
    -> CmmGraph
    -> [Block CmmNode C C]
    -> ProcPointSet
    -> UniqSM ProcPointSet
    extendPPSet Platform
    platform CmmGraph
    g (CmmGraph -> [Block CmmNode C C]
    revPostorder CmmGraph
    g) ProcPointSet
    callProcPoints

    extendPPSet
        :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
    extendPPSet :: Platform
    -> CmmGraph
    -> [Block CmmNode C C]
    -> ProcPointSet
    -> UniqSM ProcPointSet
    extendPPSet Platform
    platform CmmGraph
    g [Block CmmNode C C]
    blocks ProcPointSet
    procPoints =
        let env :: LabelMap Status
    env = ProcPointSet -> CmmGraph -> LabelMap Status
    procPointAnalysis ProcPointSet
    procPoints CmmGraph
    g
            add :: ProcPointSet -> Block CmmNode C C -> ProcPointSet
    add ProcPointSet
    pps Block CmmNode C C
    block = let id :: BlockId
    id = Block CmmNode C C -> BlockId
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> BlockId
    entryLabel Block CmmNode C C
    block
                            in  case KeyOf LabelMap -> LabelMap Status -> Maybe Status
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    id LabelMap Status
    env of
                                  Just Status
    ProcPoint -> ElemOf ProcPointSet -> ProcPointSet -> ProcPointSet
    forall set. IsSet set => ElemOf set -> set -> set
    setInsert ElemOf ProcPointSet
    BlockId
    id ProcPointSet
    pps
                                  Maybe Status
    _ -> ProcPointSet
    pps
            procPoints' :: ProcPointSet
    procPoints' = (ProcPointSet -> Block CmmNode C C -> ProcPointSet)
    -> ProcPointSet -> CmmGraph -> ProcPointSet
    forall a. (a -> Block CmmNode C C -> a) -> a -> CmmGraph -> a
    foldlGraphBlocks ProcPointSet -> Block CmmNode C C -> ProcPointSet
    add ProcPointSet
    forall set. IsSet set => set
    setEmpty CmmGraph
    g
            newPoints :: [BlockId]
    newPoints = (Block CmmNode C C -> Maybe BlockId)
    -> [Block CmmNode C C] -> [BlockId]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe Block CmmNode C C -> Maybe BlockId
    ppSuccessor [Block CmmNode C C]
    blocks
            newPoint :: Maybe BlockId
    newPoint  = [BlockId] -> Maybe BlockId
    forall a. [a] -> Maybe a
    listToMaybe [BlockId]
    newPoints
            ppSuccessor :: Block CmmNode C C -> Maybe BlockId
    ppSuccessor Block CmmNode C C
    b =
                let nreached :: BlockId -> Int
    nreached BlockId
    id = case KeyOf LabelMap -> LabelMap Status -> Maybe Status
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    id LabelMap Status
    env Maybe Status -> Status -> Status
    forall a. Maybe a -> a -> a
    `orElse`
                                        String -> SDoc -> Status
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "no ppt" (BlockId -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr BlockId
    id SDoc -> SDoc -> SDoc
    <+> Platform -> Block CmmNode C C -> SDoc
    forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform Block CmmNode C C
    b) of
                                    Status
    ProcPoint -> Int
    1
                                    ReachedBy ProcPointSet
    ps -> ProcPointSet -> Int
    forall set. IsSet set => set -> Int
    setSize ProcPointSet
    ps
                    block_procpoints :: Int
    block_procpoints = BlockId -> Int
    nreached (Block CmmNode C C -> BlockId
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> BlockId
    entryLabel Block CmmNode C C
    b)
                    -- | Looking for a successor of b that is reached by
                    -- more proc points than b and is not already a proc
                    -- point.  If found, it can become a proc point.
                    newId :: BlockId -> Bool
    newId BlockId
    succ_id = Bool -> Bool
    not (ElemOf ProcPointSet -> ProcPointSet -> Bool
    forall set. IsSet set => ElemOf set -> set -> Bool
    setMember ElemOf ProcPointSet
    BlockId
    succ_id ProcPointSet
    procPoints') Bool -> Bool -> Bool
    &&
                                    BlockId -> Int
    nreached BlockId
    succ_id Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    block_procpoints
                in  [BlockId] -> Maybe BlockId
    forall a. [a] -> Maybe a
    listToMaybe ([BlockId] -> Maybe BlockId) -> [BlockId] -> Maybe BlockId
    forall a b. (a -> b) -> a -> b
    $ (BlockId -> Bool) -> [BlockId] -> [BlockId]
    forall a. (a -> Bool) -> [a] -> [a]
    filter BlockId -> Bool
    newId ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
    forall a b. (a -> b) -> a -> b
    $ Block CmmNode C C -> [BlockId]
    forall (thing :: Extensibility -> Extensibility -> *)
           (e :: Extensibility).
    NonLocal thing =>
    thing e C -> [BlockId]
    successors Block CmmNode C C
    b

        in case Maybe BlockId
    newPoint of
             Just BlockId
    id ->
                 if ElemOf ProcPointSet -> ProcPointSet -> Bool
    forall set. IsSet set => ElemOf set -> set -> Bool
    setMember ElemOf ProcPointSet
    BlockId
    id ProcPointSet
    procPoints'
                    then String -> UniqSM ProcPointSet
    forall a. String -> a
    panic String
    "added old proc pt"
                    else Platform
    -> CmmGraph
    -> [Block CmmNode C C]
    -> ProcPointSet
    -> UniqSM ProcPointSet
    extendPPSet Platform
    platform CmmGraph
    g [Block CmmNode C C]
    blocks (ElemOf ProcPointSet -> ProcPointSet -> ProcPointSet
    forall set. IsSet set => ElemOf set -> set -> set
    setInsert ElemOf ProcPointSet
    BlockId
    id ProcPointSet
    procPoints')
             Maybe BlockId
    Nothing -> ProcPointSet -> UniqSM ProcPointSet
    forall (m :: * -> *) a. Monad m => a -> m a
    return ProcPointSet
    procPoints'

    -- At this point, we have found a set of procpoints, each of which should be
    -- the entry point of a procedure.
    -- Now, we create the procedure for each proc point,
    -- which requires that we:
    -- 1. build a map from proc points to the blocks reachable from the proc point
    -- 2. turn each branch to a proc point into a jump
    -- 3. turn calls and returns into jumps
    -- 4. build info tables for the procedures -- and update the info table for
    --    the SRTs in the entry procedure as well.
    -- Input invariant: A block should only be reachable from a single ProcPoint.
    -- ToDo: use the _ret naming convention that the old code generator
    -- used. -- EZY
    splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl
                      -> UniqSM [CmmDecl]
    splitAtProcPoints :: Platform
    -> CLabel
    -> ProcPointSet
    -> ProcPointSet
    -> LabelMap Status
    -> CmmDecl
    -> UniqSM [CmmDecl]
    splitAtProcPoints Platform
    _ CLabel
    _ ProcPointSet
    _ ProcPointSet
    _ LabelMap Status
    _ t :: CmmDecl
    t@(CmmData Section
    _ CmmStatics
    _) = [CmmDecl] -> UniqSM [CmmDecl]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [CmmDecl
    t]
    splitAtProcPoints Platform
    platform CLabel
    entry_label ProcPointSet
    callPPs ProcPointSet
    procPoints LabelMap Status
    procMap CmmDecl
    cmmProc = do
      -- Build a map from procpoints to the blocks they reach
      let (CmmProc (TopInfo {info_tbls :: CmmTopInfo -> LabelMap CmmInfoTable
    info_tbls = LabelMap CmmInfoTable
    info_tbls}) CLabel
    top_l [GlobalReg]
    _ g :: CmmGraph
    g@(CmmGraph {g_entry :: forall (n :: Extensibility -> Extensibility -> *).
    GenCmmGraph n -> BlockId
    g_entry=BlockId
    entry})) = CmmDecl
    cmmProc

      let add :: map (map a) -> KeyOf map -> KeyOf map -> a -> map (map a)
    add map (map a)
    graphEnv KeyOf map
    procId KeyOf map
    bid a
    b = KeyOf map -> map a -> map (map a) -> map (map a)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert KeyOf map
    procId map a
    graph' map (map a)
    graphEnv
            where
              graph' :: map a
    graph' = KeyOf map -> a -> map a -> map a
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert KeyOf map
    bid a
    b map a
    graph
              graph :: map a
    graph  = KeyOf map -> map (map a) -> Maybe (map a)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf map
    procId map (map a)
    graphEnv Maybe (map a) -> map a -> map a
    forall a. Maybe a -> a -> a
    `orElse` map a
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty

      let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock)
          add_block :: LabelMap (LabelMap (Block CmmNode C C))
    -> Block CmmNode C C -> LabelMap (LabelMap (Block CmmNode C C))
    add_block LabelMap (LabelMap (Block CmmNode C C))
    graphEnv Block CmmNode C C
    b =
            case KeyOf LabelMap -> LabelMap Status -> Maybe Status
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    bid LabelMap Status
    procMap of
              Just Status
    ProcPoint -> LabelMap (LabelMap (Block CmmNode C C))
    -> KeyOf LabelMap
    -> KeyOf LabelMap
    -> Block CmmNode C C
    -> LabelMap (LabelMap (Block CmmNode C C))
    forall {map :: * -> *} {map :: * -> *} {a}.
    (IsMap map, IsMap map) =>
    map (map a) -> KeyOf map -> KeyOf map -> a -> map (map a)
    add LabelMap (LabelMap (Block CmmNode C C))
    graphEnv KeyOf LabelMap
    BlockId
    bid KeyOf LabelMap
    BlockId
    bid Block CmmNode C C
    b
              Just (ReachedBy ProcPointSet
    set) ->
                case ProcPointSet -> [ElemOf ProcPointSet]
    forall set. IsSet set => set -> [ElemOf set]
    setElems ProcPointSet
    set of
                  []   -> LabelMap (LabelMap (Block CmmNode C C))
    graphEnv
                  [ElemOf ProcPointSet
    id] -> LabelMap (LabelMap (Block CmmNode C C))
    -> KeyOf LabelMap
    -> KeyOf LabelMap
    -> Block CmmNode C C
    -> LabelMap (LabelMap (Block CmmNode C C))
    forall {map :: * -> *} {map :: * -> *} {a}.
    (IsMap map, IsMap map) =>
    map (map a) -> KeyOf map -> KeyOf map -> a -> map (map a)
    add LabelMap (LabelMap (Block CmmNode C C))
    graphEnv KeyOf LabelMap
    ElemOf ProcPointSet
    id KeyOf LabelMap
    BlockId
    bid Block CmmNode C C
    b
                  [ElemOf ProcPointSet]
    _    -> String -> LabelMap (LabelMap (Block CmmNode C C))
    forall a. String -> a
    panic String
    "Each block should be reachable from only one ProcPoint"
              Maybe Status
    Nothing -> LabelMap (LabelMap (Block CmmNode C C))
    graphEnv
            where
              bid :: BlockId
    bid = Block CmmNode C C -> BlockId
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> BlockId
    entryLabel Block CmmNode C C
    b

      let liveness :: BlockEntryLiveness GlobalReg
    liveness = Platform -> CmmGraph -> BlockEntryLiveness GlobalReg
    cmmGlobalLiveness Platform
    platform CmmGraph
    g
      let ppLiveness :: BlockId -> [GlobalReg]
    ppLiveness BlockId
    pp = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter GlobalReg -> Bool
    isArgReg ([GlobalReg] -> [GlobalReg]) -> [GlobalReg] -> [GlobalReg]
    forall a b. (a -> b) -> a -> b
    $ RegSet GlobalReg -> [GlobalReg]
    forall r. RegSet r -> [r]
    regSetToList (RegSet GlobalReg -> [GlobalReg])
    -> RegSet GlobalReg -> [GlobalReg]
    forall a b. (a -> b) -> a -> b
    $
                            String -> Maybe (RegSet GlobalReg) -> RegSet GlobalReg
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "ppLiveness" (Maybe (RegSet GlobalReg) -> RegSet GlobalReg)
    -> Maybe (RegSet GlobalReg) -> RegSet GlobalReg
    forall a b. (a -> b) -> a -> b
    $ KeyOf LabelMap
    -> BlockEntryLiveness GlobalReg -> Maybe (RegSet GlobalReg)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    pp BlockEntryLiveness GlobalReg
    liveness
      LabelMap (LabelMap (Block CmmNode C C))
    graphEnv <- LabelMap (LabelMap (Block CmmNode C C))
    -> UniqSM (LabelMap (LabelMap (Block CmmNode C C)))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LabelMap (LabelMap (Block CmmNode C C))
     -> UniqSM (LabelMap (LabelMap (Block CmmNode C C))))
    -> LabelMap (LabelMap (Block CmmNode C C))
    -> UniqSM (LabelMap (LabelMap (Block CmmNode C C)))
    forall a b. (a -> b) -> a -> b
    $ (LabelMap (LabelMap (Block CmmNode C C))
     -> Block CmmNode C C -> LabelMap (LabelMap (Block CmmNode C C)))
    -> LabelMap (LabelMap (Block CmmNode C C))
    -> CmmGraph
    -> LabelMap (LabelMap (Block CmmNode C C))
    forall a. (a -> Block CmmNode C C -> a) -> a -> CmmGraph -> a
    foldlGraphBlocks LabelMap (LabelMap (Block CmmNode C C))
    -> Block CmmNode C C -> LabelMap (LabelMap (Block CmmNode C C))
    add_block LabelMap (LabelMap (Block CmmNode C C))
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty CmmGraph
    g

      -- Build a map from proc point BlockId to pairs of:
      --  * Labels for their new procedures
      --  * Labels for the info tables of their new procedures (only if
      --    the proc point is a callPP)
      -- Due to common blockification, we may overestimate the set of procpoints.
      let add_label :: LabelMap (CLabel, Maybe CLabel)
    -> BlockId -> LabelMap (CLabel, Maybe CLabel)
    add_label LabelMap (CLabel, Maybe CLabel)
    map BlockId
    pp = KeyOf LabelMap
    -> (CLabel, Maybe CLabel)
    -> LabelMap (CLabel, Maybe CLabel)
    -> LabelMap (CLabel, Maybe CLabel)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert KeyOf LabelMap
    BlockId
    pp (CLabel, Maybe CLabel)
    lbls LabelMap (CLabel, Maybe CLabel)
    map
            where lbls :: (CLabel, Maybe CLabel)
    lbls | BlockId
    pp BlockId -> BlockId -> Bool
    forall a. Eq a => a -> a -> Bool
    == BlockId
    entry = (CLabel
    entry_label, (CmmInfoTable -> CLabel) -> Maybe CmmInfoTable -> Maybe CLabel
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap CmmInfoTable -> CLabel
    cit_lbl (KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    entry LabelMap CmmInfoTable
    info_tbls))
                       | Bool
    otherwise   = (CLabel
    block_lbl, Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (ElemOf ProcPointSet -> ProcPointSet -> Bool
    forall set. IsSet set => ElemOf set -> set -> Bool
    setMember ElemOf ProcPointSet
    BlockId
    pp ProcPointSet
    callPPs) Maybe () -> Maybe CLabel -> Maybe CLabel
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
                                                     CLabel -> Maybe CLabel
    forall a. a -> Maybe a
    Just CLabel
    info_table_lbl)
                       where block_lbl :: CLabel
    block_lbl      = BlockId -> CLabel
    blockLbl BlockId
    pp
                             info_table_lbl :: CLabel
    info_table_lbl = BlockId -> CLabel
    infoTblLbl BlockId
    pp

          procLabels :: LabelMap (CLabel, Maybe CLabel)
          procLabels :: LabelMap (CLabel, Maybe CLabel)
    procLabels = (LabelMap (CLabel, Maybe CLabel)
     -> BlockId -> LabelMap (CLabel, Maybe CLabel))
    -> LabelMap (CLabel, Maybe CLabel)
    -> [BlockId]
    -> LabelMap (CLabel, Maybe CLabel)
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' LabelMap (CLabel, Maybe CLabel)
    -> BlockId -> LabelMap (CLabel, Maybe CLabel)
    add_label LabelMap (CLabel, Maybe CLabel)
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty
                              ((BlockId -> Bool) -> [BlockId] -> [BlockId]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((BlockId -> LabelMap (Block CmmNode C C) -> Bool)
    -> LabelMap (Block CmmNode C C) -> BlockId -> Bool
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip BlockId -> LabelMap (Block CmmNode C C) -> Bool
    forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
    mapMember (CmmGraph -> LabelMap (Block CmmNode C C)
    toBlockMap CmmGraph
    g)) (ProcPointSet -> [ElemOf ProcPointSet]
    forall set. IsSet set => set -> [ElemOf set]
    setElems ProcPointSet
    procPoints))

      -- In each new graph, add blocks jumping off to the new procedures,
      -- and replace branches to procpoints with branches to the jump-off blocks
      let add_jump_block :: (LabelMap Label, [CmmBlock])
                         -> (Label, CLabel)
                         -> UniqSM (LabelMap Label, [CmmBlock])
          add_jump_block :: (LabelMap BlockId, [Block CmmNode C C])
    -> (BlockId, CLabel)
    -> UniqSM (LabelMap BlockId, [Block CmmNode C C])
    add_jump_block (LabelMap BlockId
    env, [Block CmmNode C C]
    bs) (BlockId
    pp, CLabel
    l) = do
            BlockId
    bid <- (Unique -> BlockId) -> UniqSM Unique -> UniqSM BlockId
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM Unique -> BlockId
    mkBlockId UniqSM Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
            let b :: Block CmmNode C C
    b    = CmmNode C O
    -> Block CmmNode O O -> CmmNode O C -> Block CmmNode C C
    forall (n :: Extensibility -> Extensibility -> *).
    n C O -> Block n O O -> n O C -> Block n C C
    blockJoin (BlockId -> CmmTickScope -> CmmNode C O
    CmmEntry BlockId
    bid CmmTickScope
    GlobalScope) Block CmmNode O O
    forall (n :: Extensibility -> Extensibility -> *). Block n O O
    emptyBlock CmmNode O C
    jump
                live :: [GlobalReg]
    live = BlockId -> [GlobalReg]
    ppLiveness BlockId
    pp
                jump :: CmmNode O C
    jump = CmmExpr
    -> Maybe BlockId -> [GlobalReg] -> Int -> Int -> Int -> CmmNode O C
    CmmCall (CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel CLabel
    l)) Maybe BlockId
    forall a. Maybe a
    Nothing [GlobalReg]
    live Int
    0 Int
    0 Int
    0
            (LabelMap BlockId, [Block CmmNode C C])
    -> UniqSM (LabelMap BlockId, [Block CmmNode C C])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (KeyOf LabelMap -> BlockId -> LabelMap BlockId -> LabelMap BlockId
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert KeyOf LabelMap
    BlockId
    pp BlockId
    bid LabelMap BlockId
    env, Block CmmNode C C
    b Block CmmNode C C -> [Block CmmNode C C] -> [Block CmmNode C C]
    forall a. a -> [a] -> [a]
    : [Block CmmNode C C]
    bs)

      -- when jumping to a PP that has an info table, if
      -- tablesNextToCode is off we must jump to the entry
      -- label instead.
      let tablesNextToCode :: Bool
    tablesNextToCode = Platform -> Bool
    platformTablesNextToCode Platform
    platform

      let jump_label :: Maybe CLabel -> CLabel -> CLabel
    jump_label (Just CLabel
    info_lbl) CLabel
    _
                     | Bool
    tablesNextToCode = CLabel
    info_lbl
                     | Bool
    otherwise        = Platform -> CLabel -> CLabel
    toEntryLbl Platform
    platform CLabel
    info_lbl
          jump_label Maybe CLabel
    Nothing  CLabel
    block_lbl = CLabel
    block_lbl

      let add_if_pp :: BlockId -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
    add_if_pp BlockId
    id [(BlockId, CLabel)]
    rst =
            case KeyOf LabelMap
    -> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    id LabelMap (CLabel, Maybe CLabel)
    procLabels of
              Just (CLabel
    lbl, Maybe CLabel
    mb_info_lbl) -> (BlockId
    id, Maybe CLabel -> CLabel -> CLabel
    jump_label Maybe CLabel
    mb_info_lbl CLabel
    lbl) (BlockId, CLabel) -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
    forall a. a -> [a] -> [a]
    : [(BlockId, CLabel)]
    rst
              Maybe (CLabel, Maybe CLabel)
    Nothing                 -> [(BlockId, CLabel)]
    rst

      let add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
          add_if_branch_to_pp :: Block CmmNode C C -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
    add_if_branch_to_pp Block CmmNode C C
    block [(BlockId, CLabel)]
    rst =
            case Block CmmNode C C -> CmmNode O C
    forall (n :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    Block n x C -> n O C
    lastNode Block CmmNode C C
    block of
              CmmBranch BlockId
    id            -> BlockId -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
    add_if_pp BlockId
    id [(BlockId, CLabel)]
    rst
              CmmCondBranch CmmExpr
    _ BlockId
    ti BlockId
    fi Maybe Bool
    _ -> BlockId -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
    add_if_pp BlockId
    ti (BlockId -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
    add_if_pp BlockId
    fi [(BlockId, CLabel)]
    rst)
              CmmSwitch CmmExpr
    _ SwitchTargets
    ids         -> (BlockId -> [(BlockId, CLabel)] -> [(BlockId, CLabel)])
    -> [(BlockId, CLabel)] -> [BlockId] -> [(BlockId, CLabel)]
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr BlockId -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
    add_if_pp [(BlockId, CLabel)]
    rst ([BlockId] -> [(BlockId, CLabel)])
    -> [BlockId] -> [(BlockId, CLabel)]
    forall a b. (a -> b) -> a -> b
    $ SwitchTargets -> [BlockId]
    switchTargetsToList SwitchTargets
    ids
              CmmNode O C
    _                       -> [(BlockId, CLabel)]
    rst

      let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)
          add_jumps :: LabelMap CmmGraph
    -> (BlockId, LabelMap (Block CmmNode C C))
    -> UniqSM (LabelMap CmmGraph)
    add_jumps LabelMap CmmGraph
    newGraphEnv (BlockId
    ppId, LabelMap (Block CmmNode C C)
    blockEnv) = do
            -- find which procpoints we currently branch to
            let needed_jumps :: [(BlockId, CLabel)]
    needed_jumps = (Block CmmNode C C -> [(BlockId, CLabel)] -> [(BlockId, CLabel)])
    -> [(BlockId, CLabel)]
    -> LabelMap (Block CmmNode C C)
    -> [(BlockId, CLabel)]
    forall (map :: * -> *) a b.
    IsMap map =>
    (a -> b -> b) -> b -> map a -> b
    mapFoldr Block CmmNode C C -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
    add_if_branch_to_pp [] LabelMap (Block CmmNode C C)
    blockEnv

            (LabelMap BlockId
    jumpEnv, [Block CmmNode C C]
    jumpBlocks) <-
               ((LabelMap BlockId, [Block CmmNode C C])
     -> (BlockId, CLabel)
     -> UniqSM (LabelMap BlockId, [Block CmmNode C C]))
    -> (LabelMap BlockId, [Block CmmNode C C])
    -> [(BlockId, CLabel)]
    -> UniqSM (LabelMap BlockId, [Block CmmNode C C])
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM (LabelMap BlockId, [Block CmmNode C C])
    -> (BlockId, CLabel)
    -> UniqSM (LabelMap BlockId, [Block CmmNode C C])
    add_jump_block (LabelMap BlockId
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty, []) [(BlockId, CLabel)]
    needed_jumps
                -- update the entry block
            let b :: Block CmmNode C C
    b = String -> Maybe (Block CmmNode C C) -> Block CmmNode C C
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "block in env" (Maybe (Block CmmNode C C) -> Block CmmNode C C)
    -> Maybe (Block CmmNode C C) -> Block CmmNode C C
    forall a b. (a -> b) -> a -> b
    $ KeyOf LabelMap
    -> LabelMap (Block CmmNode C C) -> Maybe (Block CmmNode C C)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    ppId LabelMap (Block CmmNode C C)
    blockEnv
                blockEnv' :: LabelMap (Block CmmNode C C)
    blockEnv' = KeyOf LabelMap
    -> Block CmmNode C C
    -> LabelMap (Block CmmNode C C)
    -> LabelMap (Block CmmNode C C)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert KeyOf LabelMap
    BlockId
    ppId Block CmmNode C C
    b LabelMap (Block CmmNode C C)
    blockEnv
                -- replace branches to procpoints with branches to jumps
                blockEnv'' :: LabelMap (Block CmmNode C C)
    blockEnv'' = CmmGraph -> LabelMap (Block CmmNode C C)
    toBlockMap (CmmGraph -> LabelMap (Block CmmNode C C))
    -> CmmGraph -> LabelMap (Block CmmNode C C)
    forall a b. (a -> b) -> a -> b
    $ LabelMap BlockId -> CmmGraph -> CmmGraph
    replaceBranches LabelMap BlockId
    jumpEnv (CmmGraph -> CmmGraph) -> CmmGraph -> CmmGraph
    forall a b. (a -> b) -> a -> b
    $ BlockId -> LabelMap (Block CmmNode C C) -> CmmGraph
    ofBlockMap BlockId
    ppId LabelMap (Block CmmNode C C)
    blockEnv'
                -- add the jump blocks to the graph
                blockEnv''' :: LabelMap (Block CmmNode C C)
    blockEnv''' = (LabelMap (Block CmmNode C C)
     -> Block CmmNode C C -> LabelMap (Block CmmNode C C))
    -> LabelMap (Block CmmNode C C)
    -> [Block CmmNode C C]
    -> LabelMap (Block CmmNode C C)
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' ((Block CmmNode C C
     -> LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C))
    -> LabelMap (Block CmmNode C C)
    -> Block CmmNode C C
    -> LabelMap (Block CmmNode C C)
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Block CmmNode C C
    -> LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C)
    forall (block :: Extensibility -> Extensibility -> *).
    (NonLocal block, HasDebugCallStack) =>
    block C C -> LabelMap (block C C) -> LabelMap (block C C)
    addBlock) LabelMap (Block CmmNode C C)
    blockEnv'' [Block CmmNode C C]
    jumpBlocks
            let g' :: CmmGraph
    g' = BlockId -> LabelMap (Block CmmNode C C) -> CmmGraph
    ofBlockMap BlockId
    ppId LabelMap (Block CmmNode C C)
    blockEnv'''
            -- pprTrace "g' pre jumps" (ppr g') $ do
            LabelMap CmmGraph -> UniqSM (LabelMap CmmGraph)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (KeyOf LabelMap
    -> CmmGraph -> LabelMap CmmGraph -> LabelMap CmmGraph
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert KeyOf LabelMap
    BlockId
    ppId CmmGraph
    g' LabelMap CmmGraph
    newGraphEnv)

      LabelMap CmmGraph
    graphEnv <- (LabelMap CmmGraph
     -> (BlockId, LabelMap (Block CmmNode C C))
     -> UniqSM (LabelMap CmmGraph))
    -> LabelMap CmmGraph
    -> [(BlockId, LabelMap (Block CmmNode C C))]
    -> UniqSM (LabelMap CmmGraph)
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM LabelMap CmmGraph
    -> (BlockId, LabelMap (Block CmmNode C C))
    -> UniqSM (LabelMap CmmGraph)
    add_jumps LabelMap CmmGraph
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty ([(BlockId, LabelMap (Block CmmNode C C))]
     -> UniqSM (LabelMap CmmGraph))
    -> [(BlockId, LabelMap (Block CmmNode C C))]
    -> UniqSM (LabelMap CmmGraph)
    forall a b. (a -> b) -> a -> b
    $ LabelMap (LabelMap (Block CmmNode C C))
    -> [(KeyOf LabelMap, LabelMap (Block CmmNode C C))]
    forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
    mapToList LabelMap (LabelMap (Block CmmNode C C))
    graphEnv

      let to_proc :: (BlockId, CmmGraph) -> CmmDecl
    to_proc (BlockId
    bid, CmmGraph
    g)
              | BlockId
    bid BlockId -> BlockId -> Bool
    forall a. Eq a => a -> a -> Bool
    == BlockId
    entry
              =  CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc (TopInfo {info_tbls :: LabelMap CmmInfoTable
    info_tbls  = LabelMap CmmInfoTable
    info_tbls,
                                   stack_info :: CmmStackInfo
    stack_info = CmmStackInfo
    stack_info})
                         CLabel
    top_l [GlobalReg]
    live CmmGraph
    g'
              | Bool
    otherwise
              = case String -> Maybe (CLabel, Maybe CLabel) -> (CLabel, Maybe CLabel)
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "pp label" (Maybe (CLabel, Maybe CLabel) -> (CLabel, Maybe CLabel))
    -> Maybe (CLabel, Maybe CLabel) -> (CLabel, Maybe CLabel)
    forall a b. (a -> b) -> a -> b
    $ KeyOf LabelMap
    -> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    bid LabelMap (CLabel, Maybe CLabel)
    procLabels of
                  (CLabel
    lbl, Just CLabel
    info_lbl)
                     -> CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc (TopInfo { info_tbls :: LabelMap CmmInfoTable
    info_tbls = KeyOf LabelMap -> CmmInfoTable -> LabelMap CmmInfoTable
    forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
    mapSingleton (CmmGraph -> BlockId
    forall (n :: Extensibility -> Extensibility -> *).
    GenCmmGraph n -> BlockId
    g_entry CmmGraph
    g) (CLabel -> CmmInfoTable
    mkEmptyContInfoTable CLabel
    info_lbl)
                                         , stack_info :: CmmStackInfo
    stack_info=CmmStackInfo
    stack_info})
                                CLabel
    lbl [GlobalReg]
    live CmmGraph
    g'
                  (CLabel
    lbl, Maybe CLabel
    Nothing)
                     -> CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc (TopInfo {info_tbls :: LabelMap CmmInfoTable
    info_tbls = LabelMap CmmInfoTable
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty, stack_info :: CmmStackInfo
    stack_info=CmmStackInfo
    stack_info})
                                CLabel
    lbl [GlobalReg]
    live CmmGraph
    g'
                 where
                  g' :: CmmGraph
    g' = CmmGraph -> CmmGraph
    replacePPIds CmmGraph
    g
                  live :: [GlobalReg]
    live = BlockId -> [GlobalReg]
    ppLiveness (CmmGraph -> BlockId
    forall (n :: Extensibility -> Extensibility -> *).
    GenCmmGraph n -> BlockId
    g_entry CmmGraph
    g')
                  stack_info :: CmmStackInfo
    stack_info = StackInfo { arg_space :: Int
    arg_space = Int
    0
                                         , do_layout :: Bool
    do_layout = Bool
    True }
                                -- cannot use panic, this is printed by -ddump-cmm

          -- References to procpoint IDs can now be replaced with the
          -- infotable's label
          replacePPIds :: CmmGraph -> CmmGraph
    replacePPIds CmmGraph
    g = {-# SCC "replacePPIds" #-}
                           (CmmNode C O -> CmmNode C O, CmmNode O O -> CmmNode O O,
     CmmNode O C -> CmmNode O C)
    -> CmmGraph -> CmmGraph
    mapGraphNodes (CmmNode C O -> CmmNode C O
    forall a. a -> a
    id, (CmmExpr -> CmmExpr) -> CmmNode O O -> CmmNode O O
    forall (e :: Extensibility) (x :: Extensibility).
    (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
    mapExp CmmExpr -> CmmExpr
    repl, (CmmExpr -> CmmExpr) -> CmmNode O C -> CmmNode O C
    forall (e :: Extensibility) (x :: Extensibility).
    (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
    mapExp CmmExpr -> CmmExpr
    repl) CmmGraph
    g
            where repl :: CmmExpr -> CmmExpr
    repl e :: CmmExpr
    e@(CmmLit (CmmBlock BlockId
    bid)) =
                    case KeyOf LabelMap
    -> LabelMap (CLabel, Maybe CLabel) -> Maybe (CLabel, Maybe CLabel)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    bid LabelMap (CLabel, Maybe CLabel)
    procLabels of
                      Just (CLabel
    _, Just CLabel
    info_lbl)  -> CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel CLabel
    info_lbl)
                      Maybe (CLabel, Maybe CLabel)
    _ -> CmmExpr
    e
                  repl CmmExpr
    e = CmmExpr
    e

      -- The C back end expects to see return continuations before the
      -- call sites.  Here, we sort them in reverse order -- it gets
      -- reversed later.
      let add_block_num :: (a, map a) -> thing C x -> (a, map a)
    add_block_num (a
    i, map a
    map) thing C x
    block =
            (a
    i a -> a -> a
    forall a. Num a => a -> a -> a
    + a
    1, KeyOf map -> a -> map a -> map a
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert (thing C x -> BlockId
    forall (thing :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> BlockId
    entryLabel thing C x
    block) a
    i map a
    map)
      let (Int
    _, LabelMap Int
    block_order) =
              ((Int, LabelMap Int) -> Block CmmNode C C -> (Int, LabelMap Int))
    -> (Int, LabelMap Int)
    -> [Block CmmNode C C]
    -> (Int, LabelMap Int)
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (Int, LabelMap Int) -> Block CmmNode C C -> (Int, LabelMap Int)
    forall {map :: * -> *} {a}
           {thing :: Extensibility -> Extensibility -> *}
           {x :: Extensibility}.
    (KeyOf map ~ BlockId, Num a, IsMap map, NonLocal thing) =>
    (a, map a) -> thing C x -> (a, map a)
    add_block_num (Int
    0::Int, LabelMap Int
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty :: LabelMap Int)
                    (CmmGraph -> [Block CmmNode C C]
    revPostorder CmmGraph
    g)
      let sort_fn :: (BlockId, CmmGraph) -> (BlockId, CmmGraph) -> Ordering
    sort_fn (BlockId
    bid, CmmGraph
    _) (BlockId
    bid', CmmGraph
    _) =
            Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (String -> Maybe Int -> Int
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "block_order" (Maybe Int -> Int) -> Maybe Int -> Int
    forall a b. (a -> b) -> a -> b
    $ KeyOf LabelMap -> LabelMap Int -> Maybe Int
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    bid  LabelMap Int
    block_order)
                    (String -> Maybe Int -> Int
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "block_order" (Maybe Int -> Int) -> Maybe Int -> Int
    forall a b. (a -> b) -> a -> b
    $ KeyOf LabelMap -> LabelMap Int -> Maybe Int
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    bid' LabelMap Int
    block_order)

      [CmmDecl] -> UniqSM [CmmDecl]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([CmmDecl] -> UniqSM [CmmDecl]) -> [CmmDecl] -> UniqSM [CmmDecl]
    forall a b. (a -> b) -> a -> b
    $ ((BlockId, CmmGraph) -> CmmDecl)
    -> [(BlockId, CmmGraph)] -> [CmmDecl]
    forall a b. (a -> b) -> [a] -> [b]
    map (BlockId, CmmGraph) -> CmmDecl
    to_proc ([(BlockId, CmmGraph)] -> [CmmDecl])
    -> [(BlockId, CmmGraph)] -> [CmmDecl]
    forall a b. (a -> b) -> a -> b
    $ ((BlockId, CmmGraph) -> (BlockId, CmmGraph) -> Ordering)
    -> [(BlockId, CmmGraph)] -> [(BlockId, CmmGraph)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (BlockId, CmmGraph) -> (BlockId, CmmGraph) -> Ordering
    sort_fn ([(BlockId, CmmGraph)] -> [(BlockId, CmmGraph)])
    -> [(BlockId, CmmGraph)] -> [(BlockId, CmmGraph)]
    forall a b. (a -> b) -> a -> b
    $ LabelMap CmmGraph -> [(KeyOf LabelMap, CmmGraph)]
    forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
    mapToList LabelMap CmmGraph
    graphEnv

    -- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a
    -- recursive lookup, see comment below.
    replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
    replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
    replaceBranches LabelMap BlockId
    env CmmGraph
    cmmg
      = {-# SCC "replaceBranches" #-}
        BlockId -> LabelMap (Block CmmNode C C) -> CmmGraph
    ofBlockMap (CmmGraph -> BlockId
    forall (n :: Extensibility -> Extensibility -> *).
    GenCmmGraph n -> BlockId
    g_entry CmmGraph
    cmmg) (LabelMap (Block CmmNode C C) -> CmmGraph)
    -> LabelMap (Block CmmNode C C) -> CmmGraph
    forall a b. (a -> b) -> a -> b
    $ (Block CmmNode C C -> Block CmmNode C C)
    -> LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C)
    forall (map :: * -> *) a b. IsMap map => (a -> b) -> map a -> map b
    mapMap Block CmmNode C C -> Block CmmNode C C
    forall {x :: Extensibility}. Block CmmNode x C -> Block CmmNode x C
    f (LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C))
    -> LabelMap (Block CmmNode C C) -> LabelMap (Block CmmNode C C)
    forall a b. (a -> b) -> a -> b
    $ CmmGraph -> LabelMap (Block CmmNode C C)
    toBlockMap CmmGraph
    cmmg
      where
        f :: Block CmmNode x C -> Block CmmNode x C
    f Block CmmNode x C
    block = Block CmmNode x C -> CmmNode O C -> Block CmmNode x C
    forall (n :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    Block n x C -> n O C -> Block n x C
    replaceLastNode Block CmmNode x C
    block (CmmNode O C -> Block CmmNode x C)
    -> CmmNode O C -> Block CmmNode x C
    forall a b. (a -> b) -> a -> b
    $ CmmNode O C -> CmmNode O C
    last (Block CmmNode x C -> CmmNode O C
    forall (n :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    Block n x C -> n O C
    lastNode Block CmmNode x C
    block)

        last :: CmmNode O C -> CmmNode O C
        last :: CmmNode O C -> CmmNode O C
    last (CmmBranch BlockId
    id)          = BlockId -> CmmNode O C
    CmmBranch (BlockId -> BlockId
    lookup BlockId
    id)
        last (CmmCondBranch CmmExpr
    e BlockId
    ti BlockId
    fi Maybe Bool
    l) = CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
    CmmCondBranch CmmExpr
    e (BlockId -> BlockId
    lookup BlockId
    ti) (BlockId -> BlockId
    lookup BlockId
    fi) Maybe Bool
    l
        last (CmmSwitch CmmExpr
    e SwitchTargets
    ids)       = CmmExpr -> SwitchTargets -> CmmNode O C
    CmmSwitch CmmExpr
    e ((BlockId -> BlockId) -> SwitchTargets -> SwitchTargets
    mapSwitchTargets BlockId -> BlockId
    lookup SwitchTargets
    ids)
        last l :: CmmNode O C
    l@(CmmCall {})          = CmmNode O C
    l { cml_cont :: Maybe BlockId
    cml_cont = Maybe BlockId
    forall a. Maybe a
    Nothing }
                -- NB. remove the continuation of a CmmCall, since this
                -- label will now be in a different CmmProc.  Not only
                -- is this tidier, it stops CmmLint from complaining.
        last l :: CmmNode O C
    l@(CmmForeignCall {})   = CmmNode O C
    l
        lookup :: BlockId -> BlockId
    lookup BlockId
    id = (BlockId -> BlockId) -> Maybe BlockId -> Maybe BlockId
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap BlockId -> BlockId
    lookup (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
                -- XXX: this is a recursive lookup, it follows chains
                -- until the lookup returns Nothing, at which point we
                -- return the last BlockId

    -- --------------------------------------------------------------
    -- Not splitting proc points: add info tables for continuations

    attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
    attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
    attachContInfoTables ProcPointSet
    call_proc_points (CmmProc CmmTopInfo
    top_info CLabel
    top_l [GlobalReg]
    live CmmGraph
    g)
     = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc CmmTopInfo
    top_info{info_tbls :: LabelMap CmmInfoTable
    info_tbls = LabelMap CmmInfoTable
    info_tbls'} CLabel
    top_l [GlobalReg]
    live CmmGraph
    g
     where
       info_tbls' :: LabelMap CmmInfoTable
    info_tbls' = LabelMap CmmInfoTable
    -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
    forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
    mapUnion (CmmTopInfo -> LabelMap CmmInfoTable
    info_tbls CmmTopInfo
    top_info) (LabelMap CmmInfoTable -> LabelMap CmmInfoTable)
    -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
    forall a b. (a -> b) -> a -> b
    $
                    [(KeyOf LabelMap, CmmInfoTable)] -> LabelMap CmmInfoTable
    forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
    mapFromList [ (KeyOf LabelMap
    BlockId
    l, CLabel -> CmmInfoTable
    mkEmptyContInfoTable (BlockId -> CLabel
    infoTblLbl BlockId
    l))
                                | BlockId
    l <- ProcPointSet -> [ElemOf ProcPointSet]
    forall set. IsSet set => set -> [ElemOf set]
    setElems ProcPointSet
    call_proc_points
                                , BlockId
    l BlockId -> BlockId -> Bool
    forall a. Eq a => a -> a -> Bool
    /= CmmGraph -> BlockId
    forall (n :: Extensibility -> Extensibility -> *).
    GenCmmGraph n -> BlockId
    g_entry CmmGraph
    g ]
    attachContInfoTables ProcPointSet
    _ CmmDecl
    other_decl
     = CmmDecl
    other_decl

    ----------------------------------------------------------------

    {-
    Note [Direct reachability]

    Block B is directly reachable from proc point P iff control can flow
    from P to B without passing through an intervening proc point.
    -}

    ----------------------------------------------------------------

    {-
    Note [No simple dataflow]

    Sadly, it seems impossible to compute the proc points using a single
    dataflow pass.  One might attempt to use this simple lattice:

      data Location = Unknown
                    | InProc BlockId -- node is in procedure headed by the named proc point
                    | ProcPoint      -- node is itself a proc point

    At a join, a node in two different blocks becomes a proc point.
    The difficulty is that the change of information during iterative
    computation may promote a node prematurely.  Here's a program that
    illustrates the difficulty:

      f () {
      entry:
        ....
      L1:
        if (...) { ... }
        else { ... }

      L2: if (...) { g(); goto L1; }
          return x + y;
      }

    The only proc-point needed (besides the entry) is L1.  But in an
    iterative analysis, consider what happens to L2.  On the first pass
    through, it rises from Unknown to 'InProc entry', but when L1 is
    promoted to a proc point (because it's the successor of g()), L1's
    successors will be promoted to 'InProc L1'.  The problem hits when the
    new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
    The join operation makes it a proc point when in fact it needn't be,
    because its immediate dominator L1 is already a proc point and there
    are no other proc points that directly reach L2.
    -}

    {- Note [Separate Adams optimization]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    It may be worthwhile to attempt the Adams optimization by rewriting
    the graph before the assignment of proc-point protocols.  Here are a
    couple of rules:

      g() returns to k;                    g() returns to L;
      k: CopyIn c ress; goto L:
       ...                        ==>        ...
      L: // no CopyIn node here            L: CopyIn c ress;

    And when c == c' and ress == ress', this also:

      g() returns to k;                    g() returns to L;
      k: CopyIn c ress; goto L:
       ...                        ==>        ...
      L: CopyIn c' ress'                   L: CopyIn c' ress' ;

    In both cases the goal is to eliminate k.
    -}