X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FZipDataflow.hs;h=92fc37518124dc333b03bf0c9a78f0f29124bcf2;hp=e8fefbfd0d56b2d4da49813c2169ba45599dac31;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=31a9d04804d9cacda35695c5397590516b964964 diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index e8fefbf..92fc375 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -29,10 +29,8 @@ import qualified ZipCfg as G import Maybes import Outputable -import Panic import Control.Monad -import Maybe {- @@ -505,7 +503,7 @@ forward_sol check_maybe = forw forw rewrite name start_facts transfers rewrites = let anal_f :: DFM a b -> a -> Graph m l -> DFM a b anal_f finish in' g = - do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish } + do { _ <- fwd_pure_anal name emptyBlockEnv transfers in' g; finish } solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel) solve finish in_fact (Graph entry blockenv) fuel = @@ -513,55 +511,46 @@ forward_sol check_maybe = forw set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv) set_successor_facts (Block id tail) fuel = do { idfact <- getFact id - ; (last_outs, fuel) <- - case check_maybe fuel $ fr_first rewrites id idfact of - Nothing -> solve_tail (ft_first_out transfers id idfact) tail fuel - Just g -> - do g <- areturn g - (a, fuel) <- subAnalysis' $ - case rewrite of - RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel) - RewriteShallow -> - do { a <- anal_f getExitFact idfact g - ; return (a, oneLessFuel fuel) } - solve_tail a tail fuel + ; (last_outs, fuel) <- rec_rewrite (fr_first rewrites id idfact) + (ft_first_out transfers id idfact) + getExitFact (solve_tail tail) + (solve_tail tail) idfact fuel ; set_or_save last_outs ; return fuel } - - in do { (last_outs, fuel) <- solve_tail in_fact entry fuel - ; set_or_save last_outs + in do { (last_outs, fuel) <- solve_tail entry in_fact fuel + -- last_outs contains a mix of internal facts, which + -- are inputs to 'run', and external facts, which + -- are going to be forgotten by 'run' + ; set_or_save last_outs ; fuel <- run "forward" name set_successor_facts blocks fuel - ; b <- finish + ; set_or_save last_outs + -- Re-set facts that may have been forgotten by run + ; b <- finish ; return (b, fuel) } - - solve_tail in' (G.ZTail m t) fuel = - case check_maybe fuel $ fr_middle rewrites m in' of - Nothing -> solve_tail (ft_middle_out transfers m in') t fuel - Just g -> - do { g <- areturn g - ; (a, fuel) <- subAnalysis' $ - case rewrite of - RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel) - RewriteShallow -> do { a <- anal_f getExitFact in' g - ; return (a, oneLessFuel fuel) } - ; solve_tail a t fuel - } - solve_tail in' (G.ZLast l) fuel = - case check_maybe fuel $ either_last rewrites in' l of - Nothing -> - case l of LastOther l -> return (ft_last_outs transfers l in', fuel) - LastExit -> do { setExitFact (ft_exit_out transfers in') - ; return (LastOutFacts [], fuel) } - Just g -> - do { g <- areturn g - ; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $ - case rewrite of - RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel) - RewriteShallow -> do { los <- anal_f lastOutFacts in' g - ; return (los, fuel) } - ; return (last_outs, fuel) - } + -- The need for both k1 and k2 suggests that maybe there's an opportunity + -- for improvement here -- in most cases, they're the same... + rec_rewrite rewritten analyzed finish k1 k2 in' fuel = + case check_maybe fuel rewritten of -- fr_first rewrites id idfact of + Nothing -> k1 analyzed fuel + Just g -> do g <- areturn g + (a, fuel) <- subAnalysis' $ + case rewrite of + RewriteDeep -> solve finish in' g (oneLessFuel fuel) + RewriteShallow -> do { a <- anal_f finish in' g + ; return (a, oneLessFuel fuel) } + k2 a fuel + solve_tail (G.ZTail m t) in' fuel = + rec_rewrite (fr_middle rewrites m in') (ft_middle_out transfers m in') + getExitFact (solve_tail t) (solve_tail t) in' fuel + solve_tail (G.ZLast (LastOther l)) in' fuel = + rec_rewrite (fr_last rewrites l in') (ft_last_outs transfers l in') + lastOutFacts k k in' fuel + where k a b = return (a, b) + solve_tail (G.ZLast LastExit) in' fuel = + rec_rewrite (fr_exit rewrites in') (ft_exit_out transfers in') + lastOutFacts k (\a b -> return (a, b)) in' fuel + where k a fuel = do { setExitFact a ; return (LastOutFacts [], fuel) } fixed_point in_fact g fuel = do { setAllFacts start_facts @@ -572,10 +561,6 @@ forward_sol check_maybe = forw ; let fp = FFP cfp last_outs ; return (fp, fuel) } - - either_last rewrites in' (LastExit) = fr_exit rewrites in' - either_last rewrites in' (LastOther l) = fr_last rewrites l in' - in fixed_point @@ -585,7 +570,7 @@ mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) => (BlockId -> Bool) -> LastOutFacts a -> df a () mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l where set_or_save_one (id, a) = - if is_local id then setFact id a else addLastOutFact (id, a) + if is_local id then setFact id a else pprTrace "addLastOutFact" (ppr $ length l) $ addLastOutFact (id, a) @@ -619,9 +604,10 @@ forward_rew check_maybe = forw -> a -> Graph m l -> Fuel -> DFM a (b, Graph m l, Fuel) rewrite start finish in_fact g fuel = + in_fact `seq` g `seq` let Graph entry blockenv = g blocks = G.postorder_dfs_from blockenv entry - in do { solve depth name start transfers rewrites in_fact g fuel + in do { _ <- solve depth name start transfers rewrites in_fact g fuel ; eid <- freshBlockId "temporary entry id" ; (rewritten, fuel) <- rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel @@ -630,7 +616,7 @@ forward_rew check_maybe = forw ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) } don't_rewrite facts finish in_fact g fuel = - do { solve depth name facts transfers rewrites in_fact g fuel + do { _ <- solve depth name facts transfers rewrites in_fact g fuel ; a <- finish ; return (a, g, fuel) } @@ -647,6 +633,7 @@ forward_rew check_maybe = forw ; let fp = FFP cfp last_outs ; return (fp, fuel) } +-- JD: WHY AREN'T WE TAKING ANY FUEL HERE? rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l)) -> Fuel -> DFM a (BlockEnv (Block m l), Fuel) rewrite_blocks [] rewritten fuel = return (rewritten, fuel) @@ -667,10 +654,11 @@ forward_rew check_maybe = forw ; rewrite_blocks bs rewritten fuel } rew_tail head in' (G.ZTail m t) rewritten fuel = + in' `seq` rewritten `seq` my_trace "Rewriting middle node" (ppr m) $ case check_maybe fuel $ fr_middle rewrites m in' of Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers m in') t - rewritten fuel + rewritten fuel Just g -> do { markGraphRewritten ; g <- areturn g ; (a, g, fuel) <- inner_rew getExitFact in' g fuel @@ -678,13 +666,15 @@ forward_rew check_maybe = forw ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel } rew_tail h in' (G.ZLast l) rewritten fuel = + in' `seq` rewritten `seq` 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 + Just g -> do { markGraphRewritten ; g <- areturn g - ; ((), g, fuel) <- inner_rew (return ()) in' g fuel + ; ((), g, fuel) <- + my_trace "Just" (ppr g) $ inner_rew (return ()) in' g fuel ; let g' = G.splice_head_only' h g ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel) } @@ -692,8 +682,8 @@ forward_rew check_maybe = forw either_last rewrites in' (LastOther l) = fr_last rewrites l in' check_facts in' (LastOther l) = let LastOutFacts last_outs = ft_last_outs transfers l in' - in mapM (uncurry checkFactMatch) last_outs - check_facts _ LastExit = return [] + in mapM_ (uncurry checkFactMatch) last_outs + check_facts _ LastExit = return () in fixed_pt_and_fuel lastOutFacts :: DFM f (LastOutFacts f) @@ -789,7 +779,7 @@ backward_sol check_maybe = back my_trace "analysis rewrites last node" (ppr l <+> pprGraph g') $ subsolve g exit_fact fuel - ; set_head_fact h a fuel + ; _ <- set_head_fact h a fuel ; return fuel } in do { fuel <- run "backward" name set_block_fact blocks fuel @@ -1010,10 +1000,9 @@ run dir name do_block blocks b = do_block block b return (b', cnt + 1) iterate n = - do { markFactsUnchanged - ; (b, _) <- - my_trace "block count:" (ppr (length blocks)) $ - foldM trace_block (b, 0 :: Int) blocks + do { forgetLastOutFacts + ; markFactsUnchanged + ; (b, _) <- foldM trace_block (b, 0 :: Int) blocks ; changed <- factsStatus ; facts <- getAllFacts ; let depth = 0 -- was nesting depth