MkGraph.hs 14.8 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, mkReturnSimple, 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

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

#include "HsVersions.h"


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 72
-----------------------------------------------------------------------------
-- 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
73
  body = foldr addBlock emptyBody $ flatten id stmts []
74 75

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

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

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

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

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

  -- 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
135 136


137 138 139 140

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

225
mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
226
                -> UpdFrameOffset -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
227
                -> CmmAGraph
228 229
mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
230 231 232 233 234 235 236 237
    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

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

244 245 246 247 248
mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
  mkReturn dflags e actuals updfr_off
  where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)

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

252 253
mkFinalCall   :: DynFlags
              -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
254
              -> CmmAGraph
255 256
mkFinalCall dflags f _ actuals updfr_off =
  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
257 258
    toCall f Nothing updfr_off 0

259
mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
260 261 262
                -> BlockId
                -> ByteOff
                -> UpdFrameOffset
263
                -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
264
                -> CmmAGraph
265 266
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
267 268 269
     updfr_off extra_stack $
       toCall f (Just ret_lbl) updfr_off ret_off

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

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

284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299

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




-- 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
300 301 302 303 304 305 306
-- 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]
307
             -> (Int, [GlobalReg], CmmAGraph)
308

309
copyInOflow dflags conv area formals extra_stk
310 311
  = (offset, gregs, catAGraphs $ map mkMiddle nodes)
  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
312 313 314

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

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

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

340
copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
341
             -> UpdFrameOffset
342
             -> [CmmActual] -- extra stack args
343
             -> (Int, [GlobalReg], CmmAGraph)
344

345
-- Generate code to move the actual parameters into the locations
346 347
-- required by the calling convention.  This includes a store for the
-- return address.
348
--
349 350 351 352 353
-- 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.
354 355 356 357 358 359 360 361 362
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
363

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

379 380
    (extra_stack_off, stack_params) =
       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
381

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

386 387


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

393
lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
394
             -> UpdFrameOffset
395
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
Simon Marlow's avatar
Simon Marlow committed
396
             -> CmmAGraph
397 398
lastWithArgs dflags transfer area conv actuals updfr_off last =
  lastWithArgsAndExtraStack dflags transfer area conv actuals
399
                            updfr_off noExtraStack last
Simon Marlow's avatar
Simon Marlow committed
400

401 402
lastWithArgsAndExtraStack :: DynFlags
             -> Transfer -> Area -> Convention -> [CmmActual]
403
             -> UpdFrameOffset -> [CmmActual]
404
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
Simon Marlow's avatar
Simon Marlow committed
405
             -> CmmAGraph
406
lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
Simon Marlow's avatar
Simon Marlow committed
407
                          extra_stack last =
408 409
  copies <*> last outArgs regs
 where
410
  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
411 412
                               updfr_off extra_stack

413

414 415
noExtraStack :: [CmmActual]
noExtraStack = []
416

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