+{-# INLINE forward_rew #-}
+forward_rew
+ :: forall m l a .
+ (DebugNodes m l, LastNode l, Outputable a)
+ => (forall a . Fuel -> Maybe a -> Maybe a)
+ -> RewritingDepth
+ -> BlockEnv a
+ -> PassName
+ -> ForwardTransfers m l a
+ -> ForwardRewrites m l a
+ -> a
+ -> Graph m l
+ -> Fuel
+ -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
+forward_rew check_maybe = forw
+ where
+ solve = forward_sol check_maybe
+ forw :: RewritingDepth
+ -> BlockEnv a
+ -> PassName
+ -> ForwardTransfers m l a
+ -> ForwardRewrites m l a
+ -> a
+ -> Graph m l
+ -> Fuel
+ -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
+ forw depth xstart_facts name transfers rewrites in_factx gx fuelx =
+ let rewrite :: BlockEnv a -> DFM a b
+ -> a -> Graph m l -> Fuel
+ -> DFM a (b, Graph m l, Fuel)
+ rewrite start finish in_fact g fuel =
+ let Graph entry blockenv = g
+ blocks = G.postorder_dfs_from blockenv entry
+ in do { solve depth name start transfers rewrites in_fact g fuel
+ ; eid <- freshBlockId "temporary entry id"
+ ; (rewritten, fuel) <-
+ rew_tail (ZFirst eid emptyStackInfo)
+ in_fact entry emptyBlockEnv fuel
+ ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
+ ; a <- finish
+ ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel)
+ }
+ don't_rewrite facts finish in_fact g fuel =
+ do { solve depth name facts transfers rewrites in_fact g fuel
+ ; a <- finish
+ ; return (a, g, fuel)
+ }
+ inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
+ inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
+ where inner_rew' = case depth of RewriteShallow -> don't_rewrite
+ RewriteDeep -> rewrite
+ fixed_pt_and_fuel =
+ do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx
+ ; facts <- getAllFacts
+ ; changed <- graphWasRewritten
+ ; last_outs <- lastOutFacts
+ ; let cfp = FP facts a changed (panic "no decoration?!") g
+ ; let fp = FFP cfp last_outs
+ ; return (fp, fuel)
+ }
+ rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
+ -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
+ rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
+ rewrite_blocks (G.Block id off t : bs) rewritten fuel =
+ do let h = ZFirst id off
+ a <- getFact id
+ case check_maybe fuel $ fr_first rewrites a id of
+ Nothing -> do { (rewritten, fuel) <-
+ rew_tail h (ft_first_out transfers a id)
+ t rewritten fuel
+ ; rewrite_blocks bs rewritten fuel }
+ Just g -> do { markGraphRewritten
+ ; g <- areturn g
+ ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
+ ; let (blocks, h) = splice_head' h g
+ ; (rewritten, fuel) <-
+ rew_tail h outfact t (blocks `plusBlockEnv` rewritten) fuel
+ ; rewrite_blocks bs rewritten fuel }
+
+ rew_tail head in' (G.ZTail m t) rewritten fuel =
+ my_trace "Rewriting middle node" (ppr m) $
+ case check_maybe fuel $ fr_middle rewrites in' m of
+ Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
+ rewritten fuel
+ Just g -> do { markGraphRewritten
+ ; g <- areturn g
+ ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
+ ; let (blocks, h) = G.splice_head' head g
+ ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel
+ }
+ rew_tail h in' (G.ZLast l) rewritten fuel =
+ my_trace "Rewriting last node" (ppr l) $
+ case check_maybe fuel $ either_last rewrites in' l of
+ Nothing -> do check_facts in' l
+ return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
+ Just g -> do { markGraphRewritten
+ ; g <- areturn g
+ ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
+ ; let g' = G.splice_head_only' h g
+ ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel)
+ }
+ either_last rewrites in' (LastExit) = fr_exit rewrites in'
+ either_last rewrites in' (LastOther l) = fr_last rewrites in' l
+ check_facts in' (LastOther l) =
+ let LastOutFacts last_outs = ft_last_outs transfers in' l
+ in mapM (uncurry checkFactMatch) last_outs
+ check_facts _ LastExit = return []
+ in fixed_pt_and_fuel
+
+lastOutFacts :: DFM f (LastOutFacts f)
+lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
+
+{- ================================================================ -}
+
+solve_b :: (DebugNodes m l, Outputable a)
+ => BlockEnv a -- initial facts (unbound == bottom)
+ -> PassName
+ -> DataflowLattice a -- lattice
+ -> BackwardTransfers m l a -- dataflow transfer functions
+ -> a -- exit fact
+ -> Graph m l -- graph to be analyzed
+ -> FuelMonad (BackwardFixedPoint m l a ()) -- answers
+solve_b env name lattice transfers exit_fact g =
+ runDFM lattice $ bwd_pure_anal name env transfers g exit_fact
+
+
+rewrite_b_agraph :: (DebugNodes m l, Outputable a)
+ => RewritingDepth
+ -> BlockEnv a
+ -> PassName
+ -> DataflowLattice a
+ -> BackwardTransfers m l a
+ -> BackwardRewrites m l a
+ -> a -- fact flowing in at exit
+ -> Graph m l
+ -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
+rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
+ runDFM lattice $
+ do fuel <- fuelRemaining
+ (fp, fuel') <- backward_rew maybeRewriteWithFuel depth start_facts name
+ transfers rewrites g exit_fact fuel
+ fuelDecrement name fuel fuel'
+ return fp
+
+
+
+{-# INLINE backward_sol #-}
+backward_sol
+ :: forall m l a .
+ (DebugNodes m l, LastNode l, Outputable a)
+ => (forall a . Fuel -> Maybe a -> Maybe a)
+ -> RewritingDepth
+ -> PassName
+ -> BlockEnv a
+ -> BackwardTransfers m l a
+ -> BackwardRewrites m l a
+ -> Graph m l
+ -> a
+ -> Fuel
+ -> DFM a (BackwardFixedPoint m l a (), Fuel)
+backward_sol check_maybe = back
+ where
+ back :: RewritingDepth
+ -> PassName
+ -> BlockEnv a
+ -> BackwardTransfers m l a
+ -> BackwardRewrites m l a
+ -> Graph m l
+ -> a
+ -> Fuel
+ -> DFM a (BackwardFixedPoint m l a (), Fuel)
+ back rewrite name start_facts transfers rewrites =
+ let anal_b :: Graph m l -> a -> DFM a a
+ anal_b g out =
+ do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
+ ; return $ zdfFpOutputFact fp }
+
+ subsolve :: AGraph m l -> a -> Fuel -> DFM a (a, Fuel)
+ subsolve =
+ case rewrite of
+ RewriteDeep -> \g a fuel ->
+ subAnalysis' $ do { g <- areturn g; solve g a (oneLessFuel fuel) }
+ RewriteShallow -> \g a fuel ->
+ subAnalysis' $ do { g <- areturn g; a <- anal_b g a
+ ; return (a, oneLessFuel fuel) }
+
+ solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)
+ solve (Graph entry blockenv) exit_fact fuel =
+ let blocks = reverse $ G.postorder_dfs_from blockenv entry
+ last_in _env (LastExit) = exit_fact
+ last_in env (LastOther l) = bt_last_in transfers env l
+ last_rew _env (LastExit) = br_exit rewrites
+ last_rew env (LastOther l) = br_last rewrites env l
+ set_block_fact block fuel =
+ let (h, l) = G.goto_end (G.unzip block) in
+ do { env <- factsEnv
+ ; (a, fuel) <-
+ case check_maybe fuel $ last_rew env l of
+ Nothing -> return (last_in env l, fuel)
+ Just g -> do g' <- areturn g
+ my_trace "analysis rewrites last node"
+ (ppr l <+> pprGraph g') $
+ subsolve g exit_fact fuel
+ ; set_head_fact h a fuel
+ ; return fuel }
+
+ in do { fuel <- run "backward" name set_block_fact blocks fuel
+ ; eid <- freshBlockId "temporary entry id"
+ ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel
+ ; a <- getFact eid
+ ; forgetFact eid
+ ; return (a, fuel)
+ }
+
+ set_head_fact (G.ZFirst id _) a fuel =
+ case check_maybe fuel $ br_first rewrites a id of
+ Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+>
+ ppr (bt_first_in transfers a id)) $
+ setFact id $ bt_first_in transfers a id
+ ; return fuel }
+ Just g -> do { g' <- areturn g
+ ; (a, fuel) <- my_trace "analysis rewrites first node"
+ (ppr id <+> pprGraph g') $
+ subsolve g a fuel
+ ; setFact id $ bt_first_in transfers a id
+ ; return fuel
+ }
+ set_head_fact (G.ZHead h m) a fuel =
+ case check_maybe fuel $ br_middle rewrites a m of
+ Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel
+ Just g -> do { g' <- areturn g
+ ; (a, fuel) <- my_trace "analysis rewrites middle node"
+ (ppr m <+> pprGraph g') $
+ subsolve g a fuel
+ ; set_head_fact h a fuel }
+
+ fixed_point g exit_fact fuel =
+ do { setAllFacts start_facts
+ ; (a, fuel) <- solve g exit_fact fuel
+ ; facts <- getAllFacts
+ ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
+ ; return (cfp, fuel)
+ }
+ in fixed_point
+
+bwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
+ => PassName
+ -> BlockEnv a
+ -> BackwardTransfers m l a
+ -> Graph m l
+ -> a
+ -> DFM a (BackwardFixedPoint m l a ())
+
+bwd_pure_anal name env transfers g exit_fact =
+ do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
+ return fp
+ where -- another case of "I love lazy evaluation"
+ anal_b = backward_sol (\_ _ -> Nothing) panic_depth
+ panic_rewrites = panic "pure analysis asked for a rewrite function"
+ panic_fuel = panic "pure analysis asked for fuel"
+ panic_depth = panic "pure analysis asked for a rewrite depth"
+
+
+{- ================================================================ -}
+
+{-# INLINE backward_rew #-}
+backward_rew
+ :: forall m l a .
+ (DebugNodes m l, LastNode l, Outputable a)
+ => (forall a . Fuel -> Maybe a -> Maybe a)
+ -> RewritingDepth
+ -> BlockEnv a
+ -> PassName
+ -> BackwardTransfers m l a
+ -> BackwardRewrites m l a
+ -> Graph m l
+ -> a
+ -> Fuel
+ -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
+backward_rew check_maybe = back
+ where
+ solve = backward_sol check_maybe
+ back :: RewritingDepth
+ -> BlockEnv a
+ -> PassName
+ -> BackwardTransfers m l a
+ -> BackwardRewrites m l a
+ -> Graph m l
+ -> a
+ -> Fuel
+ -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
+ back depth xstart_facts name transfers rewrites gx exit_fact fuelx =
+ let rewrite :: BlockEnv a
+ -> Graph m l -> a -> Fuel
+ -> DFM a (a, Graph m l, Fuel)
+ rewrite start g exit_fact fuel =
+ let Graph entry blockenv = g
+ blocks = reverse $ G.postorder_dfs_from blockenv entry
+ in do { (FP env in_fact _ _ _, _) <- -- don't drop the entry fact!
+ solve depth name start transfers rewrites g exit_fact fuel
+ --; env <- getAllFacts
+ -- ; my_trace "facts after solving" (ppr env) $ return ()
+ ; eid <- freshBlockId "temporary entry id"
+ ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel
+ -- We can't have the fact check fail on the bogus entry, which _may_ change
+ ; (rewritten, fuel) <-
+ rewrite_blocks False [Block eid emptyStackInfo entry]
+ rewritten fuel
+ ; my_trace "eid" (ppr eid) $ return ()
+ ; my_trace "exit_fact" (ppr exit_fact) $ return ()
+ ; my_trace "in_fact" (ppr in_fact) $ return ()
+ ; return (in_fact, lgraphToGraph (LGraph eid 0 rewritten), fuel)
+ } -- Remember: the entry fact computed by @solve@ accounts for rewriting
+ don't_rewrite facts g exit_fact fuel =
+ do { (fp, _) <-
+ solve depth name facts transfers rewrites g exit_fact fuel
+ ; return (zdfFpOutputFact fp, g, fuel) }
+ inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel)
+ inner_rew g a f = getAllFacts >>= \facts -> inner_rew' facts g a f
+ where inner_rew' = case depth of RewriteShallow -> don't_rewrite
+ RewriteDeep -> rewrite
+ fixed_pt_and_fuel =
+ do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx
+ ; facts <- getAllFacts
+ ; changed <- graphWasRewritten
+ ; let fp = FP facts a changed (panic "no decoration?!") g
+ ; return (fp, fuel)
+ }
+ rewrite_blocks :: Bool -> [Block m l] -> (BlockEnv (Block m l))
+ -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
+ rewrite_blocks check bs rewritten fuel =
+ do { env <- factsEnv
+ ; let rew [] r f = return (r, f)
+ rew (b : bs) r f =
+ do { (r, f) <- rewrite_block check env b r f; rew bs r f }
+ ; rew bs rewritten fuel }
+ rewrite_block check env b rewritten fuel =
+ let (h, l) = G.goto_end (G.unzip b) in
+ case maybeRewriteWithFuel fuel $ either_last env l of
+ Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten
+ Just g ->
+ do { markGraphRewritten
+ ; g <- areturn g
+ ; (a, g, fuel) <- inner_rew g exit_fact fuel
+ ; let G.Graph t new_blocks = g
+ ; let rewritten' = new_blocks `plusBlockEnv` rewritten
+ ; propagate check fuel h a t rewritten' -- continue at entry of g
+ }
+ either_last _env (LastExit) = br_exit rewrites
+ either_last env (LastOther l) = br_last rewrites env l
+ last_in _env (LastExit) = exit_fact
+ last_in env (LastOther l) = bt_last_in transfers env l
+ propagate check fuel (ZHead h m) a tail rewritten =
+ case maybeRewriteWithFuel fuel $ br_middle rewrites a m of
+ Nothing ->
+ propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
+ Just g ->
+ do { markGraphRewritten
+ ; g <- areturn g
+ ; my_trace "With Facts" (ppr a) $ return ()
+ ; my_trace " Rewrote middle node"
+ (f4sep [ppr m, text "to", pprGraph g]) $
+ return ()
+ ; (a, g, fuel) <- inner_rew g a fuel
+ ; let Graph t newblocks = G.splice_tail g tail
+ ; my_trace "propagating facts" (ppr a) $
+ propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) }
+ propagate check fuel (ZFirst id off) a tail rewritten =
+ case maybeRewriteWithFuel fuel $ br_first rewrites a id of
+ Nothing -> do { if check then
+ checkFactMatch id $ bt_first_in transfers a id
+ else return ()
+ ; return (insertBlock (Block id off tail) rewritten, fuel) }
+ Just g ->
+ do { markGraphRewritten
+ ; g <- areturn g
+ ; my_trace "Rewrote first node"
+ (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
+ ; (a, g, fuel) <- inner_rew g a fuel
+ ; if check then checkFactMatch id (bt_first_in transfers a id)
+ else return ()
+ ; let Graph t newblocks = G.splice_tail g tail
+ ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten)
+ ; return (r, fuel) }
+ in fixed_pt_and_fuel
+
+{- ================================================================ -}
+
+instance FixedPoint CommonFixedPoint where
+ zdfFpFacts = fp_facts
+ zdfFpOutputFact = fp_out
+ zdfGraphChanged = fp_changed
+ zdfDecoratedGraph = fp_dec_graph
+ zdfFpContents = fp_contents
+ zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a)
+
+instance FixedPoint ForwardFixedPoint where
+ zdfFpFacts = fp_facts . ffp_common
+ zdfFpOutputFact = fp_out . ffp_common
+ zdfGraphChanged = fp_changed . ffp_common
+ zdfDecoratedGraph = fp_dec_graph . ffp_common
+ zdfFpContents = fp_contents . ffp_common
+ zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los