Commit 31a9d048 authored by dias@eecs.harvard.edu's avatar dias@eecs.harvard.edu
Browse files

A few bug fixes; some improvements spurred by paper writing

Among others:
- Fixed Stg->C-- translation of let-no-escapes -- it's important to use the
  right continuation...
- Fixed infinite recursion in X86 backend (shortcutJump mishandled infinite loops)
- Fixed yet another wrong calling convention -- primops take args only in vanilla regs,
  but they may return results on the stack!
- Removed StackInfo from LGraph and Block -- now in LastCall and CmmZ
- Updated avail-variable and liveness code
parent 6d38e24e
......@@ -135,7 +135,7 @@ cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (Gen
cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops
cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g)
cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm
cmmTopMapGraphM f (CmmProc h l args g) =
......
......@@ -39,7 +39,7 @@ import Panic
import SMRep
import StgCmmClosure
import StgCmmForeign
import StgCmmMonad
-- import StgCmmMonad
import StgCmmUtils
import UniqSupply
import ZipCfg hiding (zip, unzip, last)
......@@ -130,35 +130,13 @@ setInfoTableStackMap _ _ t@(NoInfoTable _) = t
setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) =
updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
setInfoTableStackMap slotEnv areaMap
t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph _ _ blocks))
procpoints) =
t@(ProcInfoTable (CmmProc (CmmInfo _ _ _) _ _ ((_, Just updfr_off), _)) procpoints) =
case blockSetToList procpoints of
[bid] ->
let oldByte = case infoTbl of
CmmInfoTable _ _ _ (ContInfo _ _) ->
case lookupBlockEnv blocks bid of
Just (Block _ (StackInfo {returnOff = Just n}) _) -> n
_ -> pprPanic "misformed graph at procpoint" (ppr g)
_ -> initUpdFrameOff -- entry to top-level function
stack_vars = live_ptrs oldByte slotEnv areaMap bid
in updInfo (const stack_vars) id t
_ -> panic "setInfoTableStackMap: unexpect number of procpoints"
[bid] -> updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
_ -> panic "setInfoTableStackMap: unexpected number of procpoints"
-- until we stop splitting the graphs at procpoints in the native path
setInfoTableStackMap _ _ _ = panic "unexpected case for setInfoTableStackMap"
{-
setInfoTableStackMap slotEnv areaMap
(Just bid, p@(CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))) =
let oldByte = case infoTbl of
CmmInfoTable _ _ _ (ContInfo _ _) ->
case lookupBlockEnv blocks bid of
Just (Block _ (StackInfo {returnOff = Just n}) _) -> n
_ -> pprPanic "misformed graph at procpoint" (ppr g)
_ -> initUpdFrameOff -- entry to top-level function
stack_vars = live_ptrs oldByte slotEnv areaMap bid
in (Just bid, upd_info_tbl (const stack_vars) id p)
setInfoTableStackMap _ _ t@(_, CmmData {}) = t
setInfoTableStackMap _ _ _ = panic "bad args to setInfoTableStackMap"
-}
setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" (ppr t)
-----------------------------------------------------------------------
......@@ -187,9 +165,9 @@ cafLattice = DataflowLattice "live cafs" emptyFM add False
cafTransfers :: BackwardTransfers Middle Last CAFSet
cafTransfers = BackwardTransfers first middle last
where first live _ = live
middle live m = foldExpDeepMiddle addCaf m live
last env l = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
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
......@@ -330,7 +308,7 @@ to_SRT top_srt off len bmp
-- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing
localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) =
localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) =
case infoTbl of
CmmInfoTable False _ _ _ ->
Just (cvtToClosureLbl top_l,
......@@ -436,13 +414,13 @@ extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotE
extendEnvsForSafeForeignCalls cafEnv slotEnv g =
fold_blocks block (cafEnv, slotEnv) g
where block b z =
tail ( bt_last_in cafTransfers (lookupFn cafEnv) l
, bt_last_in liveSlotTransfers (lookupFn slotEnv) l)
tail ( bt_last_in cafTransfers l (lookupFn cafEnv)
, bt_last_in liveSlotTransfers l (lookupFn slotEnv))
z head
where (head, last) = goto_end (G.unzip b)
l = case last of LastOther l -> l
LastExit -> panic "extendEnvs lastExit"
tail _ z (ZFirst _ _) = z
tail _ z (ZFirst _) = z
tail lives@(cafs, slots) (cafEnv, slotEnv)
(ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
let slots' = removeLiveSlotDefs slots m
......@@ -452,7 +430,7 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g =
tail lives z (ZHead h m) = tail (upd lives m) z h
lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k
upd (cafs, slots) m =
(bt_middle_in cafTransfers cafs m, bt_middle_in liveSlotTransfers slots m)
(bt_middle_in cafTransfers m cafs, bt_middle_in liveSlotTransfers m slots)
-- Safe foreign calls: We need to insert the code that suspends and resumes
-- the thread before and after a safe foreign call.
......@@ -489,9 +467,9 @@ data SafeState = State { s_blocks :: BlockEnv CmmBlock
lowerSafeForeignCalls
:: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do
lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do
let init = return $ State emptyBlockEnv emptyBlockSet []
let block b@(Block bid _ _) z = do
let block b@(Block bid _) z = do
state@(State {s_pps = ppset, s_blocks = blocks}) <- z
let ppset' = if bid == entry then extendBlockSet ppset bid else ppset
state' = state { s_pps = ppset' }
......@@ -499,13 +477,15 @@ lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do
then lowerSafeCallBlock state' b
else return (state' { s_blocks = insertBlock b blocks })
State blocks' g_procpoints safeCalls <- fold_blocks block init g
return $ safeCalls
: [ProcInfoTable (CmmProc info l args (LGraph entry off blocks')) g_procpoints]
: rst
let proc = (CmmProc info l args (off, LGraph entry blocks'))
procTable = case off of
(_, Just _) -> [ProcInfoTable proc g_procpoints]
_ -> [NoInfoTable proc] -- not a successor of a call
return $ safeCalls : procTable : rst
-- Check for foreign calls -- if none, then we can avoid copying the block.
hasSafeForeignCall :: CmmBlock -> Bool
hasSafeForeignCall (Block _ _ t) = tail t
hasSafeForeignCall (Block _ t) = tail t
where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True
tail (ZTail _ t) = tail t
tail (ZLast _) = False
......@@ -515,7 +495,7 @@ hasSafeForeignCall (Block _ _ t) = tail t
lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState
lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
where (head, last) = goto_end (G.unzip b)
tail s b@(ZBlock (ZFirst _ _) _) =
tail s b@(ZBlock (ZFirst _) _) =
do state <- s
return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) =
......
......@@ -71,14 +71,16 @@ cpsTop :: HscEnv -> CmmTopZ ->
IO ([(CLabel, CAFSet)],
[(CAFSet, CmmTopForInfoTables)])
cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)])
cpsTop hsc_env (CmmProc h l args g) =
cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
do
dump Opt_D_dump_cmmz "Pre Proc Points Added" g
let callPPs = callProcPoints g
g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
(dualLivenessWithInsertion callPPs) g
g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
(removeDeadAssignmentsAndReloads callPPs) g
-- Why bother doing it this early?
-- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
-- (dualLivenessWithInsertion callPPs) g
-- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
-- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
-- (removeDeadAssignmentsAndReloads callPPs) g
dump Opt_D_dump_cmmz "Pre common block elimination" g
g <- return $ elimCommonBlocks g
dump Opt_D_dump_cmmz "Post common block elimination" g
......@@ -96,23 +98,21 @@ cpsTop hsc_env (CmmProc h l args 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
mbpprTrace "graph before procPointMap: " (ppr g) $ return ()
procPointMap <- run $ procPointAnalysis procPoints g
slotEnv <- run $ liveSlotAnal g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
cafEnv <- run $ cafAnal g
(cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
let areaMap = layout procPoints slotEnv g
let areaMap = layout procPoints slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return ()
g <- run $ manifestSP procPoints procPointMap areaMap g
g <- run $ manifestSP areaMap entry_off g
dump Opt_D_dump_cmmz "after manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
procPointMap <- run $ procPointAnalysis procPoints g
dump Opt_D_dump_cmmz "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
(CmmProc h l args g)
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l args (stackInfo, g))
mapM (dump Opt_D_dump_cmmz "after splitting") gs
let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
......@@ -125,18 +125,6 @@ cpsTop hsc_env (CmmProc h l args g) =
let gs'' = map (bundleCAFs cafEnv) gs'
mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
return (localCAFs, gs'')
{-
-- Return: (a) CAFs used by this proc (b) a closure that will compute
-- a new SRT for the procedure.
let toTops topCAFEnv (topSRT, tops) =
do let setSRT (topSRT, rst) g =
do (topSRT, gs) <- setInfoTableSRT cafEnv topCAFEnv topSRT g
return (topSRT, gs : rst)
(topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs'
gs' <- mapM finishInfoTables (concat gs')
return (topSRT, concat gs' : tops)
return (localCAFs, toTops)
-}
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
......@@ -157,7 +145,6 @@ toTops hsc_env topCAFEnv (topSRT, tops) gs =
do let setSRT (topSRT, rst) g =
do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
return (topSRT, gs : rst)
(topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs
(topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
gs' <- mapM finishInfoTables (concat gs')
return (topSRT, concat gs' : tops)
where run = runFuelIO (hsc_OptFuel hsc_env)
......@@ -56,9 +56,10 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
where
regs = case conv of Native -> getRegs isCall
GC -> getRegs False
PrimOp -> noStack
PrimOp -> if isCall then noStack else getRegs isCall
Slow -> noRegs
_ -> panic "unrecognized calling convention"
_ -> getRegs isCall
-- _ -> panic "unrecognized calling convention"
(sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
assignArguments' [] _ _ = []
assignArguments' (r:rs) offset avails =
......
......@@ -73,8 +73,8 @@ upd_graph g subst = map_nodes id middle last g
last l = last' (mapExpDeepLast exp l)
last' (LastBranch bid) = LastBranch $ sub bid
last' (LastCondBranch p t f) = cond p (sub t) (sub f)
last' (LastCall t (Just bid) s u) = LastCall t (Just $ sub bid) s u
last' l@(LastCall _ Nothing _ _) = l
last' (LastCall t (Just bid) args res u) = LastCall t (Just $ sub bid) args res u
last' l@(LastCall _ Nothing _ _ _) = l
last' (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs
cond p t f = if t == f then LastBranch t else LastCondBranch p t f
exp (CmmStackSlot (CallArea (Young id)) off) =
......@@ -87,7 +87,7 @@ upd_graph g subst = map_nodes id middle last g
-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough.
hash_block :: CmmBlock -> Int
hash_block (Block _ _ t) =
hash_block (Block _ t) =
fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32))
-- UniqFM doesn't like negative Ints
where hash_mid (MidComment (FastString u _ _ _ _)) = cvt u
......@@ -118,7 +118,7 @@ hash_block (Block _ _ t) =
hash_lst f = foldl (\z x -> f x + z) (0::Word32)
hash_last (LastBranch _) = 23 -- would be great to hash these properly
hash_last (LastCondBranch p _ _) = hash_e p
hash_last (LastCall e _ _ _) = hash_e e
hash_last (LastCall e _ _ _ _) = hash_e e
hash_last (LastSwitch e _) = hash_e e
hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1
hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1)
......@@ -136,8 +136,7 @@ lookupBid subst bid = case lookupBlockEnv subst bid of
-- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith eqBid (Block _ sinfo t) (Block _ sinfo' t') =
sinfo == sinfo' && eqTailWith eqBid t t'
eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t'
type CmmTail = ZTail Middle Last
eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
......@@ -150,8 +149,8 @@ eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2
eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) =
c1 == c2 && eqBid t1 t2 && eqBid f1 f2
eqLastWith eqBid (LastCall t1 c1 s1 u1) (LastCall t2 c2 s2 u2) =
t1 == t2 && eqMaybeWith eqBid c1 c2 && s1 == s2 && u1 == u2
eqLastWith eqBid (LastCall t1 c1 a1 r1 u1) (LastCall t2 c2 a2 r2 u2) =
t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) =
e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2
eqLastWith _ _ _ = False
......
......@@ -16,7 +16,6 @@ import ZipCfgCmmRep
import Maybes
import Monad
import Outputable
import Panic
import Prelude hiding (unzip, zip)
import Util
......@@ -27,20 +26,25 @@ runCmmContFlowOptsZs prog
| cmm_top <- prog ]
cmmCfgOpts :: Tx (ListGraph CmmStmt)
cmmCfgOptsZ :: Tx CmmGraph
cmmCfgOptsZ :: Tx (a, CmmGraph)
cmmCfgOpts = branchChainElim -- boring, but will get more exciting later
cmmCfgOptsZ g =
optGraph
(branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
runCmmOpts :: Tx g -> Tx (GenCmm d h g)
runCmmOpts opt = mapProcs (optGraph opt)
runCmmOpts opt = mapProcs (optProc opt)
optGraph :: Tx g -> Tx (GenCmmTop d h g)
optGraph _ top@(CmmData {}) = noTx top
optGraph opt (CmmProc info lbl formals g) = fmap (CmmProc info lbl formals) (opt g)
optProc :: Tx g -> Tx (GenCmmTop d h g)
optProc _ top@(CmmData {}) = noTx top
optProc opt (CmmProc info lbl formals g) =
fmap (CmmProc info lbl formals) (opt g)
optGraph :: Tx g -> Tx (a, g)
optGraph opt (a, g) = fmap (\g' -> (a, g')) (opt g)
------------------------------------
mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
......@@ -80,28 +84,25 @@ replaceLabels env (BasicBlock id stmts)
branchChainElimZ :: Tx CmmGraph
-- Remove any basic block of the form L: goto L',
-- and replace L with L' everywhere else
branchChainElimZ g@(G.LGraph eid args _)
branchChainElimZ g@(G.LGraph eid _)
| null lone_branch_blocks -- No blocks to remove
= noTx g
| otherwise
= aTx $ replaceLabelsZ env $ G.of_block_list eid args (self_branches ++ others)
= aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others)
where
(lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g)
env = mkClosureBlockEnvZ lone_branch_blocks
self_branches =
let loop_to (id, _) =
if lookup id == id then
Just (G.Block id emptyStackInfo (G.ZLast (G.mkBranchNode id)))
Just (G.Block id (G.ZLast (G.mkBranchNode id)))
else
Nothing
in mapMaybe loop_to lone_branch_blocks
lookup id = lookupBlockEnv env id `orElse` id
-- Be careful not to mark a block as a lone branch if it carries
-- important information about incoming arguments or the update frame.
isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
isLoneBranchZ (G.Block id (StackInfo {argBytes = Nothing, returnOff = Nothing})
(G.ZLast (G.LastOther (LastBranch target))))
isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target))))
| id /= target = Left (id,target)
isLoneBranchZ other = Right other
-- An infinite loop is not a link in a branch chain!
......@@ -109,13 +110,13 @@ isLoneBranchZ other = Right other
replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceLabelsZ env = replace_eid . G.map_nodes id middle last
where
replace_eid (G.LGraph eid off blocks) = G.LGraph (lookup eid) off blocks
replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
middle = mapExpDeepMiddle exp
last l = mapExpDeepLast exp (last' l)
last' (LastBranch bid) = LastBranch (lookup bid)
last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f)
last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms)
last' (LastCall t k a r) = LastCall t (liftM lookup k) a r
last' (LastCall t k a res r) = LastCall t (liftM lookup k) a res r
exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
exp (CmmStackSlot (CallArea (Young id)) i) =
CmmStackSlot (CallArea (Young (lookup id))) i
......@@ -136,7 +137,7 @@ replaceBranches env g = map_nodes id id last g
predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet
predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
where add_preds b env = foldl (add b) env (G.succs b)
add (G.Block bid _ _) env b' =
add (G.Block bid _) env b' =
extendBlockEnv env b' $
extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
----------------------------------------------------------------
......@@ -153,11 +154,11 @@ predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
blockConcatZ :: Tx CmmGraph
blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
blockConcatZ' :: Tx CmmGraph
blockConcatZ' g@(G.LGraph eid off blocks) =
tx $ replaceLabelsZ concatMap $ G.LGraph eid off blocks'
blockConcatZ' g@(G.LGraph eid blocks) =
tx $ replaceLabelsZ concatMap $ G.LGraph eid blocks'
where (changed, blocks', concatMap) =
foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
maybe_concat b@(G.Block bid _ _) (changed, blocks', concatMap) =
maybe_concat b@(G.Block bid _) (changed, blocks', concatMap) =
let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap)
in case G.goto_end $ G.unzip b of
(h, G.LastOther (LastBranch b')) ->
......@@ -167,17 +168,11 @@ blockConcatZ' g@(G.LGraph eid off blocks) =
else unchanged
_ -> unchanged
num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
canConcatWith b' =
case lookupBlockEnv blocks b' of
Just (G.Block _ (StackInfo {returnOff = Nothing}) _) -> num_preds b' == 1
_ -> False
canConcatWith b' = num_preds b' == 1
backEdges = predMap g
splice blocks' h bid' =
case lookupBlockEnv blocks' bid' of
Just (G.Block _ (StackInfo {returnOff = Nothing}) t) ->
G.zip $ G.ZBlock h t
Just (G.Block _ _ _) ->
panic "trying to concatenate but successor block has incoming args"
Just (G.Block _ t) -> G.zip $ G.ZBlock h t
Nothing -> pprPanic "unknown successor block" (ppr bid' <+> ppr blocks' <+> ppr blocks)
tx = if changed then aTx else noTx
----------------------------------------------------------------
......@@ -197,7 +192,7 @@ mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks
_ -> id
----------------------------------------------------------------
removeUnreachableBlocksZ :: Tx CmmGraph
removeUnreachableBlocksZ g@(G.LGraph id off blocks) =
if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id off blocks'
removeUnreachableBlocksZ g@(G.LGraph id blocks) =
if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id blocks'
else noTx g
where blocks' = G.postorder_dfs g
......@@ -22,24 +22,27 @@ import UniqSupply
import Maybe
cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h (CmmStackInfo, CmmGraph))
cmmOfZgraph :: GenCmm d h (CmmStackInfo, CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
where mapTop (CmmProc h l args g) =
toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
mapTop (CmmData s ds) = return $ CmmData s ds
cmmOfZgraph = cmmMapGraph ofZgraph
cmmOfZgraph = cmmMapGraph (ofZgraph . snd)
toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM CmmGraph
toZgraph _ _ (ListGraph []) = lgraphOfAGraph 0 emptyAGraph
toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
toZgraph _ _ (ListGraph []) =
do g <- lgraphOfAGraph emptyAGraph
return ((0, Nothing), g)
toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
let (offset, entry) = mkEntry id Native args in
labelAGraph id offset $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
do g <- labelAGraph id $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
return ((offset, Nothing), g)
where addBlock (BasicBlock id ss) g =
mkLabel id emptyStackInfo <*> mkStmts ss <*> g
updfr_sz = panic "upd frame size lost in cmm conversion"
mkLabel id <*> mkStmts ss <*> g
updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
......@@ -106,11 +109,11 @@ ofZgraph g = ListGraph $ swallow blocks
extend_block _id stmts = stmts
_extend_entry stmts = scomment showblocks : scomment cscomm : stmts
showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
concat (map (\(G.Block id _ _) -> " " ++ show id) blocks)
concat (map (\(G.Block id _) -> " " ++ show id) blocks)
cscomm = "Call successors are" ++
(concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
swallow [] = []
swallow (G.Block id _ t : rest) = tail id [] t rest
swallow (G.Block id t : rest) = tail id [] t rest
tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
......@@ -139,7 +142,7 @@ ofZgraph g = ListGraph $ swallow blocks
_ -> endblock (CmmBranch tgt)
LastCondBranch expr tid fid ->
case n of
G.Block id' _ t : bs
G.Block id' t : bs
-- It would be better to handle earlier, but we still must
-- generate correct code here.
| id' == fid, tid == fid, unique_pred id' ->
......@@ -152,11 +155,11 @@ ofZgraph g = ListGraph $ swallow blocks
_ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
in block' id instrs' : swallow n
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
LastCall e _ _ _ -> endblock $ CmmJump e []
LastCall e _ _ _ _ -> endblock $ CmmJump e []
exit id prev' n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
case n of [] -> endblock (scomment "procedure falls off end")
G.Block id' _ t : bs ->
G.Block id' t : bs ->
if unique_pred id' then
tail id (scomment "went thru exit" : prev') t bs
else
......@@ -175,7 +178,7 @@ ofZgraph g = ListGraph $ swallow blocks
call_succs =
let add b succs =
case G.last (G.unzip b) of
G.LastOther (LastCall _ (Just id) _ _) ->
G.LastOther (LastCall _ (Just id) _ _ _) ->
extendBlockSet succs id
_ -> succs
in G.fold_blocks add emptyBlockSet g
......
......@@ -22,7 +22,7 @@ module CmmExpr
, DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet
, Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, StackSlotMap, getSlot
, Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
-- MachOp
, MachOp(..)
......@@ -263,23 +263,14 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
-- Stack slots
-----------------------------------------------------------------------------
mkVarSlot :: LocalReg -> CmmExpr
mkVarSlot r = CmmStackSlot (RegSlot r) 0
-- Usually, we either want to lookup a variable's spill slot in an environment
-- or else allocate it and add it to the environment.
-- For a variable, we just need a single area of the appropriate size.
type StackSlotMap = FiniteMap LocalReg CmmExpr
getSlot :: StackSlotMap -> LocalReg -> (StackSlotMap, CmmExpr)
getSlot map r = case lookupFM map r of
Just s -> (map, s)
Nothing -> (addToFM map r s, s) where s = mkVarSlot r
isStackSlotOf :: CmmExpr -> LocalReg -> Bool
isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
isStackSlotOf _ _ = False
-----------------------------------------------------------------------------
-- Stack slot use information for expressions and other types [_$_]
-----------------------------------------------------------------------------
-- Fold over the area, the offset into the area, and the width of the subarea.
class UserOfSlots a where
foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
......
......@@ -21,10 +21,10 @@ import SMRep
import ZipCfgCmmRep
import Constants
import Panic
import StaticFlags
import Unique
import UniqSupply
import Panic
import Data.Bits
......
......@@ -3,7 +3,7 @@ module CmmLiveZ
( CmmLive
, cmmLivenessZ
, liveLattice
, middleLiveness, lastLiveness, noLiveOnEntry
, middleLiveness, noLiveOnEntry
)
where
......@@ -43,17 +43,22 @@ type BlockEntryLiveness = BlockEnv CmmLive
-- | Calculated liveness info for a CmmGraph
-----------------------------------------------------------------------------
cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
cmmLivenessZ g@(LGraph entry _ _) =
cmmLivenessZ g@(LGraph entry _) =
liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers
emptyUniqSet (graphOfLGraph g)
transfers = BackwardTransfers first middle last
first live _ = live
middle = flip middleLiveness
last = flip lastLiveness
check facts =
transfers = BackwardTransfers (flip const) mid last
mid m = gen_kill m . midLive m