MkGraph.hs 14.6 KB
Newer Older
1 2 3
{-# LANGUAGE GADTs #-}

module MkGraph
4 5
  ( CmmAGraph, CgStmt(..)
  , (<*>), catAGraphs
Simon Marlow's avatar
Simon Marlow committed
6
  , mkLabel, mkMiddle, mkLast, outOfLine
7
  , lgraphOfAGraph, labelAGraph
8 9

  , stackStubExpr
Simon Marlow's avatar
Simon Marlow committed
10
  , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
11
  , mkJumpReturnsTo
12 13
  , mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra
  , mkRawJump
Simon Marlow's avatar
Simon Marlow committed
14
  , mkCbranch, mkSwitch
15
  , mkReturn, mkComment, mkCallEntry, mkBranch
Simon Marlow's avatar
Simon Marlow committed
16
  , copyInOflow, copyOutOflow
17
  , noExtraStack
18
  , toCall, Transfer(..)
19 20 21 22 23
  )
where

import BlockId
import Cmm
24
import CmmCallConv
25 26

import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
27
import DynFlags
28 29 30 31 32
import FastString
import ForeignCall
import Prelude hiding (succ)
import SMRep (ByteOff)
import UniqSupply
33
import OrdList
34 35 36 37

#include "HsVersions.h"


38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
-----------------------------------------------------------------------------
-- 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; see 'labelAGraph'.
--
type CmmAGraph = OrdList CgStmt

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

flattenCmmAGraph :: BlockId -> CmmAGraph -> CmmGraph
flattenCmmAGraph id stmts =
    CmmGraph { g_entry = id,
               g_graph = GMany NothingO body NothingO }
  where
Simon Marlow's avatar
Simon Marlow committed
72
  body = foldr addBlock emptyBody $ flatten id stmts []
73 74

  --
Simon Marlow's avatar
Simon Marlow committed
75
  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
76 77 78 79
  --
  -- 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).
  --
Simon Marlow's avatar
Simon Marlow committed
80 81 82
  flatten :: Label -> CmmAGraph -> [Block CmmNode C C] -> [Block CmmNode C C]
  flatten id g blocks
      = flatten1 (fromOL g) (blockJoinHead (CmmEntry id) emptyBlock) blocks
83

Simon Marlow's avatar
Simon Marlow committed
84 85 86 87 88 89 90 91
  --
  -- 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 : stmts) blocks
92 93 94
    = flatten1 stmts block blocks
    where !block = blockJoinHead (CmmEntry id) emptyBlock

Simon Marlow's avatar
Simon Marlow committed
95 96
  flatten0 (CgFork fork_id stmts : rest) blocks
    = flatten fork_id stmts $ flatten0 rest blocks
97

Simon Marlow's avatar
Simon Marlow committed
98 99
  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
100 101 102

  --
  -- flatten1: we have a partial block, collect statements until the
Simon Marlow's avatar
Simon Marlow committed
103
  -- next last node to make a block, then call flatten0 to get the rest
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
  -- 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
Simon Marlow's avatar
Simon Marlow committed
119
    = block' : flatten0 stmts blocks
120 121 122 123 124 125 126
    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 : rest) block blocks
Simon Marlow's avatar
Simon Marlow committed
127
    = flatten fork_id stmts $ flatten1 rest block blocks
128 129 130 131 132 133

  -- 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 : stmts) block blocks
    = blockJoinTail block (CmmBranch id) :
      flatten1 stmts (blockJoinHead (CmmEntry id) emptyBlock) blocks
134 135


136 137 138 139

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

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

142
catAGraphs     :: [CmmAGraph] -> CmmAGraph
143 144 145 146 147
catAGraphs      = concatOL

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

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

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

Simon Marlow's avatar
Simon Marlow committed
157 158 159
-- | A labelled code block; should end in a last node
outOfLine      :: BlockId -> CmmAGraph -> CmmAGraph
outOfLine l g   = unitOL (CgFork l g)
160 161

-- | allocate a fresh label for the entry point
162
lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
163
lgraphOfAGraph g = do u <- getUniqueM
164
                      return (labelAGraph (mkBlockId u) g)
165 166

-- | use the given BlockId as the label of the entry point
167 168
labelAGraph    :: BlockId -> CmmAGraph -> CmmGraph
labelAGraph lbl ag = flattenCmmAGraph lbl ag
169 170 171

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

174
mkComment    :: FastString -> CmmAGraph
175 176 177 178 179 180
#ifdef DEBUG
-- SDM: generating all those comments takes time, this saved about 4% for me
mkComment fs  = mkMiddle $ CmmComment fs
#else
mkComment _   = nilOL
#endif
181 182 183

---------- Assignment and store
mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
Simon Marlow's avatar
Simon Marlow committed
184
mkAssign l (CmmReg r) | l == r  = mkNop
185
mkAssign l r  = mkMiddle $ CmmAssign l r
186

187 188
mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore  l r  = mkMiddle $ CmmStore  l r
189 190

---------- Control transfer
191 192 193 194
mkJump          :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> CmmAGraph
mkJump dflags e actuals updfr_off =
  lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $
195 196
    toCall e Nothing updfr_off 0

197 198 199
-- | A jump where the caller says what the live GlobalRegs are.  Used
-- for low-level hand-written Cmm.
mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
200
                -> CmmAGraph
201 202 203 204 205 206 207 208 209
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 -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> [CmmActual] -> CmmAGraph
mkJumpExtra dflags e actuals updfr_off extra_stack =
  lastWithArgsAndExtraStack dflags Jump Old NativeNodeCall actuals updfr_off extra_stack $
210 211
    toCall e Nothing updfr_off 0

212
mkDirectJump    :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
213
                -> CmmAGraph
214 215
mkDirectJump dflags e actuals updfr_off =
  lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
216 217
    toCall e Nothing updfr_off 0

218 219
mkForeignJump   :: DynFlags
                -> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
220
                -> CmmAGraph
221 222
mkForeignJump dflags conv e actuals updfr_off =
  mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
Simon Marlow's avatar
Simon Marlow committed
223

224
mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
225
                -> UpdFrameOffset -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
226
                -> CmmAGraph
227 228
mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
229 230 231 232 233 234 235 236
    toCall e Nothing updfr_off 0

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

mkSwitch        :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
mkSwitch e tbl   = mkLast $ CmmSwitch e tbl

237 238 239 240
mkReturn        :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> CmmAGraph
mkReturn dflags e actuals updfr_off =
  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
241 242
    toCall e Nothing updfr_off 0

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

246 247
mkFinalCall   :: DynFlags
              -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
248
              -> CmmAGraph
249 250
mkFinalCall dflags f _ actuals updfr_off =
  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
251 252
    toCall f Nothing updfr_off 0

253
mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
254 255 256
                -> BlockId
                -> ByteOff
                -> UpdFrameOffset
257
                -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
258
                -> CmmAGraph
259 260
mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
Simon Marlow's avatar
Simon Marlow committed
261 262 263
     updfr_off extra_stack $
       toCall f (Just ret_lbl) updfr_off ret_off

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

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

278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293

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




-- 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
294 295 296 297 298 299 300
-- 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]
301
             -> (Int, [GlobalReg], CmmAGraph)
302

303
copyInOflow dflags conv area formals extra_stk
304 305
  = (offset, gregs, catAGraphs $ map mkMiddle nodes)
  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
306 307 308

-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
309 310 311
copyIn :: DynFlags -> Convention -> Area
       -> [CmmFormal]
       -> [CmmFormal]
312
       -> (ByteOff, [GlobalReg], [CmmNode O O])
313
copyIn dflags conv area formals extra_stk
314
  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
315 316 317 318 319 320 321 322 323 324 325 326 327
  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
328 329 330 331

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

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

334
copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
335
             -> UpdFrameOffset
336
             -> [CmmActual] -- extra stack args
337
             -> (Int, [GlobalReg], CmmAGraph)
338

339
-- Generate code to move the actual parameters into the locations
340 341
-- required by the calling convention.  This includes a store for the
-- return address.
342
--
343 344 345 346 347
-- 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.
348 349 350 351 352 353 354 355 356
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)
Simon Marlow's avatar
Simon Marlow committed
357

358
    (setRA, init_offset) =
Simon Marlow's avatar
Simon Marlow committed
359
      case area of
360 361
            Young id ->  -- Generate a store instruction for
                         -- the return address if making a call
362 363 364
                  case transfer of
                     Call ->
                       ([(CmmLit (CmmBlock id), StackParam init_offset)],
365
                       widthInBytes (wordWidth dflags))
366 367
                     JumpRet ->
                       ([],
368
                       widthInBytes (wordWidth dflags))
369 370
                     _other ->
                       ([], 0)
Simon Marlow's avatar
Simon Marlow committed
371 372
            Old -> ([], updfr_off)

373 374
    (extra_stack_off, stack_params) =
       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
375

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

380 381


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

387
lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
388
             -> UpdFrameOffset
389
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
Simon Marlow's avatar
Simon Marlow committed
390
             -> CmmAGraph
391 392
lastWithArgs dflags transfer area conv actuals updfr_off last =
  lastWithArgsAndExtraStack dflags transfer area conv actuals
393
                            updfr_off noExtraStack last
Simon Marlow's avatar
Simon Marlow committed
394

395 396
lastWithArgsAndExtraStack :: DynFlags
             -> Transfer -> Area -> Convention -> [CmmActual]
397
             -> UpdFrameOffset -> [CmmActual]
398
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
Simon Marlow's avatar
Simon Marlow committed
399
             -> CmmAGraph
400
lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
Simon Marlow's avatar
Simon Marlow committed
401
                          extra_stack last =
402 403
  copies <*> last outArgs regs
 where
404
  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
405 406
                               updfr_off extra_stack

407

408 409
noExtraStack :: [CmmActual]
noExtraStack = []
410

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