compiler/cmm/MkGraph.hs

   1 {-# LANGUAGE BangPatterns, CPP, GADTs #-}
   2
   3 module MkGraph
   4   ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
   5   , (<*>), catAGraphs
   6   , mkLabel, mkMiddle, mkLast, outOfLine
   7   , lgraphOfAGraph, labelAGraph
   8
   9   , stackStubExpr
  10   , mkNop, mkAssign, mkStore
  11   , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
  12   , mkJumpReturnsTo
  13   , mkJump, mkJumpExtra
  14   , mkRawJump
  15   , mkCbranch, mkSwitch
  16   , mkReturn, mkComment, mkCallEntry, mkBranch
  17   , mkUnwind
  18   , copyInOflow, copyOutOflow
  19   , noExtraStack
  20   , toCall, Transfer(..)
  21   )
  22 where
  23
  24 import GhcPrelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)
  25
  26 import BlockId
  27 import Cmm
  28 import CmmCallConv
  29 import CmmSwitch (SwitchTargets)
  30
  31 import Hoopl.Block
  32 import Hoopl.Graph
  33 import Hoopl.Label
  34 import DynFlags
  35 import FastString
  36 import ForeignCall
  37 import OrdList
  38 import SMRep (ByteOff)
  39 import UniqSupply
  40
  41 import Control.Monad
  42 import Data.List
  43 import Data.Maybe
  44
  45
  46 -----------------------------------------------------------------------------
  47 -- Building Graphs
  48
  49
  50 -- | CmmAGraph is a chunk of code consisting of:
  51 --
  52 --   * ordinary statements (assignments, stores etc.)
  53 --   * jumps
  54 --   * labels
  55 --   * out-of-line labelled blocks
  56 --
  57 -- The semantics is that control falls through labels and out-of-line
  58 -- blocks.  Everything after a jump up to the next label is by
  59 -- definition unreachable code, and will be discarded.
  60 --
  61 -- Two CmmAGraphs can be stuck together with <*>, with the meaning that
  62 -- control flows from the first to the second.
  63 --
  64 -- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
  65 -- by providing a label for the entry point and a tick scope; see
  66 -- 'labelAGraph'.
  67 type CmmAGraph = OrdList CgStmt
  68 -- | Unlabeled graph with tick scope
  69 type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
  70
  71 data CgStmt
  72   = CgLabel BlockId CmmTickScope
  73   | CgStmt  (CmmNode O O)
  74   | CgLast  (CmmNode O C)
  75   | CgFork  BlockId CmmAGraph CmmTickScope
  76
  77 flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
  78 flattenCmmAGraph id (stmts_t, tscope) =
  79     CmmGraph { g_entry = id,
  80                g_graph = GMany NothingO body NothingO }
  81   where
  82   body = foldr addBlock emptyBody $ flatten id stmts_t tscope []
  83
  84   --
  85   -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
  86   --
  87   -- NB. avoid the quadratic-append trap by passing in the tail of the
  88   -- list.  This is important for Very Long Functions (e.g. in T783).
  89   --
  90   flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
  91           -> [Block CmmNode C C]
  92   flatten id g tscope blocks
  93       = flatten1 (fromOL g) block' blocks
  94       where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock
  95   --
  96   -- flatten0: we are outside a block at this point: any code before
  97   -- the first label is unreachable, so just drop it.
  98   --
  99   flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
 100   flatten0 [] blocks = blocks
 101
 102   flatten0 (CgLabel id tscope : stmts) blocks
 103     = flatten1 stmts block blocks
 104     where !block = blockJoinHead (CmmEntry id tscope) emptyBlock
 105
 106   flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
 107     = flatten fork_id stmts_t tscope $ flatten0 rest blocks
 108
 109   flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
 110   flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
 111
 112   --
 113   -- flatten1: we have a partial block, collect statements until the
 114   -- next last node to make a block, then call flatten0 to get the rest
 115   -- of the blocks
 116   --
 117   flatten1 :: [CgStmt] -> Block CmmNode C O
 118            -> [Block CmmNode C C] -> [Block CmmNode C C]
 119
 120   -- The current block falls through to the end of a function or fork:
 121   -- this code should not be reachable, but it may be referenced by
 122   -- other code that is not reachable.  We'll remove it later with
 123   -- dead-code analysis, but for now we have to keep the graph
 124   -- well-formed, so we terminate the block with a branch to the
 125   -- beginning of the current block.
 126   flatten1 [] block blocks
 127     = blockJoinTail block (CmmBranch (entryLabel block)) : blocks
 128
 129   flatten1 (CgLast stmt : stmts) block blocks
 130     = block' : flatten0 stmts blocks
 131     where !block' = blockJoinTail block stmt
 132
 133   flatten1 (CgStmt stmt : stmts) block blocks
 134     = flatten1 stmts block' blocks
 135     where !block' = blockSnoc block stmt
 136
 137   flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks
 138     = flatten fork_id stmts_t tscope $ flatten1 rest block blocks
 139
 140   -- a label here means that we should start a new block, and the
 141   -- current block should fall through to the new block.
 142   flatten1 (CgLabel id tscp : stmts) block blocks
 143     = blockJoinTail block (CmmBranch id) :
 144       flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks
 145
 146
 147
 148 ---------- AGraph manipulation
 149
 150 (<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph
 151 (<*>)           = appOL
 152
 153 catAGraphs     :: [CmmAGraph] -> CmmAGraph
 154 catAGraphs      = concatOL
 155
 156 -- | created a sequence "goto id; id:" as an AGraph
 157 mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
 158 mkLabel bid scp = unitOL (CgLabel bid scp)
 159
 160 -- | creates an open AGraph from a given node
 161 mkMiddle        :: CmmNode O O -> CmmAGraph
 162 mkMiddle middle = unitOL (CgStmt middle)
 163
 164 -- | created a closed AGraph from a given node
 165 mkLast         :: CmmNode O C -> CmmAGraph
 166 mkLast last     = unitOL (CgLast last)
 167
 168 -- | A labelled code block; should end in a last node
 169 outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph
 170 outOfLine l (c,s) = unitOL (CgFork l c s)
 171
 172 -- | allocate a fresh label for the entry point
 173 lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
 174 lgraphOfAGraph g = do
 175   u <- getUniqueM
 176   return (labelAGraph (mkBlockId u) g)
 177
 178 -- | use the given BlockId as the label of the entry point
 179 labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph
 180 labelAGraph lbl ag = flattenCmmAGraph lbl ag
 181
 182 ---------- No-ops
 183 mkNop        :: CmmAGraph
 184 mkNop         = nilOL
 185
 186 mkComment    :: FastString -> CmmAGraph
 187 #if defined(DEBUG)
 188 -- SDM: generating all those comments takes time, this saved about 4% for me
 189 mkComment fs  = mkMiddle $ CmmComment fs
 190 #else
 191 mkComment _   = nilOL
 192 #endif
 193
 194 ---------- Assignment and store
 195 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 196 mkAssign l (CmmReg r) | l == r  = mkNop
 197 mkAssign l r  = mkMiddle $ CmmAssign l r
 198
 199 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 200 mkStore  l r  = mkMiddle $ CmmStore  l r
 201
 202 ---------- Control transfer
 203 mkJump          :: DynFlags -> Convention -> CmmExpr
 204                 -> [CmmExpr]
 205                 -> UpdFrameOffset
 206                 -> CmmAGraph
 207 mkJump dflags conv e actuals updfr_off =
 208   lastWithArgs dflags Jump Old conv actuals updfr_off $
 209     toCall e Nothing updfr_off 0
 210
 211 -- | A jump where the caller says what the live GlobalRegs are.  Used
 212 -- for low-level hand-written Cmm.
 213 mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
 214                 -> CmmAGraph
 215 mkRawJump dflags e updfr_off vols =
 216   lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $
 217     \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols
 218
 219
 220 mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
 221                 -> UpdFrameOffset -> [CmmExpr]
 222                 -> CmmAGraph
 223 mkJumpExtra dflags conv e actuals updfr_off extra_stack =
 224   lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
 225     toCall e Nothing updfr_off 0
 226
 227 mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
 228 mkCbranch pred ifso ifnot likely =
 229   mkLast (CmmCondBranch pred ifso ifnot likely)
 230
 231 mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph
 232 mkSwitch e tbl   = mkLast $ CmmSwitch e tbl
 233
 234 mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
 235                 -> CmmAGraph
 236 mkReturn dflags e actuals updfr_off =
 237   lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
 238     toCall e Nothing updfr_off 0
 239
 240 mkBranch        :: BlockId -> CmmAGraph
 241 mkBranch bid     = mkLast (CmmBranch bid)
 242
 243 mkFinalCall   :: DynFlags
 244               -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
 245               -> CmmAGraph
 246 mkFinalCall dflags f _ actuals updfr_off =
 247   lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
 248     toCall f Nothing updfr_off 0
 249
 250 mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
 251                 -> BlockId
 252                 -> ByteOff
 253                 -> UpdFrameOffset
 254                 -> [CmmExpr]
 255                 -> CmmAGraph
 256 mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
 257   lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
 258      updfr_off extra_stack $
 259        toCall f (Just ret_lbl) updfr_off ret_off
 260
 261 -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
 262 -- already on the stack).
 263 mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
 264                 -> BlockId
 265                 -> ByteOff
 266                 -> UpdFrameOffset
 267                 -> CmmAGraph
 268 mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do
 269   lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
 270        toCall f (Just ret_lbl) updfr_off ret_off
 271
 272 mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
 273 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
 274
 275 -- | Construct a 'CmmUnwind' node for the given register and unwinding
 276 -- expression.
 277 mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph
 278 mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]
 279
 280 --------------------------------------------------------------------------
 281
 282
 283
 284
 285 -- Why are we inserting extra blocks that simply branch to the successors?
 286 -- Because in addition to the branch instruction, @mkBranch@ will insert
 287 -- a necessary adjustment to the stack pointer.
 288
 289
 290 -- For debugging purposes, we can stub out dead stack slots:
 291 stackStubExpr :: Width -> CmmExpr
 292 stackStubExpr w = CmmLit (CmmInt 0 w)
 293
 294 -- When we copy in parameters, we usually want to put overflow
 295 -- parameters on the stack, but sometimes we want to pass the
 296 -- variables in their spill slots.  Therefore, for copying arguments
 297 -- and results, we provide different functions to pass the arguments
 298 -- in an overflow area and to pass them in spill slots.
 299 copyInOflow  :: DynFlags -> Convention -> Area
 300              -> [CmmFormal]
 301              -> [CmmFormal]
 302              -> (Int, [GlobalReg], CmmAGraph)
 303
 304 copyInOflow dflags conv area formals extra_stk
 305   = (offset, gregs, catAGraphs $ map mkMiddle nodes)
 306   where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
 307
 308 -- Return the number of bytes used for copying arguments, as well as the
 309 -- instructions to copy the arguments.
 310 copyIn :: DynFlags -> Convention -> Area
 311        -> [CmmFormal]
 312        -> [CmmFormal]
 313        -> (ByteOff, [GlobalReg], [CmmNode O O])
 314 copyIn dflags conv area formals extra_stk
 315   = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
 316   where
 317      ci (reg, RegisterParam r) =
 318           CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
 319      ci (reg, StackParam off) =
 320           CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
 321           where ty = localRegType reg
 322
 323      init_offset = widthInBytes (wordWidth dflags) -- infotable
 324
 325      (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
 326
 327      (stk_size, args) = assignArgumentsPos dflags stk_off conv
 328                                            localRegType formals
 329
 330 -- Factoring out the common parts of the copyout functions yielded something
 331 -- more complicated:
 332
 333 data Transfer = Call | JumpRet | Jump | Ret deriving Eq
 334
 335 copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
 336              -> UpdFrameOffset
 337              -> [CmmExpr] -- extra stack args
 338              -> (Int, [GlobalReg], CmmAGraph)
 339
 340 -- Generate code to move the actual parameters into the locations
 341 -- required by the calling convention.  This includes a store for the
 342 -- return address.
 343 --
 344 -- The argument layout function ignores the pointer to the info table,
 345 -- so we slot that in here. When copying-out to a young area, we set
 346 -- the info table for return and adjust the offsets of the other
 347 -- parameters.  If this is a call instruction, we adjust the offsets
 348 -- of the other parameters.
 349 copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
 350   = (stk_size, regs, graph)
 351   where
 352     (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
 353
 354     co (v, RegisterParam r) (rs, ms)
 355        = (r:rs, mkAssign (CmmGlobal r) v <*> ms)
 356     co (v, StackParam off)  (rs, ms)
 357        = (rs, mkStore (CmmStackSlot area off) v <*> ms)
 358
 359     (setRA, init_offset) =
 360       case area of
 361             Young id ->  -- Generate a store instruction for
 362                          -- the return address if making a call
 363                   case transfer of
 364                      Call ->
 365                        ([(CmmLit (CmmBlock id), StackParam init_offset)],
 366                        widthInBytes (wordWidth dflags))
 367                      JumpRet ->
 368                        ([],
 369                        widthInBytes (wordWidth dflags))
 370                      _other ->
 371                        ([], 0)
 372             Old -> ([], updfr_off)
 373
 374     (extra_stack_off, stack_params) =
 375        assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
 376
 377     args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
 378     (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
 379                                           (cmmExprType dflags) actuals
 380
 381
 382
 383 mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
 384             -> (Int, [GlobalReg], CmmAGraph)
 385 mkCallEntry dflags conv formals extra_stk
 386   = copyInOflow dflags conv Old formals extra_stk
 387
 388 lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]
 389              -> UpdFrameOffset
 390              -> (ByteOff -> [GlobalReg] -> CmmAGraph)
 391              -> CmmAGraph
 392 lastWithArgs dflags transfer area conv actuals updfr_off last =
 393   lastWithArgsAndExtraStack dflags transfer area conv actuals
 394                             updfr_off noExtraStack last
 395
 396 lastWithArgsAndExtraStack :: DynFlags
 397              -> Transfer -> Area -> Convention -> [CmmExpr]
 398              -> UpdFrameOffset -> [CmmExpr]
 399              -> (ByteOff -> [GlobalReg] -> CmmAGraph)
 400              -> CmmAGraph
 401 lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
 402                           extra_stack last =
 403   copies <*> last outArgs regs
 404  where
 405   (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
 406                                updfr_off extra_stack
 407
 408
 409 noExtraStack :: [CmmExpr]
 410 noExtraStack = []
 411
 412 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
 413        -> ByteOff -> [GlobalReg]
 414        -> CmmAGraph
 415 toCall e cont updfr_off res_space arg_space regs =
 416   mkLast $ CmmCall e cont regs arg_space res_space updfr_off