CmmCPS.hs 13.5 KB
Newer Older
1
2
3
4
5
6
7
8
module CmmCPS (cmmCPS) where

#include "HsVersions.h"

import Cmm
import CmmLint
import PprCmm

9
10
import Dataflow (fixedpoint)
import CmmLive
11
12
13
14

import MachOp
import ForeignCall
import CLabel
15
16
import SMRep
import Constants
17
18
19
20
21

import DynFlags
import ErrUtils
import Maybes
import Outputable
22
23
24
25
import UniqSupply
import UniqFM
import UniqSet
import Unique
26
27
28

import Monad
import IO
29
import Data.List
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47

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

-- The format for the call to a continuation
-- The fst is the arguments that must be passed to the continuation
-- by the continuation's caller.
-- The snd is the live values that must be saved on stack.
-- A Nothing indicates an ignored slot.
-- The head of each list is the stack top or the first parameter.

-- The format for live values for a particular continuation
-- All on stack for now.
-- Head element is the top of the stack (or just under the header).
-- Nothing means an empty slot.
-- Future possibilities include callee save registers (i.e. passing slots in register)
-- and heap memory (not sure if that's usefull at all though, but it may
-- be worth exploring the design space).

48
data BrokenBlock
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
  = BrokenBlock {
      brokenBlockId :: BlockId, -- Like a CmmBasicBlock
      brokenBlockEntry :: BlockEntryInfo,
                                -- How this block can be entered

      brokenBlockStmts :: [CmmStmt],
                                -- Like a CmmBasicBlock
                                -- (but without the last statement)

      brokenBlockTargets :: [BlockId],
                                -- Blocks that this block could
                                -- branch to one either by conditional
                                -- branches or via the last statement

      brokenBlockExit :: BlockExitInfo
                                -- How the block can be left
    }

67
68
69
70
71

data BlockEntryInfo
  = FunctionEntry		-- Beginning of function

  | ContinuationEntry 		-- Return point of a call
72
73
74
      CmmFormals                -- return values
  -- TODO:
  -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame
75
76
77
78

  | ControlEntry		-- A label in the input

data BlockExitInfo
79
  = ControlExit
80
81
    BlockId -- next block (must be a ControlEntry)

82
  | ReturnExit
83
84
    CmmActuals -- return values

85
  | TailCallExit
86
87
88
    CmmExpr -- the function to call
    CmmActuals -- arguments to call

89
  | CallExit
90
91
92
93
94
95
96
97
98
    BlockId -- next block after call (must be a ContinuationEntry)
    CmmCallTarget -- the function to call
    CmmFormals -- results from call (redundant with ContinuationEntry)
    CmmActuals -- arguments to call
    (Maybe [GlobalReg]) -- registers that must be saved (TODO)
  -- TODO: | ProcPointExit (needed?)

data StackFormat
    = StackFormat
99
100
101
         BlockId {- block that is the start of the continuation. may or may not be the current block -}
         WordOff {- total frame size -}
         [(CmmReg, WordOff)] {- local reg offsets from stack top -}
102
103
104
105
106

-- A block can be a continuation of a call
-- A block can be a continuation of another block (w/ or w/o joins)
-- A block can be an entry to a function

107
--------------------------------------------------------------------------------
108
-- For now just select the continuation orders in the order they are in the set with no gaps
109
110

selectStackFormat2 :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat
111
112
113
selectStackFormat2 live blocks = fixedpoint dependants update (map brokenBlockId blocks) emptyUFM where
  blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
  dependants ident =
114
      brokenBlockTargets $ lookupWithDefaultUFM blocks_ufm (panic "TODO") ident
115
  update ident cause formats =
116
    let BrokenBlock _ entry _ _ _ = lookupWithDefaultUFM blocks_ufm (panic "unknown BlockId in selectStackFormat:live") ident in
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
    case cause of
      -- Propagate only to blocks entered by branches (not function entry blocks or continuation entry blocks)
      Just cause_name ->
          let cause_format = lookupWithDefaultUFM formats (panic "update signaled for block not in format") cause_name
          in case entry of
            ControlEntry -> Just $ addToUFM formats ident cause_format
            FunctionEntry -> Nothing
            ContinuationEntry _ -> Nothing
      -- Do initial calculates for function blocks
      Nothing ->
          case entry of
            ControlEntry -> Nothing
            FunctionEntry -> Just $ addToUFM formats ident $ StackFormat ident 0 []
            ContinuationEntry _ -> Just $ addToUFM formats ident $ live_to_format ident $ lookupWithDefaultUFM live (panic "TODO") ident
  live_to_format label live =
      foldl extend_format
                (StackFormat label retAddrSizeW [])
                (uniqSetToList live)
  extend_format :: StackFormat -> LocalReg -> StackFormat
  extend_format (StackFormat block size offsets) reg =
      StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)

slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1

141
142
constructContinuation2 :: BlockEnv StackFormat -> BrokenBlock -> CmmBasicBlock
constructContinuation2 formats (BrokenBlock ident entry stmts _ exit) =
143
144
145
146
147
148
149
150
    BasicBlock ident (prefix++stmts++postfix)
    where
      curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
      prefix = case entry of
                 ControlEntry -> []
                 FunctionEntry -> []
                 ContinuationEntry formals -> unpack_continuation curr_format
      postfix = case exit of
151
152
153
                  ControlExit next -> [CmmBranch next]
                  ReturnExit arguments -> exit_function curr_format (CmmLoad (CmmReg spReg) wordRep) arguments
                  TailCallExit target arguments -> exit_function curr_format target arguments
154
                  -- TODO: do something about global saves
155
                  CallExit next (CmmForeignCall target CmmCallConv) results arguments saves ->
156
157
158
                      let cont_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next)) next
                      in pack_continuation curr_format cont_format ++
                             [CmmJump target arguments]
159
                  CallExit next _ results arguments saves -> panic "unimplemented CmmCall"
160

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
--------------------------------------------------------------------------------
-- Functions that generate CmmStmt sequences
-- for packing/unpacking continuations
-- and entering/exiting functions

exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
  = adjust_spReg ++ jump where
    adjust_spReg = [
     CmmAssign spReg
     (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
    jump = [CmmJump target arguments]

enter_function :: WordOff -> [CmmStmt]
enter_function max_frame_size
  = check_stack_limit where
    check_stack_limit = [
     CmmCondBranch
     (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
                    [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
     gc_block]
    gc_block = undefined -- TODO: get stack and heap checks to go to same

-- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
                       (StackFormat cont_id cont_frame_size cont_offsets)
  = save_live_values ++ set_stack_header ++ adjust_spReg where
    -- TODO: only save variables when actually needed
    save_live_values =
        [CmmStore
         (CmmRegOff
          spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
         (CmmReg reg)
         | (reg, offset) <- cont_offsets]
    set_stack_header = -- TODO: only set when needed
        [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
    continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique cont_id
    adjust_spReg =
        if curr_frame_size == cont_frame_size
        then []
        else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]

-- Lazy adjustment of stack headers assumes all blocks
-- that could branch to eachother (i.e. control blocks)
-- have the same stack format (this causes a problem
-- only for proc-point).
unpack_continuation :: StackFormat -> [CmmStmt]
unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
  = load_live_values where
    -- TODO: only save variables when actually needed
    load_live_values =
        [CmmAssign
         reg
         (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
         | (reg, offset) <- curr_offsets]

218
219
220
-----------------------------------------------------------------------------
-- Breaking basic blocks on function calls
-----------------------------------------------------------------------------
221

222
-----------------------------------------------------------------------------
223
224
225
-- Takes a basic block and returns a list of basic blocks that
-- each have at most 1 CmmCall in them which must occur at the end.
-- Also returns with each basic block, the variables that will
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
-- be arguments to the continuation of the block once the call (if any)
-- returns.

breakBlock uniques (BasicBlock ident stmts) entry =
    breakBlock' uniques ident entry [] [] stmts where
        breakBlock' uniques current_id entry exits accum_stmts stmts =
            case stmts of
              [] -> panic "block doesn't end in jump, goto or return"
              [CmmJump target arguments] ->
                  [BrokenBlock current_id entry accum_stmts exits
                                   (TailCallExit target arguments)]
              [CmmReturn arguments] ->
                  [BrokenBlock current_id entry accum_stmts exits
                                   (ReturnExit arguments)]
              [CmmBranch target] ->
                  [BrokenBlock current_id entry accum_stmts (target:exits)
                                   (ControlExit target)]
              (CmmJump _ _:_) ->
                  panic "jump in middle of block"
              (CmmReturn _:_) ->
                  panic "return in middle of block"
              (CmmBranch _:_) ->
                  panic "branch in middle of block"
              (CmmSwitch _ _:_) ->
                  panic "switch in block not implemented"
              (CmmCall target results arguments saves:stmts) ->
                  let new_id = BlockId $ head uniques
                      rest = breakBlock' (tail uniques) new_id (ContinuationEntry results) [] [] stmts
                  in BrokenBlock current_id entry accum_stmts (new_id:exits)
                         (CallExit new_id target results arguments saves) : rest
              (s@(CmmCondBranch test target):stmts) ->
                  breakBlock' uniques current_id entry (target:exits) (accum_stmts++[s]) stmts
              (s:stmts) ->
                  breakBlock' uniques current_id entry exits (accum_stmts++[s]) stmts

-----------------------------------------------------------------------------
cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) = BasicBlock ident (stmts++exit_stmt)
264
    where
265
      exit_stmt =
266
          case exit of
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
            ControlExit target -> [CmmBranch target]
            ReturnExit arguments -> [CmmReturn arguments]
            TailCallExit target arguments -> [CmmJump target arguments]
            CallExit branch_target call_target results arguments saves -> [CmmCall call_target results arguments saves, CmmBranch branch_target]

-----------------------------------------------------------------------------
-- CPS a single CmmTop (proceedure)
-----------------------------------------------------------------------------

cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
cpsProc uniqSupply x@(CmmData _ _) = [x]
cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
  [CmmProc info_table ident params $ map (constructContinuation2 formats) broken_blocks]
    where
      uniqes :: [[Unique]]
      uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply

      broken_blocks :: [BrokenBlock]
      broken_blocks = concat $ zipWith3 breakBlock uniqes blocks (FunctionEntry:repeat ControlEntry)
  
      live :: BlockEntryLiveness
      live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks

      -- TODO: branches for proc points
      -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks

      formats :: BlockEnv StackFormat	-- Stack format on entry
      formats = selectStackFormat2 live broken_blocks

296

297
--------------------------------------------------------------------------------
298
299
300
301
302
303
304
305
306
307
308
309
cmmCPS :: DynFlags
       -> [Cmm]                 -- C-- with Proceedures
       -> IO [Cmm]		-- Output: CPS transformed C--

cmmCPS dflags abstractC = do
  when (dopt Opt_DoCmmLinting dflags) $
       do showPass dflags "CmmLint"
	  case firstJust $ map cmmLint abstractC of
	    Just err -> do printDump err
			   ghcExit dflags 1
	    Nothing  -> return ()
  showPass dflags "CPS"
310
311
  -- TODO: check for use of branches to non-existant blocks
  -- TODO: check for use of Sp, SpLim, R1, R2, etc.
312
  -- continuationC <- return abstractC
313
314
  -- TODO: find out if it is valid to create a new unique source like this
  uniqSupply <- mkSplitUniqSupply 'p'
315
316
  let supplies = listSplitUniqSupply uniqSupply
  let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
317
318
319
320

  dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
  -- TODO: add option to dump Cmm to file
  return continuationC