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           let block_in = head_in h (last_in comp env l) -- 'in' fact for the block
 302           setFact id block_in
 303     head_in (G.ZHead h m) out = head_in h (bc_middle_in comp out m)
 304     head_in (G.ZFirst id) out = bc_first_in comp out id
 305
 306 last_in :: BComputation m l i o -> (BlockId -> i) -> G.ZLast l -> o
 307 last_in comp env (G.LastOther l) = bc_last_in comp env l
 308 last_in comp _   (G.LastExit)    = bc_exit_in comp
 309
 310 ------ we can now pass those facts elsewhere
 311 fold_edge_facts_b f comp graph env z =
 312     foldl fold_block_facts z (postorder_dfs graph)
 313   where
 314     fold_block_facts z b =
 315       let (h, l) = G.goto_end (G.unzip b)
 316       in head_fold h (last_in comp env l) z
 317     head_fold (G.ZHead h m) out z = head_fold h (bc_middle_in comp out m) (f out z)
 318     head_fold (G.ZFirst id) out z = f (bc_first_in comp out id) (f out z)
 319
 320 fold_edge_facts_with_nodes_b fl fm ff comp graph env z =
 321     foldl fold_block_facts z (postorder_dfs graph)
 322   where
 323     fold_block_facts z b =
 324       let (h, l) = G.goto_end (G.unzip b)
 325           in' = last_in comp env l
 326           z' = case l of { G.LastExit -> z ; G.LastOther l -> fl l in' z }
 327       in head_fold h in' z'
 328     head_fold (G.ZHead h m) out z =
 329       let a  = bc_middle_in comp out m
 330           z' = fm m a z
 331       in  head_fold h a z'
 332     head_fold (G.ZFirst id) out z =
 333       let a  = bc_first_in comp out id
 334           z' = ff id a z
 335       in  z'
 336
 337
 338 -- | In the general case we solve a graph in the context of a larger subgraph.
 339 -- To do this, we need a locally modified computation that allows an
 340 -- ``exit fact'' to flow into the exit node.
 341
 342 comp_with_exit_b :: BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) -> o ->
 343                     BComputation m l i (OptimizationFuel -> DFM f (Answer m l o))
 344 comp_with_exit_b comp exit_fact =
 345     comp { bc_exit_in = \_fuel -> return $ Dataflow $ exit_fact }
 346
 347 -- | Given this function, we can now solve a graph simply by doing a
 348 -- backward analysis on the modified computation.  Note we have to be
 349 -- very careful with 'Rewrite'.  Either a rewrite is going to
 350 -- participate, in which case we mark the graph rerewritten, or we're
 351 -- going to analysis the proposed rewrite and then throw away
 352 -- everything but the answer, in which case it's a 'subAnalysis'.  A
 353 -- Rewrite should always use exactly one of these monadic operations.
 354
 355 solve_graph_b ::
 356     (DebugNodes m l, Outputable a) =>
 357     BPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, a)
 358 solve_graph_b comp fuel graph exit_fact =
 359     general_backward (comp_with_exit_b comp exit_fact) fuel graph
 360   where
 361     -- general_backward :: BPass m l a -> OptimizationFuel -> G.LGraph m l -> DFM a (OptimizationFuel, a)
 362     general_backward comp fuel graph =
 363       let -- set_block_fact :: OptimizationFuel -> G.Block m l -> DFM a OptimizationFuel
 364           set_block_fact fuel b =
 365               do { (fuel, block_in) <-
 366                         let (h, l) = G.goto_end (G.unzip b) in
 367                             factsEnv >>= \env -> last_in comp env l fuel >>= \x ->
 368                               case x of
 369                                 Dataflow a -> head_in fuel h a
 370                                 Rewrite g ->
 371                                   do { bot <- botFact
 372                                      ; (fuel, a) <- subAnalysis' $
 373                                                     solve_graph_b_g comp (fuel-1) g bot
 374                                      ; head_in fuel h a }
 375                  ; my_trace "result of" (text (bc_name comp) <+>
 376                    text "on" <+> ppr (G.blockId b) <+> text "is" <+> ppr block_in) $
 377                    setFact (G.blockId b) block_in
 378                  ; return fuel
 379                  }
 380           head_in fuel (G.ZHead h m) out =
 381               bc_middle_in comp out m fuel >>= \x -> case x of
 382                 Dataflow a -> head_in fuel h a
 383                 Rewrite g ->
 384                   do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (fuel-1) g out
 385                      ; my_trace "Rewrote middle node"
 386                                     (f4sep [ppr m, text "to", pprGraph g]) $
 387                        head_in fuel h a }
 388           head_in fuel (G.ZFirst id) out =
 389               bc_first_in comp out id fuel >>= \x -> case x of
 390                 Dataflow a -> return (fuel, a)
 391                 Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (fuel-1) g out }
 392
 393       in do { fuel <-
 394                   run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks
 395             ; a <- getFact (G.lg_entry graph)
 396             ; facts <- allFacts
 397             ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $
 398               return (fuel, a) }
 399
 400     blocks = reverse (G.postorder_dfs graph)
 401     pprFacts g env a = (ppr a <+> text "with") $$ vcat (pprLgraph g : map pprFact (ufmToList env))
 402     pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 403
 404 solve_graph_b_g ::
 405     (DebugNodes m l, Outputable a) =>
 406     BPass m l a -> OptimizationFuel -> G.Graph m l -> a -> DFM a (OptimizationFuel, a)
 407 solve_graph_b_g comp fuel graph exit_fact =
 408   do { g <- lgraphOfGraph graph ; solve_graph_b comp fuel g exit_fact }
 409
 410
 411 lgraphOfGraph :: G.Graph m l -> DFM f (G.LGraph m l)
 412 lgraphOfGraph g =
 413     do id <- freshBlockId "temporary id for dataflow analysis"
 414        return $ labelGraph id g
 415
 416 labelGraph :: BlockId -> G.Graph m l -> G.LGraph m l
 417 labelGraph id (Graph tail blocks) = LGraph id (insertBlock (Block id tail) blocks)
 418
 419 -- | We can remove the entry label of an LGraph and remove
 420 -- it, leaving a Graph.  Notice that this operation is NOT SAFE if a
 421 -- block within the LGraph branches to the entry point.  It should
 422 -- be used only to complement 'lgraphOfGraph' above.
 423
 424 remove_entry_label :: LGraph m l -> Graph m l
 425 remove_entry_label g =
 426     let FGraph e (ZBlock (ZFirst id) tail) others = entry g
 427     in  ASSERT (id == e) Graph tail others
 428
 429 {-
 430 We solve and rewrite in two passes: the first pass iterates to a fixed
 431 point to reach a dataflow solution, and the second pass uses that
 432 solution to rewrite the graph.
 433
 434 The
 435 key job is done by [[propagate]], which propagates a fact of type~[[a]]
 436 between a head and tail.
 437 The tail is in final form; the head is still to be rewritten.
 438 -}
 439
 440 solve_and_rewrite_b ::
 441   (DebugNodes m l, Outputable a) =>
 442   BPass m l a -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, a, LGraph m l)
 443 solve_and_rewrite_b_graph ::
 444   (DebugNodes m l, Outputable a) =>
 445   BPass m l a -> OptimizationFuel -> Graph m l -> a -> DFM a (OptimizationFuel, a, Graph m l)
 446
 447
 448 solve_and_rewrite_b comp fuel graph exit_fact =
 449   do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1
 450      ; facts <- allFacts
 451      ; (fuel, g) <-                                           -- pass 2
 452        my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $
 453            backward_rewrite (comp_with_exit_b comp exit_fact) fuel graph
 454      ; facts <- allFacts
 455      ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $
 456        return (fuel, a, g) }
 457   where
 458     pprFacts g env = vcat (pprLgraph g : map pprFact (ufmToList env))
 459     pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 460     eid = G.lg_entry graph
 461     backward_rewrite comp fuel graph =
 462       rewrite_blocks comp fuel emptyBlockEnv $ reverse (G.postorder_dfs graph)
 463     -- rewrite_blocks ::
 464     --   BPass m l a -> OptimizationFuel ->
 465     --   BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel,G.LGraph m l)
 466     rewrite_blocks _comp fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
 467     rewrite_blocks  comp fuel rewritten (b:bs) =
 468       let rewrite_next_block fuel =
 469             let (h, l) = G.goto_end (G.unzip b) in
 470             factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of
 471               Dataflow a -> propagate fuel h a (G.ZLast l) rewritten
 472               Rewrite g ->
 473                 do { markGraphRewritten
 474                    ; bot <- botFact
 475                    ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g bot
 476                    ; let G.Graph t new_blocks = g'
 477                    ; let rewritten' = new_blocks `plusUFM` rewritten
 478                    ; propagate fuel h a t rewritten' -- continue at entry of g'
 479                    }
 480           -- propagate :: OptimizationFuel -- Number of rewrites permitted
 481           --           -> G.ZHead m        -- Part of current block yet to be rewritten
 482           --           -> a                -- Fact on edge between head and tail
 483           --           -> G.ZTail m l      -- Part of current block already rewritten
 484           --           -> BlockEnv (Block m l)  -- Blocks already rewritten
 485           --           -> DFM a (OptimizationFuel, G.LGraph m l)
 486           propagate fuel (G.ZHead h m) out tail rewritten =
 487               bc_middle_in comp out m fuel >>= \x -> case x of
 488                 Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten
 489                 Rewrite g ->
 490                   do { markGraphRewritten
 491                      ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
 492                      ; let G.Graph t newblocks = G.splice_tail g' tail
 493                      ; my_trace "Rewrote middle node"
 494                                              (f4sep [ppr m, text "to", pprGraph g']) $
 495                        propagate fuel h a t (newblocks `plusUFM` rewritten) }
 496           propagate fuel h@(G.ZFirst id) out tail rewritten =
 497               bc_first_in comp out id fuel >>= \x -> case x of
 498                 Dataflow a ->
 499                   let b = G.Block id tail in
 500                   do { checkFactMatch id a
 501                      ; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs }
 502                 Rewrite g ->
 503                   do { markGraphRewritten
 504                      ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
 505                      ; let G.Graph t newblocks = G.splice_tail g' tail
 506                      ; my_trace "Rewrote label " (f4sep [ppr id,text "to",pprGraph g])$
 507                        propagate fuel h a t (newblocks `plusUFM` rewritten) }
 508       in rewrite_next_block fuel
 509
 510 {- Note [Rewriting labelled LGraphs]
 511 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 512 It's hugely annoying that we get in an LGraph and in order to solve it
 513 we have to slap on a new label which we then immediately strip off.
 514 But the alternative is to have all the iterative solvers work on
 515 Graphs, and then suddenly instead of a single case (ZBlock) every
 516 solver has to deal with two cases (ZBlock and ZTail).  So until
 517 somebody comes along who is smart enough to do this and still leave
 518 the code understandable for mortals, it stays as it is.
 519
 520 (One part of the solution will be postorder_dfs_from_except.)
 521 -}
 522
 523 solve_and_rewrite_b_graph comp fuel graph exit_fact =
 524     do g <- lgraphOfGraph graph
 525        (fuel, a, g') <- solve_and_rewrite_b comp fuel g exit_fact
 526        return (fuel, a, remove_entry_label g')
 527
 528 b_rewrite comp g =
 529   do { fuel <- liftTx txRemaining
 530      ; bot <- botFact
 531      ; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot
 532      ; liftTx $ txDecrement (bc_name comp) fuel fuel'
 533      ; return gc
 534      }
 535
 536 {-
 537 This debugging stuff is left over from imperative-land.
 538 It might be useful one day if I learn how to cheat the IO monad!
 539
 540 debug_b :: (Outputable m, Outputable l, Outputable a) => BPass m l a -> BPass m l a
 541
 542 let debug s (f, comp) =
 543   let pr = Printf.eprintf in
 544   let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
 545   let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
 546   let wrap f nodestring node fuel =
 547     let answer = f node fuel in
 548     let () = match answer with
 549     | Dataflow a -> fact "in " (nodestring node) a
 550     | Rewrite g  -> rewr (nodestring node) g in
 551     answer in
 552   let wrapout f nodestring out node fuel =
 553     fact "out" (nodestring node) out;
 554     wrap (f out) nodestring node fuel in
 555   let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in
 556   let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in
 557   let first_in  =
 558     let first = function G.Entry -> "<entry>" | G.Label ((u, l), _, _) -> l in
 559     wrapout comp.first_in first in
 560   f, { comp with last_in = last_in; middle_in = middle_in; first_in = first_in; }
 561 -}
 562
 563 anal_b comp = comp { bc_last_in   = wrap2 $ bc_last_in   comp
 564                    , bc_exit_in   = wrap0 $ bc_exit_in   comp
 565                    , bc_middle_in = wrap2 $ bc_middle_in comp
 566                    , bc_first_in  = wrap2 $ bc_first_in  comp }
 567   where wrap2 f out node _fuel = return $ Dataflow (f out node)
 568         wrap0 fact       _fuel = return $ Dataflow fact
 569
 570 ignore_transactions_b comp =
 571     comp { bc_last_in   = wrap2 $ bc_last_in   comp
 572          , bc_exit_in   = wrap0 $ bc_exit_in   comp
 573          , bc_middle_in = wrap2 $ bc_middle_in comp
 574          , bc_first_in  = wrap2 $ bc_first_in  comp }
 575   where wrap2 f out node _fuel = f out node
 576         wrap0 fact       _fuel = fact
 577
 578 answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
 579 answer' lift fuel r a =
 580     case r of Just gc | fuel > 0 -> do { g <- lift gc; return $ Rewrite g }
 581               _ -> return $ Dataflow a
 582
 583 unlimited_answer'
 584     :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
 585 unlimited_answer' lift _fuel r a =
 586     case r of Just gc -> do { g <- lift gc; return $ Rewrite g }
 587               _ -> return $ Dataflow a
 588
 589 combine_a_t_with :: (OptimizationFuel -> Maybe b -> a -> DFM a (Answer m l a)) ->
 590                     BAnalysis m l a -> BComputation m l a (Maybe b) ->
 591                     BPass m l a
 592 combine_a_t_with answer anal tx =
 593  let last_in env l fuel =
 594        answer fuel (bc_last_in tx env l) (bc_last_in anal env l)
 595      exit_in fuel = answer fuel (bc_exit_in tx) (bc_exit_in anal)
 596      middle_in out m fuel =
 597        answer fuel (bc_middle_in tx out m) (bc_middle_in anal out m)
 598      first_in out f fuel =
 599        answer fuel (bc_first_in tx out f) (bc_first_in anal out f)
 600  in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx]
 601           , bc_last_in = last_in, bc_middle_in = middle_in
 602           , bc_first_in = first_in, bc_exit_in = exit_in }
 603
 604 a_t_b            = combine_a_t_with (answer' liftUSM)
 605 a_ft_b           = combine_a_t_with (answer' return)
 606 a_ft_b_unlimited = combine_a_t_with (unlimited_answer' return)
 607
 608
 609 -- =============== FORWARD ================
 610
 611 -- | We don't compute and return the \emph{in} fact for block; instead, we
 612 -- use [[P.set]] to attach that fact to the block's unique~ID.
 613 -- We iterate until no more facts have changed.
 614
 615 dump_things :: Bool
 616 dump_things = False
 617
 618 my_trace :: String -> SDoc -> a -> a
 619 my_trace = if dump_things then pprTrace else \_ _ a -> a
 620
 621 run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry
 622   where set_entry = setFact (G.lg_entry graph) entry_fact
 623
 624 refine_f_anal comp graph initial =
 625     run "forward" (fc_name comp) initial set_successor_facts () blocks
 626   where blocks = G.postorder_dfs graph
 627         set_successor_facts () (G.Block id t) =
 628           let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t
 629               forward in' (G.ZLast l)   = setEdgeFacts (last_outs comp in' l)
 630               _blockname = if id == G.lg_entry graph then "<entry>" else show id
 631           in  getFact id >>= \a -> forward (fc_first_out comp a id) t
 632         setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs
 633         setEdgeFact (id, a) = setFact id a
 634
 635 last_outs :: FComputation m l i om ol -> i -> G.ZLast l -> ol
 636 last_outs comp i (G.LastExit)    = fc_exit_outs comp i
 637 last_outs comp i (G.LastOther l) = fc_last_outs comp i l
 638
 639 -- | In the general case we solve a graph in the context of a larger subgraph.
 640 -- To do this, we need a locally modified computation that allows an
 641 -- ``exit fact'' to flow out of the exit node.  We pass in a fresh BlockId
 642 -- to which the exit fact can flow
 643
 644 comp_with_exit_f :: FPass m l a -> BlockId -> FPass m l a
 645 comp_with_exit_f comp exit_fact_id = comp { fc_exit_outs = exit_outs }
 646     where exit_outs in' _fuel = return $ Dataflow $ LastOutFacts [(exit_fact_id, in')]
 647
 648 -- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
 649 -- forward analysis on the modified computation.
 650 solve_graph_f ::
 651     (DebugNodes m l, Outputable a) =>
 652     FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
 653     DFM a (OptimizationFuel, a, LastOutFacts a)
 654 solve_graph_f comp fuel g in_fact =
 655   do { exit_fact_id <- freshBlockId "proxy for exit node"
 656      ; fuel <- general_forward (comp_with_exit_f comp exit_fact_id) fuel in_fact g
 657      ; a <- getFact exit_fact_id
 658      ; outs <- lastOutFacts
 659      ; forgetFact exit_fact_id -- close space leak
 660      ; return (fuel, a, LastOutFacts outs) }
 661   where
 662     -- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
 663     general_forward comp fuel entry_fact graph =
 664       let blocks = G.postorder_dfs g
 665           is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id
 666           -- set_or_save :: LastOutFacts a -> DFM a ()
 667           set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
 668           set_or_save_one (id, a) =
 669             if is_local id then setFact id a else addLastOutFact (id, a)
 670           set_entry = setFact (G.lg_entry graph) entry_fact
 671
 672           set_successor_facts fuel b =
 673             let set_tail_facts fuel in' (G.ZTail m t) =
 674                   my_trace "Solving middle node" (ppr m) $
 675                   fc_middle_out comp in' m fuel >>= \ x -> case x of
 676                     Dataflow a -> set_tail_facts fuel a t
 677                     Rewrite g ->
 678                       do (fuel, out, last_outs) <-
 679                              subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
 680                          set_or_save last_outs
 681                          set_tail_facts fuel out t
 682                 set_tail_facts fuel in' (G.ZLast l) =
 683                   last_outs comp in' l fuel >>= \x -> case x of
 684                     Dataflow outs -> do { set_or_save outs; return fuel }
 685                     Rewrite g ->
 686                       do (fuel, _, last_outs) <-
 687                              subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
 688                          set_or_save last_outs
 689                          return fuel
 690                 G.Block id t = b
 691             in  do idfact <- getFact id
 692                    infact <- fc_first_out comp idfact id fuel
 693                    case infact of Dataflow a -> set_tail_facts fuel a t
 694                                   Rewrite g ->
 695                                     do (fuel, out, last_outs) <- subAnalysis' $
 696                                            solve_graph_f_g comp (fuel-1) g idfact
 697                                        set_or_save last_outs
 698                                        set_tail_facts fuel out t
 699       in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks
 700
 701 solve_graph_f_g ::
 702     (DebugNodes m l, Outputable a) =>
 703     FPass m l a -> OptimizationFuel -> G.Graph m l -> a ->
 704     DFM a (OptimizationFuel, a, LastOutFacts a)
 705 solve_graph_f_g comp fuel graph in_fact =
 706   do { g <- lgraphOfGraph graph ; solve_graph_f comp fuel g in_fact }
 707
 708
 709 {-
 710 We solve and rewrite in two passes: the first pass iterates to a fixed
 711 point to reach a dataflow solution, and the second pass uses that
 712 solution to rewrite the graph.
 713
 714 The key job is done by [[propagate]], which propagates a fact of type~[[a]]
 715 between a head and tail.
 716 The tail is in final form; the head is still to be rewritten.
 717 -}
 718 solve_and_rewrite_f ::
 719   (DebugNodes m l, Outputable a) =>
 720   FPass m l a -> OptimizationFuel -> LGraph m l -> a ->
 721   DFM a (OptimizationFuel, a, LGraph m l)
 722 solve_and_rewrite_f comp fuel graph in_fact =
 723   do solve_graph_f comp fuel graph in_fact                   -- pass 1
 724      exit_id    <- freshBlockId "proxy for exit node"
 725      (fuel, g) <- forward_rewrite (comp_with_exit_f comp exit_id) fuel graph in_fact
 726      exit_fact  <- getFact exit_id
 727      return (fuel, exit_fact, g)
 728
 729 solve_and_rewrite_f_graph ::
 730   (DebugNodes m l, Outputable a) =>
 731   FPass m l a -> OptimizationFuel -> Graph m l -> a ->
 732   DFM a (OptimizationFuel, a, Graph m l)
 733 solve_and_rewrite_f_graph comp fuel graph in_fact =
 734     do g <- lgraphOfGraph graph
 735        (fuel, a, g') <- solve_and_rewrite_f comp fuel g in_fact
 736        return (fuel, a, remove_entry_label g')
 737
 738 forward_rewrite ::
 739   (DebugNodes m l, Outputable a) =>
 740   FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
 741   DFM a (OptimizationFuel, G.LGraph m l)
 742 forward_rewrite comp fuel graph entry_fact =
 743   do setFact eid entry_fact
 744      rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph)
 745   where
 746     eid = G.lg_entry graph
 747     is_local id = isJust $ lookupBlockEnv (G.lg_blocks graph) id
 748     -- set_or_save :: LastOutFacts a -> DFM a ()
 749     set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
 750     set_or_save_one (id, a) =
 751         if is_local id then checkFactMatch id a
 752         else panic "set fact outside graph during rewriting pass?!"
 753
 754     -- rewrite_blocks ::
 755     --   OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l)
 756     rewrite_blocks fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
 757     rewrite_blocks fuel rewritten (G.Block id t : bs) =
 758         do id_fact <- getFact id
 759            first_out <- fc_first_out comp id_fact id fuel
 760            case first_out of
 761              Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs
 762              Rewrite g  -> do { markGraphRewritten
 763                               ; rewrite_blocks (fuel-1) rewritten
 764                                 (G.postorder_dfs (labelGraph id g) ++ bs) }
 765     -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
 766     --             [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l)
 767     propagate fuel h in' (G.ZTail m t) rewritten bs =
 768         my_trace "Rewriting middle node" (ppr m) $
 769         do fc_middle_out comp in' m fuel >>= \x -> case x of
 770              Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs
 771              Rewrite g ->
 772                do markGraphRewritten
 773                   (fuel, a, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
 774                   let (blocks, h') = G.splice_head' h g
 775                   propagate fuel h' a t (blocks `plusUFM` rewritten) bs
 776     propagate fuel h in' (G.ZLast l) rewritten bs =
 777         do last_outs comp in' l fuel >>= \x -> case x of
 778              Dataflow outs ->
 779                do set_or_save outs
 780                   let b = G.zip (G.ZBlock h (G.ZLast l))
 781                   rewrite_blocks fuel (G.insertBlock b rewritten) bs
 782              Rewrite g ->
 783                 do markGraphRewritten
 784                    (fuel, _, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
 785                    let g' = G.splice_head_only' h g
 786                    rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs
 787
 788 f_rewrite comp entry_fact g =
 789   do { fuel <- liftTx txRemaining
 790      ; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact
 791      ; liftTx $ txDecrement (fc_name comp) fuel fuel'
 792      ; return gc
 793      }
 794
 795
 796 {-
 797 debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a
 798
 799 let debug s (f, comp) =
 800   let pr = Printf.eprintf in
 801   let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
 802   let setter dir node run_sets set =
 803     run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in
 804   let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
 805   let wrap f nodestring wrap_answer in' node fuel =
 806     fact "in " (nodestring node) in';
 807     wrap_answer (nodestring node) (f in' node fuel)
 808   and wrap_fact n answer =
 809     let () = match answer with
 810     | Dataflow a -> fact "out" n a
 811     | Rewrite g  -> rewr n g in
 812     answer
 813   and wrap_setter n answer =
 814     match answer with
 815     | Dataflow set -> Dataflow (setter "out" n set)
 816     | Rewrite g  -> (rewr n g; Rewrite g) in
 817   let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in
 818   let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in
 819   f, { comp with last_outs = last_outs; middle_out = middle_out; }
 820 -}
 821
 822 anal_f comp = comp { fc_first_out  = wrap2 $ fc_first_out  comp
 823                    , fc_middle_out = wrap2 $ fc_middle_out comp
 824                    , fc_last_outs  = wrap2 $ fc_last_outs  comp
 825                    , fc_exit_outs  = wrap1 $ fc_exit_outs  comp
 826                    }
 827   where wrap2 f out node _fuel = return $ Dataflow (f out node)
 828         wrap1 f fact     _fuel = return $ Dataflow (f fact)
 829
 830
 831 a_t_f anal tx =
 832  let answer = answer' liftUSM
 833      first_out in' id fuel =
 834          answer fuel (fc_first_out tx in' id) (fc_first_out anal in' id)
 835      middle_out in' m fuel =
 836          answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m)
 837      last_outs in' l fuel =
 838          answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l)
 839      exit_outs in' fuel = undefined
 840          answer fuel (fc_exit_outs tx in') (fc_exit_outs anal in')
 841  in  FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
 842            , fc_last_outs = last_outs, fc_middle_out = middle_out
 843            , fc_first_out = first_out, fc_exit_outs = exit_outs }
 844
 845
 846 f4sep :: [SDoc] -> SDoc
 847 f4sep [] = fsep []
 848 f4sep (d:ds) = fsep (d : map (nest 4) ds)
 849
 850 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
 851                 m f a -> m f a
 852 subAnalysis' m =
 853     do { a <- subAnalysis $
 854                do { a <- m; facts <- allFacts
 855                   ; my_trace "after sub-analysis facts are" (pprFacts facts) $
 856                     return a }
 857        ; facts <- allFacts
 858        ; my_trace "in parent analysis facts are" (pprFacts facts) $
 859          return a }
 860   where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
 861         pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 862
 863
 864 _unused :: FS.FastString
 865 _unused = undefined