2 -- | Converts C-- with full proceedures and parameters
3 -- to a CPS transformed C-- with the stack made manifest.
7 #include "HsVersions.h"
13 import Dataflow (fixedpoint)
37 --------------------------------------------------------------------------------
39 -- The format for the call to a continuation
40 -- The fst is the arguments that must be passed to the continuation
41 -- by the continuation's caller.
42 -- The snd is the live values that must be saved on stack.
43 -- A Nothing indicates an ignored slot.
44 -- The head of each list is the stack top or the first parameter.
46 -- The format for live values for a particular continuation
47 -- All on stack for now.
48 -- Head element is the top of the stack (or just under the header).
49 -- Nothing means an empty slot.
50 -- Future possibilities include callee save registers (i.e. passing slots in register)
51 -- and heap memory (not sure if that's usefull at all though, but it may
52 -- be worth exploring the design space).
54 continuationLabel (Continuation _ _ l _ _) = l
57 Bool -- True => Function entry, False => Continuation/return point
58 [CmmStatic] -- Info table, may be empty
59 CLabel -- Used to generate both info & entry labels
60 CmmFormals -- Argument locals live on entry (C-- procedure params)
61 [BrokenBlock] -- Code, may be empty. The first block is
62 -- the entry point. The order is otherwise initially
63 -- unimportant, but at some point the code gen will
66 -- the BlockId of the first block does not give rise
67 -- to a label. To jump to the first block in a Proc,
68 -- use the appropriate CLabel.
70 -- Describes the layout of a stack frame for a continuation
73 (Maybe CLabel) -- The label occupying the top slot
74 WordOff -- Total frame size in words
75 [(CmmReg, WordOff)] -- local reg offsets from stack top
77 -- A block can be a continuation of a call
78 -- A block can be a continuation of another block (w/ or w/o joins)
79 -- A block can be an entry to a function
81 -----------------------------------------------------------------------------
83 collectNonProcPointTargets ::
84 UniqSet BlockId -> BlockEnv BrokenBlock
85 -> UniqSet BlockId -> BlockId -> UniqSet BlockId
86 collectNonProcPointTargets proc_points blocks current_targets block =
87 if sizeUniqSet current_targets == sizeUniqSet new_targets
89 else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
91 block' = lookupWithDefaultUFM blocks (panic "TODO") block
93 -- Note the subtlety that since the extra branch after a call
94 -- will always be to a block that is a proc-point,
95 -- this subtraction will always remove that case
96 uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
97 -- TODO: remove redundant uniqSetToList
98 new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
100 procPointToContinuation ::
101 UniqSet BlockId -> BlockEnv BrokenBlock
102 -> BlockId -> Continuation
103 procPointToContinuation proc_points blocks start =
104 Continuation is_entry info_table clabel params body
106 children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
107 start_block = lookupWithDefaultUFM blocks (panic "TODO") start
108 children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
109 body = start_block : children_blocks
110 info_table = [] -- TODO
111 start_block_entry = brokenBlockEntry start_block
112 is_entry = case start_block_entry of
113 FunctionEntry _ _ -> True
115 clabel = case start_block_entry of
116 FunctionEntry label _ -> label
117 _ -> mkReturnPtLabel $ getUnique start
118 params = case start_block_entry of
119 FunctionEntry _ args -> args
120 ContinuationEntry args -> args
121 ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
123 --------------------------------------------------------------------------------
124 -- For now just select the continuation orders in the order they are in the set with no gaps
126 selectStackFormat :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
127 selectStackFormat live continuations =
128 map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
130 selectStackFormat' (Continuation True info_table label formals blocks) =
131 --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
133 StackFormat (Just label) 0 []
134 selectStackFormat' (Continuation False info_table label formals blocks) =
135 -- TODO: assumes the first block is the entry block
136 let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
137 in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
139 live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
140 live_to_format label formals live =
142 (StackFormat (Just label) retAddrSizeW [])
143 (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
145 extend_format :: StackFormat -> LocalReg -> StackFormat
146 extend_format (StackFormat label size offsets) reg =
147 StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
149 slot_size :: LocalReg -> Int
150 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
152 unknown_block = panic "unknown BlockId in selectStackFormat"
154 continuationToProc :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
155 continuationToProc formats (Continuation is_entry info label formals blocks) =
156 CmmProc info label formals (map (continuationToProc' label formats) blocks)
158 continuationToProc' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
160 continuationToProc' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
161 BasicBlock ident (prefix++stmts++postfix)
163 curr_format = maybe unknown_block id $ lookup curr_ident formats
164 unknown_block = panic "unknown BlockId in continuationToProc"
165 prefix = case entry of
167 FunctionEntry _ _ -> []
168 ContinuationEntry formals ->
169 unpack_continuation curr_format
170 postfix = case exit of
171 FinalBranch next -> [CmmBranch next]
172 FinalSwitch expr targets -> [CmmSwitch expr targets]
173 FinalReturn arguments ->
174 exit_function curr_format
175 (CmmLoad (CmmReg spReg) wordRep)
177 FinalJump target arguments ->
178 exit_function curr_format target arguments
179 -- TODO: do something about global saves
180 FinalCall next (CmmForeignCall target CmmCallConv)
181 results arguments saves ->
182 pack_continuation curr_format cont_format ++
183 [CmmJump target arguments]
185 cont_format = maybe unknown_block id $
186 lookup (mkReturnPtLabel $ getUnique next) formats
187 FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
189 --------------------------------------------------------------------------------
190 -- Functions that generate CmmStmt sequences
191 -- for packing/unpacking continuations
192 -- and entering/exiting functions
194 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
195 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
196 = adjust_spReg ++ jump where
198 if curr_frame_size == 0
200 else [CmmAssign spReg
201 (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
202 jump = [CmmJump target arguments]
204 enter_function :: WordOff -> [CmmStmt]
205 enter_function max_frame_size
206 = check_stack_limit where
207 check_stack_limit = [
209 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
210 [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
212 gc_block = undefined -- TODO: get stack and heap checks to go to same
214 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
215 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
216 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
217 (StackFormat cont_id cont_frame_size cont_offsets)
218 = save_live_values ++ set_stack_header ++ adjust_spReg where
219 -- TODO: only save variables when actually needed
223 spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
225 | (reg, offset) <- cont_offsets]
227 case (curr_id, cont_id) of
228 (Just x, Just y) -> x /= y
233 else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
234 continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
236 if curr_frame_size == cont_frame_size
238 else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
240 -- Lazy adjustment of stack headers assumes all blocks
241 -- that could branch to eachother (i.e. control blocks)
242 -- have the same stack format (this causes a problem
243 -- only for proc-point).
244 unpack_continuation :: StackFormat -> [CmmStmt]
245 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
246 = load_live_values where
247 -- TODO: only save variables when actually needed
251 (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
252 | (reg, offset) <- curr_offsets]
254 -----------------------------------------------------------------------------
255 -- Breaking basic blocks on function calls
256 -----------------------------------------------------------------------------
258 -----------------------------------------------------------------------------
259 -- Takes a basic block and breaks it up into a list of broken blocks
261 -- Takes a basic block and returns a list of basic blocks that
262 -- each have at most 1 CmmCall in them which must occur at the end.
263 -- Also returns with each basic block, the variables that will
264 -- be arguments to the continuation of the block once the call (if any)
267 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
268 breakBlock uniques (BasicBlock ident stmts) entry =
269 breakBlock' uniques ident entry [] [] stmts where
270 breakBlock' uniques current_id entry exits accum_stmts stmts =
272 [] -> panic "block doesn't end in jump, goto or return"
273 [CmmJump target arguments] ->
274 [BrokenBlock current_id entry accum_stmts
276 (FinalJump target arguments)]
277 [CmmReturn arguments] ->
278 [BrokenBlock current_id entry accum_stmts
280 (FinalReturn arguments)]
281 [CmmBranch target] ->
282 [BrokenBlock current_id entry accum_stmts
284 (FinalBranch target)]
285 [CmmSwitch expr targets] ->
286 [BrokenBlock current_id entry accum_stmts
287 (mapMaybe id targets ++ exits)
288 (FinalSwitch expr targets)]
290 panic "jump in middle of block"
292 panic "return in middle of block"
294 panic "branch in middle of block"
296 panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
297 (CmmCall target results arguments saves:stmts) -> block : rest
299 new_id = BlockId $ head uniques
300 block = BrokenBlock current_id entry accum_stmts
302 (FinalCall new_id target results arguments saves)
303 rest = breakBlock' (tail uniques) new_id
304 (ContinuationEntry results) [] [] stmts
305 (s@(CmmCondBranch test target):stmts) ->
306 breakBlock' uniques current_id entry
307 (target:exits) (accum_stmts++[s]) stmts
309 breakBlock' uniques current_id entry
310 exits (accum_stmts++[s]) stmts
312 --------------------------------
313 -- Convert from a BrokenBlock
314 -- to a CmmBasicBlock so the
315 -- liveness analysis can run
317 --------------------------------
318 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
319 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
320 BasicBlock ident (stmts++exit_stmt)
324 FinalBranch target -> [CmmBranch target]
325 FinalReturn arguments -> [CmmReturn arguments]
326 FinalJump target arguments -> [CmmJump target arguments]
327 FinalSwitch expr targets -> [CmmSwitch expr targets]
328 FinalCall branch_target call_target results arguments saves ->
329 [CmmCall call_target results arguments saves,
330 CmmBranch branch_target]
332 -----------------------------------------------------------------------------
333 -- CPS a single CmmTop (proceedure)
334 -----------------------------------------------------------------------------
336 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
337 cpsProc uniqSupply x@(CmmData _ _) = [x]
338 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
341 uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
343 -- Break the block at each function call
344 broken_blocks :: [BrokenBlock]
345 broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
346 (FunctionEntry ident params:repeat ControlEntry)
348 -- Calculate live variables for each broken block
349 live :: BlockEntryLiveness
350 live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
351 -- nothing can be live on entry to the first block so we could take the tail
353 proc_points :: UniqSet BlockId
354 proc_points = calculateProcPoints broken_blocks
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 continuations :: [Continuation]
362 continuations = map (procPointToContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
364 -- Select the stack format on entry to each block
365 formats :: [(CLabel, StackFormat)]
366 formats = selectStackFormat live continuations
368 -- Do the actual CPS transform
369 cps_procs :: [CmmTop]
370 cps_procs = map (continuationToProc formats) continuations
372 --------------------------------------------------------------------------------
374 -> [Cmm] -- C-- with Proceedures
375 -> IO [Cmm] -- Output: CPS transformed C--
377 cmmCPS dflags abstractC = do
378 when (dopt Opt_DoCmmLinting dflags) $
379 do showPass dflags "CmmLint"
380 case firstJust $ map cmmLint abstractC of
381 Just err -> do printDump err
384 showPass dflags "CPS"
385 -- TODO: check for use of branches to non-existant blocks
386 -- TODO: check for use of Sp, SpLim, R1, R2, etc.
387 -- TODO: find out if it is valid to create a new unique source like this
388 uniqSupply <- mkSplitUniqSupply 'p'
389 let supplies = listSplitUniqSupply uniqSupply
390 let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
392 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
393 -- TODO: add option to dump Cmm to file