compiler/cmm/MkZipCfg.hs

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