compiler/cmm/CmmProcPoint.hs

   1 {-# LANGUAGE GADTs, DisambiguateRecordFields #-}
   2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
   3
   4 module CmmProcPoint
   5     ( ProcPointSet, Status(..)
   6     , callProcPoints, minimalProcPointSet
   7     , addProcPointProtocols, splitAtProcPoints, procPointAnalysis
   8     )
   9 where
  10
  11 import Prelude hiding (last, unzip, succ, zip)
  12
  13 import BlockId
  14 import CLabel
  15 import Cmm
  16 import CmmDecl
  17 import CmmExpr
  18 import CmmContFlowOpt
  19 import CmmInfo
  20 import CmmLive
  21 import Constants
  22 import Data.List (sortBy)
  23 import Maybes
  24 import MkGraph
  25 import Control.Monad
  26 import OptimizationFuel
  27 import Outputable
  28 import UniqSet
  29 import UniqSupply
  30
  31 import Compiler.Hoopl
  32
  33 import qualified Data.Map as Map
  34
  35 -- Compute a minimal set of proc points for a control-flow graph.
  36
  37 -- Determine a protocol for each proc point (which live variables will
  38 -- be passed as arguments and which will be on the stack).
  39
  40 {-
  41 A proc point is a basic block that, after CPS transformation, will
  42 start a new function.  The entry block of the original function is a
  43 proc point, as is the continuation of each function call.
  44 A third kind of proc point arises if we want to avoid copying code.
  45 Suppose we have code like the following:
  46
  47   f() {
  48     if (...) { ..1..; call foo(); ..2..}
  49     else     { ..3..; call bar(); ..4..}
  50     x = y + z;
  51     return x;
  52   }
  53
  54 The statement 'x = y + z' can be reached from two different proc
  55 points: the continuations of foo() and bar().  We would prefer not to
  56 put a copy in each continuation; instead we would like 'x = y + z' to
  57 be the start of a new procedure to which the continuations can jump:
  58
  59   f_cps () {
  60     if (...) { ..1..; push k_foo; jump foo_cps(); }
  61     else     { ..3..; push k_bar; jump bar_cps(); }
  62   }
  63   k_foo() { ..2..; jump k_join(y, z); }
  64   k_bar() { ..4..; jump k_join(y, z); }
  65   k_join(y, z) { x = y + z; return x; }
  66
  67 You might think then that a criterion to make a node a proc point is
  68 that it is directly reached by two distinct proc points.  (Note
  69 [Direct reachability].)  But this criterion is a bit too simple; for
  70 example, 'return x' is also reached by two proc points, yet there is
  71 no point in pulling it out of k_join.  A good criterion would be to
  72 say that a node should be made a proc point if it is reached by a set
  73 of proc points that is different than its immediate dominator.  NR
  74 believes this criterion can be shown to produce a minimum set of proc
  75 points, and given a dominator tree, the proc points can be chosen in
  76 time linear in the number of blocks.  Lacking a dominator analysis,
  77 however, we turn instead to an iterative solution, starting with no
  78 proc points and adding them according to these rules:
  79
  80   1. The entry block is a proc point.
  81   2. The continuation of a call is a proc point.
  82   3. A node is a proc point if it is directly reached by more proc
  83      points than one of its predecessors.
  84
  85 Because we don't understand the problem very well, we apply rule 3 at
  86 most once per iteration, then recompute the reachability information.
  87 (See Note [No simple dataflow].)  The choice of the new proc point is
  88 arbitrary, and I don't know if the choice affects the final solution,
  89 so I don't know if the number of proc points chosen is the
  90 minimum---but the set will be minimal.
  91 -}
  92
  93 type ProcPointSet = BlockSet
  94
  95 data Status
  96   = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
  97   | ProcPoint               -- this block is itself a proc point
  98
  99 instance Outputable Status where
 100   ppr (ReachedBy ps)
 101       | setNull ps = text "<not-reached>"
 102       | otherwise = text "reached by" <+>
 103                     (hsep $ punctuate comma $ map ppr $ setElems ps)
 104   ppr ProcPoint = text "<procpt>"
 105
 106 lattice :: DataflowLattice Status
 107 lattice = DataflowLattice "direct proc-point reachability" unreached add_to
 108     where unreached = ReachedBy setEmpty
 109           add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
 110           add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint) -- because of previous case
 111           add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) =
 112               let union = setUnion p' p
 113               in  if setSize union > setSize p then (SomeChange, ReachedBy union)
 114                                                else (NoChange, ReachedBy p)
 115 --------------------------------------------------
 116 -- transfer equations
 117
 118 forward :: FwdTransfer CmmNode Status
 119 forward = mkFTransfer3 first middle ((mkFactBase lattice . ) . last)
 120     where first :: CmmNode C O -> Status -> Status
 121           first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
 122           first  _ x = x
 123
 124           middle _ x = x
 125
 126           last :: CmmNode O C -> Status -> [(Label, Status)]
 127           last (CmmCall {cml_cont = Just k}) _ = [(k, ProcPoint)]
 128           last (CmmForeignCall {succ = k})   _ = [(k, ProcPoint)]
 129           last l x = map (\id -> (id, x)) (successors l)
 130
 131 -- It is worth distinguishing two sets of proc points:
 132 -- those that are induced by calls in the original graph
 133 -- and those that are introduced because they're reachable from multiple proc points.
 134 callProcPoints      :: CmmGraph -> ProcPointSet
 135 callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
 136   where add :: CmmBlock -> BlockSet -> BlockSet
 137         add b set = case lastNode b of
 138                       CmmCall {cml_cont = Just k} -> setInsert k set
 139                       CmmForeignCall {succ=k}     -> setInsert k set
 140                       _ -> set
 141
 142 minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
 143 -- Given the set of successors of calls (which must be proc-points)
 144 -- figure out the minimal set of necessary proc-points
 145 minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints
 146
 147 procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
 148 -- Once you know what the proc-points are, figure out
 149 -- what proc-points each block is reachable from
 150 procPointAnalysis procPoints g =
 151   liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward
 152   where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
 153
 154 extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
 155 extendPPSet g blocks procPoints =
 156     do env <- procPointAnalysis procPoints g
 157        let add block pps = let id = entryLabel block
 158                            in  case mapLookup id env of
 159                                  Just ProcPoint -> setInsert id pps
 160                                  _ -> pps
 161            procPoints' = foldGraphBlocks add setEmpty g
 162            newPoints = mapMaybe ppSuccessor blocks
 163            newPoint  = listToMaybe newPoints
 164            ppSuccessor b =
 165                let nreached id = case mapLookup id env `orElse`
 166                                        pprPanic "no ppt" (ppr id <+> ppr b) of
 167                                    ProcPoint -> 1
 168                                    ReachedBy ps -> setSize ps
 169                    block_procpoints = nreached (entryLabel b)
 170                    -- | Looking for a successor of b that is reached by
 171                    -- more proc points than b and is not already a proc
 172                    -- point.  If found, it can become a proc point.
 173                    newId succ_id = not (setMember succ_id procPoints') &&
 174                                    nreached succ_id > block_procpoints
 175                in  listToMaybe $ filter newId $ successors b
 176 {-
 177        case newPoints of
 178            []  -> return procPoints'
 179            pps -> extendPPSet g blocks
 180                     (foldl extendBlockSet procPoints' pps)
 181 -}
 182        case newPoint of Just id ->
 183                           if setMember id procPoints' then panic "added old proc pt"
 184                           else extendPPSet g blocks (setInsert id procPoints')
 185                         Nothing -> return procPoints'
 186
 187
 188 ------------------------------------------------------------------------
 189 --                    Computing Proc-Point Protocols                  --
 190 ------------------------------------------------------------------------
 191
 192 {-
 193
 194 There is one major trick, discovered by Michael Adams, which is that
 195 we want to choose protocols in a way that enables us to optimize away
 196 some continuations.  The optimization is very much like branch-chain
 197 elimination, except that it involves passing results as well as
 198 control.  The idea is that if a call's continuation k does nothing but
 199 CopyIn its results and then goto proc point P, the call's continuation
 200 may be changed to P, *provided* P's protocol is identical to the
 201 protocol for the CopyIn.  We choose protocols to make this so.
 202
 203 Here's an explanatory example; we begin with the source code (lines
 204 separate basic blocks):
 205
 206   ..1..;
 207   x, y = g();
 208   goto P;
 209   -------
 210   P: ..2..;
 211
 212 Zipperization converts this code as follows:
 213
 214   ..1..;
 215   call g() returns to k;
 216   -------
 217   k: CopyIn(x, y);
 218      goto P;
 219   -------
 220   P: ..2..;
 221
 222 What we'd like to do is assign P the same CopyIn protocol as k, so we
 223 can eliminate k:
 224
 225   ..1..;
 226   call g() returns to P;
 227   -------
 228   P: CopyIn(x, y); ..2..;
 229
 230 Of course, P may be the target of more than one continuation, and
 231 different continuations may have different protocols.  Michael Adams
 232 implemented a voting mechanism, but he thinks a simple greedy
 233 algorithm would be just as good, so that's what we do.
 234
 235 -}
 236
 237 data Protocol = Protocol Convention CmmFormals Area
 238   deriving Eq
 239 instance Outputable Protocol where
 240   ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
 241
 242 -- | Function 'optimize_calls' chooses protocols only for those proc
 243 -- points that are relevant to the optimization explained above.
 244 -- The others are assigned by 'add_unassigned', which is not yet clever.
 245
 246 addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelUniqSM CmmGraph
 247 addProcPointProtocols callPPs procPoints g =
 248   do liveness <- cmmLiveness g
 249      (protos, g') <- optimize_calls liveness g
 250      blocks'' <- add_CopyOuts protos procPoints g'
 251      return $ ofBlockMap (g_entry g) blocks''
 252     where optimize_calls liveness g =  -- see Note [Separate Adams optimization]
 253             do let (protos, blocks') =
 254                        foldGraphBlocks maybe_add_call (mapEmpty, mapEmpty) g
 255                    protos' = add_unassigned liveness procPoints protos
 256                let g' = ofBlockMap (g_entry g) (add_CopyIns callPPs protos' blocks')
 257                return (protos', removeUnreachableBlocks g')
 258           maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
 259                          -> (BlockEnv Protocol, BlockEnv CmmBlock)
 260           -- ^ If the block is a call whose continuation goes to a proc point
 261           -- whose protocol either matches the continuation's or is not yet set,
 262           -- redirect the call (cf 'newblock') and set the protocol if necessary
 263           maybe_add_call block (protos, blocks) =
 264               case lastNode block of
 265                 CmmCall tgt (Just k) args res s
 266                     | Just proto <- mapLookup k protos,
 267                       Just pee   <- branchesToProcPoint k
 268                     -> let newblock = replaceLastNode block (CmmCall tgt (Just pee)
 269                                                                      args res s)
 270                            changed_blocks   = insertBlock newblock blocks
 271                            unchanged_blocks = insertBlock block    blocks
 272                        in case mapLookup pee protos of
 273                             Nothing -> (mapInsert pee proto protos, changed_blocks)
 274                             Just proto' ->
 275                               if proto == proto' then (protos, changed_blocks)
 276                               else (protos, unchanged_blocks)
 277                 _ -> (protos, insertBlock block blocks)
 278
 279           branchesToProcPoint :: BlockId -> Maybe BlockId
 280           -- ^ Tells whether the named block is just a branch to a proc point
 281           branchesToProcPoint id =
 282               let block = mapLookup id (toBlockMap g) `orElse`
 283                                     panic "branch out of graph"
 284               in case blockToNodeList block of
 285 -- MS: There is an ugly bug in ghc-6.10, which rejects following valid code.
 286 -- After trying several tricks, the NOINLINE on getItOut worked. Uffff.
 287 #if __GLASGOW_HASKELL__ >= 612
 288                    (_, [], JustC (CmmBranch pee)) | setMember pee procPoints -> Just pee
 289                    _                                                         -> Nothing
 290 #else
 291                    (_, [], exit) | CmmBranch pee <- getItOut exit
 292                                  , setMember pee procPoints      -> Just pee
 293                    _                                             -> Nothing
 294               where {-# NOINLINE getItOut #-}
 295                     getItOut :: MaybeC C a -> a
 296                     getItOut (JustC a) = a
 297 #endif
 298
 299 -- | For now, following a suggestion by Ben Lippmeier, we pass all
 300 -- live variables as arguments, hoping that a clever register
 301 -- allocator might help.
 302
 303 add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol ->
 304                   BlockEnv Protocol
 305 add_unassigned = pass_live_vars_as_args
 306
 307 pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet ->
 308                           BlockEnv Protocol -> BlockEnv Protocol
 309 pass_live_vars_as_args _liveness procPoints protos = protos'
 310   where protos' = setFold addLiveVars protos procPoints
 311         addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
 312         addLiveVars id protos =
 313             case mapLookup id protos of
 314               Just _  -> protos
 315               Nothing -> let live = emptyRegSet
 316                                     --lookupBlockEnv _liveness id `orElse`
 317                                     --panic ("no liveness at block " ++ show id)
 318                              formals = uniqSetToList live
 319                              prot = Protocol Private formals $ CallArea $ Young id
 320                          in  mapInsert id prot protos
 321
 322
 323 -- | Add copy-in instructions to each proc point that did not arise from a call
 324 -- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
 325
 326 add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock
 327 add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks
 328     where maybe_insert_CopyIns block blocks
 329              | not $ setMember bid callPPs
 330              , Just (Protocol c fs _area) <- mapLookup bid protos
 331              = let nodes     = copyInSlot c fs
 332                    (h, m, l) = blockToNodeList block
 333                in insertBlock (blockOfNodeList (h, nodes ++ m, l)) blocks
 334              | otherwise = insertBlock block blocks
 335            where bid = entryLabel block
 336
 337
 338 -- | Add a CopyOut node before each procpoint.
 339 -- If the predecessor is a call, then the copy outs should already be done by the callee.
 340 -- Note: If we need to add copy-out instructions, they may require stack space,
 341 -- so we accumulate a map from the successors to the necessary stack space,
 342 -- then update the successors after we have finished inserting the copy-outs.
 343
 344 add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
 345                 FuelUniqSM (BlockEnv CmmBlock)
 346 add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) g
 347     where mb_copy_out :: CmmBlock -> FuelUniqSM (BlockEnv CmmBlock) ->
 348                                      FuelUniqSM (BlockEnv CmmBlock)
 349           mb_copy_out b z | entryLabel b == g_entry g = skip b z
 350           mb_copy_out b z =
 351             case lastNode b of
 352               CmmCall {}        -> skip b z -- copy out done by callee
 353               CmmForeignCall {} -> skip b z -- copy out done by callee
 354               _ -> copy_out b z
 355           copy_out b z = foldr trySucc init (successors b) >>= finish
 356             where init = (\bmap -> (b, bmap)) `liftM` z
 357                   trySucc succId z =
 358                     if setMember succId procPoints then
 359                       case mapLookup succId protos of
 360                         Nothing -> z
 361                         Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
 362                     else z
 363                   insert z succId m =
 364                     do (b, bmap) <- z
 365                        (b, bs)   <- insertBetween b m succId
 366                        -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
 367                        return $ (b, foldl (flip insertBlock) bmap bs)
 368                   finish (b, bmap) = return $ insertBlock b bmap
 369           skip b bs = insertBlock b `liftM` bs
 370
 371 -- At this point, we have found a set of procpoints, each of which should be
 372 -- the entry point of a procedure.
 373 -- Now, we create the procedure for each proc point,
 374 -- which requires that we:
 375 -- 1. build a map from proc points to the blocks reachable from the proc point
 376 -- 2. turn each branch to a proc point into a jump
 377 -- 3. turn calls and returns into jumps
 378 -- 4. build info tables for the procedures -- and update the info table for
 379 --    the SRTs in the entry procedure as well.
 380 -- Input invariant: A block should only be reachable from a single ProcPoint.
 381 -- ToDo: use the _ret naming convention that the old code generator
 382 -- used. -- EZY
 383 splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
 384                      CmmTop -> FuelUniqSM [CmmTop]
 385 splitAtProcPoints entry_label callPPs procPoints procMap
 386                   (CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
 387                            top_l g@(CmmGraph {g_entry=entry})) =
 388   do -- Build a map from procpoints to the blocks they reach
 389      let addBlock b graphEnv =
 390            case mapLookup bid procMap of
 391              Just ProcPoint -> add graphEnv bid bid b
 392              Just (ReachedBy set) ->
 393                case setElems set of
 394                  []   -> graphEnv
 395                  [id] -> add graphEnv id bid b
 396                  _    -> panic "Each block should be reachable from only one ProcPoint"
 397              Nothing -> pprPanic "block not reached by a proc point?" (ppr bid)
 398            where bid = entryLabel b
 399          add graphEnv procId bid b = mapInsert procId graph' graphEnv
 400                where graph  = mapLookup procId graphEnv `orElse` mapEmpty
 401                      graph' = mapInsert bid b graph
 402      graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g
 403      -- Build a map from proc point BlockId to labels for their new procedures
 404      -- Due to common blockification, we may overestimate the set of procpoints.
 405      let add_label map pp = return $ Map.insert pp lbl map
 406            where lbl = if pp == entry then entry_label else blockLbl pp
 407      procLabels <- foldM add_label Map.empty
 408                          (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
 409      -- For each procpoint, we need to know the SP offset on entry.
 410      -- If the procpoint is:
 411      --  - continuation of a call, the SP offset is in the call
 412      --  - otherwise, 0 (and left out of the spEntryMap)
 413      let add_sp_off :: CmmBlock -> BlockEnv CmmStackInfo -> BlockEnv CmmStackInfo
 414          add_sp_off b env =
 415            case lastNode b of
 416              CmmCall {cml_cont = Just succ, cml_ret_args = off, cml_ret_off = updfr_off} ->
 417                mapInsert succ (StackInfo { arg_space = off, updfr_space = Just updfr_off}) env
 418              CmmForeignCall {succ = succ, updfr = updfr_off} ->
 419                mapInsert succ (StackInfo { arg_space = wORD_SIZE, updfr_space = Just updfr_off}) env
 420              _ -> env
 421          spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry stack_info emptyBlockMap) g
 422          getStackInfo id = mapLookup id spEntryMap `orElse` StackInfo {arg_space = 0, updfr_space = Nothing}
 423      -- In each new graph, add blocks jumping off to the new procedures,
 424      -- and replace branches to procpoints with branches to the jump-off blocks
 425      let add_jump_block (env, bs) (pp, l) =
 426            do bid <- liftM mkBlockId getUniqueM
 427               let b = blockOfNodeList (JustC (CmmEntry bid), [], JustC jump)
 428                   StackInfo {arg_space = argSpace, updfr_space = off} = getStackInfo pp
 429                   jump = CmmCall (CmmLit (CmmLabel l')) Nothing argSpace 0
 430                                  (off `orElse` 0) -- Jump's shouldn't need the offset...
 431                   l' = if setMember pp callPPs then entryLblToInfoLbl l else l
 432               return (mapInsert pp bid env, b : bs)
 433          add_jumps (newGraphEnv) (ppId, blockEnv) =
 434            do let needed_jumps = -- find which procpoints we currently branch to
 435                     mapFold add_if_branch_to_pp [] blockEnv
 436                   add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
 437                   add_if_branch_to_pp block rst =
 438                     case lastNode block of
 439                       CmmBranch id          -> add_if_pp id rst
 440                       CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
 441                       CmmSwitch _ tbl       -> foldr add_if_pp rst (catMaybes tbl)
 442                       _                     -> rst
 443                   add_if_pp id rst = case Map.lookup id procLabels of
 444                                        Just x -> (id, x) : rst
 445                                        Nothing -> rst
 446               (jumpEnv, jumpBlocks) <-
 447                  foldM add_jump_block (mapEmpty, []) needed_jumps
 448                   -- update the entry block
 449               let b = expectJust "block in env" $ mapLookup ppId blockEnv
 450                   off = getStackInfo ppId
 451                   blockEnv' = mapInsert ppId b blockEnv
 452                   -- replace branches to procpoints with branches to jumps
 453                   blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
 454                   -- add the jump blocks to the graph
 455                   blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
 456               let g' = (off, ofBlockMap ppId blockEnv''')
 457               -- pprTrace "g' pre jumps" (ppr g') $ do
 458               return (mapInsert ppId g' newGraphEnv)
 459      graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
 460      let to_proc (bid, (stack_info, g)) | setMember bid callPPs =
 461            if bid == entry then
 462              CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
 463                      top_l (replacePPIds g)
 464            else
 465              CmmProc (TopInfo {info_tbl=emptyContInfoTable, stack_info=stack_info})
 466                      lbl (replacePPIds g)
 467            where lbl = expectJust "pp label" $ Map.lookup bid procLabels
 468          to_proc (bid, (stack_info, g)) =
 469            CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info})
 470                    lbl (replacePPIds g)
 471              where lbl = expectJust "pp label" $ Map.lookup bid procLabels
 472          -- References to procpoint IDs can now be replaced with the infotable's label
 473          replacePPIds g = mapGraphNodes (id, mapExp repl, mapExp repl) g
 474            where repl e@(CmmLit (CmmBlock bid)) =
 475                    case Map.lookup bid procLabels of
 476                      Just l  -> CmmLit (CmmLabel (entryLblToInfoLbl l))
 477                      Nothing -> e
 478                  repl e = e
 479      -- The C back end expects to see return continuations before the call sites.
 480      -- Here, we sort them in reverse order -- it gets reversed later.
 481      let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g)
 482          add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
 483          sort_fn (bid, _) (bid', _) =
 484            compare (expectJust "block_order" $ mapLookup bid  block_order)
 485                    (expectJust "block_order" $ mapLookup bid' block_order)
 486      procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
 487      return -- pprTrace "procLabels" (ppr procLabels)
 488             -- pprTrace "splitting graphs" (ppr procs)
 489             procs
 490 splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
 491
 492 ----------------------------------------------------------------
 493
 494 {-
 495 Note [Direct reachability]
 496
 497 Block B is directly reachable from proc point P iff control can flow
 498 from P to B without passing through an intervening proc point.
 499 -}
 500
 501 ----------------------------------------------------------------
 502
 503 {-
 504 Note [No simple dataflow]
 505
 506 Sadly, it seems impossible to compute the proc points using a single
 507 dataflow pass.  One might attempt to use this simple lattice:
 508
 509   data Location = Unknown
 510                 | InProc BlockId -- node is in procedure headed by the named proc point
 511                 | ProcPoint      -- node is itself a proc point
 512
 513 At a join, a node in two different blocks becomes a proc point.
 514 The difficulty is that the change of information during iterative
 515 computation may promote a node prematurely.  Here's a program that
 516 illustrates the difficulty:
 517
 518   f () {
 519   entry:
 520     ....
 521   L1:
 522     if (...) { ... }
 523     else { ... }
 524
 525   L2: if (...) { g(); goto L1; }
 526       return x + y;
 527   }
 528
 529 The only proc-point needed (besides the entry) is L1.  But in an
 530 iterative analysis, consider what happens to L2.  On the first pass
 531 through, it rises from Unknown to 'InProc entry', but when L1 is
 532 promoted to a proc point (because it's the successor of g()), L1's
 533 successors will be promoted to 'InProc L1'.  The problem hits when the
 534 new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
 535 The join operation makes it a proc point when in fact it needn't be,
 536 because its immediate dominator L1 is already a proc point and there
 537 are no other proc points that directly reach L2.
 538 -}
 539
 540
 541
 542 {- Note [Separate Adams optimization]
 543 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 544 It may be worthwhile to attempt the Adams optimization by rewriting
 545 the graph before the assignment of proc-point protocols.  Here are a
 546 couple of rules:
 547
 548   g() returns to k;                    g() returns to L;
 549   k: CopyIn c ress; goto L:
 550    ...                        ==>        ...
 551   L: // no CopyIn node here            L: CopyIn c ress;
 552
 553
 554 And when c == c' and ress == ress', this also:
 555
 556   g() returns to k;                    g() returns to L;
 557   k: CopyIn c ress; goto L:
 558    ...                        ==>        ...
 559   L: CopyIn c' ress'                   L: CopyIn c' ress' ;
 560
 561 In both cases the goal is to eliminate k.
 562 -}