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
Simon Marlow's avatar
Simon Marlow committed
170
mkAssign l (CmmReg r) | l == r  = mkNop
171
mkAssign l r  = mkMiddle $ CmmAssign l r
172

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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




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

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

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

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

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

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

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

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

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

    arg_offset = init_offset + extra_stack_off
357

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

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

365
366


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

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

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

390

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

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