compiler/cmm/ZipDataflow0.hs

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