Commit 5dc8b425 authored by dias@eecs.tufts.edu's avatar dias@eecs.tufts.edu

stack overflows and out of memory's

1. Stack overflow fixed by making dataflow monad strict in the state.
2. Out of memory fixed by "forgetting" lastoutfacts in the dataflow monad
   where we should. We were creating an unnecessarily long list that grew
   exponentially...
parent 4bc25e8c
......@@ -165,15 +165,15 @@ cafLattice = DataflowLattice "live cafs" emptyFM add False
cafTransfers :: BackwardTransfers Middle Last CAFSet
cafTransfers = BackwardTransfers first middle last
where first _ live = live
middle m live = foldExpDeepMiddle addCaf m live
last l env = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
addCaf e set = case e of
CmmLit (CmmLabel c) -> add c set
CmmLit (CmmLabelOff c _) -> add c set
CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
_ -> set
add l s = if hasCAF l then addToFM s (cvtToClosureLbl l) () else s
where first _ live = live
middle m live = foldExpDeepMiddle addCaf m live
last l env = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
addCaf e set = case e of
CmmLit (CmmLabel c) -> add c set
CmmLit (CmmLabelOff c _) -> add c set
CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
_ -> set
add l s = if hasCAF l then addToFM s (cvtToClosureLbl l) () else s
type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv
......
......@@ -85,23 +85,34 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
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 ()
......
......@@ -66,7 +66,7 @@ changeRegs f live = live { in_regs = f (in_regs live) }
dualLiveLattice :: DataflowLattice DualLive
dualLiveLattice =
DataflowLattice "variables live in registers and on stack" empty add False
DataflowLattice "variables live in registers and on stack" empty add True
where empty = DualLive emptyRegSet emptyRegSet
-- | compute in the Tx monad to track whether anything has changed
add new old = do stack <- add1 (on_stack new) (on_stack old)
......
module CmmTx where
data ChangeFlag = NoChange | SomeChange
......
......@@ -59,14 +59,14 @@ data DataflowLattice a = DataflowLattice {
-- 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
......@@ -190,7 +190,7 @@ graphWasRewritten = DFM' f
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
......
......@@ -456,7 +456,8 @@ pprMiddle stmt = pp_stmt <+> pp_debug
MidForeignCall {} -> text "MidForeignCall"
ppr_fc :: ForeignConvention -> SDoc
ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
ppr_fc (ForeignConvention c args res) =
doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
ppr_safety :: ForeignSafety -> SDoc
ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
......
......@@ -513,55 +513,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 +563,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 +572,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,6 +606,7 @@ 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
......@@ -647,6 +635,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 +656,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 +668,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)
}
......@@ -1010,10 +1002,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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment