compiler/cmm/ZipDataflow.hs

   1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   2 {-# LANGUAGE ScopedTypeVariables, 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 [[txlimit]] 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 (Txlimit -> 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                                 (Txlimit -> DFM a (Answer m l a))
 136                                 (Txlimit -> 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 :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) =>
 181               BAnalysis m l a ->      LGraph m l -> DFA a ()
 182 run_f_anal :: forall m l a . (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 :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) =>
 212         FAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
 213
 214 refine_b_anal :: forall m l a . (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 (Txlimit -> DFM f (Answer m l o)) -> o ->
 342                     BComputation m l i (Txlimit -> DFM f (Answer m l o))
 343 comp_with_exit_b comp exit_fact =
 344     comp { bc_exit_in = \_txlim -> 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     forall m l a . (DebugNodes m l, Outputable a) =>
 356                    BPass m l a -> Txlimit -> G.LGraph m l -> a -> DFM a (Txlimit, a)
 357 solve_graph_b comp txlim graph exit_fact =
 358     general_backward (comp_with_exit_b comp exit_fact) txlim graph
 359   where
 360     general_backward :: BPass m l a -> Txlimit -> G.LGraph m l -> DFM a (Txlimit, a)
 361     general_backward comp txlim graph =
 362       let set_block_fact :: Txlimit -> G.Block m l -> DFM a Txlimit
 363           set_block_fact txlim b =
 364               do { (txlim, block_in) <-
 365                         let (h, l) = G.goto_end (G.unzip b) in
 366                             factsEnv >>= \env -> last_in comp env l txlim >>= \x ->
 367                               case x of
 368                                 Dataflow a -> head_in txlim h a
 369                                 Rewrite g ->
 370                                   do { bot <- botFact
 371                                      ; g <- lgraphOfGraph g
 372                                      ; (txlim, a) <- subAnalysis' $
 373                                                      solve_graph_b comp (txlim-1) g bot
 374                                      ; head_in txlim 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 txlim
 379                  }
 380           head_in txlim (G.ZHead h m) out =
 381               bc_middle_in comp out m txlim >>= \x -> case x of
 382                 Dataflow a -> head_in txlim h a
 383                 Rewrite g ->
 384                   do { g <- lgraphOfGraph g
 385                      ; (txlim, a) <- subAnalysis' $ solve_graph_b comp (txlim-1) g out
 386                      ; my_trace "Rewrote middle node" (f4sep [ppr m, text "to", ppr g]) $
 387                        head_in txlim h a }
 388           head_in txlim (G.ZFirst id) out =
 389               bc_first_in comp out id txlim >>= \x -> case x of
 390                 Dataflow a -> return (txlim, a)
 391                 Rewrite g -> do { g <- lgraphOfGraph g
 392                                 ; subAnalysis' $ solve_graph_b comp (txlim-1) g out }
 393
 394       in do { txlim <-
 395                   run "backward" (bc_name comp) (return ()) set_block_fact txlim blocks
 396             ; a <- getFact (G.gr_entry graph)
 397             ; facts <- allFacts
 398             ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $
 399               return (txlim, 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   forall m l a. (DebugNodes m l, Outputable a) =>
 427          BPass m l a -> Txlimit -> LGraph m l -> a -> DFM a (Txlimit, a, LGraph m l)
 428
 429 solve_and_rewrite_b comp txlim graph exit_fact =
 430   do { (_, a) <- solve_graph_b comp txlim graph exit_fact -- pass 1
 431      ; facts <- allFacts
 432      ; (txlim, 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) txlim graph
 435      ; facts <- allFacts
 436      ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $
 437        return (txlim, 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.gr_entry graph
 442     backward_rewrite comp txlim graph =
 443       rewrite_blocks comp txlim emptyBlockEnv $ reverse (G.postorder_dfs graph)
 444     rewrite_blocks ::
 445       BPass m l a -> Txlimit ->
 446       BlockEnv (Block m l) -> [Block m l] -> DFM a (Txlimit,G.LGraph m l)
 447     rewrite_blocks _comp txlim rewritten [] = return (txlim, G.LGraph eid rewritten)
 448     rewrite_blocks  comp txlim rewritten (b:bs) =
 449       let rewrite_next_block txlim =
 450             let (h, l) = G.goto_end (G.unzip b) in
 451             factsEnv >>= \env -> last_in comp env l txlim >>= \x -> case x of
 452               Dataflow a -> propagate txlim h a (G.ZLast l) rewritten
 453               Rewrite g ->  -- see Note [Rewriting labelled LGraphs]
 454                 do { bot <- botFact
 455                    ; g <- lgraphOfGraph g
 456                    ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-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 txlim h a t rewritten'
 462                    }
 463           propagate :: Txlimit -> G.ZHead m -> a -> G.ZTail m l ->
 464                        BlockEnv (Block m l) -> DFM a (Txlimit, G.LGraph m l)
 465           propagate txlim (G.ZHead h m) out tail rewritten =
 466               bc_middle_in comp out m txlim >>= \x -> case x of
 467                 Dataflow a -> propagate txlim h a (G.ZTail m tail) rewritten
 468                 Rewrite g ->
 469                   do { g <- lgraphOfGraph g
 470                      ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-1) g out
 471                      ; markGraphRewritten
 472                      ; let (t, g'') = G.splice_tail g' tail
 473                      ; let rewritten' = plusUFM (G.gr_blocks g'') rewritten
 474                      ; my_trace "Rewrote middle node" (f4sep [ppr m, text "to", ppr g]) $
 475                        propagate txlim h a t rewritten' }
 476           propagate txlim h@(G.ZFirst id) out tail rewritten =
 477               bc_first_in comp out id txlim >>= \x -> case x of
 478                 Dataflow a ->
 479                   let b = G.Block id tail in
 480                   do { checkFactMatch id a
 481                      ; rewrite_blocks comp txlim (extendBlockEnv rewritten id b) bs }
 482                 Rewrite fg ->
 483                   do { g <- lgraphOfGraph fg
 484                      ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-1) g out
 485                      ; markGraphRewritten
 486                      ; let (t, g'') = G.splice_tail g' tail
 487                      ; let rewritten' = plusUFM (G.gr_blocks g'') rewritten
 488                      ; my_trace "Rewrote label " (f4sep [ppr id, text "to", ppr g]) $
 489                        propagate txlim h a t rewritten' }
 490       in rewrite_next_block txlim
 491
 492 b_rewrite comp g =
 493   do { txlim <- liftTx txRemaining
 494      ; bot <- botFact
 495      ; (txlim', _, gc) <- solve_and_rewrite_b comp txlim g bot
 496      ; liftTx $ txDecrement (bc_name comp) txlim txlim'
 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 txlim =
 511     let answer = f node txlim 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 txlim =
 517     fact "out" (nodestring node) out;
 518     wrap (f out) nodestring node txlim 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 _txlim = return $ Dataflow (f out node)
 532         wrap0 fact       _txlim = 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 _txlim = f out node
 540         wrap0 fact       _txlim = fact
 541
 542 answer' :: (b -> DFM f (Graph m l)) -> Txlimit -> Maybe b -> a -> DFM f (Answer m l a)
 543 answer' lift txlim r a =
 544     case r of Just gc | txlim > 0 -> do { g <- lift gc; return $ Rewrite g }
 545               _ -> return $ Dataflow a
 546
 547 unlimited_answer'
 548     :: (b -> DFM f (Graph m l)) -> Txlimit -> Maybe b -> a -> DFM f (Answer m l a)
 549 unlimited_answer' lift _txlim 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 :: (Txlimit -> 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 txlim =
 558        answer txlim (bc_last_in tx env l) (bc_last_in anal env l)
 559      exit_in txlim = answer txlim (bc_exit_in tx) (bc_exit_in anal)
 560      middle_in out m txlim =
 561        answer txlim (bc_middle_in tx out m) (bc_middle_in anal out m)
 562      first_in out f txlim =
 563        answer txlim (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.gr_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.gr_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' _txlimit =
 611               return $ Dataflow $ LastOutFacts [(exit_fact_id, in')]
 612
 613 -- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
 614 -- forward analysis on the modified computation.
 615 solve_graph_f ::
 616     forall m l a . (DebugNodes m l, Outputable a) =>
 617                    FPass m l a -> Txlimit -> G.LGraph m l -> a ->
 618                    DFM a (Txlimit, a, LastOutFacts a)
 619 solve_graph_f comp txlim g in_fact =
 620   do { exit_fact_id <- freshBlockId "proxy for exit node"
 621      ; txlim <- general_forward (comp_with_exit_f comp exit_fact_id) txlim in_fact g
 622      ; a <- getFact exit_fact_id
 623      ; outs <- lastOutFacts
 624      ; forgetFact exit_fact_id -- close space leak
 625      ; return (txlim, a, LastOutFacts outs) }
 626   where
 627     general_forward :: FPass m l a -> Txlimit -> a -> G.LGraph m l -> DFM a Txlimit
 628     general_forward comp txlim entry_fact graph =
 629       let blocks = G.postorder_dfs g
 630           is_local id = isJust $ lookupBlockEnv (G.gr_blocks g) id
 631           set_or_save :: LastOutFacts a -> DFM a ()
 632           set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
 633           set_or_save_one (id, a) =
 634             if is_local id then setFact id a else addLastOutFact (id, a)
 635           set_entry = setFact (G.gr_entry graph) entry_fact
 636
 637           set_successor_facts txlim b =
 638             let set_tail_facts txlim in' (G.ZTail m t) =
 639                   my_trace "Solving middle node" (ppr m) $
 640                   fc_middle_out comp in' m txlim >>= \ x -> case x of
 641                     Dataflow a -> set_tail_facts txlim a t
 642                     Rewrite g ->
 643                       do g <- lgraphOfGraph g
 644                          (txlim, out, last_outs) <- subAnalysis' $
 645                                          solve_graph_f comp (txlim-1) g in'
 646                          set_or_save last_outs
 647                          set_tail_facts txlim out t
 648                 set_tail_facts txlim in' (G.ZLast l) =
 649                   last_outs comp in' l txlim >>= \x -> case x of
 650                     Dataflow outs -> do { set_or_save outs; return txlim }
 651                     Rewrite g ->
 652                       do g <- lgraphOfGraph g
 653                          (txlim, _, last_outs) <- subAnalysis' $
 654                                          solve_graph_f comp (txlim-1) g in'
 655                          set_or_save last_outs
 656                          return txlim
 657                 G.Block id t = b
 658             in  do idfact <- getFact id
 659                    infact <- fc_first_out comp idfact id txlim
 660                    case infact of Dataflow a -> set_tail_facts txlim a t
 661                                   Rewrite g ->
 662                                     do g <- lgraphOfGraph g
 663                                        (txlim, out, last_outs) <- subAnalysis' $
 664                                            solve_graph_f comp (txlim-1) g idfact
 665                                        set_or_save last_outs
 666                                        set_tail_facts txlim out t
 667       in run "forward" (fc_name comp) set_entry set_successor_facts txlim blocks
 668
 669
 670
 671 {-
 672 We solve and rewrite in two passes: the first pass iterates to a fixed
 673 point to reach a dataflow solution, and the second pass uses that
 674 solution to rewrite the graph.
 675
 676 The key job is done by [[propagate]], which propagates a fact of type~[[a]]
 677 between a head and tail.
 678 The tail is in final form; the head is still to be rewritten.
 679 -}
 680 solve_and_rewrite_f ::
 681   forall m l a . (DebugNodes m l, Outputable a) =>
 682          FPass m l a -> Txlimit -> LGraph m l -> a -> DFM a (Txlimit, a, LGraph m l)
 683 solve_and_rewrite_f comp txlim graph in_fact =
 684   do solve_graph_f comp txlim graph in_fact                   -- pass 1
 685      exit_id    <- freshBlockId "proxy for exit node"
 686      (txlim, g) <- forward_rewrite (comp_with_exit_f comp exit_id) txlim graph in_fact
 687      exit_fact  <- getFact exit_id
 688      return (txlim, exit_fact, g)
 689
 690 forward_rewrite ::
 691   forall m l a . (DebugNodes m l, Outputable a) =>
 692          FPass m l a -> Txlimit -> G.LGraph m l -> a -> DFM a (Txlimit, G.LGraph m l)
 693 forward_rewrite comp txlim graph entry_fact =
 694   do setFact eid entry_fact
 695      rewrite_blocks txlim emptyBlockEnv (G.postorder_dfs graph)
 696   where
 697     eid = G.gr_entry graph
 698     is_local id = isJust $ lookupBlockEnv (G.gr_blocks graph) id
 699     set_or_save :: LastOutFacts a -> DFM a ()
 700     set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
 701     set_or_save_one (id, a) =
 702         if is_local id then checkFactMatch id a
 703         else panic "set fact outside graph during rewriting pass?!"
 704
 705     rewrite_blocks ::
 706       Txlimit -> BlockEnv (Block m l) -> [Block m l] -> DFM a (Txlimit, LGraph m l)
 707     rewrite_blocks txlim rewritten [] = return (txlim, G.LGraph eid rewritten)
 708     rewrite_blocks txlim rewritten (G.Block id t : bs) =
 709         do id_fact <- getFact id
 710            first_out <- fc_first_out comp id_fact id txlim
 711            case first_out of
 712              Dataflow a -> propagate txlim (G.ZFirst id) a t rewritten bs
 713              Rewrite fg -> do { markGraphRewritten
 714                               ; rewrite_blocks (txlim-1) rewritten
 715                                 (G.postorder_dfs (labelGraph id fg) ++ bs) }
 716     propagate :: Txlimit -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
 717                  [G.Block m l] -> DFM a (Txlimit, G.LGraph m l)
 718     propagate txlim h in' (G.ZTail m t) rewritten bs =
 719         my_trace "Rewriting middle node" (ppr m) $
 720         do fc_middle_out comp in' m txlim >>= \x -> case x of
 721              Dataflow a -> propagate txlim (G.ZHead h m) a t rewritten bs
 722              Rewrite g ->
 723                my_trace "Rewriting middle node...\n" empty $
 724                do g <- lgraphOfGraph g
 725                   (txlim, a, g) <- solve_and_rewrite_f comp (txlim-1) g in'
 726                   markGraphRewritten
 727                   my_trace "Rewrite of middle node completed\n" empty $
 728                      let (g', h') = G.splice_head h g in
 729                      propagate txlim h' a t (plusUFM (G.gr_blocks g') rewritten) bs
 730     propagate txlim h in' (G.ZLast l) rewritten bs =
 731         do last_outs comp in' l txlim >>= \x -> case x of
 732              Dataflow outs ->
 733                do set_or_save outs
 734                   let b = G.zip (G.ZBlock h (G.ZLast l))
 735                   rewrite_blocks txlim (G.insertBlock b rewritten) bs
 736              Rewrite g ->
 737                 -- could test here that [[exits g = exits (G.Entry, G.ZLast l)]]
 738                 {- if Debug.on "rewrite-last" then
 739                       Printf.eprintf "ZLast node %s rewritten to:\n"
 740                         (RS.rtl (G.last_instr l)); -}
 741                 do g <- lgraphOfGraph g
 742                    (txlim, _, g) <- solve_and_rewrite_f comp (txlim-1) g in'
 743                    markGraphRewritten
 744                    let g' = G.splice_head_only h g
 745                    rewrite_blocks txlim (plusUFM (G.gr_blocks g') rewritten) bs
 746
 747 f_rewrite comp entry_fact g =
 748   do { txlim <- liftTx txRemaining
 749      ; (txlim', _, gc) <- solve_and_rewrite_f comp txlim g entry_fact
 750      ; liftTx $ txDecrement (fc_name comp) txlim txlim'
 751      ; return gc
 752      }
 753
 754
 755 {-
 756 debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a
 757
 758 let debug s (f, comp) =
 759   let pr = Printf.eprintf in
 760   let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
 761   let setter dir node run_sets set =
 762     run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in
 763   let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
 764   let wrap f nodestring wrap_answer in' node txlim =
 765     fact "in " (nodestring node) in';
 766     wrap_answer (nodestring node) (f in' node txlim)
 767   and wrap_fact n answer =
 768     let () = match answer with
 769     | Dataflow a -> fact "out" n a
 770     | Rewrite g  -> rewr n g in
 771     answer
 772   and wrap_setter n answer =
 773     match answer with
 774     | Dataflow set -> Dataflow (setter "out" n set)
 775     | Rewrite g  -> (rewr n g; Rewrite g) in
 776   let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in
 777   let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in
 778   f, { comp with last_outs = last_outs; middle_out = middle_out; }
 779 -}
 780
 781 anal_f comp = comp { fc_first_out  = wrap2 $ fc_first_out  comp
 782                    , fc_middle_out = wrap2 $ fc_middle_out comp
 783                    , fc_last_outs  = wrap2 $ fc_last_outs  comp
 784                    , fc_exit_outs  = wrap1 $ fc_exit_outs  comp
 785                    }
 786   where wrap2 f out node _txlim = return $ Dataflow (f out node)
 787         wrap1 f fact     _txlim = return $ Dataflow (f fact)
 788
 789
 790 a_t_f anal tx =
 791  let answer = answer' liftUSM
 792      first_out in' id txlim =
 793          answer txlim (fc_first_out tx in' id) (fc_first_out anal in' id)
 794      middle_out in' m txlim =
 795          answer txlim (fc_middle_out tx in' m) (fc_middle_out anal in' m)
 796      last_outs in' l txlim =
 797          answer txlim (fc_last_outs tx in' l) (fc_last_outs anal in' l)
 798      exit_outs in' txlim = undefined
 799          answer txlim (fc_exit_outs tx in') (fc_exit_outs anal in')
 800  in  FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
 801            , fc_last_outs = last_outs, fc_middle_out = middle_out
 802            , fc_first_out = first_out, fc_exit_outs = exit_outs }
 803
 804
 805 {- Note [Rewriting labelled LGraphs]
 806 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 807 It's hugely annoying that we get in an LGraph and in order to solve it
 808 we have to slap on a new label which we then immediately strip off.
 809 But the alternative is to have all the iterative solvers work on
 810 Graphs, and then suddenly instead of a single case (ZBlock) every
 811 solver has to deal with two cases (ZBlock and ZTail).  So until
 812 somebody comes along who is smart enough to do this and still leave
 813 the code understandable for mortals, it stays as it is.
 814
 815 (A good place to start changing things would be to figure out what is
 816 the analogue of postorder_dfs for Graphs, and to figure out what
 817 higher-order functions would do for dealing with the resulting
 818 sequences of *things*.)
 819 -}
 820
 821 f4sep :: [SDoc] -> SDoc
 822 f4sep [] = fsep []
 823 f4sep (d:ds) = fsep (d : map (nest 4) ds)
 824
 825 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
 826                 m f a -> m f a
 827 subAnalysis' m =
 828     do { a <- subAnalysis $
 829                do { a <- m; facts <- allFacts
 830                   ; my_trace "after sub-analysis facts are" (pprFacts facts) $
 831                     return a }
 832        ; facts <- allFacts
 833        ; my_trace "in parent analysis facts are" (pprFacts facts) $
 834          return a }
 835   where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
 836         pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)