+
+selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
+selectContinuations needed_continuations = formats
+ where
+ formats = map select_format format_groups
+ format_groups = groupBy by_target needed_continuations
+ by_target x y = fst x == fst y
+
+ select_format formats = winner
+ where
+ winner = head $ head $ sortBy more_votes format_votes
+ format_votes = groupBy by_format formats
+ by_format x y = snd x == snd y
+ more_votes x y = compare (length y) (length x)
+ -- sort so the most votes goes *first*
+ -- (thus the order of x and y is reversed)
+
+makeContinuationEntries formats
+ block@(BrokenBlock ident entry stmts targets exit) =
+ case lookup ident formats of
+ Nothing -> block
+ Just (ContFormat formals srt is_gc) ->
+ BrokenBlock ident (ContinuationEntry (map kindlessCmm formals) srt is_gc)
+ stmts targets exit
+
+adaptBlockToFormat :: [(BlockId, ContFormat)]
+ -> Unique
+ -> BrokenBlock
+ -> [BrokenBlock]
+adaptBlockToFormat formats unique
+ block@(BrokenBlock ident entry stmts targets
+ exit@(FinalCall next target formals
+ actuals srt ret is_gc)) =
+ if format_formals == formals &&
+ format_srt == srt &&
+ format_is_gc == is_gc
+ then [block] -- Woohoo! This block got the continuation format it wanted
+ else [adaptor_block, revised_block]
+ -- This block didn't get the format it wanted for the
+ -- continuation, so we have to build an adaptor.
+ where
+ (ContFormat format_formals format_srt format_is_gc) =
+ maybe unknown_block id $ lookup next formats
+ unknown_block = panic "unknown block in adaptBlockToFormat"
+
+ revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
+ revised_targets = adaptor_ident : delete next targets
+ revised_exit = FinalCall
+ adaptor_ident -- ^ The only part that changed
+ target formals actuals srt ret is_gc
+
+ adaptor_block = mk_adaptor_block adaptor_ident
+ (ContinuationEntry (map kindlessCmm formals) srt is_gc)
+ next format_formals
+ adaptor_ident = BlockId unique
+
+ mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> CmmFormals -> BrokenBlock
+ mk_adaptor_block ident entry next formals =
+ BrokenBlock ident entry [] [next] exit
+ where
+ exit = FinalJump
+ (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
+ (map formal_to_actual format_formals)
+
+ formal_to_actual (CmmKinded reg hint)
+ = (CmmKinded (CmmReg (CmmLocal reg)) hint)
+ -- TODO: Check if NoHint is right. We're
+ -- jumping to a C-- function not a foreign one
+ -- so it might always be right.
+adaptBlockToFormat _ _ block = [block]
+
+-----------------------------------------------------------------------------