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