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 -> G.ZHead m -> a -> G.ZTail m l ->
 464           --              BlockEnv (Block m l) -> DFM a (OptimizationFuel, G.LGraph m l)
 465           propagate fuel (G.ZHead h m) out tail rewritten =
 466               bc_middle_in comp out m fuel >>= \x -> case x of
 467                 Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten
 468                 Rewrite g ->
 469                   do { g <- lgraphOfGraph g
 470                      ; (fuel, a, g') <- solve_and_rewrite_b comp (fuel-1) g out
 471                      ; markGraphRewritten
 472                      ; let (t, g'') = G.splice_tail g' tail
 473                      ; let rewritten' = plusUFM (G.lg_blocks g'') rewritten
 474                      ; my_trace "Rewrote middle node" (f4sep [ppr m, text "to", ppr g]) $
 475                        propagate fuel h a t rewritten' }
 476           propagate fuel h@(G.ZFirst id) out tail rewritten =
 477               bc_first_in comp out id fuel >>= \x -> case x of
 478                 Dataflow a ->
 479                   let b = G.Block id tail in
 480                   do { checkFactMatch id a
 481                      ; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs }
 482                 Rewrite fg ->
 483                   do { g <- lgraphOfGraph fg
 484                      ; (fuel, a, g') <- solve_and_rewrite_b comp (fuel-1) g out
 485                      ; markGraphRewritten
 486                      ; let (t, g'') = G.splice_tail g' tail
 487                      ; let rewritten' = plusUFM (G.lg_blocks g'') rewritten
 488                      ; my_trace "Rewrote label " (f4sep [ppr id, text "to", ppr g]) $
 489                        propagate fuel h a t rewritten' }
 490       in rewrite_next_block fuel
 491
 492 b_rewrite comp g =
 493   do { fuel <- liftTx txRemaining
 494      ; bot <- botFact
 495      ; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot
 496      ; liftTx $ txDecrement (bc_name comp) fuel fuel'
 497      ; return gc
 498      }
 499
 500 {-
 501 This debugging stuff is left over from imperative-land.
 502 It might be useful one day if I learn how to cheat the IO monad!
 503
 504 debug_b :: (Outputable m, Outputable l, Outputable a) => BPass m l a -> BPass m l a
 505
 506 let debug s (f, comp) =
 507   let pr = Printf.eprintf in
 508   let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
 509   let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
 510   let wrap f nodestring node fuel =
 511     let answer = f node fuel in
 512     let () = match answer with
 513     | Dataflow a -> fact "in " (nodestring node) a
 514     | Rewrite g  -> rewr (nodestring node) g in
 515     answer in
 516   let wrapout f nodestring out node fuel =
 517     fact "out" (nodestring node) out;
 518     wrap (f out) nodestring node fuel in
 519   let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in
 520   let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in
 521   let first_in  =
 522     let first = function G.Entry -> "<entry>" | G.Label ((u, l), _, _) -> l in
 523     wrapout comp.first_in first in
 524   f, { comp with last_in = last_in; middle_in = middle_in; first_in = first_in; }
 525 -}
 526
 527 anal_b comp = comp { bc_last_in   = wrap2 $ bc_last_in   comp
 528                    , bc_exit_in   = wrap0 $ bc_exit_in   comp
 529                    , bc_middle_in = wrap2 $ bc_middle_in comp
 530                    , bc_first_in  = wrap2 $ bc_first_in  comp }
 531   where wrap2 f out node _fuel = return $ Dataflow (f out node)
 532         wrap0 fact       _fuel = return $ Dataflow fact
 533
 534 ignore_transactions_b comp =
 535     comp { bc_last_in   = wrap2 $ bc_last_in   comp
 536          , bc_exit_in   = wrap0 $ bc_exit_in   comp
 537          , bc_middle_in = wrap2 $ bc_middle_in comp
 538          , bc_first_in  = wrap2 $ bc_first_in  comp }
 539   where wrap2 f out node _fuel = f out node
 540         wrap0 fact       _fuel = fact
 541
 542 answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
 543 answer' lift fuel r a =
 544     case r of Just gc | fuel > 0 -> do { g <- lift gc; return $ Rewrite g }
 545               _ -> return $ Dataflow a
 546
 547 unlimited_answer'
 548     :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
 549 unlimited_answer' lift _fuel r a =
 550     case r of Just gc -> do { g <- lift gc; return $ Rewrite g }
 551               _ -> return $ Dataflow a
 552
 553 combine_a_t_with :: (OptimizationFuel -> Maybe b -> a -> DFM a (Answer m l a)) ->
 554                     BAnalysis m l a -> BComputation m l a (Maybe b) ->
 555                     BPass m l a
 556 combine_a_t_with answer anal tx =
 557  let last_in env l fuel =
 558        answer fuel (bc_last_in tx env l) (bc_last_in anal env l)
 559      exit_in fuel = answer fuel (bc_exit_in tx) (bc_exit_in anal)
 560      middle_in out m fuel =
 561        answer fuel (bc_middle_in tx out m) (bc_middle_in anal out m)
 562      first_in out f fuel =
 563        answer fuel (bc_first_in tx out f) (bc_first_in anal out f)
 564  in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx]
 565           , bc_last_in = last_in, bc_middle_in = middle_in
 566           , bc_first_in = first_in, bc_exit_in = exit_in }
 567
 568 a_t_b            = combine_a_t_with (answer' liftUSM)
 569 a_ft_b           = combine_a_t_with (answer' return)
 570 a_ft_b_unlimited = combine_a_t_with (unlimited_answer' return)
 571
 572
 573 -- =============== FORWARD ================
 574
 575 -- | We don't compute and return the \emph{in} fact for block; instead, we
 576 -- use [[P.set]] to attach that fact to the block's unique~ID.
 577 -- We iterate until no more facts have changed.
 578
 579 dump_things :: Bool
 580 dump_things = False
 581
 582 my_trace :: String -> SDoc -> a -> a
 583 my_trace = if dump_things then pprTrace else \_ _ a -> a
 584
 585 run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry
 586   where set_entry = setFact (G.lg_entry graph) entry_fact
 587
 588 refine_f_anal comp graph initial =
 589     run "forward" (fc_name comp) initial set_successor_facts () blocks
 590   where blocks = G.postorder_dfs graph
 591         set_successor_facts () (G.Block id t) =
 592           let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t
 593               forward in' (G.ZLast l)   = setEdgeFacts (last_outs comp in' l)
 594               _blockname = if id == G.lg_entry graph then "<entry>" else show id
 595           in  getFact id >>= \a -> forward (fc_first_out comp a id) t
 596         setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs
 597         setEdgeFact (id, a) = setFact id a
 598
 599 last_outs :: FComputation m l i om ol -> i -> G.ZLast l -> ol
 600 last_outs comp i (G.LastExit)    = fc_exit_outs comp i
 601 last_outs comp i (G.LastOther l) = fc_last_outs comp i l
 602
 603 -- | In the general case we solve a graph in the context of a larger subgraph.
 604 -- To do this, we need a locally modified computation that allows an
 605 -- ``exit fact'' to flow out of the exit node.  We pass in a fresh BlockId
 606 -- to which the exit fact can flow
 607
 608 comp_with_exit_f :: FPass m l a -> BlockId -> FPass m l a
 609 comp_with_exit_f comp exit_fact_id = comp { fc_exit_outs = exit_outs }
 610     where exit_outs in' _fuel = return $ Dataflow $ LastOutFacts [(exit_fact_id, in')]
 611
 612 -- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
 613 -- forward analysis on the modified computation.
 614 solve_graph_f ::
 615     (DebugNodes m l, Outputable a) =>
 616     FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
 617     DFM a (OptimizationFuel, a, LastOutFacts a)
 618 solve_graph_f comp fuel g in_fact =
 619   do { exit_fact_id <- freshBlockId "proxy for exit node"
 620      ; fuel <- general_forward (comp_with_exit_f comp exit_fact_id) fuel in_fact g
 621      ; a <- getFact exit_fact_id
 622      ; outs <- lastOutFacts
 623      ; forgetFact exit_fact_id -- close space leak
 624      ; return (fuel, a, LastOutFacts outs) }
 625   where
 626     -- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
 627     general_forward comp fuel entry_fact graph =
 628       let blocks = G.postorder_dfs g
 629           is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id
 630           -- set_or_save :: LastOutFacts a -> DFM a ()
 631           set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
 632           set_or_save_one (id, a) =
 633             if is_local id then setFact id a else addLastOutFact (id, a)
 634           set_entry = setFact (G.lg_entry graph) entry_fact
 635
 636           set_successor_facts fuel b =
 637             let set_tail_facts fuel in' (G.ZTail m t) =
 638                   my_trace "Solving middle node" (ppr m) $
 639                   fc_middle_out comp in' m fuel >>= \ x -> case x of
 640                     Dataflow a -> set_tail_facts fuel a t
 641                     Rewrite g ->
 642                       do g <- lgraphOfGraph g
 643                          (fuel, out, last_outs) <- subAnalysis' $
 644                                          solve_graph_f comp (fuel-1) g in'
 645                          set_or_save last_outs
 646                          set_tail_facts fuel out t
 647                 set_tail_facts fuel in' (G.ZLast l) =
 648                   last_outs comp in' l fuel >>= \x -> case x of
 649                     Dataflow outs -> do { set_or_save outs; return fuel }
 650                     Rewrite g ->
 651                       do g <- lgraphOfGraph g
 652                          (fuel, _, last_outs) <- subAnalysis' $
 653                                          solve_graph_f comp (fuel-1) g in'
 654                          set_or_save last_outs
 655                          return fuel
 656                 G.Block id t = b
 657             in  do idfact <- getFact id
 658                    infact <- fc_first_out comp idfact id fuel
 659                    case infact of Dataflow a -> set_tail_facts fuel a t
 660                                   Rewrite g ->
 661                                     do g <- lgraphOfGraph g
 662                                        (fuel, out, last_outs) <- subAnalysis' $
 663                                            solve_graph_f comp (fuel-1) g idfact
 664                                        set_or_save last_outs
 665                                        set_tail_facts fuel out t
 666       in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks
 667
 668
 669
 670 {-
 671 We solve and rewrite in two passes: the first pass iterates to a fixed
 672 point to reach a dataflow solution, and the second pass uses that
 673 solution to rewrite the graph.
 674
 675 The key job is done by [[propagate]], which propagates a fact of type~[[a]]
 676 between a head and tail.
 677 The tail is in final form; the head is still to be rewritten.
 678 -}
 679 solve_and_rewrite_f ::
 680   (DebugNodes m l, Outputable a) =>
 681   FPass m l a -> OptimizationFuel -> LGraph m l -> a ->
 682   DFM a (OptimizationFuel, a, LGraph m l)
 683 solve_and_rewrite_f comp fuel graph in_fact =
 684   do solve_graph_f comp fuel graph in_fact                   -- pass 1
 685      exit_id    <- freshBlockId "proxy for exit node"
 686      (fuel, g) <- forward_rewrite (comp_with_exit_f comp exit_id) fuel graph in_fact
 687      exit_fact  <- getFact exit_id
 688      return (fuel, exit_fact, g)
 689
 690 forward_rewrite ::
 691   (DebugNodes m l, Outputable a) =>
 692   FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
 693   DFM a (OptimizationFuel, G.LGraph m l)
 694 forward_rewrite comp fuel graph entry_fact =
 695   do setFact eid entry_fact
 696      rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph)
 697   where
 698     eid = G.lg_entry graph
 699     is_local id = isJust $ lookupBlockEnv (G.lg_blocks graph) id
 700     -- set_or_save :: LastOutFacts a -> DFM a ()
 701     set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
 702     set_or_save_one (id, a) =
 703         if is_local id then checkFactMatch id a
 704         else panic "set fact outside graph during rewriting pass?!"
 705
 706     -- rewrite_blocks ::
 707     --   OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l)
 708     rewrite_blocks fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
 709     rewrite_blocks fuel rewritten (G.Block id t : bs) =
 710         do id_fact <- getFact id
 711            first_out <- fc_first_out comp id_fact id fuel
 712            case first_out of
 713              Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs
 714              Rewrite fg -> do { markGraphRewritten
 715                               ; rewrite_blocks (fuel-1) rewritten
 716                                 (G.postorder_dfs (labelGraph id fg) ++ bs) }
 717     -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
 718     --             [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l)
 719     propagate fuel h in' (G.ZTail m t) rewritten bs =
 720         my_trace "Rewriting middle node" (ppr m) $
 721         do fc_middle_out comp in' m fuel >>= \x -> case x of
 722              Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs
 723              Rewrite g ->
 724                my_trace "Rewriting middle node...\n" empty $
 725                do g <- lgraphOfGraph g
 726                   (fuel, a, g) <- solve_and_rewrite_f comp (fuel-1) g in'
 727                   markGraphRewritten
 728                   my_trace "Rewrite of middle node completed\n" empty $
 729                      let (g', h') = G.splice_head h g in
 730                      propagate fuel h' a t (plusUFM (G.lg_blocks g') rewritten) bs
 731     propagate fuel h in' (G.ZLast l) rewritten bs =
 732         do last_outs comp in' l fuel >>= \x -> case x of
 733              Dataflow outs ->
 734                do set_or_save outs
 735                   let b = G.zip (G.ZBlock h (G.ZLast l))
 736                   rewrite_blocks fuel (G.insertBlock b rewritten) bs
 737              Rewrite g ->
 738                 -- could test here that [[exits g = exits (G.Entry, G.ZLast l)]]
 739                 {- if Debug.on "rewrite-last" then
 740                       Printf.eprintf "ZLast node %s rewritten to:\n"
 741                         (RS.rtl (G.last_instr l)); -}
 742                 do g <- lgraphOfGraph g
 743                    (fuel, _, g) <- solve_and_rewrite_f comp (fuel-1) g in'
 744                    markGraphRewritten
 745                    let g' = G.splice_head_only h g
 746                    rewrite_blocks fuel (plusUFM (G.lg_blocks g') rewritten) bs
 747
 748 f_rewrite comp entry_fact g =
 749   do { fuel <- liftTx txRemaining
 750      ; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact
 751      ; liftTx $ txDecrement (fc_name comp) fuel fuel'
 752      ; return gc
 753      }
 754
 755
 756 {-
 757 debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a
 758
 759 let debug s (f, comp) =
 760   let pr = Printf.eprintf in
 761   let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
 762   let setter dir node run_sets set =
 763     run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in
 764   let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
 765   let wrap f nodestring wrap_answer in' node fuel =
 766     fact "in " (nodestring node) in';
 767     wrap_answer (nodestring node) (f in' node fuel)
 768   and wrap_fact n answer =
 769     let () = match answer with
 770     | Dataflow a -> fact "out" n a
 771     | Rewrite g  -> rewr n g in
 772     answer
 773   and wrap_setter n answer =
 774     match answer with
 775     | Dataflow set -> Dataflow (setter "out" n set)
 776     | Rewrite g  -> (rewr n g; Rewrite g) in
 777   let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in
 778   let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in
 779   f, { comp with last_outs = last_outs; middle_out = middle_out; }
 780 -}
 781
 782 anal_f comp = comp { fc_first_out  = wrap2 $ fc_first_out  comp
 783                    , fc_middle_out = wrap2 $ fc_middle_out comp
 784                    , fc_last_outs  = wrap2 $ fc_last_outs  comp
 785                    , fc_exit_outs  = wrap1 $ fc_exit_outs  comp
 786                    }
 787   where wrap2 f out node _fuel = return $ Dataflow (f out node)
 788         wrap1 f fact     _fuel = return $ Dataflow (f fact)
 789
 790
 791 a_t_f anal tx =
 792  let answer = answer' liftUSM
 793      first_out in' id fuel =
 794          answer fuel (fc_first_out tx in' id) (fc_first_out anal in' id)
 795      middle_out in' m fuel =
 796          answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m)
 797      last_outs in' l fuel =
 798          answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l)
 799      exit_outs in' fuel = undefined
 800          answer fuel (fc_exit_outs tx in') (fc_exit_outs anal in')
 801  in  FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
 802            , fc_last_outs = last_outs, fc_middle_out = middle_out
 803            , fc_first_out = first_out, fc_exit_outs = exit_outs }
 804
 805
 806 {- Note [Rewriting labelled LGraphs]
 807 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 808 It's hugely annoying that we get in an LGraph and in order to solve it
 809 we have to slap on a new label which we then immediately strip off.
 810 But the alternative is to have all the iterative solvers work on
 811 Graphs, and then suddenly instead of a single case (ZBlock) every
 812 solver has to deal with two cases (ZBlock and ZTail).  So until
 813 somebody comes along who is smart enough to do this and still leave
 814 the code understandable for mortals, it stays as it is.
 815
 816 (A good place to start changing things would be to figure out what is
 817 the analogue of postorder_dfs for Graphs, and to figure out what
 818 higher-order functions would do for dealing with the resulting
 819 sequences of *things*.)
 820 -}
 821
 822 f4sep :: [SDoc] -> SDoc
 823 f4sep [] = fsep []
 824 f4sep (d:ds) = fsep (d : map (nest 4) ds)
 825
 826 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
 827                 m f a -> m f a
 828 subAnalysis' m =
 829     do { a <- subAnalysis $
 830                do { a <- m; facts <- allFacts
 831                   ; my_trace "after sub-analysis facts are" (pprFacts facts) $
 832                     return a }
 833        ; facts <- allFacts
 834        ; my_trace "in parent analysis facts are" (pprFacts facts) $
 835          return a }
 836   where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
 837         pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)