compiler/cmm/ZipDataflow.hs

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