- live_at_end =
- case exit of
- ControlExit _ _ -> emptyUniqSet
- ReturnExit _ actuals -> foldr ((.) . cmmExprLive) id (map fst actuals) emptyUniqSet
- TailCallExit _ target actuals ->
- cmmExprLive target $ foldr ((.) . cmmExprLive) id (map fst actuals) $ emptyUniqSet
- CallExit _ _ target _ actuals live ->
- target_liveness $
- foldr ((.) . cmmExprLive) id (map fst actuals) $
- emptyUniqSet
- where
- only_local_regs [] = []
- only_local_regs ((CmmGlobal _,_):args) = only_local_regs args
- only_local_regs ((CmmLocal r,_):args) = r:only_local_regs args
- target_liveness =
- case target of
- (CmmForeignCall target _) -> cmmExprLive target
- (CmmPrim _) -> id
-
-
-cmmBrokenBlockUpdate ::
- UniqFM {-BlockId-} BrokenBlock
- -> BlockId
- -> Maybe BlockId
- -> UniqFM {-BlockId-} CmmLive
- -> Maybe (UniqFM {-BlockId-} CmmLive)
-cmmBrokenBlockUpdate blocks node _ state =
- let old_live = lookupWithDefaultUFM state (panic "unknown block id during liveness analysis") node
- block = lookupWithDefaultUFM blocks (panic "unknown block id during liveness analysis") node
- new_live = cmmBrokenBlockLive state block
- in if (sizeUniqSet old_live) == (sizeUniqSet new_live)
- then Nothing
- else Just $ addToUFM state node new_live
-
-
-cmmLiveness2 :: [BrokenBlock] -> UniqFM {-BlockId-} CmmLive
-cmmLiveness2 blocks =
- fixedpoint (cmmBrokenBlockDependants sources) (cmmBrokenBlockUpdate blocks')
- (map brokenBlockId blocks) (listToUFM [(brokenBlockId b, emptyUniqSet) | b <- blocks]) where
- sources = cmmBrokenBlockSources blocks
- blocks' = cmmBrokenBlockNames blocks
+ -- User written continuations
+ selectContinuationFormat' (Continuation
+ (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt))))
+ label formals _ _) =
+ (formals, Just label, format)
+ -- Either user written non-continuation code
+ -- or CPS generated proc-points
+ selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
+ (formals, Nothing, [])
+ -- CPS generated continuations
+ selectContinuationFormat' (Continuation (Left srt) label formals _ blocks) =
+ -- TODO: assumes the first block is the entry block
+ let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
+ in (formals,
+ Just label,
+ map Just $ uniqSetToList $
+ lookupWithDefaultUFM live unknown_block ident)
+
+ unknown_block = panic "unknown BlockId in selectContinuationFormat"
+
+processFormats :: [(CLabel, (CmmFormalsWithoutKinds, Maybe CLabel, [Maybe LocalReg]))]
+ -> Maybe UpdateFrame
+ -> [Continuation (Either C_SRT CmmInfo)]
+ -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
+processFormats formats update_frame continuations =
+ (max_size + update_frame_size, update_frame_size, formats')
+ where
+ max_size = maximum $
+ 0 : map (continuationMaxStack formats') continuations
+ formats' = map make_format formats
+ make_format (label, (formals, top, stack)) =
+ (label,
+ ContinuationFormat {
+ continuation_formals = formals,
+ continuation_label = top,
+ continuation_frame_size = stack_size stack +
+ if isJust top
+ then label_size
+ else 0,
+ continuation_stack = stack })
+
+ update_frame_size = case update_frame of
+ Nothing -> 0
+ (Just (UpdateFrame _ args))
+ -> label_size + update_size args
+
+ update_size [] = 0
+ update_size (expr:exprs) = width + update_size exprs
+ where
+ width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
+ -- TODO: it would be better if we had a machRepWordWidth
+
+ -- TODO: get rid of "+ 1" etc.
+ label_size = 1 :: WordOff
+
+ stack_size [] = 0
+ stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
+ stack_size (Just reg:formats) = width + stack_size formats
+ where
+ width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
+ -- TODO: it would be better if we had a machRepWordWidth
+
+continuationMaxStack :: [(CLabel, ContinuationFormat)]
+ -> Continuation a
+ -> WordOff
+continuationMaxStack _ (Continuation _ _ _ True _) = 0
+continuationMaxStack formats (Continuation _ label _ False blocks) =
+ max_arg_size + continuation_frame_size stack_format
+ where
+ stack_format = maybe unknown_format id $ lookup label formats
+ unknown_format = panic "Unknown format in continuationMaxStack"
+
+ max_arg_size = maximum $ 0 : map block_max_arg_size blocks
+
+ block_max_arg_size block =
+ maximum (final_arg_size (brokenBlockExit block) :
+ map stmt_arg_size (brokenBlockStmts block))
+
+ final_arg_size (FinalReturn args) =
+ argumentsSize (cmmExprRep . kindlessCmm) args
+ final_arg_size (FinalJump _ args) =
+ argumentsSize (cmmExprRep . kindlessCmm) args
+ final_arg_size (FinalCall next _ _ args _ _ True) = 0
+ final_arg_size (FinalCall next _ _ args _ _ False) =
+ -- We have to account for the stack used when we build a frame
+ -- for the *next* continuation from *this* continuation
+ argumentsSize (cmmExprRep . kindlessCmm) args +
+ continuation_frame_size next_format
+ where
+ next_format = maybe unknown_format id $ lookup next' formats
+ next' = mkReturnPtLabel $ getUnique next
+
+ final_arg_size _ = 0
+
+ stmt_arg_size (CmmJump _ args) =
+ argumentsSize (cmmExprRep . kindlessCmm) args
+ stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
+ panic "Safe call in processFormats"
+ stmt_arg_size (CmmReturn _) =
+ panic "CmmReturn in processFormats"
+ stmt_arg_size _ = 0
+
+-----------------------------------------------------------------------------
+applyContinuationFormat :: [(CLabel, ContinuationFormat)]
+ -> Continuation (Either C_SRT CmmInfo)
+ -> Continuation CmmInfo
+
+-- User written continuations
+applyContinuationFormat formats (Continuation
+ (Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt))))
+ label formals is_gc blocks) =
+ Continuation (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo format srt)))
+ label formals is_gc blocks
+ where
+ format = continuation_stack $ maybe unknown_block id $ lookup label formats
+ unknown_block = panic "unknown BlockId in applyContinuationFormat"
+
+-- Either user written non-continuation code or CPS generated proc-point
+applyContinuationFormat formats (Continuation
+ (Right info) label formals is_gc blocks) =
+ Continuation info label formals is_gc blocks
+
+-- CPS generated continuations
+applyContinuationFormat formats (Continuation
+ (Left srt) label formals is_gc blocks) =
+ Continuation (CmmInfo gc Nothing (CmmInfoTable prof tag (ContInfo (continuation_stack $ format) srt)))
+ label formals is_gc blocks
+ where
+ gc = Nothing -- Generated continuations never need a stack check
+ -- TODO prof: this is the same as the current implementation
+ -- but I think it could be improved
+ prof = ProfilingInfo zeroCLit zeroCLit
+ tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
+ format = maybe unknown_block id $ lookup label formats
+ unknown_block = panic "unknown BlockId in applyContinuationFormat"