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
Simon Marlow's avatar
Simon Marlow committed
12 13
  , mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC
  , mkCbranch, mkSwitch
14
  , mkReturn, 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
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 164 165 166
lgraphOfAGraph g = do u <- getUniqueM
                      return (flattenCmmAGraph (mkBlockId u) g)

-- | use the given BlockId as the label of the entry point
167
labelAGraph    :: BlockId -> CmmAGraph -> UniqSM CmmGraph
168
labelAGraph lbl ag = return (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 200
mkDirectJump    :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> CmmAGraph
mkDirectJump dflags e actuals updfr_off =
  lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
201 202
    toCall e Nothing updfr_off 0

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

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

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

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

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

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

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

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

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

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

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




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

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

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

-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
copyIn :: CopyIn
302
copyIn dflags oflow conv area formals =
303 304 305 306
  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)
307
        init_offset = widthInBytes (wordWidth dflags) -- infotable
308
        args  = assignArgumentsPos dflags conv localRegType formals
309 310 311 312 313
        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
314
oneCopyOflowI :: SlotCopier
315 316 317 318 319 320 321
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:

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

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

329
-- Generate code to move the actual parameters into the locations
330 331
-- required by the calling convention.  This includes a store for the
-- return address.
332
--
333 334 335 336 337
-- 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.
338
copyOutOflow dflags conv transfer area actuals updfr_off
Simon Marlow's avatar
Simon Marlow committed
339
  (extra_stack_off, extra_stack_stuff)
340
  = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
341
  where 
342 343 344 345
    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)
346

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

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

    arg_offset = init_offset + extra_stack_off
366

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

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

374 375


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

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

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

399

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

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