nativeGen/RegAlloc/Linear/JoinToTargets.hs

    -- | Handles joining of a jump instruction to its targets.

    --      The first time we encounter a jump to a particular basic block, we
    --      record the assignment of temporaries.  The next time we encounter a
    --      jump to the same block, we compare our current assignment to the
    --      stored one.  They might be different if spilling has occurred in one
    --      branch; so some fixup code will be required to match up the assignments.
    --
    module RegAlloc.Linear.JoinToTargets (joinToTargets) where

    import RegAlloc.Linear.State
    import RegAlloc.Linear.Base
    import RegAlloc.Linear.FreeRegs
    import RegAlloc.Liveness
    import Instruction
    import Reg

    import BlockId
    import Digraph
    import DynFlags
    import Outputable
    import Unique
    import UniqFM
    import UniqSet

    -- | For a jump instruction at the end of a block, generate fixup code so its
    --      vregs are in the correct regs for its destination.
    --
    joinToTargets
            :: (FR freeRegs, Instruction instr)
            => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs
                                            --      that are known to be live on the entry to each block.

            -> BlockId                      -- ^ id of the current block
            -> instr                        -- ^ branch instr on the end of the source block.

            -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.
                             , instr)               -- the original branch
                                                    -- instruction, but maybe
                                                    -- patched to jump
                                                    -- to a fixup block first.

    joinToTargets block_live id instr

            -- we only need to worry about jump instructions.
            | not $ isJumpishInstr instr
            = return ([], instr)

            | otherwise
            = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)

    -----
    joinToTargets'
            :: (FR freeRegs, Instruction instr)
            => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs
                                            --      that are known to be live on the entry to each block.

            -> [NatBasicBlock instr]        -- ^ acc blocks of fixup code.

            -> BlockId                      -- ^ id of the current block
            -> instr                        -- ^ branch instr on the end of the source block.

            -> [BlockId]                    -- ^ branch destinations still to consider.

            -> RegM freeRegs ([NatBasicBlock instr], instr)

    -- no more targets to consider. all done.
    joinToTargets' _          new_blocks _ instr []
            = return (new_blocks, instr)

    -- handle a branch target.
    joinToTargets' block_live new_blocks block_id instr (dest:dests)
     = do
            -- get the map of where the vregs are stored on entry to each basic block.
            block_assig     <- getBlockAssigR

            -- get the assignment on entry to the branch instruction.
            assig           <- getAssigR

            -- adjust the current assignment to remove any vregs that are not live
            -- on entry to the destination block.
            let Just live_set       = mapLookup dest block_live
            let still_live uniq _   = uniq `elemUniqSet_Directly` live_set
            let adjusted_assig      = filterUFM_Directly still_live assig

            -- and free up those registers which are now free.
            let to_free =
                    [ r     | (reg, loc) <- ufmToList assig
                            , not (elemUniqSet_Directly reg live_set)
                            , r          <- regsOfLoc loc ]

            case mapLookup dest block_assig of
             Nothing
              -> joinToTargets_first
                            block_live new_blocks block_id instr dest dests
                            block_assig adjusted_assig to_free

             Just (_, dest_assig)
              -> joinToTargets_again
                            block_live new_blocks block_id instr dest dests
                            adjusted_assig dest_assig

    -- this is the first time we jumped to this block.
    joinToTargets_first :: (FR freeRegs, Instruction instr)
                        => BlockMap RegSet
                        -> [NatBasicBlock instr]
                        -> BlockId
                        -> instr
                        -> BlockId
                        -> [BlockId]
                        -> BlockAssignment freeRegs
                        -> RegMap Loc
                        -> [RealReg]
                        -> RegM freeRegs ([NatBasicBlock instr], instr)
    joinToTargets_first block_live new_blocks block_id instr dest dests
            block_assig src_assig
            to_free

     = do   dflags <- getDynFlags
            let platform = targetPlatform dflags

            -- free up the regs that are not live on entry to this block.
            freeregs        <- getFreeRegsR
            let freeregs' = foldr (frReleaseReg platform) freeregs to_free

            -- remember the current assignment on entry to this block.
            setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)

            joinToTargets' block_live new_blocks block_id instr dests

    -- we've jumped to this block before
    joinToTargets_again :: (Instruction instr, FR freeRegs)
                        => BlockMap RegSet
                        -> [NatBasicBlock instr]
                        -> BlockId
                        -> instr
                        -> BlockId
                        -> [BlockId]
                        -> UniqFM Loc
                        -> UniqFM Loc
                        -> RegM freeRegs ([NatBasicBlock instr], instr)
    joinToTargets_again
        block_live new_blocks block_id instr dest dests
        src_assig dest_assig

            -- the assignments already match, no problem.
            | ufmToList dest_assig == ufmToList src_assig
            = joinToTargets' block_live new_blocks block_id instr dests

            -- assignments don't match, need fixup code
            | otherwise
            = do

                    -- make a graph of what things need to be moved where.
                    let graph = makeRegMovementGraph src_assig dest_assig

                    -- look for cycles in the graph. This can happen if regs need to be swapped.
                    -- Note that we depend on the fact that this function does a
                    --      bottom up traversal of the tree-like portions of the graph.
                    --
                    --  eg, if we have
                    --      R1 -> R2 -> R3
                    --
                    --  ie move value in R1 to R2 and value in R2 to R3.
                    --
                    -- We need to do the R2 -> R3 move before R1 -> R2.
                    --
                    let sccs  = stronglyConnCompFromEdgedVerticesR graph

    {-              -- debugging
                    pprTrace
                            ("joinToTargets: making fixup code")
                            (vcat   [ text "        in block: "     <> ppr block_id
                                    , text " jmp instruction: "     <> ppr instr
                                    , text "  src assignment: "     <> ppr src_assig
                                    , text " dest assignment: "     <> ppr dest_assig
                                    , text "  movement graph: "     <> ppr graph
                                    , text "   sccs of graph: "     <> ppr sccs
                                    , text ""])
                            (return ())
    -}
                    delta           <- getDeltaR
                    fixUpInstrs_    <- mapM (handleComponent delta instr) sccs
                    let fixUpInstrs = concat fixUpInstrs_

                    -- make a new basic block containing the fixup code.
                    --      A the end of the current block we will jump to the fixup one,
                    --      then that will jump to our original destination.
                    fixup_block_id <- getUniqueR
                    let block = BasicBlock (mkBlockId fixup_block_id)
                                    $ fixUpInstrs ++ mkJumpInstr dest

    {-              pprTrace
                            ("joinToTargets: fixup code is:")
                            (vcat   [ ppr block
                                    , text ""])
                            (return ())
    -}
                    -- if we didn't need any fixups, then don't include the block
                    case fixUpInstrs of
                     []     -> joinToTargets' block_live new_blocks block_id instr dests

                     -- patch the original branch instruction so it goes to our
                     --     fixup block instead.
                     _      -> let  instr'  =  patchJumpInstr instr
                                                    (\bid -> if bid == dest
                                                                    then mkBlockId fixup_block_id
                                                                    else bid) -- no change!

                               in   joinToTargets' block_live (block : new_blocks) block_id instr' dests

    -- | Construct a graph of register\/spill movements.
    --
    --      Cyclic components seem to occur only very rarely.
    --
    --      We cut some corners by not handling memory-to-memory moves.
    --      This shouldn't happen because every temporary gets its own stack slot.
    --
    makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
    makeRegMovementGraph adjusted_assig dest_assig
     = [ node       | (vreg, src) <- ufmToList adjusted_assig
                        -- source reg might not be needed at the dest:
                    , Just loc <- [lookupUFM_Directly dest_assig vreg]
                    , node <- expandNode vreg src loc ]

    -- | Expand out the destination, so InBoth destinations turn into
    --      a combination of InReg and InMem.

    --      The InBoth handling is a little tricky here.  If the destination is
    --      InBoth, then we must ensure that the value ends up in both locations.
    --      An InBoth  destination must conflict with an InReg or InMem source, so
    --      we expand an InBoth destination as necessary.
    --
    --      An InBoth source is slightly different: we only care about the register
    --      that the source value is in, so that we can move it to the destinations.
    --
    expandNode
            :: a
            -> Loc                  -- ^ source of move
            -> Loc                  -- ^ destination of move
            -> [(a, Loc, [Loc])]

    expandNode vreg loc@(InReg src) (InBoth dst mem)
            | src == dst = [(vreg, loc, [InMem mem])]
            | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]

    expandNode vreg loc@(InMem src) (InBoth dst mem)
            | src == mem = [(vreg, loc, [InReg dst])]
            | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]

    expandNode _        (InBoth _ src) (InMem dst)
            | src == dst = [] -- guaranteed to be true

    expandNode _        (InBoth src _) (InReg dst)
            | src == dst = []

    expandNode vreg     (InBoth src _) dst
            = expandNode vreg (InReg src) dst

    expandNode vreg src dst
            | src == dst = []
            | otherwise  = [(vreg, src, [dst])]

    -- | Generate fixup code for a particular component in the move graph
    --      This component tells us what values need to be moved to what
    --      destinations. We have eliminated any possibility of single-node
    --      cycles in expandNode above.
    --
    handleComponent
            :: Instruction instr
            => Int -> instr -> SCC (Unique, Loc, [Loc])
            -> RegM freeRegs [instr]

    -- If the graph is acyclic then we won't get the swapping problem below.
    --      In this case we can just do the moves directly, and avoid having to
    --      go via a spill slot.
    --
    handleComponent delta _  (AcyclicSCC (vreg, src, dsts))
            = mapM (makeMove delta vreg src) dsts

    -- Handle some cyclic moves.
    --      This can happen if we have two regs that need to be swapped.
    --      eg:
    --           vreg   source loc   dest loc
    --          (vreg1, InReg r1,    [InReg r2])
    --          (vreg2, InReg r2,    [InReg r1])
    --
    --      To avoid needing temp register, we just spill all the source regs, then
    --      reaload them into their destination regs.
    --
    --      Note that we can not have cycles that involve memory locations as
    --      sources as single destination because memory locations (stack slots)
    --      are allocated exclusively for a virtual register and therefore can not
    --      require a fixup.
    --
    handleComponent delta instr
            (CyclicSCC ((vreg, InReg sreg, (InReg dreg: _)) : rest))
            -- dest list may have more than one element, if the reg is also InMem.
     = do
            -- spill the source into its slot
            (instrSpill, slot)
                            <- spillR (RegReal sreg) vreg

            -- reload into destination reg
            instrLoad       <- loadR (RegReal dreg) slot

            remainingFixUps <- mapM (handleComponent delta instr)
                                    (stronglyConnCompFromEdgedVerticesR rest)

            -- make sure to do all the reloads after all the spills,
            --      so we don't end up clobbering the source values.
            return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad])

    handleComponent _ _ (CyclicSCC _)
     = panic "Register Allocator: handleComponent cyclic"

    -- | Move a vreg between these two locations.
    --
    makeMove
        :: Instruction instr
        => Int      -- ^ current C stack delta.
        -> Unique   -- ^ unique of the vreg that we're moving.
        -> Loc      -- ^ source location.
        -> Loc      -- ^ destination location.
        -> RegM freeRegs instr  -- ^ move instruction.

    makeMove delta vreg src dst
     = do dflags <- getDynFlags
          let platform = targetPlatform dflags

          case (src, dst) of
              (InReg s, InReg d) ->
                  do recordSpill (SpillJoinRR vreg)
                     return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d)
              (InMem s, InReg d) ->
                  do recordSpill (SpillJoinRM vreg)
                     return $ mkLoadInstr dflags (RegReal d) delta s
              (InReg s, InMem d) ->
                  do recordSpill (SpillJoinRM vreg)
                     return $ mkSpillInstr dflags (RegReal s) delta d
              _ ->
                  -- we don't handle memory to memory moves.
                  -- they shouldn't happen because we don't share
                  -- stack slots between vregs.
                  panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
                      ++ show dst ++ ")"
                      ++ " we don't handle mem->mem moves.")