+ last :: CmmNode O C -> CmmNode O C
+ last (CmmBranch id) = CmmBranch (lookup id)
+ last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
+ last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
+ last l@(CmmCall {}) = l
+ last l@(CmmForeignCall {}) = l
+ lookup id = fmap lookup (mapLookup id env) `orElse` id
+
+----------------------------------------------------------------
+-- Build a map from a block to its set of predecessors. Very useful.
+predMap :: [CmmBlock] -> BlockEnv BlockSet
+predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
+ where add_preds block env = foldl (add (entryLabel block)) env (successors block)
+ add bid env b' =
+ mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
+----------------------------------------------------------------
+-- If a block B branches to a label L, L is not the entry block,
+-- and L has no other predecessors,
+-- then we can splice the block starting with L onto the end of B.
+-- Order matters, so we work bottom up (reverse postorder DFS).
+-- This optimization can be inhibited by unreachable blocks, but
+-- the reverse postorder DFS returns only reachable blocks.
+--
+-- To ensure correctness, we have to make sure that the BlockId of the block
+-- we are about to eliminate is not named in another instruction.
+--
+-- Note: This optimization does _not_ subsume branch chain elimination.
+blockConcat :: CmmGraph -> CmmGraph
+blockConcat g@(CmmGraph {g_entry=eid}) =
+ replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
+ where blocks = postorderDfs g
+ (blocks', concatMap) =
+ foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
+ maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
+ maybe_concat b unchanged@(blocks', concatMap) =
+ let bid = entryLabel b
+ in case blockToNodeList b of
+ (JustC h, m, JustC (CmmBranch b')) ->
+ if canConcatWith b' then
+ (mapInsert bid (splice blocks' h m b') blocks',
+ mapInsert b' bid concatMap)
+ else unchanged
+ _ -> unchanged
+ num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
+ canConcatWith b' = b' /= eid && num_preds b' == 1
+ backEdges = predMap blocks
+ splice :: forall map n e x.
+ IsMap map =>
+ map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
+ splice blocks' h m bid' =
+ case mapLookup bid' blocks' of
+ Nothing -> panic "unknown successor block"
+ Just block | (_, m', l') <- blockToNodeList block -> blockOfNodeList (JustC h, (m ++ m'), l')