, splice_tail, splice_head, splice_head_only', splice_head'
, of_block_list, to_block_list
, graphOfLGraph
, splice_tail, splice_head, splice_head_only', splice_head'
, of_block_list, to_block_list
, graphOfLGraph
- , map_blocks, map_nodes, mapM_blocks
+ , map_blocks, map_one_block, map_nodes, mapM_blocks
, postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
, fold_layout
, fold_blocks, fold_fwd_block
, postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
, fold_layout
, fold_blocks, fold_fwd_block
import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
, BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)
import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
, BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)
-- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
-- ZTail is a sequence of middle nodes followed by a last node
-- | Blocks and flow graphs; see Note [Kinds of graphs]
-- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
-- ZTail is a sequence of middle nodes followed by a last node
-- | Blocks and flow graphs; see Note [Kinds of graphs]
-data Block m l = Block BlockId (ZTail m l)
+-- In addition to its id, the block carries the number of bytes of stack space
+-- used for incoming parameters on entry to the block.
+data Block m l = Block BlockId (Maybe Int) (ZTail m l)
-data LGraph m l = LGraph { lg_entry :: BlockId
- , lg_blocks :: BlockEnv (Block m l) }
+data LGraph m l = LGraph { lg_entry :: BlockId
+ , lg_argoffset :: Int -- space (bytes) for incoming args
+ , lg_blocks :: BlockEnv (Block m l)}
-- Invariant: lg_entry is in domain( lg_blocks )
-- | And now the zipper. The focus is between the head and tail.
-- Invariant: lg_entry is in domain( lg_blocks )
-- | And now the zipper. The focus is between the head and tail.
-splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
-splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
+splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
+splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
splice_tail :: Graph m l -> ZTail m l -> Graph m l
-- | We can also splice a single-entry, no-exit Graph into a head.
splice_tail :: Graph m l -> ZTail m l -> Graph m l
-- | We can also splice a single-entry, no-exit Graph into a head.
-splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
-splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
+splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
+splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
-- layout or dataflow, however, one will want to use 'postorder_dfs'
-- in order to get the blocks in an order that relates to the control
-- flow in the procedure.
-- layout or dataflow, however, one will want to use 'postorder_dfs'
-- in order to get the blocks in an order that relates to the control
-- flow in the procedure.
to_block_list :: LGraph m l -> [Block m l] -- N log N
-- | Conversion from LGraph to Graph
graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
to_block_list :: LGraph m l -> [Block m l] -- N log N
-- | Conversion from LGraph to Graph
graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
-- mapping includes the entry id!
map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
-- mapping includes the entry id!
-- | Convert block between forms.
-- These functions are tail-recursive, so we can go as deep as we like
-- without fear of stack overflow.
ht_to_block head tail = case head of
-- | Convert block between forms.
-- These functions are tail-recursive, so we can go as deep as we like
-- without fear of stack overflow.
ht_to_block head tail = case head of
ZHead h m -> ht_to_block h (ZTail m tail)
ht_to_last head (ZLast l) = (head, l)
ZHead h m -> ht_to_block h (ZTail m tail)
ht_to_last head (ZLast l) = (head, l)
------------------ simple graph manipulations
focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
------------------ simple graph manipulations
focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
case lookupBlockEnv blocks id of
Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
Nothing -> panic "asked for nonexistent block in flow graph"
entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
case lookupBlockEnv blocks id of
Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
Nothing -> panic "asked for nonexistent block in flow graph"
entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
-- | pull out a block satisfying the predicate, if any
splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
-- | pull out a block satisfying the predicate, if any
splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
-- Better to geot [A,B,C,D]
-- Better to geot [A,B,C,D]
let FGraph id eblock _ = entry g in
zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
let FGraph id eblock _ = entry g in
zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
-- 'b1' what its inline successor is going to be, so that if 'b1' ends with
-- 'goto b2', the goto can be omitted.
-- 'b1' what its inline successor is going to be, so that if 'b1' ends with
-- 'goto b2', the goto can be omitted.
-map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks)
+map_blocks f (LGraph eid off blocks) = LGraph eid off (mapUFM f blocks)
+
+map_nodes idm middle last (LGraph eid off blocks) =
+ LGraph (idm eid) off (mapUFM (map_one_block idm middle last) blocks)
-map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
- where block (Block id t) = Block (idm id) (tail t)
- tail (ZTail m t) = ZTail (middle m) (tail t)
+map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t)
+ where tail (ZTail m t) = ZTail (middle m) (tail t)
where blocks' =
foldUFM (\b mblocks -> do { blocks <- mblocks
; b <- f b
; return $ insertBlock b blocks })
(return emptyBlockEnv) blocks
where blocks' =
foldUFM (\b mblocks -> do { blocks <- mblocks
; b <- f b
; return $ insertBlock b blocks })
(return emptyBlockEnv) blocks
-fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
-fold_fwd_block first middle last (Block id t) z = tail t (first id z)
+fold_blocks f z (LGraph _ _ blocks) = foldUFM f z blocks
+fold_fwd_block first middle last (Block id _ t) z = tail t (first id z)
-of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
-to_block_list (LGraph _ blocks) = eltsUFM blocks
-
-
+of_block_list e off blocks = LGraph e off $ foldr insertBlock emptyBlockEnv blocks
+to_block_list (LGraph _ _ blocks) = eltsUFM blocks
ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
where eid = head_id head
splice_one_block tail' =
case ht_to_last head tail' of
ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
where eid = head_id head
splice_one_block tail' =
case ht_to_last head tail' of
_ -> panic "entry not at start of block?!"
splice_head_only' head (Graph tail gblocks) =
let eblock = zipht head tail in
_ -> panic "entry not at start of block?!"
splice_head_only' head (Graph tail gblocks) =
let eblock = zipht head tail in
-- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
-- tm (BlockEnv (Block m' l'))
txtail h (ZTail m t) blocks' =
-- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
-- tm (BlockEnv (Block m' l'))
txtail h (ZTail m t) blocks' =
pprLast (LastOther l) = ppr l
pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
pprLast (LastOther l) = ppr l
pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
where blocks = postorder_dfs g
pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
where blocks = postorder_dfs g
pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc