g <- return $ elimCommonBlocks g
dump Opt_D_dump_cmmz "Post common block elimination" g
procPoints <- run $ minimalProcPointSet callPPs g
- -- print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
g <- run $ addProcPointProtocols callPPs procPoints g
dump Opt_D_dump_cmmz "Post Proc Points Added" g
- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+ g <-
+ -- pprTrace "pre Spills" (ppr g) $
+ dual_rewrite Opt_D_dump_cmmz "spills and reloads"
(dualLivenessWithInsertion procPoints) g
-- Insert spills at defns; reloads at return points
- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
+ g <-
+ -- pprTrace "pre insertLateReloads" (ppr g) $
+ run $ insertLateReloads g -- Duplicate reloads just before uses
dump Opt_D_dump_cmmz "Post late reloads" g
- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+ g <-
+ -- pprTrace "post insertLateReloads" (ppr g) $
+ dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
(removeDeadAssignmentsAndReloads procPoints) g
-- Remove redundant reloads (and any other redundant asst)
-- Debugging: stubbing slots on death can cause crashes early
- g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+ g <-
+ -- trace "post dead-assign elim" $
+ if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
slotEnv <- run $ liveSlotAnal g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
- cafEnv <- run $ cafAnal g
- (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
+ cafEnv <-
+ -- trace "post liveSlotAnal" $
+ run $ cafAnal g
+ (cafEnv, slotEnv) <-
+ -- trace "post print cafAnal" $
+ return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
let areaMap = layout procPoints slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return ()
-- case of DFM, parameterized over any monad.
-- In practice, we apply DFM' to the FuelMonad, which provides optimization fuel and
-- the unique supply.
-data DFState f = DFState { df_rewritten :: ChangeFlag
- , df_facts :: BlockEnv f
- , df_exit_fact :: f
- , df_last_outs :: [(BlockId, f)]
- , df_facts_change :: ChangeFlag
+data DFState f = DFState { df_rewritten :: !ChangeFlag
+ , df_facts :: !(BlockEnv f)
+ , df_exit_fact :: !f
+ , df_last_outs :: ![(BlockId, f)]
+ , df_facts_change :: !ChangeFlag
}
-newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact
+newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact
-> m (a, DFState fact))
type DFM fact a = DFM' FuelMonad fact a
instance Monad m => Monad (DFM' m f) where
DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s
- let DFM' f' = k a in f' l s')
+ s' `seq` case k a of DFM' f' -> f' l s')
return a = DFM' (\_ s -> return (a, s))
instance FuelUsingMonad (DFM' FuelMonad f) where
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
; 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
(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)
-> 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
; 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)
; 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
; 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)
}
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
projects / ghc-hetmet.git / commitdiff