module Hoopl.Graph
( Body
, Graph
, Graph'(..)
, NonLocal(..)
, addBlock
, bodyList
, emptyBody
, labelsDefined
, mapGraph
, mapGraphBlocks
, postorder_dfs_from
) where
import GhcPrelude
import Hoopl.Label
import Hoopl.Block
import Hoopl.Collections
type Body n = LabelMap (Block n C C)
type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
class NonLocal thing where
entryLabel :: thing C x -> Label
successors :: thing e C -> [Label]
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
emptyBody :: Body' block n
emptyBody = mapEmpty
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
type Graph = Graph' Block
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
mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
mapGraph f = mapGraphBlocks (mapBlock f)
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)
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)
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
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