MkGraph.hs 14.4 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 33
import FastString
import ForeignCall
import Outputable
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 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
-----------------------------------------------------------------------------
-- 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
  (block, blocks) = flatten (fromOL stmts)
  entry = blockJoinHead (CmmEntry id) block
  body = foldr addBlock emptyBody (entry:blocks)

  flatten :: [CgStmt] -> (Block CmmNode O C, [Block CmmNode C C])
  flatten [] = panic "flatten []"

  -- A label at the end of a function or fork: this label must not be reachable,
  -- but it might be referred to from another BB that also isn't reachable.
  -- Eliminating these has to be done with a dead-code analysis.  For now,
  -- we just make it into a well-formed block by adding a recursive jump.
  flatten [CgLabel id]
    = (goto_id, [blockJoinHead (CmmEntry id) goto_id] )
    where goto_id = blockJoinTail emptyBlock (CmmBranch id)

  -- A jump/branch: throw away all the code up to the next label, because
  -- it is unreachable.  Be careful to keep forks that we find on the way.
  flatten (CgLast stmt : stmts)
    = case dropWhile isOrdinaryStmt stmts of
        [] ->
            ( sing, [] )
        [CgLabel id] ->
            ( sing, [blockJoin (CmmEntry id) emptyBlock (CmmBranch id)] )
        (CgLabel id : stmts) ->
            ( sing, blockJoinHead (CmmEntry id) block : blocks )
            where (block,blocks) = flatten stmts
        (CgFork fork_id stmts : ss) -> 
            flatten (CgFork fork_id stmts : CgLast stmt : ss)
        _ -> panic "MkGraph.flatten"
    where
      sing = blockJoinTail emptyBlock stmt

  flatten (s:ss) = 
        case s of
          CgStmt stmt -> (blockCons stmt block, blocks)
          CgLabel id  -> (blockJoinTail emptyBlock (CmmBranch id),
                          blockJoinHead (CmmEntry id) block : blocks)
          CgFork fork_id stmts -> 
                (block, blockJoinHead (CmmEntry fork_id) fork_block : fork_blocks ++ blocks)
                where (fork_block, fork_blocks) = flatten (fromOL stmts)
          _ -> panic "MkGraph.flatten"
    where (block,blocks) = flatten ss

isOrdinaryStmt :: CgStmt -> Bool
isOrdinaryStmt (CgStmt _) = True
isOrdinaryStmt (CgLast _) = True
isOrdinaryStmt _          = False


122 123 124 125

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

(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph
126 127
(<*>)           = appOL

128
catAGraphs     :: [CmmAGraph] -> CmmAGraph
129 130 131 132 133
catAGraphs      = concatOL

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

135 136 137
-- | creates an open AGraph from a given node
mkMiddle        :: CmmNode O O -> CmmAGraph
mkMiddle middle = unitOL (CgStmt middle)
138

139 140 141
-- | created a closed AGraph from a given node
mkLast         :: CmmNode O C -> CmmAGraph
mkLast last     = unitOL (CgLast last)
142

Simon Marlow's avatar
Simon Marlow committed
143 144 145
-- | A labelled code block; should end in a last node
outOfLine      :: BlockId -> CmmAGraph -> CmmAGraph
outOfLine l g   = unitOL (CgFork l g)
146 147

-- | allocate a fresh label for the entry point
148
lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
149 150 151 152
lgraphOfAGraph g = do u <- getUniqueM
                      return (flattenCmmAGraph (mkBlockId u) g)

-- | use the given BlockId as the label of the entry point
153
labelAGraph    :: BlockId -> CmmAGraph -> UniqSM CmmGraph
154
labelAGraph lbl ag = return (flattenCmmAGraph lbl ag)
155 156 157

---------- No-ops
mkNop        :: CmmAGraph
158 159
mkNop         = nilOL

160
mkComment    :: FastString -> CmmAGraph
161 162 163 164 165 166
#ifdef DEBUG
-- SDM: generating all those comments takes time, this saved about 4% for me
mkComment fs  = mkMiddle $ CmmComment fs
#else
mkComment _   = nilOL
#endif
167 168 169

---------- Assignment and store
mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
170
mkAssign l r  = mkMiddle $ CmmAssign l r
171

172 173
mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore  l r  = mkMiddle $ CmmStore  l r
174 175

---------- Control transfer
176 177 178 179
mkJump          :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> CmmAGraph
mkJump dflags e actuals updfr_off =
  lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $
180 181
    toCall e Nothing updfr_off 0

182 183 184 185
mkDirectJump    :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                -> CmmAGraph
mkDirectJump dflags e actuals updfr_off =
  lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
186 187
    toCall e Nothing updfr_off 0

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

194 195
mkForeignJump   :: DynFlags
                -> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
196
                -> CmmAGraph
197 198
mkForeignJump dflags conv e actuals updfr_off =
  mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
Simon Marlow's avatar
Simon Marlow committed
199

200
mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
201 202
                -> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
                -> CmmAGraph
203 204
mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
205 206 207 208 209 210 211 212
    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

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

219 220 221
mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
  mkReturn dflags e actuals updfr_off
222
  where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
223 224

mkBranch        :: BlockId -> CmmAGraph
225 226
mkBranch bid     = mkLast (CmmBranch bid)

227 228
mkFinalCall   :: DynFlags
              -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
229
              -> CmmAGraph
230 231
mkFinalCall dflags f _ actuals updfr_off =
  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
232 233
    toCall f Nothing updfr_off 0

234
mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
235 236 237 238 239
                -> BlockId
                -> ByteOff
                -> UpdFrameOffset
                -> (ByteOff, [(CmmExpr,ByteOff)])
                -> CmmAGraph
240 241
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
242 243 244
     updfr_off extra_stack $
       toCall f (Just ret_lbl) updfr_off ret_off

245 246
-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
-- already on the stack).
247
mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
248 249 250 251
                -> BlockId
                -> ByteOff
                -> UpdFrameOffset
                -> CmmAGraph
252 253
mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do
  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
254 255
       toCall f (Just ret_lbl) updfr_off ret_off

256 257 258
mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as

259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278

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




-- 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.
279 280
copyInOflow  :: DynFlags -> Convention -> Area -> [CmmFormal]
             -> (Int, CmmAGraph)
281

282 283
copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
  where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals
284 285 286

type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
                          (ByteOff, [CmmNode O O])
287
type CopyIn  = DynFlags -> SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
288 289 290 291

-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
copyIn :: CopyIn
292
copyIn dflags oflow conv area formals =
293 294 295 296 297
  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
298
        args  = assignArgumentsPos dflags conv localRegType formals
299 300 301 302 303
        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
304
oneCopyOflowI :: SlotCopier
305 306 307 308 309 310 311
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:

312
data Transfer = Call | JumpRet | Jump | Ret deriving Eq
313

314
copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
315 316
             -> UpdFrameOffset
             -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
317
             -> (Int, [GlobalReg], CmmAGraph)
318

319
-- Generate code to move the actual parameters into the locations
320 321
-- required by the calling convention.  This includes a store for the
-- return address.
322
--
323 324 325 326 327
-- 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.
328
copyOutOflow dflags conv transfer area actuals updfr_off
Simon Marlow's avatar
Simon Marlow committed
329
  (extra_stack_off, extra_stack_stuff)
330
  = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
331
  where 
332 333 334 335
    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)
336

Simon Marlow's avatar
Simon Marlow committed
337 338 339
    stack_params = [ (e, StackParam (off + init_offset))
                   | (e,off) <- extra_stack_stuff ]

340
    (setRA, init_offset) =
Simon Marlow's avatar
Simon Marlow committed
341 342
      case area of
            Young id -> id `seq` -- Generate a store instruction for
343
                                 -- the return address if making a call
344 345 346 347 348 349 350 351 352
                  case transfer of
                     Call ->
                       ([(CmmLit (CmmBlock id), StackParam init_offset)],
                       widthInBytes wordWidth)
                     JumpRet ->
                       ([],
                       widthInBytes wordWidth)
                     _other ->
                       ([], 0)
Simon Marlow's avatar
Simon Marlow committed
353 354 355
            Old -> ([], updfr_off)

    arg_offset = init_offset + extra_stack_off
356

357
    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
358
    args = assignArgumentsPos dflags conv cmmExprType actuals
359 360

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

364 365


366 367
mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> (Int, CmmAGraph)
mkCallEntry dflags conv formals = copyInOflow dflags conv Old formals
368

369
lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
370
             -> UpdFrameOffset
371
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
Simon Marlow's avatar
Simon Marlow committed
372
             -> CmmAGraph
373 374
lastWithArgs dflags transfer area conv actuals updfr_off last =
  lastWithArgsAndExtraStack dflags transfer area conv actuals
375
                            updfr_off noExtraStack last
Simon Marlow's avatar
Simon Marlow committed
376

377 378
lastWithArgsAndExtraStack :: DynFlags
             -> Transfer -> Area -> Convention -> [CmmActual]
Simon Marlow's avatar
Simon Marlow committed
379
             -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
380
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
Simon Marlow's avatar
Simon Marlow committed
381
             -> CmmAGraph
382
lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
Simon Marlow's avatar
Simon Marlow committed
383
                          extra_stack last =
384 385
  copies <*> last outArgs regs
 where
386
  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
387 388
                               updfr_off extra_stack

389

Simon Marlow's avatar
Simon Marlow committed
390 391
noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)])
noExtraStack = (0,[])
392

393 394
toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
       -> ByteOff -> [GlobalReg]
395
       -> CmmAGraph
396 397
toCall e cont updfr_off res_space arg_space regs =
  mkLast $ CmmCall e cont regs arg_space res_space updfr_off