cmm/MkGraph.hs

    {-# LANGUAGE BangPatterns, CPP, GADTs #-}

    module MkGraph
      ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
      , (<*>), catAGraphs
      , mkLabel, mkMiddle, mkLast, outOfLine
      , lgraphOfAGraph, labelAGraph

      , stackStubExpr
      , mkNop, mkAssign, mkStore
      , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
      , mkJumpReturnsTo
      , mkJump, mkJumpExtra
      , mkRawJump
      , mkCbranch, mkSwitch
      , mkReturn, mkComment, mkCallEntry, mkBranch
      , mkUnwind
      , copyInOflow, copyOutOflow
      , noExtraStack
      , toCall, Transfer(..)
      )
    where

    import BlockId
    import Cmm
    import CmmCallConv
    import CmmSwitch (SwitchTargets)

    import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
    import DynFlags
    import FastString
    import ForeignCall
    import OrdList
    import SMRep (ByteOff)
    import UniqSupply

    import Control.Monad
    import Data.List
    import Data.Maybe
    import Prelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)

    #include "HsVersions.h"

    -----------------------------------------------------------------------------
    -- Building Graphs

    -- | CmmAGraph is a chunk of code consisting of:
    --
    --   * ordinary statements (assignments, stores etc.)
    --   * jumps
    --   * labels
    --   * out-of-line labelled blocks
    --
    -- The semantics is that control falls through labels and out-of-line
    -- blocks.  Everything after a jump up to the next label is by
    -- definition unreachable code, and will be discarded.
    --
    -- Two CmmAGraphs can be stuck together with <*>, with the meaning that
    -- control flows from the first to the second.
    --
    -- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
    -- by providing a label for the entry point and a tick scope; see
    -- 'labelAGraph'.
    type CmmAGraph = OrdList CgStmt
    -- | Unlabeled graph with tick scope
    type CmmAGraphScoped = (CmmAGraph, CmmTickScope)

    data CgStmt
      = CgLabel BlockId CmmTickScope
      | CgStmt  (CmmNode O O)
      | CgLast  (CmmNode O C)
      | CgFork  BlockId CmmAGraph CmmTickScope

    flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
    flattenCmmAGraph id (stmts_t, tscope) =
        CmmGraph { g_entry = id,
                   g_graph = GMany NothingO body NothingO }
      where
      body = foldr addBlock emptyBody $ flatten id stmts_t tscope []

      --
      -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
      --
      -- NB. avoid the quadratic-append trap by passing in the tail of the
      -- list.  This is important for Very Long Functions (e.g. in T783).
      --
      flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
              -> [Block CmmNode C C]
      flatten id g tscope blocks
          = flatten1 (fromOL g) block' blocks
          where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock
      --
      -- flatten0: we are outside a block at this point: any code before
      -- the first label is unreachable, so just drop it.
      --
      flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
      flatten0 [] blocks = blocks

      flatten0 (CgLabel id tscope : stmts) blocks
        = flatten1 stmts block blocks
        where !block = blockJoinHead (CmmEntry id tscope) emptyBlock

      flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
        = flatten fork_id stmts_t tscope $ flatten0 rest blocks

      flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
      flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks

      --
      -- flatten1: we have a partial block, collect statements until the
      -- next last node to make a block, then call flatten0 to get the rest
      -- of the blocks
      --
      flatten1 :: [CgStmt] -> Block CmmNode C O
               -> [Block CmmNode C C] -> [Block CmmNode C C]

      -- The current block falls through to the end of a function or fork:
      -- this code should not be reachable, but it may be referenced by
      -- other code that is not reachable.  We'll remove it later with
      -- dead-code analysis, but for now we have to keep the graph
      -- well-formed, so we terminate the block with a branch to the
      -- beginning of the current block.
      flatten1 [] block blocks
        = blockJoinTail block (CmmBranch (entryLabel block)) : blocks

      flatten1 (CgLast stmt : stmts) block blocks
        = block' : flatten0 stmts blocks
        where !block' = blockJoinTail block stmt

      flatten1 (CgStmt stmt : stmts) block blocks
        = flatten1 stmts block' blocks
        where !block' = blockSnoc block stmt

      flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks
        = flatten fork_id stmts_t tscope $ flatten1 rest block blocks

      -- a label here means that we should start a new block, and the
      -- current block should fall through to the new block.
      flatten1 (CgLabel id tscp : stmts) block blocks
        = blockJoinTail block (CmmBranch id) :
          flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks

    ---------- AGraph manipulation

    (<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph
    (<*>)           = appOL

    catAGraphs     :: [CmmAGraph] -> CmmAGraph
    catAGraphs      = concatOL

    -- | created a sequence "goto id; id:" as an AGraph
    mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
    mkLabel bid scp = unitOL (CgLabel bid scp)

    -- | creates an open AGraph from a given node
    mkMiddle        :: CmmNode O O -> CmmAGraph
    mkMiddle middle = unitOL (CgStmt middle)

    -- | created a closed AGraph from a given node
    mkLast         :: CmmNode O C -> CmmAGraph
    mkLast last     = unitOL (CgLast last)

    -- | A labelled code block; should end in a last node
    outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph
    outOfLine l (c,s) = unitOL (CgFork l c s)

    -- | allocate a fresh label for the entry point
    lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
    lgraphOfAGraph g = do
      u <- getUniqueM
      return (labelAGraph (mkBlockId u) g)

    -- | use the given BlockId as the label of the entry point
    labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph
    labelAGraph lbl ag = flattenCmmAGraph lbl ag

    ---------- No-ops
    mkNop        :: CmmAGraph
    mkNop         = nilOL

    mkComment    :: FastString -> CmmAGraph
    #ifdef DEBUG
    -- SDM: generating all those comments takes time, this saved about 4% for me
    mkComment fs  = mkMiddle $ CmmComment fs
    #else
    mkComment _   = nilOL
    #endif

    ---------- Assignment and store
    mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
    mkAssign l (CmmReg r) | l == r  = mkNop
    mkAssign l r  = mkMiddle $ CmmAssign l r

    mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
    mkStore  l r  = mkMiddle $ CmmStore  l r

    ---------- Control transfer
    mkJump          :: DynFlags -> Convention -> CmmExpr
                    -> [CmmExpr]
                    -> UpdFrameOffset
                    -> CmmAGraph
    mkJump dflags conv e actuals updfr_off =
      lastWithArgs dflags Jump Old conv actuals updfr_off $
        toCall e Nothing updfr_off 0

    -- | A jump where the caller says what the live GlobalRegs are.  Used
    -- for low-level hand-written Cmm.
    mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
                    -> CmmAGraph
    mkRawJump dflags e updfr_off vols =
      lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $
        \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols

    mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
                    -> UpdFrameOffset -> [CmmExpr]
                    -> CmmAGraph
    mkJumpExtra dflags conv e actuals updfr_off extra_stack =
      lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
        toCall e Nothing updfr_off 0

    mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
    mkCbranch pred ifso ifnot likely =
      mkLast (CmmCondBranch pred ifso ifnot likely)

    mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph
    mkSwitch e tbl   = mkLast $ CmmSwitch e tbl

    mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
                    -> CmmAGraph
    mkReturn dflags e actuals updfr_off =
      lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
        toCall e Nothing updfr_off 0

    mkBranch        :: BlockId -> CmmAGraph
    mkBranch bid     = mkLast (CmmBranch bid)

    mkFinalCall   :: DynFlags
                  -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
                  -> CmmAGraph
    mkFinalCall dflags f _ actuals updfr_off =
      lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
        toCall f Nothing updfr_off 0

    mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
                    -> BlockId
                    -> ByteOff
                    -> UpdFrameOffset
                    -> [CmmExpr]
                    -> CmmAGraph
    mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
      lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
         updfr_off extra_stack $
           toCall f (Just ret_lbl) updfr_off ret_off

    -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
    -- already on the stack).
    mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
                    -> BlockId
                    -> ByteOff
                    -> UpdFrameOffset
                    -> CmmAGraph
    mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do
      lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
           toCall f (Just ret_lbl) updfr_off ret_off

    mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
    mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as

    -- | Construct a 'CmmUnwind' node for the given register and unwinding
    -- expression.
    mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph
    mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]

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

    -- Why are we inserting extra blocks that simply branch to the successors?
    -- Because in addition to the branch instruction, @mkBranch@ will insert
    -- a necessary adjustment to the stack pointer.

    -- For debugging purposes, we can stub out dead stack slots:
    stackStubExpr :: Width -> CmmExpr
    stackStubExpr w = CmmLit (CmmInt 0 w)

    -- When we copy in parameters, we usually want to put overflow
    -- parameters on the stack, but sometimes we want to pass the
    -- variables in their spill slots.  Therefore, for copying arguments
    -- and results, we provide different functions to pass the arguments
    -- in an overflow area and to pass them in spill slots.
    copyInOflow  :: DynFlags -> Convention -> Area
                 -> [CmmFormal]
                 -> [CmmFormal]
                 -> (Int, [GlobalReg], CmmAGraph)

    copyInOflow dflags conv area formals extra_stk
      = (offset, gregs, catAGraphs $ map mkMiddle nodes)
      where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk

    -- Return the number of bytes used for copying arguments, as well as the
    -- instructions to copy the arguments.
    copyIn :: DynFlags -> Convention -> Area
           -> [CmmFormal]
           -> [CmmFormal]
           -> (ByteOff, [GlobalReg], [CmmNode O O])
    copyIn dflags conv area formals extra_stk
      = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
      where
         ci (reg, RegisterParam r) =
              CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
         ci (reg, StackParam off) =
              CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
              where ty = localRegType reg

         init_offset = widthInBytes (wordWidth dflags) -- infotable

         (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk

         (stk_size, args) = assignArgumentsPos dflags stk_off conv
                                               localRegType formals

    -- Factoring out the common parts of the copyout functions yielded something
    -- more complicated:

    data Transfer = Call | JumpRet | Jump | Ret deriving Eq

    copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
                 -> UpdFrameOffset
                 -> [CmmExpr] -- extra stack args
                 -> (Int, [GlobalReg], CmmAGraph)

    -- Generate code to move the actual parameters into the locations
    -- required by the calling convention.  This includes a store for the
    -- return address.
    --
    -- The argument layout function ignores the pointer to the info table,
    -- so we slot that in here. When copying-out to a young area, we set
    -- the info table for return and adjust the offsets of the other
    -- parameters.  If this is a call instruction, we adjust the offsets
    -- of the other parameters.
    copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
      = (stk_size, regs, graph)
      where
        (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)

        co (v, RegisterParam r) (rs, ms)
           = (r:rs, mkAssign (CmmGlobal r) v <*> ms)
        co (v, StackParam off)  (rs, ms)
           = (rs, mkStore (CmmStackSlot area off) v <*> ms)

        (setRA, init_offset) =
          case area of
                Young id ->  -- Generate a store instruction for
                             -- the return address if making a call
                      case transfer of
                         Call ->
                           ([(CmmLit (CmmBlock id), StackParam init_offset)],
                           widthInBytes (wordWidth dflags))
                         JumpRet ->
                           ([],
                           widthInBytes (wordWidth dflags))
                         _other ->
                           ([], 0)
                Old -> ([], updfr_off)

        (extra_stack_off, stack_params) =
           assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff

        args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
        (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
                                              (cmmExprType dflags) actuals

    mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
                -> (Int, [GlobalReg], CmmAGraph)
    mkCallEntry dflags conv formals extra_stk
      = copyInOflow dflags conv Old formals extra_stk

    lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]
                 -> UpdFrameOffset
                 -> (ByteOff -> [GlobalReg] -> CmmAGraph)
                 -> CmmAGraph
    lastWithArgs dflags transfer area conv actuals updfr_off last =
      lastWithArgsAndExtraStack dflags transfer area conv actuals
                                updfr_off noExtraStack last

    lastWithArgsAndExtraStack :: DynFlags
                 -> Transfer -> Area -> Convention -> [CmmExpr]
                 -> UpdFrameOffset -> [CmmExpr]
                 -> (ByteOff -> [GlobalReg] -> CmmAGraph)
                 -> CmmAGraph
    lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
                              extra_stack last =
      copies <*> last outArgs regs
     where
      (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
                                   updfr_off extra_stack

    noExtraStack :: [CmmExpr]
    noExtraStack = []

    toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
           -> ByteOff -> [GlobalReg]
           -> CmmAGraph
    toCall e cont updfr_off res_space arg_space regs =
      mkLast $ CmmCall e cont regs arg_space res_space updfr_off