compiler/cmm/ZipDataflow.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 module ZipDataflow
   3   ( Answer(..)
   4   , BComputation(..), BAnalysis, BTransformation, BFunctionalTransformation
   5         , BPass, BUnlimitedPass
   6   , FComputation(..), FAnalysis, FTransformation, FPass, FUnlimitedPass
   7   , LastOutFacts(..)
   8   , DebugNodes
   9   , anal_b, a_t_b, a_ft_b, a_ft_b_unlimited, ignore_transactions_b
  10   , anal_f, a_t_f
  11   , run_b_anal, run_f_anal
  12   , refine_f_anal, refine_b_anal, fold_edge_facts_b, fold_edge_facts_with_nodes_b
  13   , b_rewrite, f_rewrite
  14   , solve_graph_b, solve_graph_f
  15   )
  16 where
  17
  18 import CmmTx
  19 import DFMonad
  20 import ZipCfg
  21 import qualified ZipCfg as G
  22
  23 import Outputable
  24 import Panic
  25 import UniqFM
  26 import UniqSupply
  27
  28 import Control.Monad
  29 import Maybe
  30
  31 #include "HsVersions.h"
  32
  33 {-
  34
  35 \section{A very polymorphic infrastructure for dataflow problems}
  36
  37 This module presents a framework for solving iterative dataflow
  38 problems.
  39 There are two major submodules: one for forward problems and another
  40 for backward problems.
  41 Both modules incorporate the composition framework developed by
  42 Lerner, Grove, and Chambers.
  43 They also support a \emph{transaction limit}, which enables the
  44 binary-search debugging technique developed by Whalley and Davidson
  45 under the name \emph{vpoiso}.
  46 Transactions may either be known to the individual dataflow solvers or
  47 may be managed by the framework.
  48 -}
  49
  50 -- | In the composition framework, a pass either produces a dataflow
  51 -- fact or proposes to rewrite the graph.  To make life easy for the
  52 -- clients, the rewrite is given in unlabelled form, but we use
  53 -- labelled form internally throughout, because it greatly simplifies
  54 -- the implementation not to have the first block be a special case
  55 -- edverywhere.
  56
  57 data Answer m l a = Dataflow a | Rewrite (Graph m l)
  58
  59
  60 {-
  61
  62 ============== Descriptions of dataflow passes} ================
  63
  64 ------ Passes for backward dataflow problemsa
  65
  66 The computation of a fact is the basis of a dataflow pass.
  67 A computation takes *four* type parameters:
  68
  69   * 'middle' and 'last' are the types of the middle
  70     and last nodes of the graph over which the dataflow
  71     solution is being computed
  72
  73   * 'input' is an input, from which it should be possible to
  74      derive a dataflow fact of interest.  For example, 'input' might
  75      be equal to a fact, or it might be a tuple of which one element
  76      is a fact.
  77
  78   * 'output' is an output, or possibly a function from 'fuel' to an
  79     output
  80
  81 A computation is interesting for any pair of 'middle' and 'last' type
  82 parameters that can form a reasonable graph.  But it is not useful to
  83 instantiate 'input' and 'output' arbitrarily.  Rather, only certain
  84 combinations of instances are likely to be useful, such as those shown
  85 below.
  86
  87 Backward analyses compute *in* facts (facts on inedges).
  88 -}
  89
  90 -- A dataflow pass requires a name and a transfer function for each of
  91 -- four kinds of nodes:
  92 --      first (the BlockId),
  93 --      middle
  94 --      last
  95 --      LastExit
  96
  97 -- A 'BComputation' describes a complete backward dataflow pass, as a
  98 -- record of transfer functions.  Because the analysis works
  99 -- back-to-front, we write the exit node at the beginning.
 100 --
 101 -- So there is
 102 --      an 'input' for each out-edge of the node
 103 --              (hence (BlockId -> input) for bc_last_in)
 104 --      an 'output' for the in-edge of the node
 105
 106 data BComputation middle last input output = BComp
 107    { bc_name      :: String
 108    , bc_exit_in   ::                                  output
 109    , bc_last_in   :: (BlockId -> input) -> last    -> output
 110    , bc_middle_in :: input              -> middle  -> output
 111    , bc_first_in  :: input              -> BlockId -> output
 112    }
 113
 114 -- | From these elements we build several kinds of passes:
 115 --     * A pure analysis computes a fact, using that fact as input and output.
 116 --     * A pure transformation computes no facts but only changes the graph.
 117 --     * A fully general pass both computes a fact and rewrites the graph,
 118 --       respecting the current transaction limit.
 119 --
 120 type BAnalysis                 m l a = BComputation m l a a
 121 type BTransformation           m l a = BComputation m l a (Maybe (UniqSM (Graph m l)))
 122 type BFunctionalTransformation m l a = BComputation m l a (Maybe         (Graph m l))
 123         -- ToDo: consider replacing UniqSM (Graph l m) with (AGraph m l)
 124
 125 type BPass          m l a = BComputation m l a (OptimizationFuel -> DFM a (Answer m l a))
 126 type BUnlimitedPass m l a = BComputation m l a (                    DFM a (Answer m l a))
 127
 128         -- (DFM a t) maintains the (BlockId -> a) map
 129         -- ToDo: overlap with bc_last_in??
 130
 131 {-
 132 \paragraph{Passes for forward dataflow problems}
 133
 134 A forward dataflow pass has a similar structure, but the details are
 135 different.  In particular, the output fact from a [[last]] node has a
 136 higher-order representation: it takes a function that mutates a
 137 [[uid]] to account for the new fact, then performs the necessary
 138 mutation on every successor of the last node.  We therefore have two
 139 kinds of type parameter for outputs: output from a [[middle]] node
 140 is~[[outmid]], and output from a [[last]] node is~[[outlast]].
 141 -}
 142
 143 data FComputation middle last input outmid outlast = FComp
 144  { fc_name       :: String
 145  , fc_first_out  :: input -> BlockId   -> outmid
 146  , fc_middle_out :: input -> middle    -> outmid
 147  , fc_last_outs  :: input -> last      -> outlast
 148  , fc_exit_outs  :: input              -> outlast
 149  }
 150
 151 -- | The notions of analysis, pass, and transformation are analogous to the
 152 -- backward case.
 153
 154 newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
 155   -- ^ These are facts flowing out of a last node to the node's successors.
 156   -- They are either to be set (if they pertain to the graph currently
 157   -- under analysis) or propagated out of a sub-analysis
 158
 159 type FAnalysis m l a       = FComputation m l a a (LastOutFacts a)
 160 type FTransformation m l a = FComputation m l a (Maybe (UniqSM (Graph m l)))
 161                                                 (Maybe (UniqSM (Graph m l)))
 162 type FPass m l a           = FComputation m l a
 163                                 (OptimizationFuel -> DFM a (Answer m l a))
 164                                 (OptimizationFuel -> DFM a (Answer m l (LastOutFacts a)))
 165
 166 type FUnlimitedPass m l a  = FComputation m l a
 167                                 (DFM a (Answer m l a))
 168                                 (DFM a (Answer m l (LastOutFacts a)))
 169
 170 {-
 171 \paragraph{Composing passes}
 172
 173 Both forward and backward engines share a handful of functions for
 174 composing analyses, transformations, and passes.
 175
 176 We can make an analysis pass, or we can
 177 combine a related analysis and transformation into a full pass.
 178 -}
 179
 180 anal_b :: BAnalysis m l a -> BPass m l a
 181 a_t_b  :: BAnalysis m l a -> BTransformation           m l a -> BPass m l a
 182 a_ft_b :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
 183 a_ft_b_unlimited
 184        :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
 185   -- ^ Ignores transaction limits.  Could produce a BUnlimitedPass statically,
 186   -- but that would cost too much code in the implementation for a
 187   -- static distinction that is not worth so much.
 188 ignore_transactions_b :: BUnlimitedPass m l a -> BPass m l a
 189
 190
 191
 192 anal_f :: FAnalysis m l a -> FPass m l a
 193 a_t_f  :: FAnalysis m l a -> FTransformation m l a -> FPass m l a
 194
 195
 196 {-
 197 \paragraph {Running the dataflow engine}
 198
 199 Every function for running analyses has two forms, because for a
 200 forward analysis, we supply an entry fact, whereas for a backward
 201 analysis, we don't need to supply an exit fact (because a graph for a
 202 procedure doesn't have an exit node).
 203 It's possible we could make these things more regular.
 204 -}
 205
 206 -- | The analysis functions set properties on unique IDs.
 207
 208 run_b_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
 209               BAnalysis m l a ->      LGraph m l -> DFA a ()
 210 run_f_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
 211               FAnalysis m l a -> a -> LGraph m l -> DFA a ()
 212                               -- ^ extra parameter is the entry fact
 213
 214 -- | Rematerialize results of analysis for use elsewhere.  Simply applies a
 215 -- fold function to every edge fact, in reverse postorder dfs.  The facts
 216 -- should already have been computed into the monady by run_b_anal or b_rewrite.
 217 fold_edge_facts_b
 218     :: LastNode l =>
 219        (a -> b -> b) -> BAnalysis m l a -> LGraph m l -> (BlockId -> a) -> b -> b
 220
 221 fold_edge_facts_with_nodes_b :: LastNode l
 222                              => (l -> a -> b -> b)  -- ^ inedge to last node
 223                              -> (m -> a -> b -> b)  -- ^ inedge to middle node
 224                              -> (BlockId -> a -> b -> b) -- ^ fact at label
 225                              -> BAnalysis m l a          -- ^ backwards analysis
 226                              -> LGraph m l               -- ^ graph
 227                              -> (BlockId -> a)           -- ^ solution to bwd anal
 228                              -> b -> b
 229
 230
 231 -- | It can be useful to refine the results of an existing analysis,
 232 -- or for example to use the outcome of a forward analsysis in a
 233 -- backward analysis.  These functions can also be used to compute a
 234 -- fixed point iteratively starting from somewhere other than bottom
 235 -- (as in the reachability analysis done for proc points).
 236
 237 class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
 238
 239 refine_f_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
 240         FAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
 241
 242 refine_b_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
 243         BAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
 244
 245 b_rewrite :: (DebugNodes m l, Outputable a) =>
 246              BPass m l a ->      LGraph m l -> DFM a (LGraph m l)
 247 f_rewrite :: (DebugNodes m l, LastNode l, Outputable m, Outputable a) =>
 248              FPass m l a -> a -> LGraph m l -> DFM a (LGraph m l)
 249                     -- ^ extra parameter is the entry fact
 250
 251 -- | If the solution to a problem is already sitting in a monad, we
 252 -- should be able to take a short cut and just rewrite it in one pass.
 253 -- But not yet implemented.
 254
 255 {-
 256 f_rewrite_solved :: (LastNode l, Outputable m, Outputable a) =>
 257                     FPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l)
 258 b_rewrite_solved :: (LastNode l, Outputable m, Outputable a) =>
 259                     BPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l)
 260 -}
 261
 262 -- ===================== IMPLEMENTATION ======================--
 263
 264 -- | Here's a function to run an action on blocks until we reach a fixed point.
 265 run :: (DataflowAnalysis anal, Monad (anal a), Outputable a, DebugNodes m l) =>
 266        String -> String -> anal a () -> (b -> Block m l -> anal a b) ->
 267        b -> [Block m l] -> anal a b
 268 run dir name set_entry do_block b blocks =
 269    do { set_entry; show_blocks $ iterate (1::Int) }
 270    where
 271      -- N.B. Each iteration starts with the same transaction limit;
 272      -- only the rewrites in the final iteration actually count
 273      trace_block b block = my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
 274                            do_block b block
 275      iterate n =
 276          do { markFactsUnchanged
 277             ; b <- foldM trace_block b blocks
 278             ; changed <- factsStatus
 279             ; facts <- allFacts
 280             ; let depth = 0 -- was nesting depth
 281             ; ppIter depth n $
 282               case changed of
 283                 NoChange -> unchanged depth $ return b
 284                 SomeChange ->
 285                     pprFacts depth n facts $
 286                     if n < 1000 then iterate (n+1)
 287                     else panic $ msg n
 288             }
 289      msg n = concat [name, " didn't converge in ", show n, " " , dir,
 290                      " iterations"]
 291      my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
 292      ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
 293      pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
 294      unchanged depth = my_nest depth (text "facts are unchanged")
 295
 296      pprFacts depth n env =
 297          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
 298                         (nest 2 $ vcat $ map pprFact $ ufmToList env))
 299      pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 300      graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
 301      show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
 302      pprBlock (Block id t) = nest 2 (pprFact (id, t))
 303
 304 {-
 305 \subsection{Backward problems}
 306
 307 In a backward problem, we compute \emph{in} facts from \emph{out}
 308 facts.  The analysis gives us [[exit_in]], [[last_in]], [[middle_in]],
 309 and [[first_in]], each of which computes an \emph{in} fact for one
 310 kind of node.  We provide [[head_in]], which computes the \emph{in}
 311 fact for a first node followed by zero or more middle nodes.
 312
 313 We don't compute and return the \emph{in} fact for block; instead, we
 314 use [[setFact]] to attach that fact to the block's unique~ID.
 315 We iterate until no more facts have changed.
 316 -}
 317 run_b_anal comp graph =
 318   refine_b_anal comp graph (return ())
 319       -- for a backward analysis, everything is initially bottom
 320
 321 refine_b_anal comp graph initial =
 322       run "backward" (bc_name comp) initial set_block_fact () blocks
 323   where
 324     blocks = reverse (postorder_dfs graph)
 325     set_block_fact () b@(G.Block id _) =
 326       let (h, l) = G.goto_end (G.unzip b) in
 327       do  env <- factsEnv
 328           setFact id $ head_in h (last_in comp env l) -- 'in' fact for the block
 329     head_in (G.ZHead h m) out = head_in h (bc_middle_in comp out m)
 330     head_in (G.ZFirst id) out = bc_first_in comp out id
 331
 332 last_in :: BComputation m l i o -> (BlockId -> i) -> G.ZLast l -> o
 333 last_in comp env (G.LastOther l) = bc_last_in comp env l
 334 last_in comp _   (G.LastExit)    = bc_exit_in comp
 335
 336 ------ we can now pass those facts elsewhere
 337 fold_edge_facts_b f comp graph env z =
 338     foldl fold_block_facts z (postorder_dfs graph)
 339   where
 340     fold_block_facts z b =
 341       let (h, l) = G.goto_end (G.unzip b)
 342       in head_fold h (last_in comp env l) z
 343     head_fold (G.ZHead h m) out z = head_fold h (bc_middle_in comp out m) (f out z)
 344     head_fold (G.ZFirst id) out z = f (bc_first_in comp out id) (f out z)
 345
 346 fold_edge_facts_with_nodes_b fl fm ff comp graph env z =
 347     foldl fold_block_facts z (postorder_dfs graph)
 348   where
 349     fold_block_facts z b =
 350       let (h, l) = G.goto_end (G.unzip b)
 351           in' = last_in comp env l
 352           z' = case l of { G.LastExit -> z ; G.LastOther l -> fl l in' z }
 353       in head_fold h in' z'
 354     head_fold (G.ZHead h m) out z =
 355       let a  = bc_middle_in comp out m
 356           z' = fm m a z
 357       in  head_fold h a z'
 358     head_fold (G.ZFirst id) out z =
 359       let a  = bc_first_in comp out id
 360           z' = ff id a z
 361       in  z'
 362
 363
 364 -- | In the general case we solve a graph in the context of a larger subgraph.
 365 -- To do this, we need a locally modified computation that allows an
 366 -- ``exit fact'' to flow into the exit node.
 367
 368 comp_with_exit_b :: BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) -> o ->
 369                     BComputation m l i (OptimizationFuel -> DFM f (Answer m l o))
 370 comp_with_exit_b comp exit_fact =
 371     comp { bc_exit_in = \_fuel -> return $ Dataflow $ exit_fact }
 372
 373 -- | Given this function, we can now solve a graph simply by doing a
 374 -- backward analysis on the modified computation.  Note we have to be
 375 -- very careful with 'Rewrite'.  Either a rewrite is going to
 376 -- participate, in which case we mark the graph rerewritten, or we're
 377 -- going to analysis the proposed rewrite and then throw away
 378 -- everything but the answer, in which case it's a 'subAnalysis'.  A
 379 -- Rewrite should always use exactly one of these monadic operations.
 380
 381 solve_graph_b ::
 382     (DebugNodes m l, Outputable a) =>
 383     BPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, a)
 384 solve_graph_b comp fuel graph exit_fact =
 385     general_backward (comp_with_exit_b comp exit_fact) fuel graph
 386   where
 387     -- general_backward :: BPass m l a -> OptimizationFuel -> G.LGraph m l -> DFM a (OptimizationFuel, a)
 388     general_backward comp fuel graph =
 389       let -- set_block_fact :: OptimizationFuel -> G.Block m l -> DFM a OptimizationFuel
 390           set_block_fact fuel b =
 391               do { (fuel, block_in) <-
 392                         let (h, l) = G.goto_end (G.unzip b) in
 393                             factsEnv >>= \env -> last_in comp env l fuel >>= \x ->
 394                               case x of
 395                                 Dataflow a -> head_in fuel h a
 396                                 Rewrite g ->
 397                                   do { bot <- botFact
 398                                      ; (fuel, a) <- subAnalysis' $
 399                                                     solve_graph_b_g comp (fuel-1) g bot
 400                                      ; head_in fuel h a }
 401                  ; my_trace "result of" (text (bc_name comp) <+>
 402                    text "on" <+> ppr (G.blockId b) <+> text "is" <+> ppr block_in) $
 403                    setFact (G.blockId b) block_in
 404                  ; return fuel
 405                  }
 406           head_in fuel (G.ZHead h m) out =
 407               bc_middle_in comp out m fuel >>= \x -> case x of
 408                 Dataflow a -> head_in fuel h a
 409                 Rewrite g ->
 410                   do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (fuel-1) g out
 411                      ; my_trace "Rewrote middle node"
 412                                     (f4sep [ppr m, text "to", pprGraph g]) $
 413                        head_in fuel h a }
 414           head_in fuel (G.ZFirst id) out =
 415               bc_first_in comp out id fuel >>= \x -> case x of
 416                 Dataflow a -> return (fuel, a)
 417                 Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (fuel-1) g out }
 418
 419       in do { fuel <-
 420                   run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks
 421             ; a <- getFact (G.lg_entry graph)
 422             ; facts <- allFacts
 423             ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $
 424               return (fuel, a) }
 425
 426     blocks = reverse (G.postorder_dfs graph)
 427     pprFacts g env a = (ppr a <+> text "with") $$ vcat (pprLgraph g : map pprFact (ufmToList env))
 428     pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 429
 430 solve_graph_b_g ::
 431     (DebugNodes m l, Outputable a) =>
 432     BPass m l a -> OptimizationFuel -> G.Graph m l -> a -> DFM a (OptimizationFuel, a)
 433 solve_graph_b_g comp fuel graph exit_fact =
 434   do { g <- lgraphOfGraph graph ; solve_graph_b comp fuel g exit_fact }
 435
 436
 437 lgraphOfGraph :: G.Graph m l -> DFM f (G.LGraph m l)
 438 lgraphOfGraph g =
 439     do id <- freshBlockId "temporary id for dataflow analysis"
 440        return $ labelGraph id g
 441
 442 labelGraph :: BlockId -> G.Graph m l -> G.LGraph m l
 443 labelGraph id (Graph tail blocks) = LGraph id (insertBlock (Block id tail) blocks)
 444
 445 -- | We can remove the entry label of an LGraph and remove
 446 -- it, leaving a Graph.  Notice that this operation is NOT SAFE if a
 447 -- block within the LGraph branches to the entry point.  It should
 448 -- be used only to complement 'lgraphOfGraph' above.
 449
 450 remove_entry_label :: LGraph m l -> Graph m l
 451 remove_entry_label g =
 452     let FGraph e (ZBlock (ZFirst id) tail) others = entry g
 453     in  ASSERT (id == e) Graph tail others
 454
 455 {-
 456 We solve and rewrite in two passes: the first pass iterates to a fixed
 457 point to reach a dataflow solution, and the second pass uses that
 458 solution to rewrite the graph.
 459
 460 The
 461 key job is done by [[propagate]], which propagates a fact of type~[[a]]
 462 between a head and tail.
 463 The tail is in final form; the head is still to be rewritten.
 464 -}
 465
 466 solve_and_rewrite_b ::
 467   (DebugNodes m l, Outputable a) =>
 468   BPass m l a -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, a, LGraph m l)
 469 solve_and_rewrite_b_graph ::
 470   (DebugNodes m l, Outputable a) =>
 471   BPass m l a -> OptimizationFuel -> Graph m l -> a -> DFM a (OptimizationFuel, a, Graph m l)
 472
 473
 474 solve_and_rewrite_b comp fuel graph exit_fact =
 475   do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1
 476      ; facts <- allFacts
 477      ; (fuel, g) <-                                           -- pass 2
 478        my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $
 479            backward_rewrite (comp_with_exit_b comp exit_fact) fuel graph
 480      ; facts <- allFacts
 481      ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $
 482        return (fuel, a, g) }
 483   where
 484     pprFacts g env = vcat (pprLgraph g : map pprFact (ufmToList env))
 485     pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 486     eid = G.lg_entry graph
 487     backward_rewrite comp fuel graph =
 488       rewrite_blocks comp fuel emptyBlockEnv $ reverse (G.postorder_dfs graph)
 489     -- rewrite_blocks ::
 490     --   BPass m l a -> OptimizationFuel ->
 491     --   BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel,G.LGraph m l)
 492     rewrite_blocks _comp fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
 493     rewrite_blocks  comp fuel rewritten (b:bs) =
 494       let rewrite_next_block fuel =
 495             let (h, l) = G.goto_end (G.unzip b) in
 496             factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of
 497               Dataflow a -> propagate fuel h a (G.ZLast l) rewritten
 498               Rewrite g ->
 499                 do { markGraphRewritten
 500                    ; bot <- botFact
 501                    ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g bot
 502                    ; let G.Graph t new_blocks = g'
 503                    ; let rewritten' = new_blocks `plusUFM` rewritten
 504                    ; propagate fuel h a t rewritten' -- continue at entry of g'
 505                    }
 506           -- propagate :: OptimizationFuel -- Number of rewrites permitted
 507           --           -> G.ZHead m        -- Part of current block yet to be rewritten
 508           --           -> a                -- Fact on edge between head and tail
 509           --           -> G.ZTail m l      -- Part of current block already rewritten
 510           --           -> BlockEnv (Block m l)  -- Blocks already rewritten
 511           --           -> DFM a (OptimizationFuel, G.LGraph m l)
 512           propagate fuel (G.ZHead h m) out tail rewritten =
 513               bc_middle_in comp out m fuel >>= \x -> case x of
 514                 Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten
 515                 Rewrite g ->
 516                   do { markGraphRewritten
 517                      ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
 518                      ; let G.Graph t newblocks = G.splice_tail g' tail
 519                      ; my_trace "Rewrote middle node"
 520                                              (f4sep [ppr m, text "to", pprGraph g']) $
 521                        propagate fuel h a t (newblocks `plusUFM` rewritten) }
 522           propagate fuel h@(G.ZFirst id) out tail rewritten =
 523               bc_first_in comp out id fuel >>= \x -> case x of
 524                 Dataflow a ->
 525                   let b = G.Block id tail in
 526                   do { checkFactMatch id a
 527                      ; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs }
 528                 Rewrite g ->
 529                   do { markGraphRewritten
 530                      ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
 531                      ; let G.Graph t newblocks = G.splice_tail g' tail
 532                      ; my_trace "Rewrote label " (f4sep [ppr id,text "to",pprGraph g])$
 533                        propagate fuel h a t (newblocks `plusUFM` rewritten) }
 534       in rewrite_next_block fuel
 535
 536 {- Note [Rewriting labelled LGraphs]
 537 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 538 It's hugely annoying that we get in an LGraph and in order to solve it
 539 we have to slap on a new label which we then immediately strip off.
 540 But the alternative is to have all the iterative solvers work on
 541 Graphs, and then suddenly instead of a single case (ZBlock) every
 542 solver has to deal with two cases (ZBlock and ZTail).  So until
 543 somebody comes along who is smart enough to do this and still leave
 544 the code understandable for mortals, it stays as it is.
 545
 546 (One part of the solution will be postorder_dfs_from_except.)
 547 -}
 548
 549 solve_and_rewrite_b_graph comp fuel graph exit_fact =
 550     do g <- lgraphOfGraph graph
 551        (fuel, a, g') <- solve_and_rewrite_b comp fuel g exit_fact
 552        return (fuel, a, remove_entry_label g')
 553
 554 b_rewrite comp g =
 555   do { fuel <- liftTx txRemaining
 556      ; bot <- botFact
 557      ; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot
 558      ; liftTx $ txDecrement (bc_name comp) fuel fuel'
 559      ; return gc
 560      }
 561
 562 {-
 563 This debugging stuff is left over from imperative-land.
 564 It might be useful one day if I learn how to cheat the IO monad!
 565
 566 debug_b :: (Outputable m, Outputable l, Outputable a) => BPass m l a -> BPass m l a
 567
 568 let debug s (f, comp) =
 569   let pr = Printf.eprintf in
 570   let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
 571   let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
 572   let wrap f nodestring node fuel =
 573     let answer = f node fuel in
 574     let () = match answer with
 575     | Dataflow a -> fact "in " (nodestring node) a
 576     | Rewrite g  -> rewr (nodestring node) g in
 577     answer in
 578   let wrapout f nodestring out node fuel =
 579     fact "out" (nodestring node) out;
 580     wrap (f out) nodestring node fuel in
 581   let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in
 582   let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in
 583   let first_in  =
 584     let first = function G.Entry -> "<entry>" | G.Label ((u, l), _, _) -> l in
 585     wrapout comp.first_in first in
 586   f, { comp with last_in = last_in; middle_in = middle_in; first_in = first_in; }
 587 -}
 588
 589 anal_b comp = comp { bc_last_in   = wrap2 $ bc_last_in   comp
 590                    , bc_exit_in   = wrap0 $ bc_exit_in   comp
 591                    , bc_middle_in = wrap2 $ bc_middle_in comp
 592                    , bc_first_in  = wrap2 $ bc_first_in  comp }
 593   where wrap2 f out node _fuel = return $ Dataflow (f out node)
 594         wrap0 fact       _fuel = return $ Dataflow fact
 595
 596 ignore_transactions_b comp =
 597     comp { bc_last_in   = wrap2 $ bc_last_in   comp
 598          , bc_exit_in   = wrap0 $ bc_exit_in   comp
 599          , bc_middle_in = wrap2 $ bc_middle_in comp
 600          , bc_first_in  = wrap2 $ bc_first_in  comp }
 601   where wrap2 f out node _fuel = f out node
 602         wrap0 fact       _fuel = fact
 603
 604 answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
 605 answer' lift fuel r a =
 606     case r of Just gc | fuel > 0 -> do { g <- lift gc; return $ Rewrite g }
 607               _ -> return $ Dataflow a
 608
 609 unlimited_answer'
 610     :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
 611 unlimited_answer' lift _fuel r a =
 612     case r of Just gc -> do { g <- lift gc; return $ Rewrite g }
 613               _ -> return $ Dataflow a
 614
 615 combine_a_t_with :: (OptimizationFuel -> Maybe b -> a -> DFM a (Answer m l a)) ->
 616                     BAnalysis m l a -> BComputation m l a (Maybe b) ->
 617                     BPass m l a
 618 combine_a_t_with answer anal tx =
 619  let last_in env l fuel =
 620        answer fuel (bc_last_in tx env l) (bc_last_in anal env l)
 621      exit_in fuel = answer fuel (bc_exit_in tx) (bc_exit_in anal)
 622      middle_in out m fuel =
 623        answer fuel (bc_middle_in tx out m) (bc_middle_in anal out m)
 624      first_in out f fuel =
 625        answer fuel (bc_first_in tx out f) (bc_first_in anal out f)
 626  in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx]
 627           , bc_last_in = last_in, bc_middle_in = middle_in
 628           , bc_first_in = first_in, bc_exit_in = exit_in }
 629
 630 a_t_b            = combine_a_t_with (answer' liftUSM)
 631 a_ft_b           = combine_a_t_with (answer' return)
 632 a_ft_b_unlimited = combine_a_t_with (unlimited_answer' return)
 633
 634
 635 -- =============== FORWARD ================
 636
 637 -- | We don't compute and return the \emph{in} fact for block; instead, we
 638 -- use [[P.set]] to attach that fact to the block's unique~ID.
 639 -- We iterate until no more facts have changed.
 640
 641 dump_things :: Bool
 642 dump_things = False
 643
 644 my_trace :: String -> SDoc -> a -> a
 645 my_trace = if dump_things then pprTrace else \_ _ a -> a
 646
 647 run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry
 648   where set_entry = setFact (G.lg_entry graph) entry_fact
 649
 650 refine_f_anal comp graph initial =
 651     run "forward" (fc_name comp) initial set_successor_facts () blocks
 652   where blocks = G.postorder_dfs graph
 653         set_successor_facts () (G.Block id t) =
 654           let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t
 655               forward in' (G.ZLast l)   = setEdgeFacts (last_outs comp in' l)
 656               _blockname = if id == G.lg_entry graph then "<entry>" else show id
 657           in  getFact id >>= \a -> forward (fc_first_out comp a id) t
 658         setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs
 659         setEdgeFact (id, a) = setFact id a
 660
 661 last_outs :: FComputation m l i om ol -> i -> G.ZLast l -> ol
 662 last_outs comp i (G.LastExit)    = fc_exit_outs comp i
 663 last_outs comp i (G.LastOther l) = fc_last_outs comp i l
 664
 665 -- | In the general case we solve a graph in the context of a larger subgraph.
 666 -- To do this, we need a locally modified computation that allows an
 667 -- ``exit fact'' to flow out of the exit node.  We pass in a fresh BlockId
 668 -- to which the exit fact can flow
 669
 670 comp_with_exit_f :: FPass m l a -> BlockId -> FPass m l a
 671 comp_with_exit_f comp exit_fact_id = comp { fc_exit_outs = exit_outs }
 672     where exit_outs in' _fuel = return $ Dataflow $ LastOutFacts [(exit_fact_id, in')]
 673
 674 -- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
 675 -- forward analysis on the modified computation.
 676 solve_graph_f ::
 677     (DebugNodes m l, Outputable a) =>
 678     FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
 679     DFM a (OptimizationFuel, a, LastOutFacts a)
 680 solve_graph_f comp fuel g in_fact =
 681   do { exit_fact_id <- freshBlockId "proxy for exit node"
 682      ; fuel <- general_forward (comp_with_exit_f comp exit_fact_id) fuel in_fact g
 683      ; a <- getFact exit_fact_id
 684      ; outs <- lastOutFacts
 685      ; forgetFact exit_fact_id -- close space leak
 686      ; return (fuel, a, LastOutFacts outs) }
 687   where
 688     -- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
 689     general_forward comp fuel entry_fact graph =
 690       let blocks = G.postorder_dfs g
 691           is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id
 692           -- set_or_save :: LastOutFacts a -> DFM a ()
 693           set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
 694           set_or_save_one (id, a) =
 695             if is_local id then setFact id a else addLastOutFact (id, a)
 696           set_entry = setFact (G.lg_entry graph) entry_fact
 697
 698           set_successor_facts fuel b =
 699             let set_tail_facts fuel in' (G.ZTail m t) =
 700                   my_trace "Solving middle node" (ppr m) $
 701                   fc_middle_out comp in' m fuel >>= \ x -> case x of
 702                     Dataflow a -> set_tail_facts fuel a t
 703                     Rewrite g ->
 704                       do (fuel, out, last_outs) <-
 705                              subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
 706                          set_or_save last_outs
 707                          set_tail_facts fuel out t
 708                 set_tail_facts fuel in' (G.ZLast l) =
 709                   last_outs comp in' l fuel >>= \x -> case x of
 710                     Dataflow outs -> do { set_or_save outs; return fuel }
 711                     Rewrite g ->
 712                       do (fuel, _, last_outs) <-
 713                              subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
 714                          set_or_save last_outs
 715                          return fuel
 716                 G.Block id t = b
 717             in  do idfact <- getFact id
 718                    infact <- fc_first_out comp idfact id fuel
 719                    case infact of Dataflow a -> set_tail_facts fuel a t
 720                                   Rewrite g ->
 721                                     do (fuel, out, last_outs) <- subAnalysis' $
 722                                            solve_graph_f_g comp (fuel-1) g idfact
 723                                        set_or_save last_outs
 724                                        set_tail_facts fuel out t
 725       in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks
 726
 727 solve_graph_f_g ::
 728     (DebugNodes m l, Outputable a) =>
 729     FPass m l a -> OptimizationFuel -> G.Graph m l -> a ->
 730     DFM a (OptimizationFuel, a, LastOutFacts a)
 731 solve_graph_f_g comp fuel graph in_fact =
 732   do { g <- lgraphOfGraph graph ; solve_graph_f comp fuel g in_fact }
 733
 734
 735 {-
 736 We solve and rewrite in two passes: the first pass iterates to a fixed
 737 point to reach a dataflow solution, and the second pass uses that
 738 solution to rewrite the graph.
 739
 740 The key job is done by [[propagate]], which propagates a fact of type~[[a]]
 741 between a head and tail.
 742 The tail is in final form; the head is still to be rewritten.
 743 -}
 744 solve_and_rewrite_f ::
 745   (DebugNodes m l, Outputable a) =>
 746   FPass m l a -> OptimizationFuel -> LGraph m l -> a ->
 747   DFM a (OptimizationFuel, a, LGraph m l)
 748 solve_and_rewrite_f comp fuel graph in_fact =
 749   do solve_graph_f comp fuel graph in_fact                   -- pass 1
 750      exit_id    <- freshBlockId "proxy for exit node"
 751      (fuel, g) <- forward_rewrite (comp_with_exit_f comp exit_id) fuel graph in_fact
 752      exit_fact  <- getFact exit_id
 753      return (fuel, exit_fact, g)
 754
 755 solve_and_rewrite_f_graph ::
 756   (DebugNodes m l, Outputable a) =>
 757   FPass m l a -> OptimizationFuel -> Graph m l -> a ->
 758   DFM a (OptimizationFuel, a, Graph m l)
 759 solve_and_rewrite_f_graph comp fuel graph in_fact =
 760     do g <- lgraphOfGraph graph
 761        (fuel, a, g') <- solve_and_rewrite_f comp fuel g in_fact
 762        return (fuel, a, remove_entry_label g')
 763
 764 forward_rewrite ::
 765   (DebugNodes m l, Outputable a) =>
 766   FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
 767   DFM a (OptimizationFuel, G.LGraph m l)
 768 forward_rewrite comp fuel graph entry_fact =
 769   do setFact eid entry_fact
 770      rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph)
 771   where
 772     eid = G.lg_entry graph
 773     is_local id = isJust $ lookupBlockEnv (G.lg_blocks graph) id
 774     -- set_or_save :: LastOutFacts a -> DFM a ()
 775     set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
 776     set_or_save_one (id, a) =
 777         if is_local id then checkFactMatch id a
 778         else panic "set fact outside graph during rewriting pass?!"
 779
 780     -- rewrite_blocks ::
 781     --   OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l)
 782     rewrite_blocks fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
 783     rewrite_blocks fuel rewritten (G.Block id t : bs) =
 784         do id_fact <- getFact id
 785            first_out <- fc_first_out comp id_fact id fuel
 786            case first_out of
 787              Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs
 788              Rewrite g  -> do { markGraphRewritten
 789                               ; rewrite_blocks (fuel-1) rewritten
 790                                 (G.postorder_dfs (labelGraph id g) ++ bs) }
 791     -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
 792     --             [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l)
 793     propagate fuel h in' (G.ZTail m t) rewritten bs =
 794         my_trace "Rewriting middle node" (ppr m) $
 795         do fc_middle_out comp in' m fuel >>= \x -> case x of
 796              Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs
 797              Rewrite g ->
 798                do markGraphRewritten
 799                   (fuel, a, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
 800                   let (blocks, h') = G.splice_head' h g
 801                   propagate fuel h' a t (blocks `plusUFM` rewritten) bs
 802     propagate fuel h in' (G.ZLast l) rewritten bs =
 803         do last_outs comp in' l fuel >>= \x -> case x of
 804              Dataflow outs ->
 805                do set_or_save outs
 806                   let b = G.zip (G.ZBlock h (G.ZLast l))
 807                   rewrite_blocks fuel (G.insertBlock b rewritten) bs
 808              Rewrite g ->
 809                 do markGraphRewritten
 810                    (fuel, _, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
 811                    let g' = G.splice_head_only' h g
 812                    rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs
 813
 814 f_rewrite comp entry_fact g =
 815   do { fuel <- liftTx txRemaining
 816      ; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact
 817      ; liftTx $ txDecrement (fc_name comp) fuel fuel'
 818      ; return gc
 819      }
 820
 821
 822 {-
 823 debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a
 824
 825 let debug s (f, comp) =
 826   let pr = Printf.eprintf in
 827   let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
 828   let setter dir node run_sets set =
 829     run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in
 830   let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
 831   let wrap f nodestring wrap_answer in' node fuel =
 832     fact "in " (nodestring node) in';
 833     wrap_answer (nodestring node) (f in' node fuel)
 834   and wrap_fact n answer =
 835     let () = match answer with
 836     | Dataflow a -> fact "out" n a
 837     | Rewrite g  -> rewr n g in
 838     answer
 839   and wrap_setter n answer =
 840     match answer with
 841     | Dataflow set -> Dataflow (setter "out" n set)
 842     | Rewrite g  -> (rewr n g; Rewrite g) in
 843   let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in
 844   let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in
 845   f, { comp with last_outs = last_outs; middle_out = middle_out; }
 846 -}
 847
 848 anal_f comp = comp { fc_first_out  = wrap2 $ fc_first_out  comp
 849                    , fc_middle_out = wrap2 $ fc_middle_out comp
 850                    , fc_last_outs  = wrap2 $ fc_last_outs  comp
 851                    , fc_exit_outs  = wrap1 $ fc_exit_outs  comp
 852                    }
 853   where wrap2 f out node _fuel = return $ Dataflow (f out node)
 854         wrap1 f fact     _fuel = return $ Dataflow (f fact)
 855
 856
 857 a_t_f anal tx =
 858  let answer = answer' liftUSM
 859      first_out in' id fuel =
 860          answer fuel (fc_first_out tx in' id) (fc_first_out anal in' id)
 861      middle_out in' m fuel =
 862          answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m)
 863      last_outs in' l fuel =
 864          answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l)
 865      exit_outs in' fuel = undefined
 866          answer fuel (fc_exit_outs tx in') (fc_exit_outs anal in')
 867  in  FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
 868            , fc_last_outs = last_outs, fc_middle_out = middle_out
 869            , fc_first_out = first_out, fc_exit_outs = exit_outs }
 870
 871
 872 f4sep :: [SDoc] -> SDoc
 873 f4sep [] = fsep []
 874 f4sep (d:ds) = fsep (d : map (nest 4) ds)
 875
 876 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
 877                 m f a -> m f a
 878 subAnalysis' m =
 879     do { a <- subAnalysis $
 880                do { a <- m; facts <- allFacts
 881                   ; my_trace "after sub-analysis facts are" (pprFacts facts) $
 882                     return a }
 883        ; facts <- allFacts
 884        ; my_trace "in parent analysis facts are" (pprFacts facts) $
 885          return a }
 886   where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
 887         pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 888
 889
 890 _unused :: FS.FastString
 891 _unused = undefined