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