1 module CmmCPS (cmmCPS) where
3 #include "HsVersions.h"
9 import Dataflow (fixedpoint)
33 --------------------------------------------------------------------------------
35 -- The format for the call to a continuation
36 -- The fst is the arguments that must be passed to the continuation
37 -- by the continuation's caller.
38 -- The snd is the live values that must be saved on stack.
39 -- A Nothing indicates an ignored slot.
40 -- The head of each list is the stack top or the first parameter.
42 -- The format for live values for a particular continuation
43 -- All on stack for now.
44 -- Head element is the top of the stack (or just under the header).
45 -- Nothing means an empty slot.
46 -- Future possibilities include callee save registers (i.e. passing slots in register)
47 -- and heap memory (not sure if that's usefull at all though, but it may
48 -- be worth exploring the design space).
50 continuationLabel (Continuation _ _ l _ _) = l
53 Bool -- True => Function entry, False => Continuation/return point
54 [CmmStatic] -- Info table, may be empty
55 CLabel -- Used to generate both info & entry labels
56 CmmFormals -- Argument locals live on entry (C-- procedure params)
57 [BrokenBlock] -- Code, may be empty. The first block is
58 -- the entry point. The order is otherwise initially
59 -- unimportant, but at some point the code gen will
62 -- the BlockId of the first block does not give rise
63 -- to a label. To jump to the first block in a Proc,
64 -- use the appropriate CLabel.
66 -- Describes the layout of a stack frame for a continuation
69 (Maybe CLabel) -- The label occupying the top slot
70 WordOff -- Total frame size in words
71 [(CmmReg, WordOff)] -- local reg offsets from stack top
73 -- A block can be a continuation of a call
74 -- A block can be a continuation of another block (w/ or w/o joins)
75 -- A block can be an entry to a function
77 -----------------------------------------------------------------------------
79 collectNonProcPointTargets ::
80 UniqSet BlockId -> BlockEnv BrokenBlock
81 -> UniqSet BlockId -> BlockId -> UniqSet BlockId
82 collectNonProcPointTargets proc_points blocks current_targets block =
83 if sizeUniqSet current_targets == sizeUniqSet new_targets
85 else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
87 block' = lookupWithDefaultUFM blocks (panic "TODO") block
89 -- Note the subtlety that since the extra branch after a call
90 -- will always be to a block that is a proc-point,
91 -- this subtraction will always remove that case
92 uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
93 -- TODO: remove redundant uniqSetToList
94 new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
97 UniqSet BlockId -> BlockEnv BrokenBlock
98 -> BlockId -> Continuation
99 buildContinuation proc_points blocks start =
100 Continuation is_entry info_table clabel params body
102 children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
103 start_block = lookupWithDefaultUFM blocks (panic "TODO") start
104 children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
105 body = start_block : children_blocks
106 info_table = [] -- TODO
107 start_block_entry = brokenBlockEntry start_block
108 is_entry = case start_block_entry of
109 FunctionEntry _ _ -> True
111 clabel = case start_block_entry of
112 FunctionEntry label _ -> label
113 _ -> mkReturnPtLabel $ getUnique start
114 params = case start_block_entry of
115 FunctionEntry _ args -> args
116 ContinuationEntry args -> args
117 ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
119 --------------------------------------------------------------------------------
120 -- For now just select the continuation orders in the order they are in the set with no gaps
122 selectStackFormat2 :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
123 selectStackFormat2 live continuations =
124 map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
126 selectStackFormat' (Continuation True info_table label formals blocks) =
127 --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
129 StackFormat (Just label) 0 []
130 selectStackFormat' (Continuation False info_table label formals blocks) =
131 -- TODO: assumes the first block is the entry block
132 let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
133 in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
135 live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
136 live_to_format label formals live =
138 (StackFormat (Just label) retAddrSizeW [])
139 (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
141 extend_format :: StackFormat -> LocalReg -> StackFormat
142 extend_format (StackFormat label size offsets) reg =
143 StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
145 unknown_block = panic "unknown BlockId in selectStackFormat"
147 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
149 constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
150 constructContinuation formats (Continuation is_entry info label formals blocks) =
151 CmmProc info label formals (map (constructContinuation2' label formats) blocks)
153 constructContinuation2' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
155 constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
156 BasicBlock ident (prefix++stmts++postfix)
158 curr_format = maybe unknown_block id $ lookup curr_ident formats
159 unknown_block = panic "unknown BlockId in constructContinuation"
160 prefix = case entry of
162 FunctionEntry _ _ -> []
163 ContinuationEntry formals ->
164 unpack_continuation curr_format
165 postfix = case exit of
166 FinalBranch next -> [CmmBranch next]
167 FinalSwitch expr targets -> [CmmSwitch expr targets]
168 FinalReturn arguments ->
169 exit_function curr_format
170 (CmmLoad (CmmReg spReg) wordRep)
172 FinalJump target arguments ->
173 exit_function curr_format target arguments
174 -- TODO: do something about global saves
175 FinalCall next (CmmForeignCall target CmmCallConv)
176 results arguments saves ->
177 pack_continuation curr_format cont_format ++
178 [CmmJump target arguments]
180 cont_format = maybe unknown_block id $
181 lookup (mkReturnPtLabel $ getUnique next) formats
182 FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
184 --------------------------------------------------------------------------------
185 -- Functions that generate CmmStmt sequences
186 -- for packing/unpacking continuations
187 -- and entering/exiting functions
189 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
190 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
191 = adjust_spReg ++ jump where
193 if curr_frame_size == 0
195 else [CmmAssign spReg
196 (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
197 jump = [CmmJump target arguments]
199 enter_function :: WordOff -> [CmmStmt]
200 enter_function max_frame_size
201 = check_stack_limit where
202 check_stack_limit = [
204 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
205 [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
207 gc_block = undefined -- TODO: get stack and heap checks to go to same
209 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
210 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
211 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
212 (StackFormat cont_id cont_frame_size cont_offsets)
213 = save_live_values ++ set_stack_header ++ adjust_spReg where
214 -- TODO: only save variables when actually needed
218 spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
220 | (reg, offset) <- cont_offsets]
222 case (curr_id, cont_id) of
223 (Just x, Just y) -> x /= y
228 else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
229 continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
231 if curr_frame_size == cont_frame_size
233 else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
235 -- Lazy adjustment of stack headers assumes all blocks
236 -- that could branch to eachother (i.e. control blocks)
237 -- have the same stack format (this causes a problem
238 -- only for proc-point).
239 unpack_continuation :: StackFormat -> [CmmStmt]
240 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
241 = load_live_values where
242 -- TODO: only save variables when actually needed
246 (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
247 | (reg, offset) <- curr_offsets]
249 -----------------------------------------------------------------------------
250 -- Breaking basic blocks on function calls
251 -----------------------------------------------------------------------------
253 -----------------------------------------------------------------------------
254 -- Takes a basic block and breaks it up into a list of broken blocks
256 -- Takes a basic block and returns a list of basic blocks that
257 -- each have at most 1 CmmCall in them which must occur at the end.
258 -- Also returns with each basic block, the variables that will
259 -- be arguments to the continuation of the block once the call (if any)
262 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
263 breakBlock uniques (BasicBlock ident stmts) entry =
264 breakBlock' uniques ident entry [] [] stmts where
265 breakBlock' uniques current_id entry exits accum_stmts stmts =
267 [] -> panic "block doesn't end in jump, goto or return"
268 [CmmJump target arguments] ->
269 [BrokenBlock current_id entry accum_stmts
271 (FinalJump target arguments)]
272 [CmmReturn arguments] ->
273 [BrokenBlock current_id entry accum_stmts
275 (FinalReturn arguments)]
276 [CmmBranch target] ->
277 [BrokenBlock current_id entry accum_stmts
279 (FinalBranch target)]
280 [CmmSwitch expr targets] ->
281 [BrokenBlock current_id entry accum_stmts
282 (mapMaybe id targets ++ exits)
283 (FinalSwitch expr targets)]
285 panic "jump in middle of block"
287 panic "return in middle of block"
289 panic "branch in middle of block"
291 panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
292 (CmmCall target results arguments saves:stmts) -> block : rest
294 new_id = BlockId $ head uniques
295 block = BrokenBlock current_id entry accum_stmts
297 (FinalCall new_id target results arguments saves)
298 rest = breakBlock' (tail uniques) new_id
299 (ContinuationEntry results) [] [] stmts
300 (s@(CmmCondBranch test target):stmts) ->
301 breakBlock' uniques current_id entry
302 (target:exits) (accum_stmts++[s]) stmts
304 breakBlock' uniques current_id entry
305 exits (accum_stmts++[s]) stmts
307 --------------------------------
308 -- Convert from a BrokenBlock
309 -- to a CmmBasicBlock so the
310 -- liveness analysis can run
312 --------------------------------
313 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
314 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
315 BasicBlock ident (stmts++exit_stmt)
319 FinalBranch target -> [CmmBranch target]
320 FinalReturn arguments -> [CmmReturn arguments]
321 FinalJump target arguments -> [CmmJump target arguments]
322 FinalSwitch expr targets -> [CmmSwitch expr targets]
323 FinalCall branch_target call_target results arguments saves ->
324 [CmmCall call_target results arguments saves,
325 CmmBranch branch_target]
327 -----------------------------------------------------------------------------
328 -- CPS a single CmmTop (proceedure)
329 -----------------------------------------------------------------------------
331 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
332 cpsProc uniqSupply x@(CmmData _ _) = [x]
333 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
334 --[CmmProc info_table ident params cps_blocks]
338 uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
340 -- Break the block at each function call
341 broken_blocks :: [BrokenBlock]
342 broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
343 (FunctionEntry ident params:repeat ControlEntry)
345 -- Calculate live variables for each broken block
346 live :: BlockEntryLiveness
347 live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
348 -- nothing can be live on entry to the first block so we could take the tail
350 proc_points :: UniqSet BlockId
351 proc_points = calculateProcPoints broken_blocks
353 continuations :: [Continuation]
354 continuations = map (buildContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
356 -- TODO: insert proc point code here
357 -- * Branches and switches to proc points may cause new blocks to be created
358 -- (or proc points could leave behind phantom blocks that just jump to them)
359 -- * Proc points might get some live variables passed as arguments
361 -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
363 --procs = groupBlocksIntoContinuations live broken_blocks
365 -- Select the stack format on entry to each block
366 formats2 :: [(CLabel, StackFormat)]
367 formats2 = selectStackFormat2 live continuations
369 -- Do the actual CPS transform
370 cps_continuations :: [CmmTop]
371 cps_continuations = map (constructContinuation formats2) continuations
373 --------------------------------------------------------------------------------
375 -> [Cmm] -- C-- with Proceedures
376 -> IO [Cmm] -- Output: CPS transformed C--
378 cmmCPS dflags abstractC = do
379 when (dopt Opt_DoCmmLinting dflags) $
380 do showPass dflags "CmmLint"
381 case firstJust $ map cmmLint abstractC of
382 Just err -> do printDump err
385 showPass dflags "CPS"
386 -- TODO: check for use of branches to non-existant blocks
387 -- TODO: check for use of Sp, SpLim, R1, R2, etc.
388 -- TODO: find out if it is valid to create a new unique source like this
389 uniqSupply <- mkSplitUniqSupply 'p'
390 let supplies = listSplitUniqSupply uniqSupply
391 let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
393 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
394 -- TODO: add option to dump Cmm to file