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