src/Compiler/Hoopl/Util.hs

   1 {-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes #-}
   2
   3 module Compiler.Hoopl.Util
   4   ( gUnitOO, gUnitOC, gUnitCO, gUnitCC
   5   , catGraphNodeOC, catGraphNodeOO
   6   , catNodeCOGraph, catNodeOOGraph
   7   , graphMapBlocks
   8   , blockGraph
   9   , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
  10   , preorder_dfs, preorder_dfs_from_except
  11   , labelsDefined, labelsUsed, externalEntryLabels
  12   , LabelsPtr(..)
  13   )
  14 where
  15
  16 import Control.Monad
  17
  18 import Compiler.Hoopl.Collections
  19 import Compiler.Hoopl.Graph
  20 import Compiler.Hoopl.Label
  21
  22
  23 ----------------------------------------------------------------
  24
  25 gUnitOO :: block n O O -> Graph' block n O O
  26 gUnitOC :: block n O C -> Graph' block n O C
  27 gUnitCO :: block n C O -> Graph' block n C O
  28 gUnitCC :: Edges (block n) => block n C C -> Graph' block n C C
  29 gUnitOO b = GUnit b
  30 gUnitOC b = GMany (JustO b) emptyBody  NothingO
  31 gUnitCO b = GMany NothingO  emptyBody (JustO b)
  32 gUnitCC b = GMany NothingO  (addBlock b $ emptyBody) NothingO
  33
  34
  35 catGraphNodeOO ::            Graph n e O -> n O O -> Graph n e O
  36 catGraphNodeOC :: Edges n => Graph n e O -> n O C -> Graph n e C
  37 catNodeOOGraph ::            n O O -> Graph n O x -> Graph n O x
  38 catNodeCOGraph :: Edges n => n C O -> Graph n O x -> Graph n C x
  39
  40 catGraphNodeOO GNil                     n = gUnitOO $ BMiddle n
  41 catGraphNodeOO (GUnit b)                n = gUnitOO $ b `BCat` BMiddle n
  42 catGraphNodeOO (GMany e body (JustO x)) n = GMany e body (JustO $ x `BHead` n)
  43
  44 catGraphNodeOC GNil                     n = gUnitOC $ BLast n
  45 catGraphNodeOC (GUnit b)                n = gUnitOC $ addToLeft b $ BLast n
  46   where addToLeft :: Block n O O -> Block n O C -> Block n O C
  47         addToLeft (BMiddle m)    g = m `BTail` g
  48         addToLeft (b1 `BCat` b2) g = addToLeft b1 $ addToLeft b2 g
  49 catGraphNodeOC (GMany e body (JustO x)) n = GMany e body' NothingO
  50   where body' = addBlock (x `BClosed` BLast n) body
  51
  52 catNodeOOGraph n GNil                     = gUnitOO $ BMiddle n
  53 catNodeOOGraph n (GUnit b)                = gUnitOO $ BMiddle n `BCat` b
  54 catNodeOOGraph n (GMany (JustO e) body x) = GMany (JustO $ n `BTail` e) body x
  55
  56 catNodeCOGraph n GNil                     = gUnitCO $ BFirst n
  57 catNodeCOGraph n (GUnit b)                = gUnitCO $ addToRight (BFirst n) b
  58   where addToRight :: Block n C O -> Block n O O -> Block n C O
  59         addToRight g (BMiddle m)    = g `BHead` m
  60         addToRight g (b1 `BCat` b2) = addToRight (addToRight g b1) b2
  61 catNodeCOGraph n (GMany (JustO e) body x) = GMany NothingO body' x
  62   where body' = addBlock (BFirst n `BClosed` e) body
  63
  64
  65
  66
  67
  68 blockGraph :: Edges n => Block n e x -> Graph n e x
  69 blockGraph b@(BFirst  {}) = gUnitCO b
  70 blockGraph b@(BMiddle {}) = gUnitOO b
  71 blockGraph b@(BLast   {}) = gUnitOC b
  72 blockGraph b@(BCat {})    = gUnitOO b
  73 blockGraph b@(BHead {})   = gUnitCO b
  74 blockGraph b@(BTail {})   = gUnitOC b
  75 blockGraph b@(BClosed {}) = gUnitCC b
  76
  77
  78 -- | Function 'graphMapBlocks' enables a change of representation of blocks,
  79 -- nodes, or both.  It lifts a polymorphic block transform into a polymorphic
  80 -- graph transform.  When the block representation stabilizes, a similar
  81 -- function should be provided for blocks.
  82 graphMapBlocks :: forall block n block' n' e x .
  83                   (forall e x . block n e x -> block' n' e x)
  84                -> (Graph' block n e x -> Graph' block' n' e x)
  85 bodyMapBlocks  :: forall block n block' n' .
  86                   (block n C C -> block' n' C C)
  87                -> (Body' block n -> Body' block' n')
  88
  89 graphMapBlocks f = map
  90   where map :: Graph' block n e x -> Graph' block' n' e x
  91         map GNil = GNil
  92         map (GUnit b) = GUnit (f b)
  93         map (GMany e b x) = GMany (fmap f e) (bodyMapBlocks f b) (fmap f x)
  94
  95 bodyMapBlocks f (Body body) = Body $ mapMap f body
  96
  97
  98 ----------------------------------------------------------------
  99
 100 class LabelsPtr l where
 101   targetLabels :: l -> [Label]
 102
 103 instance Edges n => LabelsPtr (n e C) where
 104   targetLabels n = successors n
 105
 106 instance LabelsPtr Label where
 107   targetLabels l = [l]
 108
 109 instance LabelsPtr LabelSet where
 110   targetLabels = elemsSet
 111
 112 instance LabelsPtr l => LabelsPtr [l] where
 113   targetLabels = concatMap targetLabels
 114
 115
 116 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
 117 -- from the entry of enterable graph. The entry and exit are *not* included.
 118 -- The list has the following property:
 119 --
 120 --      Say a "back reference" exists if one of a block's
 121 --      control-flow successors precedes it in the output list
 122 --
 123 --      Then there are as few back references as possible
 124 --
 125 -- The output is suitable for use in
 126 -- a forward dataflow problem.  For a backward problem, simply reverse
 127 -- the list.  ('postorder_dfs' is sufficiently tricky to implement that
 128 -- one doesn't want to try and maintain both forward and backward
 129 -- versions.)
 130
 131 postorder_dfs :: Edges (block n) => Graph' block n O x -> [block n C C]
 132 preorder_dfs  :: Edges (block n) => Graph' block n O x -> [block n C C]
 133
 134 -- | This is the most important traversal over this data structure.  It drops
 135 -- unreachable code and puts blocks in an order that is good for solving forward
 136 -- dataflow problems quickly.  The reverse order is good for solving backward
 137 -- dataflow problems quickly.  The forward order is also reasonably good for
 138 -- emitting instructions, except that it will not usually exploit Forrest
 139 -- Baskett's trick of eliminating the unconditional branch from a loop.  For
 140 -- that you would need a more serious analysis, probably based on dominators, to
 141 -- identify loop headers.
 142 --
 143 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
 144 -- representation, when for most purposes the plain 'Graph' representation is
 145 -- more mathematically elegant (but results in more complicated code).
 146 --
 147 -- Here's an easy way to go wrong!  Consider
 148 -- @
 149 --      A -> [B,C]
 150 --      B -> D
 151 --      C -> D
 152 -- @
 153 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
 154 -- Better to get [A,B,C,D]
 155
 156
 157 graphDfs :: (Edges (block n))
 158          => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])
 159          -> (Graph' block n O x -> [block n C C])
 160 graphDfs _     (GNil)    = []
 161 graphDfs _     (GUnit{}) = []
 162 graphDfs order (GMany (JustO entry) (Body body) _) = order body entry emptySet
 163
 164 postorder_dfs = graphDfs postorder_dfs_from_except
 165 preorder_dfs  = graphDfs preorder_dfs_from_except
 166
 167 postorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)
 168                           => LabelMap (block C C) -> e -> LabelSet -> [block C C]
 169 postorder_dfs_from_except blocks b visited =
 170  vchildren (get_children b) (\acc _visited -> acc) [] visited
 171  where
 172    vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
 173    vnode block cont acc visited =
 174         if memberSet id visited then
 175             cont acc visited
 176         else
 177             let cont' acc visited = cont (block:acc) visited in
 178             vchildren (get_children block) cont' acc (insertSet id visited)
 179       where id = entryLabel block
 180    vchildren bs cont acc visited = next bs acc visited
 181       where next children acc visited =
 182                 case children of []     -> cont acc visited
 183                                  (b:bs) -> vnode b (next bs) acc visited
 184    get_children block = foldr add_id [] $ targetLabels block
 185    add_id id rst = case lookupFact id blocks of
 186                       Just b -> b : rst
 187                       Nothing -> rst
 188
 189 postorder_dfs_from
 190     :: (Edges block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
 191 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptySet
 192
 193
 194 ----------------------------------------------------------------
 195
 196 data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }
 197 marked :: Label -> VM Bool
 198 mark   :: Label -> VM ()
 199 instance Monad VM where
 200   return a = VM $ \visited -> (a, visited)
 201   m >>= k  = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
 202 marked l = VM $ \v -> (memberSet l v, v)
 203 mark   l = VM $ \v -> ((), insertSet l v)
 204
 205 preorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)
 206                          => LabelMap (block C C) -> e -> LabelSet -> [block C C]
 207 preorder_dfs_from_except blocks b visited =
 208     (fst $ unVM (children (get_children b)) visited) []
 209   where children [] = return id
 210         children (b:bs) = liftM2 (.) (visit b) (children bs)
 211         visit :: block C C -> VM (HL (block C C))
 212         visit b = do already <- marked (entryLabel b)
 213                      if already then return id
 214                       else do mark (entryLabel b)
 215                               bs <- children $ get_children b
 216                               return $ b `cons` bs
 217         get_children block = foldr add_id [] $ targetLabels block
 218         add_id id rst = case lookupFact id blocks of
 219                           Just b -> b : rst
 220                           Nothing -> rst
 221
 222 type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)
 223 cons :: a -> HL a -> HL a
 224 cons a as tail = a : as tail
 225
 226 ----------------------------------------------------------------
 227
 228 labelsDefined :: forall block n e x . Edges (block n) => Graph' block n e x -> LabelSet
 229 labelsDefined GNil      = emptySet
 230 labelsDefined (GUnit{}) = emptySet
 231 labelsDefined (GMany _ body x) = foldBodyBlocks addEntry body $ exitLabel x
 232   where addEntry block labels = insertSet (entryLabel block) labels
 233         exitLabel :: MaybeO x (block n C O) -> LabelSet
 234         exitLabel NothingO = emptySet
 235         exitLabel (JustO b) = fromListSet [entryLabel b]
 236
 237 labelsUsed :: forall block n e x. Edges (block n) => Graph' block n e x -> LabelSet
 238 labelsUsed GNil      = emptySet
 239 labelsUsed (GUnit{}) = emptySet
 240 labelsUsed (GMany e body _) = foldBodyBlocks addTargets body $ entryTargets e
 241   where addTargets block labels = insertListSet (successors block) labels
 242         entryTargets :: MaybeO e (block n O C) -> LabelSet
 243         entryTargets NothingO = emptySet
 244         entryTargets (JustO b) = addTargets b emptySet
 245
 246 foldBodyBlocks :: (block n C C -> a -> a) -> Body' block n -> a -> a
 247 foldBodyBlocks f (Body body) z = foldMap f z body
 248
 249 externalEntryLabels :: Edges (block n) => Body' block n -> LabelSet
 250 externalEntryLabels body = defined `differenceSet` used
 251   where defined = labelsDefined g
 252         used = labelsUsed g
 253         g = GMany NothingO body NothingO