- let loop_to (id, _) =
- if lookup id == id then
- Just (G.Block id Nothing (G.ZLast (G.mkBranchNode id)))
- else
- Nothing
- in mapMaybe loop_to lone_branch_blocks
- lookup id = lookupBlockEnv env id `orElse` id
-
-isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
-isLoneBranchZ (G.Block id Nothing (G.ZLast (G.LastOther (LastBranch target))))
- | id /= target = Left (id,target)
-isLoneBranchZ other = Right other
- -- An infinite loop is not a link in a branch chain!
-
-replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
-replaceLabelsZ env = replace_eid . G.map_nodes id middle last
+ let loop_to (id, _) =
+ if lookup id == id then
+ Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id))
+ else
+ Nothing
+ in mapMaybe loop_to lone_branch_blocks
+ lookup id = mapLookup id env `orElse` id
+
+ call_succs = foldl add emptyBlockSet blocks
+ where add :: BlockSet -> CmmBlock -> BlockSet
+ add succs b =
+ case lastNode b of
+ (CmmCall _ (Just k) _ _ _) -> setInsert k succs
+ (CmmForeignCall {succ=k}) -> setInsert k succs
+ _ -> succs
+ isLoneBranch :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
+ isLoneBranch block | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block,
+ id /= target && not (setMember id call_succs)
+ = Left (id,target)
+ isLoneBranch other = Right other
+ -- An infinite loop is not a link in a branch chain!
+
+maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
+maybeReplaceLabels lpred env =
+ replace_eid . mapGraphNodes (id, middle, last)
+ where
+ replace_eid g = g {g_entry = lookup (g_entry g)}
+ lookup id = fmap lookup (mapLookup id env) `orElse` id
+
+ middle = mapExpDeep exp
+ last l = if lpred l then mapExpDeep exp (last' l) else l
+ last' :: CmmNode O C -> CmmNode O C
+ last' (CmmBranch bid) = CmmBranch (lookup bid)
+ last' (CmmCondBranch p t f) = CmmCondBranch p (lookup t) (lookup f)
+ last' (CmmSwitch e arms) = CmmSwitch e (map (liftM lookup) arms)
+ last' (CmmCall t k a res r) = CmmCall t (liftM lookup k) a res r
+ last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (lookup bid) u i
+
+ exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
+ exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
+ exp e = e
+
+
+replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+replaceLabels = maybeReplaceLabels (const True)
+
+replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+replaceBranches env g = mapGraphNodes (id, id, last) g