hoopl-3.10.2.1: src/Compiler/Hoopl/Graph.hs
{-# LANGUAGE CPP, GADTs, TypeFamilies, ScopedTypeVariables,
RankNTypes, FlexibleInstances, TypeSynonymInstances #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
#if __GLASGOW_HASKELL__ < 701
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
module Compiler.Hoopl.Graph
(
-- * Body
Body, Body', emptyBody, bodyList, addBlock, bodyUnion
-- * Graph
, Graph, Graph'(..)
, NonLocal(entryLabel, successors)
-- ** Constructing graphs
, bodyGraph
, blockGraph
, gUnitOO, gUnitOC, gUnitCO, gUnitCC
, catGraphNodeOC, catGraphNodeOO
, catNodeCOGraph, catNodeOOGraph
-- ** Splicing graphs
, splice, gSplice
-- ** Maps
, mapGraph, mapGraphBlocks
-- ** Folds
, foldGraphNodes
-- ** Extracting Labels
, labelsDefined, labelsUsed, externalEntryLabels
-- ** Depth-first traversals
, postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
, preorder_dfs, preorder_dfs_from_except
, LabelsPtr(..)
)
where
import Compiler.Hoopl.Collections
import Compiler.Hoopl.Block
import Compiler.Hoopl.Label
import Control.Applicative as AP (Applicative(..))
import Control.Monad (ap,liftM,liftM2)
-- -----------------------------------------------------------------------------
-- Body
-- | A (possibly empty) collection of closed/closed blocks
type Body n = LabelMap (Block n C C)
-- | @Body@ abstracted over @block@
type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
emptyBody :: Body' block n
emptyBody = mapEmpty
bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a
bodyUnion = mapUnionWithKey nodups
where nodups l _ _ = error $ "duplicate blocks with label " ++ show l
bodyList :: Body' block n -> [(Label,block n C C)]
bodyList body = mapToList body
addBlock :: NonLocal thing
=> thing C C -> LabelMap (thing C C)
-> LabelMap (thing C C)
addBlock b body
| mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph"
| otherwise = mapInsert lbl b body
where lbl = entryLabel b
-- ---------------------------------------------------------------------------
-- Graph
-- | A control-flow graph, which may take any of four shapes (O/O,
-- O/C, C/O, C/C). A graph open at the entry has a single,
-- distinguished, anonymous entry point; if a graph is closed at the
-- entry, its entry point(s) are supplied by a context.
type Graph = Graph' Block
-- | @Graph'@ is abstracted over the block type, so that we can build
-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
-- needs this).
data Graph' block (n :: * -> * -> *) e x where
GNil :: Graph' block n O O
GUnit :: block n O O -> Graph' block n O O
GMany :: MaybeO e (block n O C)
-> Body' block n
-> MaybeO x (block n C O)
-> Graph' block n e x
-------------------------------
-- | Gives access to the anchor points for
-- nonlocal edges as well as the edges themselves
class NonLocal thing where
entryLabel :: thing C x -> Label -- ^ The label of a first node or block
successors :: thing e C -> [Label] -- ^ Gives control-flow successors
instance NonLocal n => NonLocal (Block n) where
entryLabel (BlockCO f _) = entryLabel f
entryLabel (BlockCC f _ _) = entryLabel f
successors (BlockOC _ n) = successors n
successors (BlockCC _ _ n) = successors n
-- -----------------------------------------------------------------------------
-- Constructing graphs
bodyGraph :: Body n -> Graph n C C
bodyGraph b = GMany NothingO b NothingO
gUnitOO :: block n O O -> Graph' block n O O
gUnitOC :: block n O C -> Graph' block n O C
gUnitCO :: block n C O -> Graph' block n C O
gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C
gUnitOO b = GUnit b
gUnitOC b = GMany (JustO b) emptyBody NothingO
gUnitCO b = GMany NothingO emptyBody (JustO b)
gUnitCC b = GMany NothingO (addBlock b emptyBody) NothingO
catGraphNodeOO :: Graph n e O -> n O O -> Graph n e O
catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C
catNodeOOGraph :: n O O -> Graph n O x -> Graph n O x
catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x
catGraphNodeOO GNil n = gUnitOO $ BMiddle n
catGraphNodeOO (GUnit b) n = gUnitOO $ BSnoc b n
catGraphNodeOO (GMany e body (JustO (BlockCO f b))) n
= GMany e body (JustO (BlockCO f (BSnoc b n)))
catGraphNodeOC GNil n = gUnitOC $ BlockOC BNil n
catGraphNodeOC (GUnit b) n = gUnitOC $ BlockOC b n
catGraphNodeOC (GMany e body (JustO (BlockCO f x))) n
= GMany e (addBlock (BlockCC f x n) body) NothingO
catNodeOOGraph n GNil = gUnitOO $ BMiddle n
catNodeOOGraph n (GUnit b) = gUnitOO $ BCons n b
catNodeOOGraph n (GMany (JustO (BlockOC b l)) body x)
= GMany (JustO (BlockOC (n `BCons` b) l)) body x
catNodeCOGraph f GNil = gUnitCO (BlockCO f BNil)
catNodeCOGraph f (GUnit b) = gUnitCO (BlockCO f b)
catNodeCOGraph f (GMany (JustO (BlockOC b n)) body x)
= GMany NothingO (addBlock (BlockCC f b n) body) x
blockGraph :: NonLocal n => Block n e x -> Graph n e x
blockGraph b@(BlockCO {}) = gUnitCO b
blockGraph b@(BlockOC {}) = gUnitOC b
blockGraph b@(BlockCC {}) = gUnitCC b
blockGraph (BNil {}) = GNil
blockGraph b@(BMiddle {}) = gUnitOO b
blockGraph b@(BCat {}) = gUnitOO b
blockGraph b@(BSnoc {}) = gUnitOO b
blockGraph b@(BCons {}) = gUnitOO b
-- -----------------------------------------------------------------------------
-- Splicing graphs
splice :: forall block n e a x . NonLocal (block n) =>
(forall e x . block n e O -> block n O x -> block n e x)
-> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)
splice bcat = sp
where sp :: forall e a x .
Graph' block n e a -> Graph' block n a x -> Graph' block n e x
sp GNil g2 = g2
sp g1 GNil = g1
sp (GUnit b1) (GUnit b2) = {-# SCC "sp1" #-} GUnit $! b1 `bcat` b2
sp (GUnit b) (GMany (JustO e) bs x) = {-# SCC "sp2" #-} GMany (JustO (b `bcat` e)) bs x
sp (GMany e bs (JustO x)) (GUnit b2) = {-# SCC "sp3" #-} x `seq` GMany e bs (JustO x')
where x' = x `bcat` b2
sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)
= {-# SCC "sp4" #-} (GMany e1 $! b1 `bodyUnion` b2) x2
where b1 = (addBlock $! x1 `bcat` e2) bs1
sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)
= {-# SCC "sp5" #-} (GMany e1 $! b1 `bodyUnion` b2) x2
#if __GLASGOW_HASKELL__ < 711
sp _ _ = error "bogus GADT match failure"
#endif
gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x
gSplice = splice blockAppend
-- -----------------------------------------------------------------------------
-- Mapping over graphs
-- | Maps over all nodes in a graph.
mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
mapGraph f = mapGraphBlocks (mapBlock f)
-- | Function 'mapGraphBlocks' enables a change of representation of blocks,
-- nodes, or both. It lifts a polymorphic block transform into a polymorphic
-- graph transform. When the block representation stabilizes, a similar
-- function should be provided for blocks.
mapGraphBlocks :: forall block n block' n' e x .
(forall e x . block n e x -> block' n' e x)
-> (Graph' block n e x -> Graph' block' n' e x)
mapGraphBlocks f = map
where map :: Graph' block n e x -> Graph' block' n' e x
map GNil = GNil
map (GUnit b) = GUnit (f b)
map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
-- -----------------------------------------------------------------------------
-- Folds
-- | Fold a function over every node in a graph.
-- The fold function must be polymorphic in the shape of the nodes.
foldGraphNodes :: forall n a .
(forall e x . n e x -> a -> a)
-> (forall e x . Graph n e x -> a -> a)
foldGraphNodes f = graph
where graph :: forall e x . Graph n e x -> a -> a
lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)
graph GNil = id
graph (GUnit b) = block b
graph (GMany e b x) = lift block e . body b . lift block x
body :: Body n -> a -> a
body bdy = \a -> mapFold block a bdy
lift _ NothingO = id
lift f (JustO thing) = f thing
block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a
block = foldBlockNodesF f
----------------------------------------------------------------
class LabelsPtr l where
targetLabels :: l -> [Label]
instance NonLocal n => LabelsPtr (n e C) where
targetLabels n = successors n
instance LabelsPtr Label where
targetLabels l = [l]
instance LabelsPtr LabelSet where
targetLabels = setElems
instance LabelsPtr l => LabelsPtr [l] where
targetLabels = concatMap targetLabels
-- | Traversal: 'postorder_dfs' returns a list of blocks reachable
-- from the entry of enterable graph. The entry and exit are *not* included.
-- The list has the following property:
--
-- Say a "back reference" exists if one of a block's
-- control-flow successors precedes it in the output list
--
-- Then there are as few back references as possible
--
-- The output is suitable for use in
-- a forward dataflow problem. For a backward problem, simply reverse
-- the list. ('postorder_dfs' is sufficiently tricky to implement that
-- one doesn't want to try and maintain both forward and backward
-- versions.)
postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C]
preorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C]
-- | This is the most important traversal over this data structure. It drops
-- unreachable code and puts blocks in an order that is good for solving forward
-- dataflow problems quickly. The reverse order is good for solving backward
-- dataflow problems quickly. The forward order is also reasonably good for
-- emitting instructions, except that it will not usually exploit Forrest
-- Baskett's trick of eliminating the unconditional branch from a loop. For
-- that you would need a more serious analysis, probably based on dominators, to
-- identify loop headers.
--
-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
-- representation, when for most purposes the plain 'Graph' representation is
-- more mathematically elegant (but results in more complicated code).
--
-- Here's an easy way to go wrong! Consider
-- @
-- A -> [B,C]
-- B -> D
-- C -> D
-- @
-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
-- Better to get [A,B,C,D]
graphDfs :: (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])
-> (Graph' block n O x -> [block n C C])
graphDfs _ (GNil) = []
graphDfs _ (GUnit{}) = []
graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty
postorder_dfs = graphDfs postorder_dfs_from_except
preorder_dfs = graphDfs preorder_dfs_from_except
postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
=> LabelMap (block C C) -> e -> LabelSet -> [block C C]
postorder_dfs_from_except blocks b visited =
vchildren (get_children b) (\acc _visited -> acc) [] visited
where
vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
vnode block cont acc visited =
if setMember id visited then
cont acc visited
else
let cont' acc visited = cont (block:acc) visited in
vchildren (get_children block) cont' acc (setInsert id visited)
where id = entryLabel block
vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
vchildren bs cont acc visited = next bs acc visited
where next children acc visited =
case children of [] -> cont acc visited
(b:bs) -> vnode b (next bs) acc visited
get_children :: forall l. LabelsPtr l => l -> [block C C]
get_children block = foldr add_id [] $ targetLabels block
add_id id rst = case lookupFact id blocks of
Just b -> b : rst
Nothing -> rst
postorder_dfs_from
:: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty
----------------------------------------------------------------
data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }
instance Functor VM where
fmap = liftM
instance Applicative VM where
pure a = VM $ \visited -> (a, visited)
(<*>) = ap
instance Monad VM where
return = AP.pure
m >>= k = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
marked :: Label -> VM Bool
marked l = VM $ \v -> (setMember l v, v)
mark :: Label -> VM ()
mark l = VM $ \v -> ((), setInsert l v)
preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
=> LabelMap (block C C) -> e -> LabelSet -> [block C C]
preorder_dfs_from_except blocks b visited =
(fst $ unVM (children (get_children b)) visited) []
where children [] = return id
children (b:bs) = liftM2 (.) (visit b) (children bs)
visit :: block C C -> VM (HL (block C C))
visit b = do already <- marked (entryLabel b)
if already then return id
else do mark (entryLabel b)
bs <- children $ get_children b
return $ b `cons` bs
get_children :: forall l. LabelsPtr l => l -> [block C C]
get_children block = foldr add_id [] $ targetLabels block
add_id id rst = case lookupFact id blocks of
Just b -> b : rst
Nothing -> rst
type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)
cons :: a -> HL a -> HL a
cons a as tail = a : as tail
-- -----------------------------------------------------------------------------
-- Extracting Labels from graphs
labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
-> LabelSet
labelsDefined GNil = setEmpty
labelsDefined (GUnit{}) = setEmpty
labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet
addEntry label _ labels = setInsert label labels
exitLabel :: MaybeO x (block n C O) -> LabelSet
exitLabel NothingO = setEmpty
exitLabel (JustO b) = setSingleton (entryLabel b)
labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x
-> LabelSet
labelsUsed GNil = setEmpty
labelsUsed (GUnit{}) = setEmpty
labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body
where addTargets :: forall e. block n e C -> LabelSet -> LabelSet
addTargets block labels = setInsertList (successors block) labels
entryTargets :: MaybeO e (block n O C) -> LabelSet
entryTargets NothingO = setEmpty
entryTargets (JustO b) = addTargets b setEmpty
externalEntryLabels :: forall n .
NonLocal n => LabelMap (Block n C C) -> LabelSet
externalEntryLabels body = defined `setDifference` used
where defined = labelsDefined g
used = labelsUsed g
g = GMany NothingO body NothingO