Ticket #3193: ZDF5ex.hs

File ZDF5ex.hs, 56.4 KB (added by nr, 6 years ago)

Source file leading to error message with bad line number

Line 
1{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, KindSignatures, FlexibleContexts, GADTs #-}
2
3module ZDF5ex
4    ( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
5    , zdfSolveFrom, zdfRewriteFrom
6    , ForwardTransfers(..), BackwardTransfers(..)
7    , ForwardRewrites(..),  BackwardRewrites(..) 
8    , ForwardFixedPoint, BackwardFixedPoint
9    , zdfFpFacts
10    , zdfFpOutputFact
11    , zdfGraphChanged
12    , zdfDecoratedGraph -- not yet implemented
13    , zdfFpContents
14    , zdfFpLastOuts
15    , FuelMonad, liftUniq  -- re-export from OptimizationFuel
16    , DataflowPass(..)
17    )
18where
19
20#include "HsVersions.h"
21
22import BlockId
23import CmmTx
24import DFLattice
25import DFMonad2
26import OptimizationFuel as F
27import ZipGFex
28
29import UniqSupply -- temporary
30
31import Outputable
32import Panic
33
34import Control.Monad
35import Maybe
36
37{-
38
39This module implements two useful tools:
40
41  1. An iterative solver for dataflow problems
42
43  2. The combined dataflow-analysis-and-transformation framework
44     described by Lerner, Grove, and Chambers in their excellent
45     2002 POPL paper (http://tinyurl.com/3zycbr or
46     http://tinyurl.com/3pnscd).
47
48Each tool comes in two flavors: one for forward dataflow problems
49and one for backward dataflow problems.
50
51We quote the paper above:
52
53  Dataflow analyses can have mutually beneficial interactions.
54  Previous efforts to exploit these interactions have either
55  (1) iteratively performed each individual analysis until no
56  further improvements are discovered or (2) developed "super-
57  analyses" that manually combine conceptually separate anal-
58  yses. We have devised a new approach that allows anal-
59  yses to be defined independently while still enabling them
60  to be combined automatically and profitably. Our approach
61  avoids the loss of precision associated with iterating indi-
62  vidual analyses and the implementation difficulties of man-
63  ually writing a super-analysis.   
64
65The key idea is to provide at each CFG node not only a dataflow
66transfer function but also a rewriting function that has the option to
67replace the node with a new (possibly empty) graph.  The rewriting
68function takes a dataflow fact as input, and the fact is used to
69justify any rewriting.  For example, in a backward problem, the fact
70that variable x is dead can be used to justify rewriting node
71  x := e
72to the empty graph.  In a forward problem, the fact that x == 7 can
73be used to justify rewriting node
74  y := x + 1
75to
76  y := 8
77which in turn will be analyzed and produce a new fact:
78x == 7 and y == 8.
79
80In its most general form, this module takes as input graph, transfer
81equations, rewrites, and an initial set of dataflow facts, and
82iteratively computes a new graph and a new set of dataflow facts such
83that
84  * The set of facts is a fixed point of the transfer equations
85  * The graph has been rewritten as much as is consistent with
86    the given facts and requested rewriting depth (see below)
87N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'.
88
89The types of transfer equations, rewrites, and fixed points are
90different for forward and backward problems.  To avoid cluttering the
91name space with two versions of every names, other names such as
92zdfSolveFrom are overloaded to work in both forward or backward
93directions.  This design decision is based on experience with the
94predecessor module, now called ZipDataflow0 and destined for the bit bucket.
95
96
97This module is deliberately very abstract.  It is a completely general
98framework and well-nigh impossible to understand in isolation.  The
99cautious reader will begin with some concrete examples in the form of
100clients.  NR recommends
101
102  CmmLiveZ             A simple liveness analysis
103
104  CmmSpillReload.removeDeadAssignmentsAndReloads
105                       A piece of spaghetti to pull on, which leads to
106                         - a two-part liveness analysis that tracks
107                           variables live in registers and live on the stack
108                         - elimination of assignments to dead variables
109                         - elimination of redundant reloads
110
111Even hearty souls should avoid the CmmProcPointZ client, at least for
112the time being.
113
114-}   
115
116
117{- ============ TRANSFER FUNCTIONS AND REWRITES =========== -}
118
119-- | For a backward transfer, you're given the fact on a node's
120-- outedge and you compute the fact on the inedge.  Facts have type 'a'.
121-- A last node may have multiple outedges, each pointing to a labelled
122-- block, so instead of a fact it is given a mapping from BlockId to fact.
123
124data BackwardTransfers middle last a = BackwardTransfers
125    { bt_first_in  :: BlockId -> a              -> a
126    , bt_middle_in :: middle  -> a              -> a
127    , bt_last_in   :: last    -> (BlockId -> a) -> a
128    } 
129
130-- | For a forward transfer, you're given the fact on a node's
131-- inedge and you compute the fact on the outedge. Because a last node
132-- may have multiple outedges, each pointing to a labelled
133-- block, so instead of a fact it produces a list of (BlockId, fact) pairs.
134
135data ForwardTransfers middle last a = ForwardTransfers
136    { ft_first_out  :: BlockId -> a -> a
137    , ft_middle_out :: middle  -> a -> a
138    , ft_last_outs  :: last    -> a -> LastOutFacts a
139    } 
140
141newtype LastOutFacts a = LastOutFacts [(BlockId, a)] 
142  -- ^ These are facts flowing out of a last node to the node's successors.
143  -- They are either to be set (if they pertain to the graph currently
144  -- under analysis) or propagated out of a sub-analysis
145
146
147-- | A backward rewrite takes the same inputs as a backward transfer,
148-- but instead of producing a fact, it produces a replacement graph or Nothing.
149
150type O = ZOpen
151type C = ZClosed
152
153data BackwardRewrites middle last a = BackwardRewrites
154    { br_first  :: BlockId -> a              -> Maybe (ZipGF' middle last C O)
155    , br_middle :: middle  -> a              -> Maybe (ZipGF' middle last O O)
156    , br_last   :: last    -> (BlockId -> a) -> Maybe (ZipGF' middle last O C)
157    , br_entry  ::                              Maybe (ZipGF' middle last O O)
158    } 
159
160-- | A forward rewrite takes the same inputs as a forward transfer,
161-- but instead of producing a fact, it produces a replacement graph or Nothing.
162
163data ForwardRewrites middle last a = ForwardRewrites
164    { fr_first  :: BlockId -> a -> Maybe (ZipGF' middle last C O)
165    , fr_middle :: middle  -> a -> Maybe (ZipGF' middle last O O)
166    , fr_last   :: last    -> a -> Maybe (ZipGF' middle last O C)
167    , fr_exit   ::            a -> Maybe (ZipGF' middle last O O)
168    } 
169
170type ZipGF' m l e x = UniqSM (ZipGF m l e x) -- simulate monadic goo for now
171
172
173{- ===================== A DATAFLOW PASS =================== -}
174
175data DataflowPass transfers rewrites m l a
176  = DataflowPass { dfp_lattice   :: DataflowLattice a
177                 , dfp_transfers :: transfers m l a
178                 , dfp_rewrites  :: rewrites m l a
179                 }
180
181
182{- ===================== FIXED POINTS =================== -}
183
184-- | The result of combined analysis and transformation is a
185-- solution to the set of dataflow equations together with a 'contained value'.
186-- This solution is a member of type class 'FixedPoint', which is parameterized by
187--   * middle and last nodes 'm' and 'l'
188--   * data flow fact 'fact'
189--   * the type 'a' of the contained value
190--
191-- In practice, the contained value 'zdfFpContents' is either a
192-- rewritten graph, when rewriting, or (), when solving without
193-- rewriting.  A function 'zdfFpMap' allows a client to change
194-- the contents without changing other values.
195--
196-- To save space, we provide the solution 'zdfFpFacts' as a mapping
197-- from BlockId to fact; if necessary, facts on edges can be
198-- reconstructed using the transfer functions; this functionality is
199-- intended to be included as the 'zdfDecoratedGraph', but the code
200-- has not yet been implemented.
201--
202-- The solution may also includes a fact 'zdfFpOuputFact', which is
203-- not associated with any label:
204--   * for a backward problem, this is the fact at entry
205--   * for a forward problem, this is the fact at the distinguished exit node,
206--     if such a node is present
207--
208-- For a forward problem only, the solution includes 'zdfFpLastOuts',
209-- which is the set of facts on edges leaving the graph.
210--
211-- The flag 'zdfGraphChanged' tells whether the engine did any rewriting.
212
213class FixedPoint fp where
214    zdfFpContents     :: fp m l e x fact a -> a
215    zdfFpFacts        :: fp m l e x fact a -> BlockEnv fact
216    zdfFpOutputFact   :: fp m l e x fact a -> fact  -- entry for backward; exit for forward
217    zdfDecoratedGraph :: fp m l e x fact a -> ZipGF (fact, m) (fact, l) e x
218    zdfGraphChanged   :: fp m l e x fact a -> ChangeFlag
219    zdfFpMap          :: (a -> b) -> (fp m l e x fact a -> fp m l e x fact b)
220
221-- | The class 'FixedPoint' has two instances: one for forward problems and
222-- one for backward problems.  The 'CommonFixedPoint' defines all fields
223-- common to both.  (The instance declarations are uninteresting and appear below.)
224
225data CommonFixedPoint m l e x fact a = FP
226    { fp_facts     :: BlockEnv fact
227    , fp_out       :: fact  -- entry for backward; exit for forward
228    , fp_changed   :: ChangeFlag
229    , fp_dec_graph :: ZipGF (fact, m) (fact, l) e x
230    , fp_contents  :: a
231    }
232
233-- | The common fixed point is sufficient for a backward problem.
234type BackwardFixedPoint = CommonFixedPoint
235
236-- | A forward problem needs the common fields, plus the facts on the outedges.
237data ForwardFixedPoint m l e x fact a = FFP
238    { ffp_common    :: CommonFixedPoint m l e x fact a
239    , zdfFpLastOuts :: LastOutFacts fact
240    }
241
242
243instance FixedPoint CommonFixedPoint where
244    zdfFpFacts        = fp_facts
245    zdfFpOutputFact   = fp_out
246    zdfGraphChanged   = fp_changed
247    zdfDecoratedGraph = fp_dec_graph
248    zdfFpContents     = fp_contents
249    zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a)
250
251instance FixedPoint ForwardFixedPoint where
252    zdfFpFacts        = fp_facts     . ffp_common
253    zdfFpOutputFact   = fp_out       . ffp_common
254    zdfGraphChanged   = fp_changed   . ffp_common
255    zdfDecoratedGraph = fp_dec_graph . ffp_common
256    zdfFpContents     = fp_contents  . ffp_common
257    zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los
258
259
260
261-- | Extraction of the common fixed point, given a function to get the
262-- fact emerging from the graph
263cfp :: (b -> a) -> c -> DFM a b -> DFM a (CommonFixedPoint m l e x a c)
264cfp get_fact c solution =
265    do { b <- solution
266       ; let emerging = get_fact b
267       ; facts <- getAllFacts
268       ; return $ FP facts emerging NoChange (panic "decoration?!") c }
269
270-- | Extract a fixed point from a backward analysis
271bfp :: b -> DFM a a -> DFM a (BackwardFixedPoint m l e x a b)
272bfp = cfp id
273
274-- | Extract a fixed point from a forward analysis
275ffp :: b -> DFM a (Maybe a) -> DFM a (ForwardFixedPoint m l e x a b)
276ffp b exit = do { common <- cfp get_fact b exit
277                ; last_outs <- getLastOutFacts
278                ; return $ FFP common last_outs
279                }
280  where get_fact ma = fromMaybe (panic "exit of non-exitable graph") ma
281
282
283
284
285{- ============== SOLVING AND REWRITING ============== -}
286
287type PassName = String
288
289-- | 'zdfSolveFrom' is an overloaded name that resolves to a pure
290-- analysis with no rewriting.  It has only two instances: forward and
291-- backward.  Since it needs no rewrites, the type parameters of the
292-- class are transfer functions and the fixed point.
293--
294--
295-- An iterative solver normally starts with the bottom fact at every
296-- node, but it can be useful in other contexts as well.  For this
297-- reason the initial set of facts (at labelled blocks only) is a
298-- parameter to the solver. 
299--
300-- The constraints on the type signature exist purely for debugging;
301-- they make it possible to prettyprint nodes and facts.  The parameter of
302-- type 'PassName' is also used just for debugging.
303--
304-- Note that the result is a fixed point with no contents, that is,
305-- the contents have type ().
306--
307-- The intent of the rest of the type signature should be obvious.
308-- If not, place a skype call to norman-ramsey or complain bitterly
309-- to <[email protected]>.
310
311class DataflowSolverDirection transfers fixedpt where
312  zdfSolveFrom   :: (DebugNodes m l e x, LastNode l, Outputable a)
313                 => BlockEnv a        -- ^ Initial facts (unbound == bottom)
314                 -> PassName
315                 -> DataflowLattice a -- ^ Lattice
316                 -> transfers m l a   -- ^ Dataflow transfer functions
317                 -> a                 -- ^ Fact flowing in (at entry or exit)
318                 -> ZipGF m l e x     -- ^ Graph to be analyzed
319                 -> fixedpt m l e x a ()  -- ^ Answers
320
321-- There are exactly two instances: forward and backward
322instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
323  where zdfSolveFrom = solve_f
324
325instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
326  where zdfSolveFrom = solve_b
327
328solve_b, rewrite_b_agraph, forward_rew :: a
329solve_b = undefined
330rewrite_b_agraph = undefined
331forward_rew = undefined
332
333-- | zdfRewriteFrom is an overloaded name that resolves to an
334-- interleaved analysis and transformation.  It too is instantiated in
335-- forward and backward directions.
336--
337-- The type parameters of the class include not only transfer
338-- functions and the fixed point but also rewrites and the type
339-- constructor (here called 'graph') for making rewritten graphs.  As
340-- above, in the definitoins of the rewrites, it might simplify
341-- matters if 'graph' were replaced with 'ZipGF'.
342--
343-- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom'
344-- with additional parameters and a different result.  Of course the
345-- rewrites are an additional parameter.
346-- The resulting fixed point containts a rewritten graph.
347
348class DataflowSolverDirection transfers fixedpt =>
349      DataflowDirection transfers fixedpt rewrites where
350  zdfRewriteFrom :: (DebugNodes m l e x, Outputable a, LastNode l)
351                 => RewritingDepth      -- whether to rewrite a rewritten graph
352                 -> BlockEnv a          -- initial facts (unbound == botton)
353                 -> PassName
354                 -> DataflowLattice a
355                 -> transfers m l a
356                 -> rewrites m l a
357                 -> a                   -- fact flowing in (at entry or exit)
358                 -> ZipGF m l e x
359                 -> FuelMonad (fixedpt m l e x a (ZipGF m l e x))
360
361data RewritingDepth = RewriteShallow | RewriteDeep
362-- When a transformation proposes to rewrite a node,
363-- you can either ask the system to
364--  * "shallow": accept the new graph, analyse it without further rewriting
365--  * "deep": recursively analyse-and-rewrite the new graph
366
367
368-- There are currently four instances, but there could be more
369--      forward, backward (instantiates transfers, fixedpt, rewrites)
370--      ZipGF, ZipGF    (instantiates graph)
371
372instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites
373  where zdfRewriteFrom = rewrite_f_agraph
374
375instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites
376  where zdfRewriteFrom = rewrite_b_agraph
377
378
379{- =================== IMPLEMENTATIONS ===================== -}
380
381
382-----------------------------------------------------------
383--      solve_f: forward, pure
384
385solve_f         :: (DebugNodes m l e x, LastNode l, Outputable a)
386                => BlockEnv a        -- initial facts (unbound == bottom)
387                -> PassName
388                -> DataflowLattice a -- lattice
389                -> ForwardTransfers m l a   -- dataflow transfer functions
390                -> a
391                -> ZipGF m l e x        -- graph to be analyzed
392                -> ForwardFixedPoint m l e x a ()  -- answers
393solve_f env name lattice transfers in_fact g =
394   runWithoutFuel $ runDFM lattice $ ffp () $ liftM undefined $ 
395   fwd_pure_anal name env transfers (maybe_entry g in_fact) g
396
397maybe_entry :: ZipGF m l e x -> a -> ZMaybe e a
398maybe_entry (GF (ZE_C _) _ _) _ = ZNothing
399maybe_entry (GF (ZE_O _) _ _) a = ZJust a
400maybe_entry (GM _)            a = ZJust a
401   
402rewrite_f_agraph :: (DebugNodes m l e x, LastNode l, Outputable a)
403                 => RewritingDepth
404                 -> BlockEnv a
405                 -> PassName
406                 -> DataflowLattice a
407                 -> ForwardTransfers m l a
408                 -> ForwardRewrites  m l a
409                 -> a                 -- fact flowing in (at entry or exit)
410                 -> ZipGF m l e x
411                 -> FuelMonad (ForwardFixedPoint m l e x a (ZipGF m l e x))
412rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
413    runDFM lattice $
414    do fuel <- fuelRemaining
415       fp <- rewr_fp $ forward_rew maybeRewriteAndUseFuel depth start_facts name
416                       transfers rewrites in_fact g
417       fuel' <- fuelRemaining
418       fuelDecrement name fuel fuel'
419       return fp
420  where rewr_fp ga = do { (g, a) <- ga ; ffp g $ return a }
421
422maybeRewriteAndUseFuel :: Maybe b -> DFM a (Maybe b)
423maybeRewriteAndUseFuel Nothing = return Nothing
424maybeRewriteAndUseFuel (Just b) =
425    do { done <- fuelExhausted
426       ; if done then return Nothing
427         else fuelDec1 >> (return $ Just b) }
428
429
430  -- convert graph from form produced by rewrite function to form used internally
431importGraph :: ZipGF' m l e x -> DFM a (ZipGF m l e x)
432importGraph g = liftToDFM $ liftUniq $ g
433
434class (Outputable m, Outputable l, HavingSuccessors l, Outputable (ZipGF m l e x)) => DebugNodes m l e x
435
436fwd_pure_anal :: (DebugNodes m l e x, LastNode l, Outputable a)
437             => PassName
438             -> BlockEnv a
439             -> ForwardTransfers m l a
440             -> ZMaybe e a
441             -> ZipGF m l e x
442             -> DFM a (ZMaybe x a)
443
444fwd_pure_anal name env transfers in_fact g =
445    anal_f name env transfers panic_rewrites in_fact g
446  where -- definitely a case of "I love lazy evaluation"
447    anal_f = forward_sol (\_ -> return Nothing) panic_depth
448    panic_rewrites = panic "pure analysis asked for a rewrite function"
449    panic_depth    = panic "pure analysis asked for a rewrite depth"
450
451-----------------------------------------------------------------------
452--
453--      Here beginneth the super-general functions
454--
455--  Think of them as (typechecked) macros
456--   *  They are not exported
457--
458--   *  They are called by the specialised wrappers
459--      above, and always inlined into their callers
460--
461-- There are four functions, one for each combination of:
462--      Forward, Backward
463--      Solver, Rewriter
464--
465-- A "solver" produces a (DFM f (f, Fuel)),
466--      where f is the fact at entry(Bwd)/exit(Fwd)
467--      and from the DFM you can extract
468--              the BlockId->f
469--              the change-flag
470--              and more besides
471--
472-- A "rewriter" produces a rewritten *Graph* as well
473--
474-- Both constrain their rewrites by
475--      a) Fuel
476--      b) RewritingDepth: shallow/deep
477
478-----------------------------------------------------------------------
479
480data ZMaybe x a where
481  ZJust    :: a -> ZMaybe O a
482  ZNothing ::      ZMaybe C a
483
484unZMaybe :: ZMaybe x a -> Maybe a
485unZMaybe (ZJust a) = Just a
486unZMaybe (ZNothing) = Nothing
487
488fromZJust :: ZMaybe O a -> a
489fromZJust (ZJust a) = a
490
491 -- continuation types
492type FactKont a b = a              -> DFM a b
493type LOFsKont a b = LastOutFacts a -> DFM a b
494type Kont     a b =                   DFM a b
495type ZKont ex a b = ZMaybe ex a    -> DFM a b
496
497  -- solves a single-entry, at-most-one-exit, graph fragment given
498  -- an input fact a and input Fuel, producing a possible output fact
499  -- and remaining Fuel
500
501forward_sol
502        :: forall m l e x a . 
503           (DebugNodes m l e x, LastNode l, Outputable a)
504        => (forall b . Maybe b -> DFM a (Maybe b))
505                -- Squashes proposed rewrites if there is
506                -- no more fuel; OR if we are doing a pure
507                -- analysis, so totally ignore the rewrite
508                -- ie. For pure-analysis the fn is (\f _ -> (f, Nothing)).
509                -- Also accounts for fuel consumption.
510        -> RewritingDepth       -- Shallow/deep
511        -> PassName
512        -> BlockEnv a           -- Initial set of facts
513        -> ForwardTransfers m l a
514        -> ForwardRewrites m l a
515        -> ZMaybe e a                   -- Entry fact
516        -> ZipGF m l e x
517        -> DFM a (ZMaybe x a)
518forward_sol with_fuel = forw  -- see [Note inlining] below
519 where
520  forw :: RewritingDepth
521       -> PassName
522       -> BlockEnv a
523       -> ForwardTransfers m l a
524       -> ForwardRewrites m l a
525       -> ZMaybe e a
526       -> ZipGF m l e x
527       -> DFM a (ZMaybe x a)
528  forw depth name start_facts transfers rewrites =
529     \in_fact g -> do { setAllFacts start_facts ; solve_ex g in_fact  }
530   where 
531       -- the solver is executed mostly for side effect;
532       -- it may take an OO or OC graph.
533     solve_ex :: ZipGF m l e x -> ZKont e a (ZMaybe x a)
534     solve_ex (GM mids) (ZJust a) = solve_mids mids (return . ZJust) a
535     solve_ex (GM _) (ZNothing) = can't_match
536     solve_ex g@(GF entry blocks exit) in' =
537         do { set_locals blocks exit
538            ; solve_entry entry set_last in'
539            ; solve_blocks (postorder_dfs g) 
540            ; solve_exit exit }
541       where set_locals :: BlockEnv (Block m l) -> ZExit m x -> DFM a ()
542             set_locals blocks (ZX_O exit) = set_local_blocks_with_exit blocks exit
543             set_locals blocks ZX_C = set_local_blocks blocks
544     solve_entry :: ZEntry m l e -> LOFsKont a b -> ZKont e a b
545     solve_exit  :: ZExit m x    -> Kont a (ZMaybe x a)
546     solve_entry (ZE_O tail) k (ZJust a) = solve_tail tail k a
547     solve_entry (ZE_C _) k (ZNothing) = k $ LastOutFacts []
548     solve_entry _ _ _ = can't_match
549     solve_exit  (ZX_O head) = solve_head head (return . ZJust)
550     solve_exit  (ZX_C)      = return ZNothing
551
552     -- From here out, we present myriad solver functions, starting with
553     -- individual nodes and working our way up to graphs
554
555
556
557     -- not clear where to put this tidbit---it's the side-effecting action that
558     -- updates the internal state of the dataflow monad.  Everything else boils
559     -- down to calling @set_last@ to do the deed...   XXX
560
561     set_last :: LOFsKont a ()
562     set_last (LastOutFacts l) = mapM_ (uncurry setFact) l
563
564     -- In order to compose continuations, the order of arguments no longer
565     -- reflects the flow of a fact through a node.  Instead we want to
566     -- be able to partially apply a solver to a thing and take the
567     -- input fact and fuel as later arguments.
568
569     -- XXX we would like to see if solve_first, solve_mid, and solve_last
570     -- can each be obtained as a partial application of a single higher-order
571     -- function.  We just want to know if it can be done, even if we believe
572     -- the higher-order version may be harder to understand and therefore
573     -- not worthy to be deployed.
574
575     ----------- SOLVER FUNCTIONS FOR NODES --------------
576
577       -- the types are all CPS-style types, but with three different
578       -- types of continuations which very by enterability and exitability
579
580     solve_first :: BlockId -> FactKont a b -> Kont     a b
581     solve_first id k =
582       do { idfact <- getFact id
583          ; (with_fuel $ fr_first rewrites id idfact) >>= \x -> case x of
584              Nothing -> k (ft_first_out transfers id idfact) 
585              Just g ->
586                  do { g <- importGraph g
587                     ; a <- subAnalysis' $
588                          case depth of
589                            RewriteDeep -> solve_CO' id g return
590                            RewriteShallow -> anal_f_CO g
591                     ; k a } }
592
593     solve_mid :: m -> FactKont a b -> FactKont a b
594     solve_mid m k in' =
595       (with_fuel $ fr_middle rewrites m in') >>= \x -> case x of
596         Nothing -> k (ft_middle_out transfers m in') 
597         Just g ->
598           do { g <- importGraph g
599              ; a <- subAnalysis' $
600                   case depth of
601                     RewriteDeep -> solve_OO' g return in'
602                     RewriteShallow -> anal_f_OO g in'
603              ; k a }
604
605     solve_last :: l -> LOFsKont a b -> FactKont a b
606     solve_last l k in' =
607      (with_fuel $ fr_last rewrites l in') >>= \x -> case x of
608         Nothing -> k (ft_last_outs transfers l in')
609         Just g ->
610           do { g <- importGraph g
611              ; (last_outs :: LastOutFacts a) <- subAnalysis' $
612                  case depth of
613                    RewriteDeep -> solve_OC' g return in'
614                    RewriteShallow -> anal_f_OC g in'
615              ; k last_outs } 
616
617     ----------- SOLVER FUNCTIONS FOR SEQUENCES OF NODES -----------
618
619     solve_mids :: ZMids m -> FactKont a b -> FactKont a b
620     solve_mids (ZUnit)      = id
621     solve_mids (ZMid m)     = solve_mid m
622     solve_mids (ZCat m1 m2) = solve_mids m1 . solve_mids m2
623         
624     solve_tail :: ZTail m l -> LOFsKont a b -> FactKont a b
625     solve_tail (ZTail m t) = solve_mid m . solve_tail t
626     solve_tail (ZLast l)   = solve_last l
627
628     solve_head :: ZHead m -> FactKont a b -> Kont a b
629     solve_head (ZHead h m) = solve_head h . solve_mid m
630     solve_head (ZFirst id) = solve_first id
631
632     solve_block :: Block m l -> Kont a ()
633     solve_block (Block id tail) = solve_first id $ solve_tail tail $ set_last
634
635     ----------- SOLVER FUNCTIONS FOR GRAPHS --------------
636
637     solve_blocks :: [Block m l] -> Kont a ()
638     solve_blocks = run "forward" name solve_block
639        --- the reason this falls out so nicely is that solve_block
640        --- is executed only for side effect (just like the old
641        --- 'set_successor_facts'
642
643       -- primed functions perform dynamic checks; we may one day
644       -- want to refine types to eliminate the dynamic checks
645     solve_CO' :: BlockId -> ZipGF m l C O -> FactKont a b -> Kont     a b
646     solve_OO' ::            ZipGF m l O O -> FactKont a b -> FactKont a b
647     solve_OC' ::            ZipGF m l O C -> LOFsKont a b -> FactKont a b
648
649     solve_CO' id (GF (ZE_C id2) blocks (ZX_O exit)) =
650         ASSERT( id == id2 ) solve_CO id2 blocks exit
651     solve_CO' _ _ = can't_match
652                                                                   
653     solve_OO' (GM mids) = solve_mids mids
654     solve_OO' (GF (ZE_O entry) blocks (ZX_O exit)) = solve_OO entry blocks exit
655     solve_OO' _ = can't_match
656                                                                   
657     solve_OC' (GF (ZE_O entry) blocks ZX_C) = solve_OC entry blocks
658     solve_OC' _ = can't_match
659                                                                     
660       -- from here down, the dynamic checks have already been done
661     solve_CO :: BlockId   -> BlockEnv (Block m l) -> ZHead m
662               -> FactKont a b -> Kont     a b
663     solve_OO :: ZTail m l -> BlockEnv (Block m l) -> ZHead m
664               -> FactKont a b -> FactKont a b
665     solve_OC :: ZTail m l -> BlockEnv (Block m l)
666               -> LOFsKont a b -> FactKont a b
667         
668     solve_OO entry blocks exit k in' =
669         do { set_local_blocks_with_exit blocks exit
670            ; solve_tail entry set_last in'
671            ; solve_blocks (postorder_dfs_from blocks entry) 
672            ; solve_head exit k }
673
674     solve_CO id blocks exit k = 
675         do { set_local_blocks_with_exit blocks exit
676            ; solve_blocks (postorder_dfs_from blocks (BlockPtr id))
677            ; solve_head exit k }
678
679     solve_OC entry blocks k in' = 
680         do { set_local_blocks blocks
681            ; solve_tail entry set_last in'
682            ; solve_blocks (postorder_dfs_from blocks entry) 
683            ; facts <- getLastOutFacts
684            ; k facts }
685
686       ----------- ANALYSIS FUNCTIONS FOR SHALLOW REWRITING --------
687
688       -- inputs of each analysis depend on whether entry is open;
689       -- outputs depend on whether exit is open:
690     anal_f_OO :: ZipGF m l O O -> a -> DFM a a
691     anal_f_OC :: ZipGF m l O C -> a -> DFM a (LastOutFacts a)
692     anal_f_CO :: ZipGF m l C O ->      DFM a a
693
694       -- we have only one top-level analysis, so we specialize anal_f
695     anal_f_OO g = anal_f g (return . fromZJust) . ZJust
696     anal_f_OC g = anal_f g (\ _ -> getLastOutFacts) . ZJust
697     anal_f_CO g = anal_f g (return . fromZJust) ZNothing
698
699     anal_f :: ZipGF m l e x -> (ZKont x a b) -> ZKont e a b
700     anal_f g finish in' = getAllFacts >>= \env ->
701                           fwd_pure_anal name env transfers in' g >>= finish
702         -- XXX is this correct or do we want the empty env?
703
704
705newtype BlockPtr = BlockPtr BlockId -- pointer to a successor block
706instance HavingSuccessors BlockPtr where
707  fold_succs add (BlockPtr id) z = add id z
708
709set_local_blocks           :: (DataflowAnalysis df) => BlockEnv b ->            df a ()
710set_local_blocks_with_exit :: (DataflowAnalysis df) => BlockEnv b -> ZHead m -> df a ()
711set_local_blocks blockenv = setInternalBlocks $ is_internal blockenv
712set_local_blocks_with_exit blockenv exit = 
713     setInternalBlocks $ is_internal blockenv `orp` (== label exit)
714  where label (ZFirst id) = id
715        label (ZHead h _) = label h
716        orp p q x = p x || q x
717
718is_internal :: BlockEnv a -> BlockId -> Bool
719is_internal env = isJust . lookupBlockEnv env
720
721getLastOutFacts :: DFM f (LastOutFacts f)
722getLastOutFacts = bareLastOutFacts >>= return . LastOutFacts
723
724
725type GraphFactKont  m l e x a b = ZipGF m l e x -> a -> DFM a b
726type GraphKont      m l e x a b = ZipGF m l e x      -> DFM a b
727
728{-
729forward_rew
730        :: forall m l e x a .
731           (DebugNodes m l e x, LastNode l, Outputable a)
732        => (forall b . Maybe b -> DFM a (Maybe b))
733        -> RewritingDepth
734        -> BlockEnv a
735        -> PassName
736        -> ForwardTransfers m l a
737        -> ForwardRewrites m l a
738        -> a
739        -> ZipGF m l
740        -> DFM a (ZipGF m l, Maybe a)
741forward_rew with_fuel = forw
742  where
743    forw :: RewritingDepth
744         -> BlockEnv a
745         -> PassName
746         -> ForwardTransfers m l a
747         -> ForwardRewrites m l a
748         -> a
749         -> ZipGF m l
750         -> DFM a (ZipGF m l, Maybe a)
751    forw depth start_facts name transfers rewrites in_fact g =
752        do setAllFacts start_facts
753           sar_Ox g (\ma g -> return (g, ma)) in_fact
754      where
755          ----------- REWRITE FUNCTIONS FOR NODES --------------
756        rew_first :: BlockId -> GraphFactKont m l e x a b -> GraphKont m l e x a b
757        rew_first id k head =
758          do a <- getFact id
759             (with_fuel $ fr_first rewrites id a) >>= \x -> case x of
760               Nothing -> k (head `appId` id) (ft_first_out transfers id a)
761               Just g ->
762                   do { markGraphRewritten
763                      ; g <- importGraph g
764                      ; (g, a) <- subAnalysis' $
765                          case depth of
766                            RewriteDeep    -> sar_CO id g return2
767                            RewriteShallow -> do { a <- anal_f_CO id g; return (g, a) }
768                      ; k (head <*> g) a }
769
770        rew_mid :: m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
771        rew_mid m k head in' =
772          my_trace "Rewriting middle node" (ppr m) $
773          (with_fuel $ fr_middle rewrites m in') >>= \x -> case x of
774            Nothing -> k (head `appMid` m) (ft_middle_out transfers m in')
775            Just g ->
776                do { markGraphRewritten
777                   ; g <- importGraph g
778                   ; (g, a) <- subAnalysis' $
779                        case depth of
780                          RewriteDeep -> sar_OO g return2 in'
781                          RewriteShallow -> do { a <- anal_f_OO g in'; return (g, a) }
782                   ; k (head <*> g) a }
783
784        rew_last :: l -> GraphKont m l e x a b -> GraphFactKont m l e x a b
785        rew_last l k head in' =
786          my_trace "Rewriting last node" (ppr l) $
787          (with_fuel $ fr_last rewrites l in') >>= \x -> case x of
788            Nothing -> do check_facts in' l   -- redundant error checking
789                          k (head <=*> (ZLast l::ZTail m l))
790            Just g ->
791                do { markGraphRewritten
792                   ; g <- importGraph g
793                   ; g <- subAnalysis' $
794                            case depth of
795                              RewriteDeep -> sar_OC g return in'
796                              RewriteShallow -> return g
797                   ; k (head <*> g) }
798
799         where check_facts in' l =
800                    let LastOutFacts last_outs = ft_last_outs transfers l in'
801                    in mapM (uncurry checkFactMatch) last_outs
802
803         ----------- REWRITE FUNCTIONS FOR SEQUENCES OF NODES --------------
804        rew_mids :: ZMids m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
805        rew_mids (ZUnit)      = id
806        rew_mids (ZMid m)     = rew_mid m
807        rew_mids (ZCat m1 m2) = rew_mids m1 . rew_mids m2
808
809        rew_tail :: ZTail m l -> GraphKont m l e x a b -> GraphFactKont m l e x a b
810        rew_tail (ZTail m t) = rew_mid m . rew_tail t
811        rew_tail (ZLast l)   = rew_last l
812
813        rew_head :: ZHead m -> GraphFactKont m l e x a b -> GraphKont m l e x a b
814        rew_head (ZHead h m) = rew_head h . rew_mid m
815        rew_head (ZFirst id) = rew_first id
816
817        rew_block :: Block m l -> GraphKont m l e x a b -> GraphKont m l e x a b
818        rew_block (Block id tail) = rew_first id . rew_tail tail
819
820        rew_blocks :: [Block m l] -> GraphKont m l e x a b -> GraphKont m l e x a b
821        rew_blocks = flip (foldr rew_block)
822           -- 'foldl (flip rew_block)' might consume less stack than 'foldr rew_block'?
823
824         -------- ANALYSIS FUNCTIONS FOR NON-REWRITTEN GRAPHS -----
825          -- this code is almost exact duplicate of solver code
826        anal_f :: (Maybe a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b
827        anal_f finish g in' = subAnalysis $
828          do { env <- getAllFacts ; fwd_pure_anal name env transfers in' g >>= finish }
829
830        anal_f_OO :: ZipGF m l e x -> a -> DFM a a
831        anal_f_OO = anal_f (return . fromMaybe (panic "no exit fact?!"))
832
833        anal_f_CO :: BlockId -> ZipGF m l e x -> DFM a a
834        anal_f_CO id g = botFact >>= anal_f_OO (mkLast (mkBranchNode id) <*> g)
835          -- exact duplicate ends
836
837        solve :: GraphFactKont m l e x a (Maybe a)
838        solve g in' =
839          do { facts <- getAllFacts
840             ; forward_sol with_fuel depth name facts transfers rewrites in' g }
841
842
843         -------- SOLVE-AND-REWRITE COMBINATIONS FOR GRAPHS ----------
844           -- sar_ex == solve-and-rewrite entry exit
845
846        sar_Ox :: ZipGF m l e x -> (Maybe a -> GraphKont m l e x a b) -> FactKont a b
847        sar_Ox g@(GF _ _ Nothing) pre_k = sar_OC g (pre_k Nothing)
848        sar_Ox g pre_k = sar_OO g (\g a -> pre_k (Just a) g)
849
850        sar_OO ::            ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b
851        sar_CO :: BlockId -> ZipGF m l e x -> GraphFactKont m l e x a b -> Kont     a b
852        sar_OC ::            ZipGF m l e x -> GraphKont     m l e x a b -> FactKont a b
853
854        sar_OO g k in' = solve g in' >> rew_OO' g k emptyZipGF in'
855        sar_OC g k in' = solve g in' >> rew_OC' g k emptyZipGF in'
856        sar_CO id g k =
857         do { in' <- botFact; solve g' in' ; rew_CO' id g k emptyZipGF }
858         where g' = mkLast (mkBranchNode id) <*> g
859
860         ----------------- REWRITE FUNCTIONS FOR GRAPHS ---------------
861        rew_OO' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
862        rew_OC' :: ZipGF m l e x -> GraphKont m l e x a b -> GraphFactKont m l e x a b
863        rew_CO' :: BlockId -> ZipGF m l e x -> GraphFactKont m l e x a b -> GraphKont m l e x a b
864
865        rew_OO' (GM mids) = rew_mids mids
866        rew_OO' (GF (Just entry) blockenv (Just exit)) = rew_OO entry blockenv exit
867        rew_OO' _ = panic "EX graph missing entry or exit"
868
869        rew_OC' (GF (Just entry) blockenv Nothing) = rew_OC entry blockenv
870        rew_OC' _ = panic "EJ graph is exitable"
871
872        rew_CO' id (GF Nothing blockenv (Just exit)) = rew_CO id blockenv exit
873        rew_CO' _ _ = panic "BX graph is enterable"
874
875        rew_OO :: ZTail m l e x -> BlockEnv (Block m l) -> ZHead m
876               -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
877        rew_OC :: ZTail m l e x -> BlockEnv (Block m l)
878               -> GraphKont m l e x a b -> GraphFactKont m l e x a b
879        rew_CO :: BlockId -> BlockEnv (Block m l)  -> ZHead m
880               -> GraphFactKont m l e x a b -> GraphKont m l e x a b
881
882        rew_OO entry blockenv exit =
883            rew_tail entry .
884            rew_blocks (postorder_dfs_from blockenv entry) .
885            rew_head exit
886
887        rew_OC entry blockenv =
888            rew_tail entry .
889            rew_blocks (postorder_dfs_from blockenv entry)
890
891        rew_CO id blockenv exit =
892            rew_blocks (postorder_dfs_from blockenv (BlockPtr id)) .
893            rew_head exit
894-}
895
896return2 :: Monad m => a -> b -> m (a, b)
897return2 = curry return
898
899{-
900{- ================== ONCE MORE, ONLY BACKWARD THIS TIME =========================== -}
901
902solve_b         :: (DebugNodes m l e x, Outputable a)
903                => BlockEnv a        -- initial facts (unbound == bottom)
904                -> PassName
905                -> DataflowLattice a -- lattice
906                -> BackwardTransfers m l a   -- dataflow transfer functions
907                -> a                 -- exit fact
908                -> ZipGF m l e x         -- graph to be analyzed
909                -> BackwardFixedPoint m l e x a ()  -- answers
910solve_b env name lattice transfers exit_fact g =
911   runWithoutFuel $ runDFM lattice $ bfp () $
912   bwd_pure_anal name env transfers g exit_fact
913   
914
915rewrite_b_agraph :: (DebugNodes m l e x, Outputable a)
916                 => RewritingDepth
917                 -> BlockEnv a
918                 -> PassName
919                 -> DataflowLattice a
920                 -> BackwardTransfers m l a
921                 -> BackwardRewrites m l a
922                 -> a                 -- fact flowing in at exit
923                 -> ZipGF m l
924                 -> FuelMonad (BackwardFixedPoint m l e x a (ZipGF m l))
925rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
926   runDFM lattice $
927   do fuel <- fuelRemaining
928      fp <- rewr_fp $ backward_rew maybeRewriteAndUseFuel depth start_facts name
929                      transfers rewrites g exit_fact
930      fuel' <- fuelRemaining
931      fuelDecrement name fuel fuel'
932      return fp
933  where rewr_fp ga = do { (g, a) <- ga ; bfp g $ return a }
934
935
936bwd_pure_anal :: (DebugNodes m l e x, HavingSuccessors l, Outputable a)
937              => PassName
938              -> BlockEnv a
939              -> BackwardTransfers m l a
940              -> ZipGF m l
941              -> a
942              -> DFM a a
943
944bwd_pure_anal name env transfers g exit_fact =
945    anal_b name env transfers panic_rewrites g exit_fact
946  where -- another case of "I love lazy evaluation"
947    anal_b = backward_sol (\ _ -> return Nothing) panic_depth
948    panic_rewrites = panic "pure analysis asked for a rewrite function"
949    panic_depth    = panic "pure analysis asked for a rewrite depth"
950
951
952
953backward_sol :: forall m l e x a .
954                (DebugNodes m l e x, HavingSuccessors l, Outputable a)
955             => (forall b . Maybe b -> DFM a (Maybe b))
956             -> RewritingDepth
957             -> PassName
958             -> BlockEnv a
959             -> BackwardTransfers m l a
960             -> BackwardRewrites m l a
961             -> ZipGF m l
962             -> a
963             -> DFM a a
964backward_sol with_fuel = back  -- see [Note inlining] below
965 where
966  back :: RewritingDepth
967       -> PassName
968       -> BlockEnv a
969       -> BackwardTransfers m l a
970       -> BackwardRewrites m l a
971       -> ZipGF m l
972       -> a
973       -> DFM a a
974  back depth name start_facts transfers rewrites =
975     \ g exit_fact -> do { setAllFacts start_facts; solve_Ox g exit_fact }
976   where
977     solve_Ox :: ZipGF m l e x -> FactKont a a
978     solve_Ox g@(GF Nothing _ _) = \_ -> solve_OC' g return
979     solve_Ox g                  =       solve_OO' g return
980
981     ----------- SOLVER FUNCTIONS FOR NODES --------------
982     solve_first :: BlockId -> Kont     a b -> FactKont a b
983     solve_first id k a =
984       (with_fuel $ br_first rewrites id a) >>= \x -> case x of
985         Nothing -> do { my_trace "solve_first" (ppr id <+> text "=" <+>
986                                                   ppr (bt_first_in transfers id a)) $
987                         setFact id $ bt_first_in transfers id a
988                       ; k }
989         Just g ->
990             do { g <- importGraph g
991                ; my_trace "analysis rewrites first node" (ppr id <+> ppr g) $
992                  subAnalysis' $
993                    case depth of
994                      RewriteDeep -> solve_CO' id g (return ()) a
995                      RewriteShallow -> anal_b_CO g a
996                ; k }
997
998     solve_mid :: m -> FactKont a b -> FactKont a b
999     solve_mid m k a =
1000       (with_fuel $ br_middle rewrites m a) >>= \x -> case x of
1001         Nothing -> k (bt_middle_in transfers m a)
1002         Just g ->
1003             do { g <- importGraph g
1004                ; a <-
1005                    my_trace "analysis rewrites middle node" (ppr m <+> ppr g) $
1006                    subAnalysis' $
1007                       case depth of
1008                         RewriteDeep -> solve_OO' g return a
1009                         RewriteShallow -> anal_b_OO g a
1010                ; k a }
1011
1012     solve_last :: l -> FactKont a b -> Kont     a b
1013     solve_last l k =
1014       do env <- factsEnv
1015          (with_fuel $ br_last rewrites l env) >>= \x -> case x of
1016            Nothing -> k (bt_last_in transfers l env)
1017            Just g ->
1018              do { g <- importGraph g
1019                 ; a <-
1020                       my_trace "analysis rewrites last node" (ppr l <+> ppr g) $
1021                       subAnalysis' $
1022                         case depth of
1023                           RewriteDeep -> solve_OC' g return
1024                           RewriteShallow -> anal_b_OC g
1025                 ; k a }
1026                     
1027     ----------- SOLVER FUNCTIONS FOR SEQUENCES OF NODES -----------
1028
1029        -- bodies and type signatures are dual to forward case
1030        -- (swap FactKont and Kont)
1031     solve_mids :: ZMids m -> FactKont a b -> FactKont a b
1032     solve_mids (ZUnit)      = id
1033     solve_mids (ZMid m)     = solve_mid m
1034     solve_mids (ZCat m1 m2) = solve_mids m2 . solve_mids m1
1035         
1036     solve_tail :: ZTail m l -> FactKont a b -> Kont a b
1037     solve_tail (ZTail m t) = solve_tail t . solve_mid m
1038     solve_tail (ZLast l)   = solve_last l
1039
1040     solve_head :: ZHead m -> Kont a b -> FactKont a b
1041     solve_head (ZHead h m) = solve_mid m . solve_head h
1042     solve_head (ZFirst id) = solve_first id
1043
1044     solve_block :: Block m l -> Kont a ()
1045     solve_block (Block id tail) = solve_tail tail $ solve_first id $ return ()
1046
1047     ----------- SOLVER FUNCTIONS FOR GRAPHS --------------
1048
1049     solve_blocks :: [Block m l] -> Kont a ()
1050     solve_blocks = run "backward" name solve_block
1051
1052       -- primed functions perform dynamic checks; we may one day
1053       -- want to refine types to eliminate the dynamic checks
1054     solve_CO' :: BlockId -> ZipGF m l e x -> Kont     a b -> FactKont a b
1055     solve_OO' ::            ZipGF m l e x -> FactKont a b -> FactKont a b
1056     solve_OC' ::            ZipGF m l e x -> FactKont a b -> Kont     a b
1057
1058     solve_CO' id (GF Nothing blocks (Just exit)) = solve_CO id blocks exit
1059     solve_CO' _ _ = panic "solve_CO given enterable or unexitable graph"
1060                                                                   
1061     solve_OO' (GM mids) = solve_mids mids
1062     solve_OO' (GF (Just entry) blocks (Just exit)) = solve_OO entry blocks exit
1063     solve_OO' _ = panic "solve_OO given unenterable or unexitable graph"
1064                                                                   
1065     solve_OC' (GF (Just entry) blocks Nothing) = solve_OC entry blocks
1066     solve_OC' _ = panic "solve_OC given unenterable or exitable graph"
1067                                                                     
1068       -- from here down, the dynamic checks have already been done
1069     solve_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m
1070               -> Kont     a b -> FactKont a b
1071     solve_OO :: ZTail m l -> BlockEnv (Block m l) -> ZHead m
1072               -> FactKont a b -> FactKont a b
1073     solve_OC :: ZTail m l -> BlockEnv (Block m l)
1074               -> FactKont a b -> Kont     a b
1075         
1076     solve_OO entry blocks exit k a =
1077         do { set_local_blocks_with_exit blocks exit
1078            ; solve_head exit (return ()) a
1079            ; solve_blocks (reverse $ postorder_dfs_from blocks entry)
1080            ; solve_tail entry k }
1081
1082     solve_CO id blocks exit k a =
1083         do { set_local_blocks_with_exit blocks exit
1084            ; solve_head exit (return ()) a
1085            ; solve_blocks (reverse $ postorder_dfs_from blocks (BlockPtr id))
1086            ; k }
1087
1088     solve_OC entry blocks k =
1089         do { set_local_blocks blocks
1090            ; solve_blocks (reverse $ postorder_dfs_from blocks entry)
1091            ; solve_tail entry k }
1092
1093       ----------- ANALYSIS FUNCTIONS FOR SHALLOW REWRITING --------
1094
1095       -- inputs of each analysis depend on whether exit is open;
1096       -- outputs depend on whether entry is open:
1097     anal_b_OO :: ZipGF m l e x -> a -> DFM a a
1098     anal_b_OC :: ZipGF m l e x ->      DFM a a
1099     anal_b_CO :: ZipGF m l e x -> a -> DFM a ()
1100
1101       -- we have only one top-level analysis, so we specialize anal_b
1102     anal_b_OO = anal_b return
1103     anal_b_OC g = do a <- return $ panic "closed graph used exit fact"
1104                      anal_b return g a
1105     anal_b_CO = anal_b (const $ return ())
1106
1107     anal_b :: (a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b
1108     anal_b finish g a = getAllFacts >>= \env ->
1109                         bwd_pure_anal name env transfers g a >>= finish
1110         -- XXX is this correct or do we want the empty env?
1111
1112
1113{- ================================================================ -}
1114
1115backward_rew
1116        :: forall m l e x a .
1117           (DebugNodes m l e x, HavingSuccessors l, Outputable a)
1118        => (forall b . Maybe b -> DFM a (Maybe b))
1119        -> RewritingDepth
1120        -> BlockEnv a
1121        -> PassName
1122        -> BackwardTransfers m l a
1123        -> BackwardRewrites m l a
1124        -> ZipGF m l
1125        -> a
1126        -> DFM a (ZipGF m l, a)
1127backward_rew with_fuel = back -- see [Note inline]
1128  where
1129    back :: RewritingDepth
1130         -> BlockEnv a
1131         -> PassName
1132         -> BackwardTransfers m l a
1133         -> BackwardRewrites m l a
1134         -> ZipGF m l
1135         -> a
1136         -> DFM a (ZipGF m l, a)
1137    back depth start_facts name transfers rewrites gx exit_fact =
1138        do { setAllFacts start_facts; sar_Ox gx return2 exit_fact }
1139     where
1140          ----------- REWRITE FUNCTIONS FOR NODES --------------
1141       rew_first :: BlockId -> GraphKont m l e x a b -> GraphFactKont m l e x a b
1142       rew_first id k tail a =
1143           (with_fuel $ br_first rewrites id a) >>= \x -> case x of
1144             Nothing -> check_k (mkLabel id <*> tail) (bt_first_in transfers id a)
1145             Just g ->
1146                 do { markGraphRewritten
1147                    ; g <- importGraph g
1148                    ; my_trace "Rewrote first node"
1149                         (f4sep [ppr id <> colon, text "to", ppr g]) $ return ()
1150                    ; g <-
1151                        case depth of
1152                          RewriteDeep -> sar_CO id g return a
1153                          RewriteShallow -> do { anal_b_CO g a; return g }
1154                    ; k (g <*> tail) }
1155         where check_k tail a =
1156                   do { if check then checkFactMatch id a else return ()
1157                      ; k tail }
1158
1159       rew_mid :: m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
1160       rew_mid m k tail a =
1161         (with_fuel $ br_middle rewrites m a) >>= \x -> case x of
1162           Nothing -> k (m `preMid` tail) (bt_middle_in transfers m a)
1163           Just g ->
1164               do { markGraphRewritten
1165                  ; g <- importGraph g
1166                  ; my_trace "With Facts" (ppr a) $ return ()
1167                  ; my_trace "  Rewrote middle node"
1168                                             (f4sep [ppr m, text "to", ppr g]) $
1169                    return ()
1170                  ; (g, a) <-
1171                      case depth of
1172                        RewriteDeep    -> sar_OO g return2 a
1173                        RewriteShallow -> do { a <- anal_b_OO g a; return (g, a) }
1174                  ; k (g <*> tail) a }
1175
1176       rew_last :: l -> GraphFactKont m l e x a b -> GraphKont m l e x a b
1177       rew_last l k tail =
1178         do { env <- factsEnv
1179            ; (with_fuel $ br_last rewrites l env) >>= \x -> case x of
1180                Nothing ->
1181                    k (mkLast l <*> tail) (bt_last_in transfers l env)
1182                Just g ->
1183                    do { markGraphRewritten
1184                       ; g <- importGraph g
1185                       ; (g, a) <-
1186                           case depth of
1187                             RewriteDeep -> sar_OC g return2
1188                             RewriteShallow -> do { a <- anal_b_OC g; return (g, a) }
1189                       ; k (g <*> tail) a } }
1190
1191        ----------- REWRITE FUNCTIONS FOR SEQUENCES OF NODES --------------
1192       rew_mids :: ZMids m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
1193       rew_mids (ZUnit)      = id
1194       rew_mids (ZMid m)     = rew_mid m
1195       rew_mids (ZCat m1 m2) = rew_mids m2 . rew_mids m1
1196
1197       rew_tail :: ZTail m l -> GraphFactKont m l e x a b -> GraphKont m l e x a b
1198       rew_tail (ZTail m t) = rew_tail t . rew_mid m
1199       rew_tail (ZLast l)   = rew_last l
1200
1201       rew_head :: ZHead m -> GraphKont m l e x a b -> GraphFactKont m l e x a b
1202       rew_head (ZHead h m) = rew_mid m . rew_head h
1203       rew_head (ZFirst id) = rew_first id
1204
1205       rew_block :: Block m l -> GraphKont m l e x a b -> GraphKont m l e x a b
1206       rew_block (Block id tail) = rew_tail tail . rew_first id
1207
1208       rew_blocks :: [Block m l] -> GraphKont m l e x a b -> GraphKont m l e x a b
1209       rew_blocks = flip (foldr rew_block)
1210          -- 'foldl (flip rew_block)' might consume less stack than 'foldr rew_block'?
1211
1212
1213        -------- ANALYSIS FUNCTIONS FOR NON-REWRITTEN GRAPHS -----
1214         -- this code is almost exact duplicate of solver code
1215       anal_b :: (a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b
1216       anal_b finish g a = subAnalysis $
1217         do { env <- getAllFacts ; bwd_pure_anal name env transfers g a >>= finish }
1218
1219       anal_b_OO :: ZipGF m l e x -> a -> DFM a a
1220       anal_b_OO = anal_b return
1221
1222       anal_b_CO :: ZipGF m l e x -> a -> DFM a ()
1223       anal_b_CO = anal_b (const $ return ())
1224
1225       anal_b_OC :: ZipGF m l e x -> DFM a a
1226       anal_b_OC = \g -> anal_b return g (panic "closed graph used exit fact")
1227         -- exact duplicate ends
1228
1229       solve :: GraphFactKont m l e x a a
1230       solve g a =
1231         do { facts <- getAllFacts
1232            ; backward_sol with_fuel depth name facts transfers rewrites g a }
1233
1234         -------- SOLVE-AND-REWRITE COMBINATIONS FOR GRAPHS ----------
1235           -- sar_ex == solve-and-rewrite entry exit
1236
1237       sar_Ox :: ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b
1238       sar_Ox g@(GF _ _ Nothing) = \ k _ -> sar_OC g k
1239       sar_Ox g = sar_OO g
1240
1241
1242       sar_OO ::            ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b
1243       sar_CO :: BlockId -> ZipGF m l e x -> GraphKont     m l e x a b -> FactKont a b
1244       sar_OC ::            ZipGF m l e x -> GraphFactKont m l e x a b -> Kont     a b
1245
1246
1247       sar_OO    g k a = solve g a  >> rew_OO'    g k emptyZipGF a
1248       sar_OC    g k   = solve g nx >> rew_OC'    g k emptyZipGF 
1249       sar_CO id g k a = solve g a  >> rew_CO' id g k emptyZipGF a
1250
1251       nx = panic "non-exitable graph tried to use exit fact"
1252
1253        ----------------- REWRITE FUNCTIONS FOR GRAPHS ---------------
1254       rew_OO' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
1255       rew_OC' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphKont     m l e x a b
1256       rew_CO' :: BlockId -> ZipGF m l e x -> GraphKont m l e x a b -> GraphFactKont m l e x a b
1257
1258       rew_OO' (GM mids) = rew_mids mids
1259       rew_OO' (GF (Just entry) blockenv (Just exit)) = rew_OO entry blockenv exit
1260       rew_OO' _ = panic "EX graph missing entry or exit"
1261
1262       rew_OC' (GF (Just entry) blockenv Nothing) = rew_OC entry blockenv
1263       rew_OC' _ = panic "EJ graph is exitable"
1264
1265       rew_CO' id (GF Nothing blockenv (Just exit)) = rew_CO id blockenv exit
1266       rew_CO' _ _ = panic "BX graph is enterable"
1267
1268       rew_OO :: ZTail m l e x -> BlockEnv (Block m l) -> ZHead m
1269              -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
1270       rew_OC :: ZTail m l -> BlockEnv (Block m l)
1271              -> GraphFactKont m l e x a b -> GraphKont m l e x a b
1272       rew_CO :: BlockId -> BlockEnv (Block m l)  -> ZHead m
1273              -> GraphKont m l e x a b -> GraphFactKont m l e x a b
1274
1275       rew_OO entry blockenv exit =
1276           rew_head exit .
1277           rew_blocks (reverse $ postorder_dfs_from blockenv entry) .
1278           rew_tail entry
1279
1280       rew_OC entry blockenv =
1281           rew_blocks (reverse $ postorder_dfs_from blockenv entry) .
1282           rew_tail entry
1283
1284       rew_CO id blockenv exit =
1285           rew_head exit .
1286           rew_blocks (postorder_dfs_from blockenv (BlockPtr id))
1287
1288-}
1289
1290check :: Bool  -- whether to do extra checking during execution
1291check = True
1292
1293{- ================================================================ -}
1294
1295
1296dump_things :: Bool
1297dump_things = False
1298
1299my_trace :: String -> SDoc -> a -> a
1300my_trace = if dump_things then pprTrace else \_ _ a -> a
1301
1302
1303-- | Here's a function to run an action on blocks until we reach a fixed point.
1304-- It changes facts but leaves the fuel supply untouched.
1305run :: (Outputable a, Outputable m, Outputable l) =>
1306       String -> String -> (Block m l -> DFM a ()) -> [Block m l] -> DFM a ()
1307run dir name do_block blocks =
1308   do { show_blocks $ iterate (1::Int) }
1309   where
1310     -- N.B. Each iteration starts and finished with the same fuel supply;
1311     -- only rewrites in a rewriting function actually count
1312     trace_block cnt block =
1313         do my_trace "about to do" (text name <+> text "on" <+>
1314                     ppr (blockId block) <+> ppr cnt) $
1315                    do_block block
1316            return (cnt + 1)
1317     iterate n = 
1318         do { markFactsUnchanged
1319            ; my_trace "block count:" (ppr (length blocks)) $
1320              withDuplicateFuel $ foldM trace_block (0 :: Int) blocks
1321            ; changed <- factsStatus
1322            ; facts <- getAllFacts
1323            ; let depth = 0 -- was nesting depth
1324            ; ppIter depth n $
1325              case changed of
1326                NoChange -> unchanged depth $ return ()
1327                SomeChange ->
1328                    pprFacts depth n facts $ 
1329                    if n < 1000 then iterate (n+1)
1330                    else panic $ msg n
1331            }
1332     msg n = concat [name, " didn't converge in ", show n, " " , dir, " iterations"]
1333     my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
1334     ppIter depth n =
1335         my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
1336     pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
1337     unchanged depth =
1338       my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
1339
1340     graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
1341     show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
1342     pprBlock (Block id t) = nest 2 (pprFact (id, t))
1343     pprFacts depth n env =
1344         my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
1345                        (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
1346     pprFact  (id, a) = hang (ppr id <> colon) 4 (ppr a)
1347
1348
1349f4sep :: [SDoc] -> SDoc
1350f4sep [] = fsep []
1351f4sep (d:ds) = fsep (d : map (nest 4) ds)
1352
1353
1354subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => m f a -> m f a
1355subAnalysis' m =
1356    do { a <- subAnalysis $
1357               do { a <- m; -- facts <- getAllFacts
1358                  ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
1359                    return a }
1360       -- ; facts <- getAllFacts
1361       ; -- my_trace "in parent analysis facts are" (pprFacts facts) $
1362         return a }
1363  -- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
1364        -- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
1365
1366
1367{-
1368
1369[Note inlining]
1370~~~~~~~~~~~~~~~
1371The definitions of 'forward_sol' and 'backward_sol' are curried in a funny
1372way because we badly want GHC to inline and specialize the partial application
1373
1374  forward_sol (\_ _ -> Nothing)
1375
1376NR checked on this property ages ago (summer 2007), but it needs to be checked
1377again once things will have stabilized in mid-2009.
1378
1379-}
1380
1381{- ================= EXTRA UTILITY SPLICING FUNCTIONS ================ -}
1382
1383
1384appId :: ZipGF m l e C -> BlockId -> ZipGF m l e O   -- splice new label onto closed graph
1385appId (GF entry blocks ZX_C) id = GF entry blocks (ZX_O $ ZFirst id)
1386appId _ _ = can't_match
1387
1388
1389
1390  -- based on no measurement whatever, NR felt this special case was
1391  -- worth optimizing (avoids allocating 'ZMid m' in the 'GF' case):
1392  --    appMid g m = g <=*> ZMid m
1393appMid :: ZipGF m l e O -> m -> ZipGF m l e O
1394appMid (GM ms) m = GM $ ZCat ms (ZMid m)
1395appMid (GF entry blocks (ZX_O h)) m = GF entry blocks (ZX_O $ ZHead h m)
1396--appMid (GF _ _ ZX_C) _ = can't_match
1397
1398preMid :: m -> ZipGF m l O x -> ZipGF m l O x
1399preMid m (GM ms) = GM $ ZCat (ZMid m) ms
1400preMid m (GF (ZE_O t) blocks exit) = GF (ZX_O $ ZTail m t) blocks exit
1401--preMid _ (GF (ZE_C _) _ _) = can't_match
1402
1403can't_match :: a
1404can't_match = panic "GADT pattern matcher is too stupid to live"