2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
9 -- | Converts C-- with full proceedures and parameters
10 -- to a CPS transformed C-- with the stack made manifest.
14 #include "HsVersions.h"
47 -----------------------------------------------------------------------------
48 -- |Top level driver for the CPS pass
49 -----------------------------------------------------------------------------
50 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
51 -> [Cmm] -- ^ Input C-- with Proceedures
52 -> IO [Cmm] -- ^ Output CPS transformed C--
53 cmmCPS dflags cmm_with_calls
54 = do { when (dopt Opt_DoCmmLinting dflags) $
55 do showPass dflags "CmmLint"
56 case firstJust $ map cmmLint cmm_with_calls of
57 Just err -> do printDump err
60 ; showPass dflags "CPS"
62 -- TODO: more lint checking
63 -- check for use of branches to non-existant blocks
64 -- check for use of Sp, SpLim, R1, R2, etc.
66 ; uniqSupply <- mkSplitUniqSupply 'p'
67 ; let supplies = listSplitUniqSupply uniqSupply
68 ; let cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls
70 ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm)
72 -- TODO: add option to dump Cmm to file
77 -----------------------------------------------------------------------------
78 -- |CPS a single CmmTop (proceedure)
79 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
80 -----------------------------------------------------------------------------
82 doCpsProc :: UniqSupply -> Cmm -> Cmm
84 = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
87 -> CmmTop -- ^Input procedure
88 -> [CmmTop] -- ^Output procedures;
89 -- a single input procedure is converted to
90 -- multiple output procedures
92 -- Data blocks don't need to be CPS transformed
93 cpsProc uniqSupply proc@(CmmData _ _) = [proc]
95 -- Empty functions just don't work with the CPS algorithm, but
96 -- they don't need the transformation anyway so just output them directly
97 cpsProc uniqSupply proc@(CmmProc _ _ _ (ListGraph []))
98 = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
100 -- CPS transform for those procs that actually need it
103 -- * Introduce a stack-check block as the first block
104 -- * The first blocks gets a FunctionEntry; the rest are ControlEntry
105 -- * Now break each block into a bunch of blocks (at call sites);
106 -- all but the first will be ContinuationEntry
108 cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs
110 -- We need to be generating uniques for several things.
111 -- We could make this function monadic to handle that
112 -- but since there is no other reason to make it monadic,
113 -- we instead will just split them all up right here.
114 (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
115 uniques :: [[Unique]]
116 uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
117 (stack_check_block_unique:stack_use_unique:adaptor_uniques) :
118 block_uniques = uniques
119 proc_uniques = map (map (map uniqsFromSupply . listSplitUniqSupply) . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
121 stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) GCKindPtr)
122 stack_check_block_id = BlockId stack_check_block_unique
123 stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
125 forced_blocks = stack_check_block : blocks
127 CmmInfo maybe_gc_block_id update_frame _ = info
129 -- Break the block at each function call.
130 -- The part after the function call will have to become a continuation.
131 broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
133 (\x -> (concatMap fst x, concatMap snd x)) $
134 zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
137 (FunctionEntry info ident params :
140 f' = selectContinuations (fst broken_blocks)
141 broken_blocks' = map (makeContinuationEntries f') $
143 zipWith (adaptBlockToFormat f')
147 -- Calculate live variables for each broken block.
149 -- Nothing can be live on entry to the first block
150 -- so we could take the tail, but for now we wont
151 -- to help future proof the code.
152 live :: BlockEntryLiveness
153 live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
155 -- Calculate which blocks must be made into full fledged procedures.
156 proc_points :: UniqSet BlockId
157 proc_points = calculateProcPoints broken_blocks'
159 -- Construct a map so we can lookup a broken block by its 'BlockId'.
160 block_env :: BlockEnv BrokenBlock
161 block_env = blocksToBlockEnv broken_blocks'
163 -- Group the blocks into continuations based on the set of proc-points.
164 continuations :: [Continuation (Either C_SRT CmmInfo)]
165 continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
166 (uniqSetToList proc_points)
168 -- Select the stack format on entry to each continuation.
169 -- Return the max stack offset and an association list
171 -- This is an association list instead of a UniqFM because
172 -- CLabel's don't have a 'Uniqueable' instance.
173 formats :: [(CLabel, -- key
174 (CmmFormalsWithoutKinds, -- arguments
175 Maybe CLabel, -- label in top slot
176 [Maybe LocalReg]))] -- slots
177 formats = selectContinuationFormat live continuations
179 -- Do a little meta-processing on the stack formats such as
180 -- getting the individual frame sizes and the maximum frame size
181 formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
182 formats'@(_, _, format_list) = processFormats formats update_frame continuations
184 -- Update the info table data on the continuations with
185 -- the selected stack formats.
186 continuations' :: [Continuation CmmInfo]
187 continuations' = map (applyContinuationFormat format_list) continuations
189 -- Do the actual CPS transform.
190 cps_procs :: [CmmTop]
191 cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
193 make_stack_check stack_check_block_id info stack_use next_block_id =
194 BasicBlock stack_check_block_id $
195 check_stmts ++ [CmmBranch next_block_id]
199 -- If we are given a stack check handler,
200 -- then great, well check the stack.
201 CmmInfo (Just gc_block) _ _
203 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
204 [CmmReg stack_use, CmmReg spLimReg])
206 -- If we aren't given a stack check handler,
207 -- then humph! we just won't check the stack for them.
210 -----------------------------------------------------------------------------
212 collectNonProcPointTargets ::
213 UniqSet BlockId -> BlockEnv BrokenBlock
214 -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
215 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
216 if sizeUniqSet current_targets == sizeUniqSet new_targets
219 (collectNonProcPointTargets proc_points blocks)
223 blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
225 -- Note the subtlety that since the extra branch after a call
226 -- will always be to a block that is a proc-point,
227 -- this subtraction will always remove that case
228 uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
229 `minusUniqSet` proc_points
230 -- TODO: remove redundant uniqSetToList
231 new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
233 -- TODO: insert proc point code here
234 -- * Branches and switches to proc points may cause new blocks to be created
235 -- (or proc points could leave behind phantom blocks that just jump to them)
236 -- * Proc points might get some live variables passed as arguments
238 gatherBlocksIntoContinuation ::
239 BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
240 -> BlockId -> Continuation (Either C_SRT CmmInfo)
241 gatherBlocksIntoContinuation live proc_points blocks start =
242 Continuation info_table clabel params is_gc_cont body
244 children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
245 start_block = lookupWithDefaultUFM blocks unknown_block start
246 children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children)
247 unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
248 body = start_block : children_blocks
250 -- We can't properly annotate the continuation's stack parameters
251 -- at this point because this is before stack selection
252 -- but we want to keep the C_SRT around so we use 'Either'.
253 info_table = case start_block_entry of
254 FunctionEntry info _ _ -> Right info
255 ContinuationEntry _ srt _ -> Left srt
256 ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
258 is_gc_cont = case start_block_entry of
259 FunctionEntry _ _ _ -> False
260 ContinuationEntry _ _ gc_cont -> gc_cont
261 ControlEntry -> False
263 start_block_entry = brokenBlockEntry start_block
264 clabel = case start_block_entry of
265 FunctionEntry _ label _ -> label
266 _ -> mkReturnPtLabel $ getUnique start
267 params = case start_block_entry of
268 FunctionEntry _ _ args -> args
269 ContinuationEntry args _ _ -> args
272 lookupWithDefaultUFM live unknown_block start
273 -- it's a proc-point, pass lives in parameter registers
275 --------------------------------------------------------------------------------
276 -- For now just select the continuation orders in the order they are in the set with no gaps
278 selectContinuationFormat :: BlockEnv CmmLive
279 -> [Continuation (Either C_SRT CmmInfo)]
280 -> [(CLabel, (CmmFormalsWithoutKinds, Maybe CLabel, [Maybe LocalReg]))]
281 selectContinuationFormat live continuations =
282 map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
284 -- User written continuations
285 selectContinuationFormat' (Continuation
286 (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt))))
288 (formals, Just label, format)
289 -- Either user written non-continuation code
290 -- or CPS generated proc-points
291 selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
292 (formals, Nothing, [])
293 -- CPS generated continuations
294 selectContinuationFormat' (Continuation (Left srt) label formals _ blocks) =
295 -- TODO: assumes the first block is the entry block
296 let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
299 map Just $ uniqSetToList $
300 lookupWithDefaultUFM live unknown_block ident)
302 unknown_block = panic "unknown BlockId in selectContinuationFormat"
304 processFormats :: [(CLabel, (CmmFormalsWithoutKinds, Maybe CLabel, [Maybe LocalReg]))]
306 -> [Continuation (Either C_SRT CmmInfo)]
307 -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
308 processFormats formats update_frame continuations =
309 (max_size + update_frame_size, update_frame_size, formats')
312 0 : map (continuationMaxStack formats') continuations
313 formats' = map make_format formats
314 make_format (label, (formals, top, stack)) =
317 continuation_formals = formals,
318 continuation_label = top,
319 continuation_frame_size = stack_size stack +
323 continuation_stack = stack })
325 update_frame_size = case update_frame of
327 (Just (UpdateFrame _ args))
328 -> label_size + update_size args
331 update_size (expr:exprs) = width + update_size exprs
333 width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
334 -- TODO: it would be better if we had a machRepWordWidth
336 -- TODO: get rid of "+ 1" etc.
337 label_size = 1 :: WordOff
340 stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
341 stack_size (Just reg:formats) = width + stack_size formats
343 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
344 -- TODO: it would be better if we had a machRepWordWidth
346 continuationMaxStack :: [(CLabel, ContinuationFormat)]
349 continuationMaxStack _ (Continuation _ _ _ True _) = 0
350 continuationMaxStack formats (Continuation _ label _ False blocks) =
351 max_arg_size + continuation_frame_size stack_format
353 stack_format = maybe unknown_format id $ lookup label formats
354 unknown_format = panic "Unknown format in continuationMaxStack"
356 max_arg_size = maximum $ 0 : map block_max_arg_size blocks
358 block_max_arg_size block =
359 maximum (final_arg_size (brokenBlockExit block) :
360 map stmt_arg_size (brokenBlockStmts block))
362 final_arg_size (FinalReturn args) =
363 argumentsSize (cmmExprRep . kindlessCmm) args
364 final_arg_size (FinalJump _ args) =
365 argumentsSize (cmmExprRep . kindlessCmm) args
366 final_arg_size (FinalCall next _ _ args _ _ True) = 0
367 final_arg_size (FinalCall next _ _ args _ _ False) =
368 -- We have to account for the stack used when we build a frame
369 -- for the *next* continuation from *this* continuation
370 argumentsSize (cmmExprRep . kindlessCmm) args +
371 continuation_frame_size next_format
373 next_format = maybe unknown_format id $ lookup next' formats
374 next' = mkReturnPtLabel $ getUnique next
378 stmt_arg_size (CmmJump _ args) =
379 argumentsSize (cmmExprRep . kindlessCmm) args
380 stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
381 panic "Safe call in processFormats"
382 stmt_arg_size (CmmReturn _) =
383 panic "CmmReturn in processFormats"
386 -----------------------------------------------------------------------------
387 applyContinuationFormat :: [(CLabel, ContinuationFormat)]
388 -> Continuation (Either C_SRT CmmInfo)
389 -> Continuation CmmInfo
391 -- User written continuations
392 applyContinuationFormat formats (Continuation
393 (Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt))))
394 label formals is_gc blocks) =
395 Continuation (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo format srt)))
396 label formals is_gc blocks
398 format = continuation_stack $ maybe unknown_block id $ lookup label formats
399 unknown_block = panic "unknown BlockId in applyContinuationFormat"
401 -- Either user written non-continuation code or CPS generated proc-point
402 applyContinuationFormat formats (Continuation
403 (Right info) label formals is_gc blocks) =
404 Continuation info label formals is_gc blocks
406 -- CPS generated continuations
407 applyContinuationFormat formats (Continuation
408 (Left srt) label formals is_gc blocks) =
409 Continuation (CmmInfo gc Nothing (CmmInfoTable prof tag (ContInfo (continuation_stack $ format) srt)))
410 label formals is_gc blocks
412 gc = Nothing -- Generated continuations never need a stack check
413 -- TODO prof: this is the same as the current implementation
414 -- but I think it could be improved
415 prof = ProfilingInfo zeroCLit zeroCLit
416 tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
417 format = maybe unknown_block id $ lookup label formats
418 unknown_block = panic "unknown BlockId in applyContinuationFormat"