1 module CmmCPS (cmmCPS) where
3 #include "HsVersions.h"
9 import Dataflow (fixedpoint)
31 --------------------------------------------------------------------------------
33 -- The format for the call to a continuation
34 -- The fst is the arguments that must be passed to the continuation
35 -- by the continuation's caller.
36 -- The snd is the live values that must be saved on stack.
37 -- A Nothing indicates an ignored slot.
38 -- The head of each list is the stack top or the first parameter.
40 -- The format for live values for a particular continuation
41 -- All on stack for now.
42 -- Head element is the top of the stack (or just under the header).
43 -- Nothing means an empty slot.
44 -- Future possibilities include callee save registers (i.e. passing slots in register)
45 -- and heap memory (not sure if that's usefull at all though, but it may
46 -- be worth exploring the design space).
50 brokenBlockId :: BlockId, -- Like a CmmBasicBlock
51 brokenBlockEntry :: BlockEntryInfo,
52 -- How this block can be entered
54 brokenBlockStmts :: [CmmStmt],
55 -- Like a CmmBasicBlock
56 -- (but without the last statement)
58 brokenBlockTargets :: [BlockId],
59 -- Blocks that this block could
60 -- branch to one either by conditional
61 -- branches or via the last statement
63 brokenBlockExit :: FinalStmt
64 -- How the block can be left
69 = FunctionEntry -- Beginning of function
71 | ContinuationEntry -- Return point of a call
72 CmmFormals -- return values
74 -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame
76 | ControlEntry -- A label in the input
80 BlockId -- next block (must be a ControlEntry)
83 CmmActuals -- return values
86 CmmExpr -- the function to call
87 CmmActuals -- arguments to call
90 BlockId -- next block after call (must be a ContinuationEntry)
91 CmmCallTarget -- the function to call
92 CmmFormals -- results from call (redundant with ContinuationEntry)
93 CmmActuals -- arguments to call
94 (Maybe [GlobalReg]) -- registers that must be saved (TODO)
95 -- TODO: | ProcPointExit (needed?)
99 BlockId {- block that is the start of the continuation. may or may not be the current block -}
100 WordOff {- total frame size -}
101 [(CmmReg, WordOff)] {- local reg offsets from stack top -}
103 -- A block can be a continuation of a call
104 -- A block can be a continuation of another block (w/ or w/o joins)
105 -- 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
110 selectStackFormat2 :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat
111 selectStackFormat2 live blocks = fixedpoint dependants update (map brokenBlockId blocks) emptyUFM where
112 blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
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
118 -- Propagate only to blocks entered by branches (not function entry blocks or continuation entry blocks)
120 let cause_format = lookupWithDefaultUFM formats (panic "update signaled for block not in format") cause_name
122 ControlEntry -> Just $ addToUFM formats ident cause_format
123 FunctionEntry -> Nothing
124 ContinuationEntry _ -> Nothing
125 -- Do initial calculates for function blocks
128 ControlEntry -> Nothing
129 FunctionEntry -> Just $ addToUFM formats ident $ StackFormat ident 0 []
130 ContinuationEntry _ -> Just $ addToUFM formats ident $ live_to_format ident $ lookupWithDefaultUFM live (panic "TODO") ident
131 live_to_format label live =
133 (StackFormat label retAddrSizeW [])
135 extend_format :: StackFormat -> LocalReg -> StackFormat
136 extend_format (StackFormat block size offsets) reg =
137 StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
139 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
141 constructContinuation2 :: BlockEnv StackFormat -> BrokenBlock -> CmmBasicBlock
142 constructContinuation2 formats (BrokenBlock ident entry stmts _ exit) =
143 BasicBlock ident (prefix++stmts++postfix)
145 curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
146 prefix = case entry of
149 ContinuationEntry formals -> unpack_continuation curr_format
150 postfix = case exit of
151 FinalBranch next -> [CmmBranch next]
152 FinalReturn arguments -> exit_function curr_format (CmmLoad (CmmReg spReg) wordRep) arguments
153 FinalJump target arguments -> exit_function curr_format target arguments
154 -- TODO: do something about global saves
155 FinalCall next (CmmForeignCall target CmmCallConv) results arguments saves ->
156 let cont_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next)) next
157 in pack_continuation curr_format cont_format ++
158 [CmmJump target arguments]
159 FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
161 --------------------------------------------------------------------------------
162 -- Functions that generate CmmStmt sequences
163 -- for packing/unpacking continuations
164 -- and entering/exiting functions
166 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
167 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
168 = adjust_spReg ++ jump where
171 (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
172 jump = [CmmJump target arguments]
174 enter_function :: WordOff -> [CmmStmt]
175 enter_function max_frame_size
176 = check_stack_limit where
177 check_stack_limit = [
179 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
180 [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
182 gc_block = undefined -- TODO: get stack and heap checks to go to same
184 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
185 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
186 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
187 (StackFormat cont_id cont_frame_size cont_offsets)
188 = save_live_values ++ set_stack_header ++ adjust_spReg where
189 -- TODO: only save variables when actually needed
193 spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
195 | (reg, offset) <- cont_offsets]
196 set_stack_header = -- TODO: only set when needed
197 [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
198 continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique cont_id
200 if curr_frame_size == cont_frame_size
202 else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
204 -- Lazy adjustment of stack headers assumes all blocks
205 -- that could branch to eachother (i.e. control blocks)
206 -- have the same stack format (this causes a problem
207 -- only for proc-point).
208 unpack_continuation :: StackFormat -> [CmmStmt]
209 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
210 = load_live_values where
211 -- TODO: only save variables when actually needed
215 (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
216 | (reg, offset) <- curr_offsets]
218 -----------------------------------------------------------------------------
219 -- Breaking basic blocks on function calls
220 -----------------------------------------------------------------------------
222 -----------------------------------------------------------------------------
223 -- Takes a basic block and returns a list of basic blocks that
224 -- each have at most 1 CmmCall in them which must occur at the end.
225 -- Also returns with each basic block, the variables that will
226 -- be arguments to the continuation of the block once the call (if any)
229 breakBlock uniques (BasicBlock ident stmts) entry =
230 breakBlock' uniques ident entry [] [] stmts where
231 breakBlock' uniques current_id entry exits accum_stmts stmts =
233 [] -> panic "block doesn't end in jump, goto or return"
234 [CmmJump target arguments] ->
235 [BrokenBlock current_id entry accum_stmts exits
236 (FinalJump target arguments)]
237 [CmmReturn arguments] ->
238 [BrokenBlock current_id entry accum_stmts exits
239 (FinalReturn arguments)]
240 [CmmBranch target] ->
241 [BrokenBlock current_id entry accum_stmts (target:exits)
242 (FinalBranch target)]
244 panic "jump in middle of block"
246 panic "return in middle of block"
248 panic "branch in middle of block"
250 panic "switch in block not implemented"
251 (CmmCall target results arguments saves:stmts) ->
252 let new_id = BlockId $ head uniques
253 rest = breakBlock' (tail uniques) new_id (ContinuationEntry results) [] [] stmts
254 in BrokenBlock current_id entry accum_stmts (new_id:exits)
255 (FinalCall new_id target results arguments saves) : rest
256 (s@(CmmCondBranch test target):stmts) ->
257 breakBlock' uniques current_id entry (target:exits) (accum_stmts++[s]) stmts
259 breakBlock' uniques current_id entry exits (accum_stmts++[s]) stmts
261 -----------------------------------------------------------------------------
262 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
263 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) = BasicBlock ident (stmts++exit_stmt)
267 FinalBranch target -> [CmmBranch target]
268 FinalReturn arguments -> [CmmReturn arguments]
269 FinalJump target arguments -> [CmmJump target arguments]
270 FinalCall branch_target call_target results arguments saves -> [CmmCall call_target results arguments saves, CmmBranch branch_target]
272 -----------------------------------------------------------------------------
273 -- CPS a single CmmTop (proceedure)
274 -----------------------------------------------------------------------------
276 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
277 cpsProc uniqSupply x@(CmmData _ _) = [x]
278 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
279 [CmmProc info_table ident params $ map (constructContinuation2 formats) broken_blocks]
282 uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
284 broken_blocks :: [BrokenBlock]
285 broken_blocks = concat $ zipWith3 breakBlock uniqes blocks (FunctionEntry:repeat ControlEntry)
287 live :: BlockEntryLiveness
288 live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
290 -- TODO: branches for proc points
291 -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
293 formats :: BlockEnv StackFormat -- Stack format on entry
294 formats = selectStackFormat2 live broken_blocks
297 --------------------------------------------------------------------------------
299 -> [Cmm] -- C-- with Proceedures
300 -> IO [Cmm] -- Output: CPS transformed C--
302 cmmCPS dflags abstractC = do
303 when (dopt Opt_DoCmmLinting dflags) $
304 do showPass dflags "CmmLint"
305 case firstJust $ map cmmLint abstractC of
306 Just err -> do printDump err
309 showPass dflags "CPS"
310 -- TODO: check for use of branches to non-existant blocks
311 -- TODO: check for use of Sp, SpLim, R1, R2, etc.
312 -- continuationC <- return abstractC
313 -- TODO: find out if it is valid to create a new unique source like this
314 uniqSupply <- mkSplitUniqSupply 'p'
315 let supplies = listSplitUniqSupply uniqSupply
316 let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
318 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
319 -- TODO: add option to dump Cmm to file