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
Simon Marlow's avatar
Simon Marlow committed
12 13
  , mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC
  , mkCbranch, mkSwitch
14
  , mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
Simon Marlow's avatar
Simon Marlow committed
15
  , copyInOflow, copyOutOflow
16
  , noExtraStack
17
  , toCall, Transfer(..)
18 19 20 21 22 23 24
  )
where

import BlockId
import Cmm
import CmmCallConv (assignArgumentsPos, ParamLocation(..))

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
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130
  blocks = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry id) emptyBlock) []
  body = foldr addBlock emptyBody blocks

  --
  -- flatten: turn a list of CgStmt into a list of Blocks.  We know
  -- that any code before the first label is unreachable, so just drop
  -- it.
  --
  -- 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 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
  flatten [] blocks = blocks

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

  flatten (CgFork fork_id stmts : rest) blocks
    = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $
      flatten rest blocks

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

  --
  -- flatten1: we have a partial block, collect statements until the
  -- next last node to make a block, then call flatten 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' : flatten 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 : rest) block blocks
    = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $
      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 : stmts) block blocks
    = blockJoinTail block (CmmBranch id) :
      flatten1 stmts (blockJoinHead (CmmEntry id) emptyBlock) blocks
131 132


133 134 135 136

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

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

139
catAGraphs     :: [CmmAGraph] -> CmmAGraph
140 141 142 143 144
catAGraphs      = concatOL

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

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

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

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

-- | allocate a fresh label for the entry point
159
lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
160 161 162 163
lgraphOfAGraph g = do u <- getUniqueM
                      return (flattenCmmAGraph (mkBlockId u) g)

-- | use the given BlockId as the label of the entry point
164
labelAGraph    :: BlockId -> CmmAGraph -> UniqSM CmmGraph
165
labelAGraph lbl ag = return (flattenCmmAGraph lbl ag)
166 167 168

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

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

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

184 185
mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore  l r  = mkMiddle $ CmmStore  l r
186 187

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

194 195 196 197
mkDirectJump    :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> CmmAGraph
mkDirectJump dflags e actuals updfr_off =
  lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
198 199
    toCall e Nothing updfr_off 0

200 201 202 203
mkJumpGC        :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> CmmAGraph
mkJumpGC dflags e actuals updfr_off =
  lastWithArgs dflags Jump Old GC actuals updfr_off $
204 205
    toCall e Nothing updfr_off 0

206 207
mkForeignJump   :: DynFlags
                -> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
208
                -> CmmAGraph
209 210
mkForeignJump dflags conv e actuals updfr_off =
  mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
Simon Marlow's avatar
Simon Marlow committed
211

212
mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
213 214
                -> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
                -> CmmAGraph
215 216
mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
217 218 219 220 221 222 223 224
    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

225 226 227 228
mkReturn        :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> CmmAGraph
mkReturn dflags e actuals updfr_off =
  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
229 230
    toCall e Nothing updfr_off 0

231 232 233
mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
  mkReturn dflags e actuals updfr_off
234
  where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
235 236

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

239 240
mkFinalCall   :: DynFlags
              -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
241
              -> CmmAGraph
242 243
mkFinalCall dflags f _ actuals updfr_off =
  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
244 245
    toCall f Nothing updfr_off 0

246
mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
247 248 249 250 251
                -> BlockId
                -> ByteOff
                -> UpdFrameOffset
                -> (ByteOff, [(CmmExpr,ByteOff)])
                -> CmmAGraph
252 253
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
254 255 256
     updfr_off extra_stack $
       toCall f (Just ret_lbl) updfr_off ret_off

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

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

271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290

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




-- 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.
291 292
copyInOflow  :: DynFlags -> Convention -> Area -> [CmmFormal]
             -> (Int, CmmAGraph)
293

294 295
copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
  where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals
296 297 298

type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
                          (ByteOff, [CmmNode O O])
299
type CopyIn  = DynFlags -> SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
300 301 302 303

-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
copyIn :: CopyIn
304
copyIn dflags oflow conv area formals =
305 306 307 308 309
  foldr ci (init_offset, []) args'
  where ci (reg, RegisterParam r) (n, ms) =
          (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
        ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
        init_offset = widthInBytes wordWidth -- infotable
310
        args  = assignArgumentsPos dflags conv localRegType formals
311 312 313 314 315
        args' = foldl adjust [] args
          where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                adjust rst x@(_, RegisterParam _) = x : rst

-- Copy-in one arg, using overflow space if needed.
Simon Marlow's avatar
Simon Marlow committed
316
oneCopyOflowI :: SlotCopier
317 318 319 320 321 322 323
oneCopyOflowI area (reg, off) (n, ms) =
  (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
  where ty = localRegType reg

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

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

326
copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
327 328
             -> UpdFrameOffset
             -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
329
             -> (Int, [GlobalReg], CmmAGraph)
330

331
-- Generate code to move the actual parameters into the locations
332 333
-- required by the calling convention.  This includes a store for the
-- return address.
334
--
335 336 337 338 339
-- 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.
340
copyOutOflow dflags conv transfer area actuals updfr_off
Simon Marlow's avatar
Simon Marlow committed
341
  (extra_stack_off, extra_stack_stuff)
342
  = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
343
  where 
344 345 346 347
    co (v, RegisterParam r) (n, rs, ms)
       = (n, r:rs, mkAssign (CmmGlobal r) v <*> ms)
    co (v, StackParam off)  (n, rs, ms)
       = (max n off, rs, mkStore (CmmStackSlot area off) v <*> ms)
348

Simon Marlow's avatar
Simon Marlow committed
349 350 351
    stack_params = [ (e, StackParam (off + init_offset))
                   | (e,off) <- extra_stack_stuff ]

352
    (setRA, init_offset) =
Simon Marlow's avatar
Simon Marlow committed
353 354
      case area of
            Young id -> id `seq` -- Generate a store instruction for
355
                                 -- the return address if making a call
356 357 358 359 360 361 362 363 364
                  case transfer of
                     Call ->
                       ([(CmmLit (CmmBlock id), StackParam init_offset)],
                       widthInBytes wordWidth)
                     JumpRet ->
                       ([],
                       widthInBytes wordWidth)
                     _other ->
                       ([], 0)
Simon Marlow's avatar
Simon Marlow committed
365 366 367
            Old -> ([], updfr_off)

    arg_offset = init_offset + extra_stack_off
368

369
    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
370
    args = assignArgumentsPos dflags conv (cmmExprType dflags) actuals
371 372

    args' = foldl adjust setRA args
Simon Marlow's avatar
Simon Marlow committed
373
      where adjust rst   (v, StackParam off)  = (v, StackParam (off + arg_offset)) : rst
374 375
            adjust rst x@(_, RegisterParam _) = x : rst

376 377


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

381
lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
382
             -> UpdFrameOffset
383
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
Simon Marlow's avatar
Simon Marlow committed
384
             -> CmmAGraph
385 386
lastWithArgs dflags transfer area conv actuals updfr_off last =
  lastWithArgsAndExtraStack dflags transfer area conv actuals
387
                            updfr_off noExtraStack last
Simon Marlow's avatar
Simon Marlow committed
388

389 390
lastWithArgsAndExtraStack :: DynFlags
             -> Transfer -> Area -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
391
             -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
392
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
Simon Marlow's avatar
Simon Marlow committed
393
             -> CmmAGraph
394
lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
Simon Marlow's avatar
Simon Marlow committed
395
                          extra_stack last =
396 397
  copies <*> last outArgs regs
 where
398
  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
399 400
                               updfr_off extra_stack

401

Simon Marlow's avatar
Simon Marlow committed
402 403
noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)])
noExtraStack = (0,[])
404

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