compiler/cmm/MkZipCfg.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 module MkZipCfg
   3     ( AGraph, (<*>), catAGraphs
   4     , freshBlockId
   5     , emptyAGraph, withFreshLabel, withUnique
   6     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
   7     , outOfLine
   8     , emptyGraph, graphOfMiddles, graphOfZTail
   9     , lgraphOfAGraph, graphOfAGraph, labelAGraph
  10     )
  11 where
  12
  13 import BlockId (BlockId(..), emptyBlockEnv)
  14 import ZipCfg
  15
  16 import Outputable
  17 import Unique
  18 import UniqFM
  19 import UniqSupply
  20 import Util
  21
  22 import Prelude hiding (zip, unzip, last)
  23
  24 #include "HsVersions.h"
  25
  26 -------------------------------------------------------------------------
  27 --     GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH (CONSTRUCTOR VIEW)      --
  28 -------------------------------------------------------------------------
  29
  30 {-
  31
  32 You can think of an AGraph like this: it is the program built by
  33 composing in sequence three kinds of nodes:
  34   * Label nodes (e.g. L2:)
  35   * Middle nodes (e.g. x = y*3)
  36   * Last nodes (e.g. if b then goto L1 else goto L2)
  37
  38 The constructors mkLabel, mkMiddle, and mkLast build single-node
  39 AGraphs of the indicated type.  The composition operator <*> glues
  40 AGraphs together in sequence (in constant time).
  41
  42 For example:
  43        x = 0
  44   L1:
  45        x = x+1
  46        if x<10 then goto L1 else goto L2
  47   L2:
  48        y = y*x
  49        x = 0
  50
  51 Notice that the AGraph may begin without a label, and may end without
  52 a control transfer.  Control *always* falls through a label and middle
  53 node, and *never* falls through a Last node.
  54
  55 A 'AGraph m l' is simply an abstract version of a 'Graph m l' from
  56 module 'ZipCfg'.  The only difference is that the 'AGraph m l'
  57 supports a constant-time splicing operation, written infix <*>.
  58 That splicing operation, together with the constructor functions in
  59 this module (and with 'labelAGraph'), is the recommended way to build
  60 large graphs.  Each construction or splice has constant cost, and to
  61 turn an AGraph into a Graph requires time linear in the number of
  62 nodes and N log N in the number of basic blocks.
  63
  64 The splicing operation warrants careful explanation.  Like a Graph, an
  65 AGraph is a control-flow graph which begins with a distinguished,
  66 unlabelled sequence of middle nodes called the *entry*.  An unlabelled
  67 graph may also end with a sequence of middle nodes called the *exit*.
  68 The entry may fall straight through to the exit, or it may fall into
  69 the rest of the graph, which may include arbitrary control flow.
  70
  71 Using ASCII art, here are examples of the two kinds of graph.  On the
  72 left, the entry and exit sequences are labelled A and B, where the
  73 control flow in the middle is labelled X.   On the right, there is no
  74 exit sequence:
  75
  76         |                      |
  77         | A                    | C
  78         |                      |
  79        / \                    / \
  80       /   \                  /   \
  81      |  X  |                |  Y  |
  82       \   /                  \   /
  83        \ /                    \_/
  84         |
  85         | B
  86         |
  87
  88
  89 The AGraph has these properties:
  90
  91   * A AGraph is opaque; nothing about its structure can be observed.
  92
  93   * A AGraph may be turned into a LGraph in time linear in the number
  94     of nodes and O(N log N) in the number of basic blocks.
  95
  96   * Two AGraphs may be spliced in constant time by writing  g1 <*> g2
  97
  98 There are two rules for splicing, depending on whether the left-hand
  99 graph falls through.  If it does, the rule is as follows:
 100
 101         |                      |                          |
 102         | A                    | C                        | A
 103         |                      |                          |
 104        / \                    / \                        / \
 105       /   \                  /   \                      /   \
 106      |  X  |      <*>       |  Y  |           =        |  X  |
 107       \   /                  \   /                      \   /
 108        \ /                    \_/                        \ /
 109         |                      |                          |
 110         | B                    | D                        | B
 111         |                      |                          |
 112                                                           |
 113                                                           | C
 114                                                           |
 115                                                          / \
 116                                                         /   \
 117                                                        |  Y  |
 118                                                         \   /
 119                                                          \ /
 120                                                           |
 121                                                           | D
 122                                                           |
 123
 124 And in the case where the left-hand graph does not fall through, the
 125 rule is
 126
 127
 128         |                      |                          |
 129         | A                    | C                        | A
 130         |                      |                          |
 131        / \                    / \                        / \
 132       /   \                  /   \                      /   \
 133      |  X  |      <*>       |  Y  |           =        |  X  |
 134       \   /                  \   /                      \   /
 135        \_/                    \_/                        \_/
 136                                |
 137                                | D                        _
 138                                |                         / \
 139                                                         /   \
 140                                                        |  Y  |
 141                                                         \   /
 142                                                          \ /
 143                                                           |
 144                                                           | D
 145                                                           |
 146
 147 In this case C will become unreachable and is lost; when such a graph
 148 is converted into a data structure, the system will bleat about
 149 unreachable code.  Also it must be assumed that there are branches
 150 from somewhere in X to labelled blocks in Y; otherwise Y and D are
 151 unreachable as well.   (However, it may be the case that X branches
 152 into some third AGraph, which in turn branches into D; the
 153 representation is agnostic on this point.)
 154
 155 -}
 156
 157 infixr 3 <*>
 158 (<*>) :: AGraph m l -> AGraph m l -> AGraph m l
 159
 160 catAGraphs :: [AGraph m l] -> AGraph m l
 161
 162 -- | A graph is built up by splicing together graphs each containing a
 163 -- single node (where a label is considered a 'first' node.  The empty
 164 -- graph is a left and right unit for splicing.  All of the AGraph
 165 -- constructors (even complex ones like 'mkIfThenElse', as well as the
 166 -- splicing operation <*>, are constant-time operations.
 167
 168 emptyAGraph :: AGraph m l
 169 mkLabel     :: (LastNode l) =>
 170                BlockId -> Maybe Int -> AGraph m l -- graph contains the label
 171 mkMiddle    :: m -> AGraph m l   -- graph contains the node
 172 mkLast      :: (Outputable m, Outputable l, LastNode l) =>
 173                l       -> AGraph m l              -- graph contains the node
 174
 175 -- | This function provides access to fresh labels without requiring
 176 -- clients to be programmed monadically.
 177 withFreshLabel :: String -> (BlockId -> AGraph m l) -> AGraph m l
 178 withUnique     :: (Unique -> AGraph m l) -> AGraph m l
 179
 180
 181 outOfLine :: (LastNode l, Outputable m, Outputable l)
 182           => AGraph m l -> AGraph m l
 183 -- ^ The argument is an AGraph that has an
 184 -- empty entry sequence and no exit sequence.
 185 -- The result is a new AGraph that has an empty entry sequence
 186 -- connected to an empty exit sequence, with the original graph
 187 -- sitting to the side out-of-line.
 188 --
 189 -- Example:  mkMiddle (x = 3)
 190 --           <*> outOfLine (mkLabel L <*> ...stuff...)
 191 --           <*> mkMiddle (y = x)
 192 -- Control will flow directly from x=3 to y=x;
 193 -- the block starting with L is "on the side".
 194 --
 195 -- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
 196
 197
 198
 199 -- below for convenience
 200 mkMiddles :: [m] -> AGraph m l
 201 mkZTail   :: (Outputable m, Outputable l, LastNode l) =>
 202   ZTail m l -> AGraph m l
 203 mkBranch  :: (Outputable m, Outputable l, LastNode l) =>
 204   BlockId   -> AGraph m l
 205
 206 -- | For the structured control-flow constructs, a condition is
 207 -- represented as a function that takes as arguments the labels to
 208 -- goto on truth or falsehood.
 209 --
 210 --      mkIfThenElse mk_cond then else
 211 --      = (mk_cond L1 L2) <*> L1: then <*> goto J
 212 --                        <*> L2: else <*> goto J
 213 --        <*> J:
 214 --
 215 -- where L1, L2, J are fresh
 216
 217 mkIfThenElse :: (Outputable m, Outputable l, LastNode l)
 218                 => (BlockId -> BlockId -> AGraph m l) -- branch condition
 219                 -> AGraph m l   -- code in the 'then' branch
 220                 -> AGraph m l   -- code in the 'else' branch
 221                 -> AGraph m l   -- resulting if-then-else construct
 222
 223 mkWhileDo    :: (Outputable m, Outputable l, LastNode l)
 224                 => (BlockId -> BlockId -> AGraph m l) -- loop condition
 225                 -> AGraph m l  -- body of the bloop
 226                 -> AGraph m l  -- the final while loop
 227
 228 -- | Converting an abstract graph to a concrete form is expensive: the
 229 -- cost is linear in the number of nodes in the answer, plus N log N
 230 -- in the number of basic blocks.  The conversion is also monadic
 231 -- because it may require the allocation of fresh, unique labels.
 232
 233 graphOfAGraph  :: AGraph m l -> UniqSM (Graph  m l)
 234 lgraphOfAGraph :: Int -> AGraph m l -> UniqSM (LGraph m l)
 235   -- ^ allocate a fresh label for the entry point
 236 labelAGraph    :: BlockId -> Int -> AGraph m l -> UniqSM (LGraph m l)
 237   -- ^ use the given BlockId as the label of the entry point
 238
 239
 240 -- | The functions below build Graphs directly; for convenience, they
 241 -- are included here with the rest of the constructor functions.
 242
 243 emptyGraph     ::              Graph m l
 244 graphOfMiddles :: [m]       -> Graph m l
 245 graphOfZTail   :: ZTail m l -> Graph m l
 246
 247
 248 -- ================================================================
 249 --                          IMPLEMENTATION
 250 -- ================================================================
 251
 252 newtype AGraph m l = AGraph (Graph m l -> UniqSM (Graph m l))
 253   -- an AGraph is a monadic function from a successor Graph to a new Graph
 254
 255 AGraph f1 <*> AGraph f2 = AGraph f
 256     where f g = f2 g >>= f1 -- note right associativity
 257
 258 catAGraphs = foldr (<*>) emptyAGraph
 259
 260 emptyAGraph = AGraph return
 261
 262 graphOfAGraph (AGraph f) = f emptyGraph
 263 emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
 264
 265 labelAGraph id args g =
 266     do Graph tail blocks <- graphOfAGraph g
 267        return $ LGraph id args $ insertBlock (Block id Nothing tail) blocks
 268
 269 lgraphOfAGraph args g = do id <- freshBlockId "graph entry"
 270                            labelAGraph id args g
 271
 272 -------------------------------------
 273 -- constructors
 274
 275 mkLabel id args = AGraph f
 276     where f (Graph tail blocks) =
 277             return $ Graph (ZLast (mkBranchNode id))
 278                            (insertBlock (Block id args tail) blocks)
 279
 280 mkBranch target = mkLast $ mkBranchNode target
 281
 282 mkMiddle m = AGraph f
 283     where f (Graph tail blocks) = return $ Graph (ZTail m tail) blocks
 284
 285 mkMiddles ms = AGraph f
 286     where f (Graph tail blocks) = return $ Graph (foldr ZTail tail ms) blocks
 287
 288 graphOfMiddles ms = Graph (foldr ZTail (ZLast LastExit) ms) emptyBlockEnv
 289 graphOfZTail   t  = Graph t emptyBlockEnv
 290
 291
 292 mkLast l = AGraph f
 293     where f (Graph tail blocks) =
 294             do note_this_code_becomes_unreachable tail
 295                return $ Graph (ZLast (LastOther l)) blocks
 296
 297 mkZTail tail = AGraph f
 298     where f (Graph utail blocks) =
 299             do note_this_code_becomes_unreachable utail
 300                return $ Graph tail blocks
 301
 302 withFreshLabel name ofId = AGraph f
 303   where f g = do id <- freshBlockId name
 304                  let AGraph f' = ofId id
 305                  f' g
 306
 307 withUnique ofU = AGraph f
 308   where f g = do u <- getUniqueM
 309                  let AGraph f' = ofU u
 310                  f' g
 311
 312 outOfLine (AGraph f) = AGraph f'
 313     where f' (Graph tail' blocks') =
 314             do Graph emptyEntrance blocks <- f emptyGraph
 315                note_this_code_becomes_unreachable emptyEntrance
 316                return $ Graph tail' (blocks `plusUFM` blocks')
 317
 318 mkIfThenElse cbranch tbranch fbranch =
 319     withFreshLabel "end of if"     $ \endif ->
 320     withFreshLabel "start of then" $ \tid ->
 321     withFreshLabel "start of else" $ \fid ->
 322         cbranch tid fid <*>
 323         mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*>
 324         mkLabel fid Nothing <*> fbranch <*> mkLabel endif Nothing
 325
 326 mkWhileDo cbranch body =
 327   withFreshLabel "loop test" $ \test ->
 328   withFreshLabel "loop head" $ \head ->
 329   withFreshLabel "end while" $ \endwhile ->
 330      -- Forrest Baskett's while-loop layout
 331      mkBranch test <*> mkLabel head Nothing <*> body <*> mkLabel test Nothing
 332                    <*> cbranch head endwhile <*> mkLabel endwhile Nothing
 333
 334 -- | Bleat if the insertion of a last node will create unreachable code
 335 note_this_code_becomes_unreachable ::
 336     (Monad m, LastNode l, Outputable middle, Outputable l) => ZTail middle l -> m ()
 337
 338 note_this_code_becomes_unreachable = if debugIsOn then u else \_ -> return ()
 339     where u (ZLast LastExit)                       = return ()
 340           u (ZLast (LastOther l)) | isBranchNode l = return ()
 341                                     -- Note [Branch follows branch]
 342           u tail = fail ("unreachable code: " ++ showSDoc (ppr tail))
 343
 344 {-
 345 Note [Branch follows branch]
 346 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 347 Why do we say it's ok for a Branch to follow a Branch?
 348 Because the standard constructor mkLabel-- has fall-through
 349 semantics. So if you do a mkLabel, you finish the current block,
 350 giving it a label, and start a new one that branches to that label.
 351 Emitting a Branch at this point is fine:
 352        goto L1; L2: ...stuff...
 353 -}
 354
 355
 356 -- | The string argument to 'freshBlockId' was originally helpful in debugging
 357 -- the Quick C-- compiler, so I have kept it here even though at present it is
 358 -- thrown away at this spot---there's no reason a BlockId couldn't one day carry
 359 -- a string.
 360
 361 freshBlockId :: MonadUnique m => String -> m BlockId
 362 freshBlockId _s = getUniqueM >>= return . BlockId
 363