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) =
import SMRep
import StgCmmClosure
import StgCmmForeign
-import StgCmmMonad
+-- import StgCmmMonad
import StgCmmUtils
import UniqSupply
import ZipCfg hiding (zip, unzip, last)
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)
+
-----------------------------------------------------------------------
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
-- 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,
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
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.
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' }
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
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) =
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
-- 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 ()
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)
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)
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 =
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) =
-- 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
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)
-- 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
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
import Maybes
import Monad
import Outputable
-import Panic
import Prelude hiding (unzip, zip)
import Util
| 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)
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!
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
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
----------------------------------------------------------------
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')) ->
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
----------------------------------------------------------------
_ -> 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
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
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
_ -> 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' ->
_ -> 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
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
, 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(..)
-- 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
import ZipCfgCmmRep
import Constants
+import Panic
import StaticFlags
import Unique
import UniqSupply
-import Panic
import Data.Bits
( CmmLive
, cmmLivenessZ
, liveLattice
- , middleLiveness, lastLiveness, noLiveOnEntry
+ , middleLiveness, noLiveOnEntry
)
where
-- | 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
+ last l = gen_kill l . lastLive l
+ check facts =
noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
+gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
+gen_kill a = gen a . kill a
+
+middleLiveness :: Middle -> CmmLive -> CmmLive
+middleLiveness = gen_kill
+
-- | On entry to the procedure, there had better not be any LocalReg's live-in.
noLiveOnEntry :: BlockId -> CmmLive -> a -> a
noLiveOnEntry bid in_fact x =
-- | The transfer equations use the traditional 'gen' and 'kill'
-- notations, which should be familiar from the dragon book.
-gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
-gen a live = foldRegsUsed extendRegSet live a
-kill a live = foldRegsUsed delOneFromUniqSet live a
+gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
+gen a live = foldRegsUsed extendRegSet live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd delOneFromUniqSet live a
--- Why aren't these function using the typeclasses on Middle and Last?
-middleLiveness :: Middle -> CmmLive -> CmmLive
-middleLiveness (MidComment {}) live = live
-middleLiveness (MidAssign lhs expr) live = gen expr $ kill lhs live
-middleLiveness (MidStore addr rval) live = gen addr $ gen rval live
-middleLiveness (MidForeignCall _ tgt _ args) _ = gen tgt $ gen args emptyUniqSet
+midLive :: Middle -> CmmLive -> CmmLive
+midLive (MidForeignCall {}) _ = emptyUniqSet
+midLive _ live = live
-lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
-lastLiveness l env = last l
- where last (LastBranch id) = env id
- last (LastCall tgt Nothing _ _) = gen tgt $ emptyUniqSet
- last (LastCall tgt (Just k) _ _) = gen tgt $ env k
- last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f)
- last (LastSwitch e tbl) =
- gen e $ unionManyUniqSets $ map env (catMaybes tbl)
+lastLive :: Last -> (BlockId -> CmmLive) -> CmmLive
+lastLive l env = last l
+ where last (LastBranch id) = env id
+ last (LastCall _ _ _ _ _) = emptyUniqSet
+ last (LastCondBranch _ t f) = unionUniqSets (env t) (env f)
+ last (LastSwitch _ tbl) = unionManyUniqSets $ map env (catMaybes tbl)
forward :: ForwardTransfers Middle Last Status
forward = ForwardTransfers first middle last exit
- where first ProcPoint id = ReachedBy $ unitBlockSet id
- first x _ = x
- middle x _ = x
- last _ (LastCall _ (Just id) _ _) = LastOutFacts [(id, ProcPoint)]
- last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
+ where first id ProcPoint = ReachedBy $ unitBlockSet id
+ first _ x = x
+ middle _ x = x
+ last (LastCall _ (Just id) _ _ _) _ = LastOutFacts [(id, ProcPoint)]
+ last l x = LastOutFacts $ map (\id -> (id, x)) (succs l)
exit x = x
-- It is worth distinguishing two sets of proc points:
callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g
where add b set = case last $ unzip b of
- LastOther (LastCall _ (Just k) _ _) -> extendBlockSet set k
+ LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k
_ -> set
minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
procPoints' = fold_blocks add emptyBlockSet g
newPoints = mapMaybe ppSuccessor blocks
newPoint = listToMaybe newPoints
- ppSuccessor b@(Block bid _ _) =
+ ppSuccessor b@(Block bid _) =
let nreached id = case lookupBlockEnv env id `orElse`
pprPanic "no ppt" (ppr id <+> ppr b) of
ProcPoint -> 1
do liveness <- cmmLivenessZ g
(protos, g') <- optimize_calls liveness g
blocks'' <- add_CopyOuts protos procPoints g'
- return $ LGraph (lg_entry g) (lg_argoffset g) blocks''
+ return $ LGraph (lg_entry g) blocks''
where optimize_calls liveness g = -- see Note [Separate Adams optimization]
do let (protos, blocks') =
fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
protos' = add_unassigned liveness procPoints protos
blocks <- add_CopyIns callPPs protos' blocks'
- let g' = LGraph (lg_entry g) (lg_argoffset g)
- (mkBlockEnv (map withKey (concat blocks)))
- withKey b@(Block bid _ _) = (bid, b)
+ let g' = LGraph (lg_entry g) (mkBlockEnv (map withKey (concat blocks)))
+ withKey b@(Block bid _) = (bid, b)
return (protos', runTx removeUnreachableBlocksZ g')
maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
-> (BlockEnv Protocol, BlockEnv CmmBlock)
-- redirect the call (cf 'newblock') and set the protocol if necessary
maybe_add_call block (protos, blocks) =
case goto_end $ unzip block of
- (h, LastOther (LastCall tgt (Just k) u s))
+ (h, LastOther (LastCall tgt (Just k) args res s))
| Just proto <- lookupBlockEnv protos k,
Just pee <- branchesToProcPoint k
- -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) u s))
+ -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee)
+ args res s))
changed_blocks = insertBlock newblock blocks
unchanged_blocks = insertBlock block blocks
in case lookupBlockEnv protos pee of
branchesToProcPoint :: BlockId -> Maybe BlockId
-- ^ Tells whether the named block is just a branch to a proc point
branchesToProcPoint id =
- let (Block _ _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
+ let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
panic "branch out of graph"
in case t of
ZLast (LastOther (LastBranch pee))
--maybe_add_proto (Block id (ZTail (CopyIn c _ fs _srt) _)) env =
-- extendBlockEnv env id (Protocol c fs $ toArea id fs)
maybe_add_proto _ env = env
+ -- JD: Is this proto stuff even necessary, now that we have
+ -- common blockification?
-- | For now, following a suggestion by Ben Lippmeier, we pass all
-- live variables as arguments, hoping that a clever register
FuelMonad [[CmmBlock]]
add_CopyIns callPPs protos blocks =
liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks)
- where maybe_insert_CopyIns (_, b@(Block id stackInfo t))
+ where maybe_insert_CopyIns (_, b@(Block id t))
| not $ elemBlockSet id callPPs
- = case (argBytes stackInfo, lookupBlockEnv protos id) of
- (Just _, _) -> panic "shouldn't copy arguments twice into a block"
- (_, Just (Protocol c fs area)) ->
- do let (off, copies) = copyIn c False area fs
- stackInfo' = stackInfo {argBytes = Just off}
- LGraph _ _ blocks <-
- lgraphOfAGraph 0 (mkLabel id stackInfo' <*>
- copies <*> mkZTail t)
+ = case lookupBlockEnv protos id of
+ Just (Protocol c fs _area) ->
+ do LGraph _ blocks <-
+ lgraphOfAGraph (mkLabel id <*> copyInSlot c False fs <*> mkZTail t)
return (map snd $ blockEnvToList blocks)
- (_, Nothing) -> return [b]
+ Nothing -> return [b]
| otherwise = return [b]
-- | Add a CopyOut node before each procpoint.
add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv) g
where mb_copy_out :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
FuelMonad (BlockEnv CmmBlock)
- mb_copy_out b@(Block bid _ _) z | bid == lg_entry g = skip b z
+ mb_copy_out b@(Block bid _) z | bid == lg_entry g = skip b z
mb_copy_out b z =
case last $ unzip b of
- LastOther (LastCall _ _ _ _) -> skip b z -- copy out done by callee
- _ -> mb_copy_out' b z
- mb_copy_out' b z = fold_succs trySucc b init >>= finish
+ LastOther (LastCall _ _ _ _ _) -> skip b z -- copy out done by callee
+ _ -> copy_out b z
+ copy_out b z = fold_succs trySucc b init >>= finish
where init = z >>= (\bmap -> return (b, bmap))
trySucc succId z =
if elemBlockSet succId procPoints then
case lookupBlockEnv protos succId of
Nothing -> z
- Just (Protocol c fs area) ->
- let (_, copies) =
- copyOut c Jump area (map (CmmReg . CmmLocal) fs) 0
- in insert z succId copies
+ Just (Protocol c fs _area) ->
+ insert z succId $ copyOutSlot c Jump fs
else z
insert z succId m =
do (b, bmap) <- z
(b, bs) <- insertBetween b m succId
-- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
return $ (b, foldl (flip insertBlock) bmap bs)
- finish (b@(Block bid _ _), bmap) =
+ finish (b@(Block bid _), bmap) =
return $ (extendBlockEnv bmap bid b)
- skip b@(Block bid _ _) bs =
+ skip b@(Block bid _) bs =
bs >>= (\bmap -> return (extendBlockEnv bmap bid b))
-- At this point, we have found a set of procpoints, each of which should be
-- the SRTs in the entry procedure as well.
-- Input invariant: A block should only be reachable from a single ProcPoint.
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
- AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
+ CmmTopZ -> FuelMonad [CmmTopZ]
+splitAtProcPoints entry_label callPPs procPoints procMap
(CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
- g@(LGraph entry e_off blocks)) =
+ (stackInfo, g@(LGraph entry blocks))) =
do -- Build a map from procpoints to the blocks they reach
- let addBlock b@(Block bid _ _) graphEnv =
+ let addBlock b@(Block bid _) graphEnv =
case lookupBlockEnv procMap bid of
Just ProcPoint -> add graphEnv bid bid b
Just (ReachedBy set) ->
add graphEnv procId bid b = extendBlockEnv graphEnv procId graph'
where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
graph' = extendBlockEnv graph bid b
- graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g
- graphEnv <- {- pprTrace "graphEnv" (ppr graphEnv_pre) -} return graphEnv_pre
+ graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
-- Build a map from proc point BlockId to labels for their new procedures
+ -- Due to common blockification, we may overestimate the set of procpoints.
let add_label map pp = return $ addToFM map pp lbl
where lbl = if pp == entry then entry_label else blockLbl pp
- -- Due to common blockification, we may overestimate the set of procpoints.
procLabels <- foldM add_label emptyFM
(filter (elemBlockEnv blocks) (blockSetToList procPoints))
+ -- For each procpoint, we need to know the SP offset on entry.
+ -- If the procpoint is:
+ -- - continuation of a call, the SP offset is in the call
+ -- - otherwise, 0 -- no overflow for passing those variables
+ let add_sp_off b env =
+ case last (unzip b) of
+ LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off,
+ cml_ret_off = updfr_off}) ->
+ extendBlockEnv env succ (off, updfr_off)
+ _ -> env
+ spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, stackInfo)]) g
+ getStackInfo id = lookupBlockEnv spEntryMap id `orElse` (0, Nothing)
-- In each new graph, add blocks jumping off to the new procedures,
-- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) =
do bid <- liftM mkBlockId getUniqueM
- let b = Block bid emptyStackInfo (ZLast (LastOther jump))
- argSpace =
- case lookupBlockEnv blocks pp of
- Just (Block _ (StackInfo {argBytes = Just s}) _) -> s
- Just (Block _ _ _) -> panic "no args at procpoint"
- _ -> panic "can't find procpoint block"
- jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace Nothing
+ let b = Block bid (ZLast (LastOther jump))
+ (argSpace, _) = getStackInfo pp
+ jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace 0 Nothing
l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
return (extendBlockEnv env pp bid, b : bs)
add_jumps (newGraphEnv) (ppId, blockEnv) =
add_if_pp id rst = case lookupFM procLabels id of
Just x -> (id, x) : rst
Nothing -> rst
- -- fmToList procLabels
(jumpEnv, jumpBlocks) <-
foldM add_jump_block (emptyBlockEnv, []) needed_jumps
-- update the entry block
- let (b_off, b) = -- get the stack offset on entry into the block and
- -- remove the offset from the block (it goes in new graph)
- case lookupBlockEnv blockEnv ppId of -- get the procpoint block
- Just (Block id sinfo@(StackInfo {argBytes = Just b_off}) t) ->
- (b_off, Block id (sinfo {argBytes = Nothing}) t)
- Just b@(Block _ _ _) -> (0, b)
- Nothing -> panic "couldn't find entry block while splitting"
+ let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId
+ off = getStackInfo ppId
blockEnv' = extendBlockEnv blockEnv ppId b
- off = if ppId == entry then e_off else b_off
-- replace branches to procpoints with branches to jumps
- LGraph _ _ blockEnv'' =
- replaceBranches jumpEnv $ LGraph ppId off blockEnv'
+ LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv'
-- add the jump blocks to the graph
blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
- let g' = LGraph ppId off blockEnv'''
+ let g' = (off, LGraph ppId blockEnv''')
-- pprTrace "g' pre jumps" (ppr g') $ do
return (extendBlockEnv newGraphEnv ppId g')
- graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
- graphEnv <- return $ -- pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
- graphEnv_pre
+ graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
let to_proc (bid, g) | elemBlockSet bid callPPs =
if bid == entry then
CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
-- The C back end expects to see return continuations before the call sites.
-- Here, we sort them in reverse order -- it gets reversed later.
let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)
- add_block_num (i, map) (Block bid _ _) = (i+1, extendBlockEnv map bid i)
+ add_block_num (i, map) (Block bid _) = (i+1, extendBlockEnv map bid i)
sort_fn (bid, _) (bid', _) =
compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
(expectJust "block_order" $ lookupBlockEnv block_order bid')
return -- pprTrace "procLabels" (ppr procLabels)
-- pprTrace "splitting graphs" (ppr procs)
procs
-splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
+splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
----------------------------------------------------------------
type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-dualLivenessWithInsertion procPoints g@(LGraph entry _ _) =
+dualLivenessWithInsertion procPoints g@(LGraph entry _) =
liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
dualLiveLattice (dualLiveTransfers entry procPoints)
empty = fact_bot dualLiveLattice
dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
-dualLiveness procPoints g@(LGraph entry _ _) =
+dualLiveness procPoints g@(LGraph entry _) =
liftM zdfFpFacts $ (res :: LiveReloadFix ())
where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
(dualLiveTransfers entry procPoints) empty g
dualLiveTransfers entry procPoints = BackwardTransfers first middle last
where last = lastDualLiveness
middle = middleDualLiveness
- first live id = check live id $ -- live at procPoint => spill
+ first id live = check live id $ -- live at procPoint => spill
if id /= entry && elemBlockSet id procPoints then
DualLive { on_stack = on_stack live `plusRegSet` in_regs live
, in_regs = emptyRegSet }
else live
check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
-middleDualLiveness :: DualLive -> Middle -> DualLive
-middleDualLiveness live m =
+middleDualLiveness :: Middle -> DualLive -> DualLive
+middleDualLiveness m live =
changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
where regs_in live = case m of MidForeignCall {} -> emptyRegSet
_ -> live
| o == w && w == widthInBytes (typeWidth ty) = x
check _ _ = panic "middleDualLiveness unsupported: slices"
-lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
-lastDualLiveness env l = last l
+lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive
+lastDualLiveness l env = last l
where last (LastBranch id) = env id
- last l@(LastCall _ Nothing _ _) = changeRegs (gen l . kill l) empty
- last l@(LastCall _ (Just k) _ _) =
+ last l@(LastCall _ Nothing _ _ _) = changeRegs (gen l . kill l) empty
+ last l@(LastCall _ (Just k) _ _ _) =
-- nothing can be live in registers at this point, unless safe foreign call
let live = env k
live_in = DualLive (on_stack live) (gen l emptyRegSet)
where middle = middleInsertSpillsAndReloads
last _ _ = Nothing
exit = Nothing
- first live id =
+ first id live =
if id /= entry && elemBlockSet id procPoints then
case map reload (uniqSetToList (in_regs live)) of
[] -> Nothing
is -> Just (mkMiddles is)
else Nothing
-middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
-middleInsertSpillsAndReloads live m = middle m
+middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
+middleInsertSpillsAndReloads m live = middle m
where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
| reg == reg' = Nothing
middle (MidAssign (CmmLocal reg) _) =
spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r)
reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
-reloadTail :: RegSet -> ZTail Middle Last -> ZTail Middle Last
-reloadTail regset t = foldl rel t $ uniqSetToList regset
- where rel t r = ZTail (reload r) t
-
----------------------------------------------------------------
--- sinking reloads
availRegsLattice :: DataflowLattice AvailRegs
availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
- -- last True <==> debugging on
where empty = UniverseMinus emptyRegSet
-- | compute in the Tx monad to track whether anything has changed
add new old =
smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
---extendAvail :: AvailRegs -> LocalReg -> AvailRegs
---extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
---extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
+extendAvail :: AvailRegs -> LocalReg -> AvailRegs
+extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
+extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
-deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-deleteFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
+delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
+delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
+delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
elemAvail :: AvailRegs -> LocalReg -> Bool
elemAvail (UniverseMinus s) r = not $ elemRegSet r s
elemAvail (AvailRegs s) r = elemRegSet r s
-type CmmAvail = BlockEnv AvailRegs
type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
-cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail
+cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs)
cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
avail_reloads_transfer empty g
empty = fact_bot availRegsLattice
avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
-avail_reloads_transfer = ForwardTransfers first middle last id
- where first avail _ = avail
- middle = flip middleAvail
- last = lastAvail
-
--- | The transfer equations use the traditional 'gen' and 'kill'
--- notations, which should be familiar from the dragon book.
---agen,
-akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
---agen a live = foldRegsUsed extendAvail live a
-akill a live = foldRegsUsed deleteFromAvail live a
-
--- Note: you can't sink the reload past a use.
-middleAvail :: Middle -> AvailRegs -> AvailRegs
-middleAvail m = middle m
- where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
- middle' (MidComment {}) live = live
- middle' (MidAssign lhs _expr) live = akill lhs live
- middle' (MidStore {}) live = live
- middle' (MidForeignCall {}) _ = AvailRegs emptyRegSet
+avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id
-lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
-lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
-lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
+middleAvail :: Middle -> AvailRegs -> AvailRegs
+middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail
+ | l `isStackSlotOf` r = extendAvail avail r
+middleAvail (MidAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
+middleAvail (MidStore l (CmmReg (CmmLocal r))) avail
+ | l `isStackSlotOf` r = avail
+middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
+middleAvail (MidStore {}) avail = avail
+middleAvail (MidForeignCall {}) _ = AvailRegs emptyRegSet
+middleAvail (MidComment {}) avail = avail
+
+lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs
+lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)]
+lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l
type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
+availRewrites :: ForwardRewrites Middle Last AvailRegs
+availRewrites = ForwardRewrites first middle last exit
+ where first _ _ = Nothing
+ middle m avail = maybe_reload_before avail m (mkMiddle m)
+ last l avail = maybe_reload_before avail l (mkLast l)
+ exit _ = Nothing
+ maybe_reload_before avail node tail =
+ let used = filterRegsUsed (elemAvail avail) node
+ in if isEmptyUniqSet used then Nothing
+ else Just $ reloadTail used tail
+ reloadTail regset t = foldl rel t $ uniqSetToList regset
+ where rel t r = mkMiddle (reload r) <*> t
+
+
insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
- availRegsLattice avail_reloads_transfer rewrites bot g
+ availRegsLattice avail_reloads_transfer availRewrites bot g
bot = fact_bot availRegsLattice
- rewrites = ForwardRewrites first middle last exit
- first _ _ = Nothing
- middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last)
- last :: AvailRegs -> Last -> Maybe (AGraph Middle Last)
- middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
- last avail l = maybe_reload_before avail l (ZLast (LastOther l))
- exit _ = Nothing
- maybe_reload_before avail node tail =
- let used = filterRegsUsed (elemAvail avail) node
- in if isEmptyUniqSet used then Nothing
- else Just $ mkZTail $ reloadTail used tail
removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _ _) =
+removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) =
liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
dualLiveLattice (dualLiveTransfers entry procPoints)
rewrites (fact_bot dualLiveLattice) g
- rewrites = BackwardRewrites first middle last exit
- exit = Nothing
- last = \_ _ -> Nothing
- middle = middleRemoveDeads
- first _ _ = Nothing
-
-middleRemoveDeads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
-middleRemoveDeads live m = middle m
- where middle (MidAssign (CmmLocal reg') _)
- | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
- middle _ = Nothing
+ rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing
+ nothing _ _ = Nothing
+
+middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
+middleRemoveDeads (MidAssign (CmmLocal reg') _) live
+ | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
+middleRemoveDeads _ _ = Nothing
import Monad
import Outputable
import Panic
+import SMRep (ByteOff)
import ZipCfg
+import ZipCfg as Z
import ZipCfgCmmRep
import ZipDataflow
liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
liveSlotTransfers =
BackwardTransfers first liveInSlots liveLastIn
- where first live id = delFromFM live (CallArea (Young id))
+ where first id live = delFromFM live (CallArea (Young id))
-- Slot sets: adding slots, removing slots, and checking for membership.
liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet
removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
removeLiveSlotDefs = foldSlotsDefd removeSlot
-liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
-liveInSlots live x = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
+liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet
+liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
-liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
-liveLastIn env l = liveInSlots (liveLastOut env l) l
+liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet
+liveLastIn l env = liveInSlots l (liveLastOut env l)
-- Don't forget to keep the outgoing parameters in the CallArea live,
-- as well as the update frame.
liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
liveLastOut env l =
case l of
- LastCall _ Nothing n _ ->
+ LastCall _ Nothing n _ _ ->
add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
- LastCall _ (Just k) n (Just _) ->
+ LastCall _ (Just k) n _ (Just _) ->
add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
- LastCall _ (Just k) n Nothing ->
+ LastCall _ (Just k) n _ Nothing ->
add_area (CallArea (Young k)) n out
_ -> out
where out = joinOuts slotLattice env l
interfere block igraph =
let (h, l) = goto_end (unzip block)
--heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x
- heads (ZFirst _ _) (igraph, _) = igraph
+ heads (ZFirst _) (igraph, _) = igraph
heads (ZHead h m) (igraph, liveOut) =
- heads h (addEdges igraph m liveOut, liveInSlots liveOut m)
+ heads h (addEdges igraph m liveOut, liveInSlots m liveOut)
-- add edges between a def and the other defs and liveouts
addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
addDef (igraph, out) def@(a, _, _) =
env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
in heads h $ case l of LastExit -> (igraph, emptyFM)
LastOther l -> (addEdges igraph l $ liveLastOut env' l,
- liveLastIn env' l)
+ liveLastIn l env')
-- Before allocating stack slots, we need to collect one more piece of information:
-- what's the highest offset (in bytes) used in each Area?
-- We'll need to allocate that much space for each Area.
-getAreaSize :: LGraph Middle Last -> AreaMap
-getAreaSize g@(LGraph _ off _) =
+getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap
+getAreaSize entry_off g@(LGraph _ _) =
fold_blocks (fold_fwd_block first add_regslots last)
- (unitFM (CallArea Old) off) g
- where first id (StackInfo {argBytes = Just off}) z = add z (CallArea (Young id)) off
- first _ _ z = z
- add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
- last l@(LastOther (LastCall _ Nothing off _)) z =
- add_regslots l (add z (CallArea Old) off)
- last l@(LastOther (LastCall _ (Just k) off _)) z =
- add_regslots l (add z (CallArea (Young k)) off)
+ (unitFM (CallArea Old) entry_off) g
+ where first _ z = z
+ last l@(LastOther (LastCall _ Nothing args res _)) z =
+ add_regslots l (add (add z area args) area res)
+ where area = CallArea Old
+ last l@(LastOther (LastCall _ (Just k) args res _)) z =
+ add_regslots l (add (add z area args) area res)
+ where area = CallArea (Young k)
last l z = add_regslots l z
- addSlot z (a@(RegSlot _), off, _) = add z a off
+ add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
+ addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) =
+ add z a $ widthInBytes $ typeWidth ty
addSlot z _ = z
add z a off = addToFM z a (max off (lookupWithDefaultFM z 0 a))
-- Note: The stack pointer only has to be younger than the youngest live stack slot
-- at proc points. Otherwise, the stack pointer can point anywhere.
-layout :: ProcPointSet -> SlotEnv -> LGraph Middle Last -> AreaMap
-layout procPoints env g =
- let builder = areaBuilder
- ig = (igraph builder env g, builder)
+layout :: ProcPointSet -> SlotEnv -> ByteOff -> LGraph Middle Last -> AreaMap
+layout procPoints env entry_off g =
+ let ig = (igraph areaBuilder env g, areaBuilder)
env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
- areaSize = getAreaSize g
- -- Find the slots that are live-in to the block
- live_in (ZTail m l) = liveInSlots (live_in l) m
- live_in (ZLast (LastOther l)) = liveLastIn env' l
+ areaSize = getAreaSize entry_off g
+ -- Find the slots that are live-in to a block tail
+ live_in (ZTail m l) = liveInSlots m (live_in l)
+ live_in (ZLast (LastOther l)) = liveLastIn l env'
live_in (ZLast LastExit) = emptyFM
-- Find the youngest live stack slot
youngest_live areaMap live = fold_subareas young_slot live 0
where young_slot (a, o, _) z = case lookupFM areaMap a of
Just top -> max z $ top + o
Nothing -> z
- fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z
- fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m
+ fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m
-- Allocate space for spill slots and call areas
allocVarSlot = allocSlotFrom ig areaSize 0
- allocCallSlot areaMap (Block id stackInfo t)
- | elemBlockSet id procPoints =
- let young = youngest_live areaMap $ live_in t
- start = case returnOff stackInfo of Just b -> max b young
- Nothing -> young
- z = allocSlotFrom ig areaSize start areaMap (CallArea (Young id))
- in -- pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z)
- z
- allocCallSlot areaMap _ = areaMap
- -- mid foreign calls need to have info tables placed on the stack
+ -- Update the successor's incoming SP.
+ setSuccSPs inSp bid areaMap =
+ case (lookupFM areaMap area, lookupBlockEnv (lg_blocks g) bid) of
+ (Just _, _) -> areaMap -- succ already knows incoming SP
+ (Nothing, Just (Block _ _)) ->
+ if elemBlockSet bid procPoints then
+ let young = youngest_live areaMap $ env' bid
+ -- start = case returnOff stackInfo of Just b -> max b young
+ -- Nothing -> young
+ start = young -- maybe wrong, but I don't understand
+ -- why the preceding is necessary...
+ in allocSlotFrom ig areaSize start areaMap area
+ else addToFM areaMap area inSp
+ (_, Nothing) -> panic "Block not found in cfg"
+ where area = CallArea (Young bid)
+ allocLast (Block id _) areaMap l =
+ fold_succs (setSuccSPs inSp) l areaMap
+ where inSp = expectJust "sp in" $ lookupFM areaMap (CallArea (Young id))
allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
area = CallArea (Young bid)
foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m
where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
alloc' areaMap _ = areaMap
- layoutAreas areaMap b@(Block _ _ t) = layout areaMap t
+ layoutAreas areaMap b@(Block _ t) = layout areaMap t
where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
- layout areaMap (ZLast _) = allocCallSlot areaMap b
- areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) (postorder_dfs g)
+ layout areaMap (ZLast l) = allocLast b areaMap l
+ initMap = addToFM (addToFM emptyFM (CallArea Old) 0)
+ (CallArea (Young (lg_entry g))) 0
+ areaMap = foldl layoutAreas initMap (postorder_dfs g)
in -- pprTrace "ProcPoints" (ppr procPoints) $
- -- pprTrace "Area SizeMap" (ppr areaSize) $
+ -- pprTrace "Area SizeMap" (ppr areaSize) $
-- pprTrace "Entry SP" (ppr entrySp) $
-- pprTrace "Area Map" (ppr areaMap) $
areaMap
-- stack pointer to be younger than the live values on the stack at proc points.
-- 3. Compute the maximum stack offset used in the procedure and replace
-- the stack high-water mark with that offset.
-manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap ->
- LGraph Middle Last -> FuelMonad (LGraph Middle Last)
-manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
- liftM (LGraph entry args) blocks'
- where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g)
- slot a = -- pprTrace "slot" (ppr a) $
+manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Middle Last)
+manifestSP areaMap entry_off g@(LGraph entry _blocks) =
+ liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g)
+ where slot a = -- pprTrace "slot" (ppr a) $
lookupFM areaMap a `orElse` panic "unallocated Area"
slot' (Just id) = slot $ CallArea (Young id)
slot' Nothing = slot $ CallArea Old
sp_high = maxSlot slot g
- proc_entry_sp = slot (CallArea Old) + args
+ proc_entry_sp = slot (CallArea Old) + entry_off
+
+ add_sp_off b env =
+ case Z.last (unzip b) of
+ LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off}) ->
+ extendBlockEnv env succ off
+ _ -> env
+ spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, entry_off)]) g
+ spOffset id = lookupBlockEnv spEntryMap id `orElse` 0
+
sp_on_entry id | id == entry = proc_entry_sp
- sp_on_entry id =
- case lookupBlockEnv blocks id of
- Just (Block _ (StackInfo {argBytes = Just o}) _) -> slot' (Just id) + o
- _ ->
- case expectJust "sp_on_entry" (lookupBlockEnv procMap id) of
- ReachedBy pp ->
- case blockSetToList pp of
- [id] -> sp_on_entry id
- _ -> panic "block not reached by one proc point"
- ProcPoint -> pprPanic "procpoint doesn't take any arguments?"
- (ppr id <+> ppr g <+> ppr procPoints <+> ppr procMap)
+ sp_on_entry id = slot' (Just id) + spOffset id
-- On entry to procpoints, the stack pointer is conventional;
-- otherwise, we check the SP set by predecessors.
replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
- replB blocks (Block id o t) =
- do bs <- replTail (Block id o) spIn t
+ replB blocks (Block id t) =
+ do bs <- replTail (Block id) spIn t
-- pprTrace "spIn" (ppr id <+> ppr spIn) $ do
liftM (flip (foldr insertBlock) bs) blocks
where spIn = sp_on_entry id
replSlot _ e = e
-- The block must establish the SP expected at each successsor.
fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock])
- fixSp h spOff l@(LastCall _ k n _) = updSp h spOff (slot' k + n) l
+ fixSp h spOff l@(LastCall _ k n _ _) = updSp h spOff (slot' k + n) l
fixSp h spOff l@(LastBranch k) =
let succSp = sp_on_entry k in
if succSp /= spOff then
-- To compute the stack high-water mark, we fold over the graph and
-- compute the highest slot offset.
maxSlot :: (Area -> Int) -> CmmGraph -> Int
-maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g
+maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g
where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
add z (a, i, _) = max z (slotOff a + i)
rewrites = BackwardRewrites first middle last Nothing
first _ _ = Nothing
last _ _ = Nothing
- middle liveSlots m = foldSlotsUsed (stub liveSlots m) Nothing m
+ middle m liveSlots = foldSlotsUsed (stub liveSlots m) Nothing m
stub liveSlots m rst subarea@(a, off, w) =
if elemSlot liveSlots subarea then rst
else let store = mkStore (CmmStackSlot a off)
-- | Compute the predecessors of each /reachable/ block
zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet
zipPreds g = foldl add emptyBlockEnv (postorder_dfs g)
- where add env block@(Block id _ _) =
+ where add env block@(Block id _) =
foldl (\env sid ->
let preds = lookupBlockEnv env sid `orElse` emptyBlockSet
in extendBlockEnv env sid (extendBlockSet preds id))
-}
data DataflowLattice a = DataflowLattice {
- fact_name :: String, -- documentation
- fact_bot :: a, -- lattice bottom element
- fact_add_to :: a -> a -> TxRes a, -- lattice join and compare
+ fact_name :: String, -- documentation
+ fact_bot :: a, -- lattice bottom element
+ fact_add_to :: a -> a -> TxRes a, -- lattice join and compare
-- ^ compute join of two args; something changed iff join is greater than 2nd arg
- fact_do_logging :: Bool -- log changes
+ fact_do_logging :: Bool -- log changes
}
getExitFact = DFM' get
where get _ s = return (df_exit_fact s, s)
setExitFact a =
- do old <- getExitFact
- DataflowLattice { fact_add_to = add_fact
- , fact_name = name, fact_do_logging = log } <- lattice
- case add_fact a old of
- TxRes NoChange _ -> return ()
- TxRes SomeChange join -> DFM' $ \_ s ->
- let debug = if log then pprTrace else \_ _ a -> a
- in debug name (pprSetFact "exit" old a join) $
- return ((), s { df_exit_fact = join, df_facts_change = SomeChange })
+ do DataflowLattice { fact_name = name, fact_do_logging = log} <- lattice
+ DFM' $ \_ s ->
+ let debug = if log then pprTrace else \_ _ a -> a
+ in debug name (pprSetFact "exit" a a a) $
+ return ((), s { df_exit_fact = a })
getAllFacts = DFM' f
where f _ s = return (df_facts s, s)
setAllFacts env = DFM' f
-- splicing operation <*>, are constant-time operations.
emptyAGraph :: AGraph m l
-mkLabel :: (LastNode l) =>
- BlockId -> StackInfo -> AGraph m l -- graph contains the label
+mkLabel :: (LastNode l) => BlockId -> AGraph m l -- graph contains the label
mkMiddle :: m -> AGraph m l -- graph contains the node
mkLast :: (Outputable m, Outputable l, LastNode l) =>
l -> AGraph m l -- graph contains the node
-- because it may require the allocation of fresh, unique labels.
graphOfAGraph :: AGraph m l -> UniqSM (Graph m l)
-lgraphOfAGraph :: Int -> AGraph m l -> UniqSM (LGraph m l)
+lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l)
-- ^ allocate a fresh label for the entry point
-labelAGraph :: BlockId -> Int -> AGraph m l -> UniqSM (LGraph m l)
+labelAGraph :: BlockId -> AGraph m l -> UniqSM (LGraph m l)
-- ^ use the given BlockId as the label of the entry point
graphOfAGraph (AGraph f) = f emptyGraph
emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
-labelAGraph id args g =
+labelAGraph id g =
do Graph tail blocks <- graphOfAGraph g
- return $ LGraph id args $ insertBlock (Block id stackInfo tail) blocks
- where stackInfo = StackInfo Nothing Nothing
+ return $ LGraph id $ insertBlock (Block id tail) blocks
-lgraphOfAGraph args g = do id <- freshBlockId "graph entry"
- labelAGraph id args g
+lgraphOfAGraph g = do id <- freshBlockId "graph entry"
+ labelAGraph id g
-------------------------------------
-- constructors
-mkLabel id args = AGraph f
+mkLabel id = AGraph f
where f (Graph tail blocks) =
return $ Graph (ZLast (mkBranchNode id))
- (insertBlock (Block id args tail) blocks)
+ (insertBlock (Block id tail) blocks)
mkBranch target = mkLast $ mkBranchNode target
withFreshLabel "start of then" $ \tid ->
withFreshLabel "start of else" $ \fid ->
cbranch tid fid <*>
- mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*>
- mkLabel fid emptyStackInfo <*> fbranch <*>
- mkLabel endif emptyStackInfo
+ mkLabel tid <*> tbranch <*> mkBranch endif <*>
+ mkLabel fid <*> fbranch <*>
+ mkLabel endif
mkWhileDo cbranch body =
withFreshLabel "loop test" $ \test ->
withFreshLabel "loop head" $ \head ->
withFreshLabel "end while" $ \endwhile ->
-- Forrest Baskett's while-loop layout
- mkBranch test <*> mkLabel head emptyStackInfo <*> body
- <*> mkLabel test emptyStackInfo <*> cbranch head endwhile
- <*> mkLabel endwhile emptyStackInfo
+ mkBranch test <*> mkLabel head <*> body
+ <*> mkLabel test <*> cbranch head endwhile
+ <*> mkLabel endwhile
-- | Bleat if the insertion of a last node will create unreachable code
note_this_code_becomes_unreachable ::
module MkZipCfgCmm
( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
, mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
- , mkReturnSimple, mkComment, copyIn, copyOut
+ , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
, mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
, (<*>), catAGraphs, mkLabel, mkBranch
, emptyAGraph, withFreshLabel, withUnique, outOfLine
, lgraphOfAGraph, graphOfAGraph, labelAGraph
- , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
+ , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo
, Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
- , emptyStackInfo, stackStubExpr, pprAGraph
+ , stackStubExpr, pprAGraph
)
where
import ForeignCall
import MkZipCfg
import Panic
+import SMRep (ByteOff)
import StaticFlags
import ZipCfg
type CmmGraph = LGraph Middle Last
type CmmAGraph = AGraph Middle Last
type CmmBlock = Block Middle Last
-type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
-type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
+type CmmStackInfo = (ByteOff, Maybe ByteOff)
+ -- probably want a record; (SP offset on entry, update frame space)
+type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
+type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
data Transfer = Call | Jump | Ret deriving Eq
= withFreshLabel "end of if" $ \endif ->
withFreshLabel "start of then" $ \tid ->
mkCbranch e tid endif <*>
- mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*>
- mkLabel endif emptyStackInfo
+ mkLabel tid <*> tbranch <*> mkBranch endif <*>
+ mkLabel endif
stackStubExpr :: Width -> CmmExpr
stackStubExpr w = CmmLit (CmmInt 0 w)
+-- When we copy in parameters, we usually want to put overflow
+-- parameters on the stack, but sometimes we want to pass
+-- the variables in their spill slots.
+-- Therefore, for copying arguments and results, we provide different
+-- functions to pass the arguments in an overflow area and to pass them in spill slots.
+copyInOflow :: Convention -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph)
+copyInSlot :: Convention -> Bool -> CmmFormals -> CmmAGraph
+copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
+ (Int, [Middle])
+copyOutSlot :: Convention -> Transfer -> [LocalReg] -> [Middle]
+ -- why a list of middles here instead of an AGraph?
+
+copyInOflow = copyIn oneCopyOflowI
+copyInSlot c i f = snd $ copyIn oneCopySlotI c i (panic "no area for copying to slots") f
+
+type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
+ (ByteOff, CmmAGraph)
+type CopyIn = SlotCopier -> Convention -> Bool -> Area -> CmmFormals ->
+ (ByteOff, CmmAGraph)
+
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
-copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last)
-copyIn conv isCall area formals =
- foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals
+copyIn :: CopyIn
+copyIn oflow conv isCall area formals =
+ foldr ci (init_offset, mkNop) args'
where ci (reg, RegisterParam r) (n, ms) =
(n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
- ci (reg, StackParam off) (n, ms) =
- let ty = localRegType reg
- off' = off + init_offset
- in (max n off',
- mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms)
- init_offset = widthInBytes wordWidth
+ ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
+ init_offset = widthInBytes wordWidth -- infotable
+ args = assignArgumentsPos conv isCall localRegType formals
+ args' = foldl adjust [] args
+ where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
+ adjust rst x@(_, RegisterParam _) = x : rst
+
+-- Copy-in one arg, using overflow space if needed.
+oneCopyOflowI, oneCopySlotI :: SlotCopier
+oneCopyOflowI area (reg, off) (n, ms) =
+ (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
+ where ty = localRegType reg
+
+-- Copy-in one arg, using spill slots if needed -- used for calling conventions at
+-- a procpoint that is not a return point. The offset is irrelevant here...
+oneCopySlotI _ (reg, _) (n, ms) =
+ (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
+ where ty = localRegType reg
+ w = widthInBytes (typeWidth ty)
+
+
+-- Factoring out the common parts of the copyout functions yielded something
+-- more complicated:
-- The argument layout function ignores the pointer to the info table, so we slot that
-- in here. When copying-out to a young area, we set the info table for return
-- and adjust the offsets of the other parameters.
-- If this is a call instruction, we adjust the offsets of the other parameters.
-copyOut :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle])
-copyOut conv transfer area@(CallArea a) actuals updfr_off =
+copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
foldr co (init_offset, []) args'
- where args = assignArgumentsPos conv skip_node cmmExprType actuals
- skip_node = transfer /= Ret
+ where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
+ co (v, StackParam off) (n, ms) =
+ (max n off, MidStore (CmmStackSlot area off) v : ms)
(setRA, init_offset) =
case a of Young id@(BlockId _) -> -- set RA if making a call
if transfer == Call then
- ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width)
+ ([(CmmLit (CmmBlock id), StackParam init_offset)],
+ widthInBytes wordWidth)
else ([], 0)
Old -> ([], updfr_off)
- ra_width = widthInBytes wordWidth
+ args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals
args' = foldl adjust setRA args
where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
adjust rst x@(_, RegisterParam _) = x : rst
- co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
- co (v, StackParam off) (n, ms) =
- (max n off, MidStore (CmmStackSlot area off) v : ms)
-copyOut _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
+copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
+
+-- Args passed only in registers and stack slots; no overflow space.
+-- No return address may apply!
+copyOutSlot conv transfer actuals = foldr co [] args
+ where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
+ co (v, StackParam off) ms =
+ MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
+ toExp r = CmmReg (CmmLocal r)
+ args = assignArgumentsPos conv (transfer /= Ret) localRegType actuals
+
+-- oneCopySlotO _ (reg, _) (n, ms) =
+-- (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
+-- where w = widthInBytes (typeWidth (localRegType reg))
mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
-mkEntry _ conv formals = copyIn conv False (CallArea Old) formals
+mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals
lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
- (Int -> Last) -> CmmAGraph
+ (ByteOff -> Last) -> CmmAGraph
lastWithArgs transfer area conv actuals updfr_off last =
- let (outArgs, copies) = copyOut conv transfer area actuals updfr_off in
+ let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
mkMiddles copies <*> mkLast (last outArgs)
-- The area created for the jump and return arguments is the same area as the
-- procedure entry.
old :: Area
old = CallArea Old
-toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> Int -> Last
-toCall e cont updfr_off arg_space = LastCall e cont arg_space (Just updfr_off)
+toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last
+toCall e cont updfr_off res_space arg_space =
+ LastCall e cont arg_space res_space (Just updfr_off)
mkJump e actuals updfr_off =
- lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off
+ lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off 0
mkJumpGC e actuals updfr_off =
- lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off
+ lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
mkForeignJump conv e actuals updfr_off =
- lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off
+ lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
mkReturn e actuals updfr_off =
- lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off
+ lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off 0
-- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
mkReturnSimple actuals updfr_off =
- lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off
+ lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off 0
where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
mkFinalCall f _ actuals updfr_off =
- lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off
+ lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off 0
mkCmmCall f results actuals = mkCall f Native results actuals
mkCall f conv results actuals updfr_off =
withFreshLabel "call successor" $ \k ->
let area = CallArea $ Young k
- (off, copyin) = copyIn conv False area results
+ (off, copyin) = copyInOflow conv False area results
copyout = lastWithArgs Call area conv actuals updfr_off
- (toCall f (Just k) updfr_off)
- in (copyout <*> mkLabel k (StackInfo (Just off) (Just updfr_off))
- <*> copyin)
+ (toCall f (Just k) updfr_off off)
+ in (copyout <*> mkLabel k <*> copyin)
optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
-- lGraphOfGraph is here because we need uniques to implement it.
-lGraphOfGraph :: Graph m l -> Int -> FuelMonad (LGraph m l)
-lGraphOfGraph (Graph tail blocks) args =
+lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l)
+lGraphOfGraph (Graph tail blocks) =
do entry <- liftM BlockId $ getUniqueM
- return $ LGraph entry args
- (insertBlock (Block entry emptyStackInfo tail) blocks)
+ return $ LGraph entry (insertBlock (Block entry tail) blocks)
where blocks = Z.postorder_dfs g
swallow :: [G.CmmBlock] -> [SDoc]
swallow [] = []
- swallow (Z.Block id off t : rest) = tail (id, off) [] Nothing t rest
+ swallow (Z.Block id t : rest) = tail id [] Nothing t rest
tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
tail id prev' _ (Z.ZLast Z.LastExit) rest = exit id prev' rest
mid m = ppr m
- block' (id, off) prev'
+ block' id prev'
| id == Z.lg_entry g, entry_has_no_pred =
- vcat (text "<entry>" <> parens (ppr off) : reverse prev')
- | otherwise = hang (ppr id <> parens (ppr off) <> colon) 4 (vcat (reverse prev'))
+ vcat (text "<entry>" : reverse prev')
+ | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
last id prev' out l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
G.LastBranch tgt ->
case n of
- Z.Block id' _ t : bs
+ Z.Block id' t : bs
| tgt == id', unique_pred id'
-> tail id prev' out t bs -- optimize out redundant labels
_ -> endblock (ppr $ CmmBranch tgt)
l@(G.LastCondBranch expr tid fid) ->
let ft id = text "// fall through to " <> ppr id in
case n of
- Z.Block id' _ t : bs
+ Z.Block id' t : bs
| id' == fid, isNothing out ->
tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
| id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs
_ -> endblock $ with_out out l
- l@(G.LastSwitch {}) -> endblock $ with_out out l
- l@(G.LastCall _ _ _ _)-> endblock $ with_out out l
+ l@(G.LastSwitch {}) -> endblock $ with_out out l
+ l@(G.LastCall _ _ _ _ _) -> endblock $ with_out out l
exit id prev' n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
endblock (text "// <exit>")
with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc
with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
with_out (Just (conv, args)) l = last l
- where last (G.LastCall e k _ _) =
+ where last (G.LastCall e k _ _ _) =
hcat [ptext (sLit "... = foreign "),
doubleQuotes(ppr conv), space,
ppr_target e, parens ( commafy $ map ppr args ),
fold_block_facts z b =
let (h, l) = goto_end (ZipCfg.unzip b)
last_in _ LastExit = fact_bot dualLiveLattice
- last_in env (LastOther l) = bt_last_in comp env l
+ last_in env (LastOther l) = bt_last_in comp l env
in head_fold h (last_in env l) z
- head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp out m) (f out z)
- head_fold (ZFirst id _) out z = f (bt_first_in comp out id) (f out z)
+ head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp m out) (f out z)
+ head_fold (ZFirst id) out z = f (bt_first_in comp id out) (f out z)
foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a
-foldConflicts f z g@(LGraph entry _ _) =
+foldConflicts f z g@(LGraph entry _) =
do env <- dualLiveness emptyBlockSet g
let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
f' dual z = f (on_stack dual) z
( -- These data types and names are carefully thought out
Graph(..), LGraph(..), FGraph(..)
, Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
- , StackInfo(..), emptyStackInfo
, insertBlock
, HavingSuccessors, succs, fold_succs
, LastNode, mkBranchNode, isBranchNode, branchNodeTarget
foldRegsUsed _f z LastExit = z
-data ZHead m = ZFirst BlockId StackInfo
+data ZHead m = ZFirst BlockId
| ZHead (ZHead m) m
-- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
-- | Blocks and flow graphs; see Note [Kinds of graphs]
--- For each block, we may need two pieces of information about the stack:
--- 1. If the block is a procpoint, how many bytes are used to pass
--- arguments on the stack?
--- 2. If the block succeeds a call, we need to generate an infotable
--- that describes the stack layout... but only up to the update frame!
--- Note that a block can be a proc point without requiring an infotable.
-data StackInfo = StackInfo { argBytes :: Maybe Int
- , returnOff :: Maybe Int }
- deriving ( Eq )
-emptyStackInfo :: StackInfo
-emptyStackInfo = StackInfo Nothing Nothing
-
data Block m l = Block { bid :: BlockId
- , stackInfo :: StackInfo
, tail :: ZTail m l }
data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
data LGraph m l = LGraph { lg_entry :: BlockId
- , lg_argoffset :: Int -- space (bytes) for incoming args
, lg_blocks :: BlockEnv (Block m l)}
-- Invariant: lg_entry is in domain( lg_blocks )
-- layout or dataflow, however, one will want to use 'postorder_dfs'
-- in order to get the blocks in an order that relates to the control
-- flow in the procedure.
-of_block_list :: BlockId -> Int -> [Block m l] -> LGraph m l -- N log N
+of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
to_block_list :: LGraph m l -> [Block m l] -- N log N
-- | Conversion from LGraph to Graph
graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
-graphOfLGraph (LGraph eid _ blocks) = Graph (ZLast $ mkBranchNode eid) blocks
+graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
-- | Traversal: 'postorder_dfs' returns a list of blocks reachable
fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
-- | Fold from first to last
-fold_fwd_block :: (BlockId -> StackInfo -> a -> a) -> (m -> a -> a) ->
+fold_fwd_block :: (BlockId -> a -> a) -> (m -> a -> a) ->
(ZLast l -> a -> a) -> Block m l -> a -> a
map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l'
----- block manipulations
-blockId (Block id _ _) = id
+blockId (Block id _) = id
-- | Convert block between forms.
-- These functions are tail-recursive, so we can go as deep as we like
-- without fear of stack overflow.
ht_to_block head tail = case head of
- ZFirst id off -> Block id off tail
+ ZFirst id -> Block id tail
ZHead h m -> ht_to_block h (ZTail m tail)
ht_to_last head (ZLast l) = (head, l)
zip (ZBlock h t) = ht_to_block h t
goto_end (ZBlock h t) = ht_to_last h t
-unzip (Block id off t) = ZBlock (ZFirst id off) t
+unzip (Block id t) = ZBlock (ZFirst id) t
head_id :: ZHead m -> BlockId
-head_id (ZFirst id _) = id
+head_id (ZFirst id) = id
head_id (ZHead h _) = head_id h
last (ZBlock _ t) = lastTail t
------------------ simple graph manipulations
focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
-focus id (LGraph entry _ blocks) =
+focus id (LGraph entry blocks) =
case lookupBlockEnv blocks id of
Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id)
Nothing -> panic "asked for nonexistent block in flow graph"
entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
-entry g@(LGraph eid _ _) = focus eid g
+entry g@(LGraph eid _) = focus eid g
-- | pull out a block satisfying the predicate, if any
splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
-- Better to get [A,B,C,D]
-postorder_dfs g@(LGraph _ _ blockenv) =
+postorder_dfs g@(LGraph _ blockenv) =
let FGraph id eblock _ = entry g in
zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
where
-- vnode ::
-- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
- vnode block@(Block id _ _) cont acc visited =
+ vnode block@(Block id _) cont acc visited =
if elemBlockSet id visited then
cont acc visited
else
-- 'b1' what its inline successor is going to be, so that if 'b1' ends with
-- 'goto b2', the goto can be omitted.
-fold_layout f z g@(LGraph eid _ _) = fold (postorder_dfs g) z
+fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
where fold blocks z =
case blocks of [] -> z
[b] -> f b Nothing z
b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
- nextlabel (Block id _ _) =
+ nextlabel (Block id _) =
if id == eid then panic "entry as successor"
else Just id
-- | The rest of the traversals are straightforward
-map_blocks f (LGraph eid off blocks) = LGraph eid off (mapBlockEnv f blocks)
+map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks)
-map_nodes idm middle last (LGraph eid off blocks) =
- LGraph (idm eid) off (mapBlockEnv (map_one_block idm middle last) blocks)
+map_nodes idm middle last (LGraph eid blocks) =
+ LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks)
-map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t)
+map_one_block idm middle last (Block id t) = Block (idm id) (tail t)
where tail (ZTail m t) = ZTail (middle m) (tail t)
tail (ZLast LastExit) = ZLast LastExit
tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
-mapM_blocks f (LGraph eid off blocks) = blocks' >>= return . LGraph eid off
+mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
where blocks' =
foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
; b <- f b
; return $ insertBlock b blocks })
(return emptyBlockEnv) blocks
-fold_blocks f z (LGraph _ _ blocks) = foldBlockEnv' f z blocks
-fold_fwd_block first middle last (Block id off t) z = tail t (first id off z)
+fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks
+fold_fwd_block first middle last (Block id t) z = tail t (first id z)
where tail (ZTail m t) z = tail t (middle m z)
tail (ZLast l) z = last l z
-of_block_list e off blocks = LGraph e off $ foldr insertBlock emptyBlockEnv blocks
-to_block_list (LGraph _ _ blocks) = eltsBlockEnv blocks
+of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
+to_block_list (LGraph _ blocks) = eltsBlockEnv blocks
-- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
is_exit :: Block m l -> Bool
is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
-splice_head head g@(LGraph _ off _) =
+splice_head head g@(LGraph _ _) =
ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
where eid = head_id head
splice_one_block tail' =
case ht_to_last head tail' of
- (head, LastExit) -> (LGraph eid off emptyBlockEnv, head)
+ (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
_ -> panic "spliced LGraph without exit"
splice_many_blocks entry exit others =
- (LGraph eid off (insertBlock (zipht head entry) others), exit)
+ (LGraph eid (insertBlock (zipht head entry) others), exit)
splice_head' head g =
ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
splice_head_only head g =
let FGraph eid gentry gblocks = entry g
in case gentry of
- ZBlock (ZFirst _ _) tail ->
- LGraph eid 0 (insertBlock (zipht head tail) gblocks)
+ ZBlock (ZFirst _) tail ->
+ LGraph eid (insertBlock (zipht head tail) gblocks)
_ -> panic "entry not at start of block?!"
splice_head_only' head (Graph tail gblocks) =
let eblock = zipht head tail in
- LGraph (blockId eblock) 0 (insertBlock eblock gblocks)
+ LGraph (blockId eblock) (insertBlock eblock gblocks)
-- the offset probably should never be used, but well, it's correct for this LGraph
--- Translation
-translate txm txl (LGraph eid off blocks) =
+translate txm txl (LGraph eid blocks) =
do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
- return $ LGraph eid off blocks'
+ return $ LGraph eid blocks'
where
-- txblock ::
-- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
- txblock (Block id boff t) expanded =
+ txblock (Block id t) expanded =
do blocks' <- expanded
- txtail (ZFirst id boff) t blocks'
+ txtail (ZFirst id) t blocks'
-- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
-- tm (BlockEnv (Block m' l'))
txtail h (ZTail m t) blocks' =
instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
ppr = pprBlock
-instance Outputable StackInfo where
- ppr = pprStackInfo
-
instance (Outputable l) => Outputable (ZLast l) where
ppr = pprLast
pprLast LastExit = text "<exit>"
pprLast (LastOther l) = ppr l
-pprStackInfo :: StackInfo -> SDoc
-pprStackInfo cs =
- text "<arg bytes:" <+> ppr (argBytes cs) <+>
- text "ret offset:" <+> ppr (returnOff cs) <> text ">"
-
pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
-pprBlock (Block id stackInfo tail) =
- ppr id <> parens (ppr stackInfo) <> colon
+pprBlock (Block id tail) =
+ ppr id <> colon
$$ (nest 3 (ppr tail))
pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
-pprLgraph g = text "{" <> text "offset" <> parens (ppr $ lg_argoffset g) $$
+pprLgraph g = text "{" <> text "offset" $$
nest 2 (vcat $ map ppr blocks) $$ text "}"
where blocks = postorder_dfs g
type CmmGraph = LGraph Middle Last
type CmmAGraph = AGraph Middle Last
type CmmBlock = Block Middle Last
-type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
-type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
+type CmmStackInfo = (ByteOff, Maybe ByteOff)
+ -- probably want a record; (SP offset on entry, update frame space)
+type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
+type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a ()
-- BlockId of continuation (Nothing for return or tail call)
cml_args :: ByteOff, -- byte offset for youngest outgoing arg
-- (includes update frame, which must be younger)
+ cml_ret_args:: ByteOff, -- byte offset for youngest incoming arg
cml_ret_off :: Maybe UpdFrameOffset}
-- stack offset for return (update frames);
-- The return offset should be Nothing only if we have to create
panic "unimp: insertBetween after a call -- probably not a good idea"
insert (_, LastExit) = panic "cannot insert after exit"
newBlocks = do id <- liftM BlockId $ getUniqueM
- return $ (id, [Block id emptyStackInfo $
+ return $ (id, [Block id $
foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
else return (Just k, [])
branchNodeTarget _ = panic "asked for target of non-branch"
cmmSuccs :: Last -> [BlockId]
-cmmSuccs (LastBranch id) = [id]
-cmmSuccs (LastCall _ Nothing _ _) = []
-cmmSuccs (LastCall _ (Just id) _ _) = [id]
-cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
-cmmSuccs (LastSwitch _ edges) = catMaybes edges
+cmmSuccs (LastBranch id) = [id]
+cmmSuccs (LastCall _ Nothing _ _ _) = []
+cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
+cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
+cmmSuccs (LastSwitch _ edges) = catMaybes edges
fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
-fold_cmm_succs f (LastBranch id) z = f id z
-fold_cmm_succs _ (LastCall _ Nothing _ _) z = z
-fold_cmm_succs f (LastCall _ (Just id) _ _) z = f id z
-fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
-fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
+fold_cmm_succs f (LastBranch id) z = f id z
+fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
+fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
+fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
+fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
----------------------------------------------------------------------
----- Instance declarations for register use
instance UserOfLocalRegs Last where
foldRegsUsed f z l = last l
where last (LastBranch _id) = z
- last (LastCall tgt _ _ _) = foldRegsUsed f z tgt
+ last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
last (LastCondBranch e _ _) = foldRegsUsed f z e
last (LastSwitch e _tbl) = foldRegsUsed f z e
instance DefinerOfLocalRegs Middle where
foldRegsDefd f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign _lhs _) = fold f z _lhs
- middle (MidStore _ _) = z
- middle (MidForeignCall _ _ fs _) = fold f z fs
+ where middle (MidComment {}) = z
+ middle (MidAssign lhs _) = fold f z lhs
+ middle (MidStore _ _) = z
+ middle (MidForeignCall _ _ fs _) = fold f z fs
fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
instance DefinerOfLocalRegs Last where
instance UserOfSlots Last where
foldSlotsUsed f z l = last l
where last (LastBranch _id) = z
- last (LastCall tgt _ _ _) = foldSlotsUsed f z tgt
+ last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
last (LastCondBranch e _ _) = foldSlotsUsed f z e
last (LastSwitch e _tbl) = foldSlotsUsed f z e
mapExpLast _ l@(LastBranch _) = l
mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
-mapExpLast exp (LastCall tgt mb_id u s) = LastCall (exp tgt) mb_id u s
+mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
foldExpLast _ (LastBranch _) z = z
foldExpLast exp (LastCondBranch e _ _) z = exp e z
foldExpLast exp (LastSwitch e _) z = exp e z
-foldExpLast exp (LastCall tgt _ _ _) z = exp tgt z
+foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
let bot = fact_bot lattice
join x y = txVal $ fact_add_to lattice x y
in case l of
- (LastBranch id) -> env id
- (LastCall _ Nothing _ _) -> bot
- (LastCall _ (Just k) _ _) -> env k
- (LastCondBranch _ t f) -> join (env t) (env f)
- (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
+ (LastBranch id) -> env id
+ (LastCall _ Nothing _ _ _) -> bot
+ (LastCall _ (Just k) _ _ _) -> env k
+ (LastCondBranch _ t f) -> join (env t) (env f)
+ (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
----------------------------------------------------------------------
----- Instance declarations for prettyprinting (avoids recursive imports)
pprLast stmt = pp_stmt <+> pp_debug
where
pp_stmt = case stmt of
- LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
- LastCondBranch expr t f -> genFullCondBranch expr t f
- LastSwitch arg ids -> ppr $ CmmSwitch arg ids
- LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off
+ LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
+ LastCondBranch expr t f -> genFullCondBranch expr t f
+ LastSwitch arg ids -> ppr $ CmmSwitch arg ids
+ LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
pp_debug = text " //" <+> case stmt of
LastBranch {} -> text "LastBranch"
LastSwitch {} -> text "LastSwitch"
LastCall {} -> text "LastCall"
-genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc
-genBareCall fn k off updfr_off =
+genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
+ Maybe UpdFrameOffset -> SDoc
+genBareCall fn k out res updfr_off =
hcat [ ptext (sLit "call"), space
, pprFun fn, ptext (sLit "(...)"), space
- , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off)
+ , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
+ <+> parens (ppr res)
, ptext (sLit " with update frame") <+> ppr updfr_off
, semi ]
--unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs)
-focusp p (LGraph entry _ blocks) =
+focusp p (LGraph entry blocks) =
fmap (\(b, bs) -> FGraph entry (unzip b) bs) (splitp_blocks p blocks)
-exit g@(LGraph eid _ _) = FGraph eid (ZBlock h (ZLast l)) others
+exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others
where FGraph _ b others = focusp is_exit g `orElse` panic "no exit in flow graph"
(h, l) = goto_end b
foldM_fwd_block ::
Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) ->
Block mid l -> a -> m a
-foldM_fwd_block first middle last (Block id _ t) z = do { z <- first id z; tail t z }
+foldM_fwd_block first middle last (Block id t) z = do { z <- first id z; tail t z }
where tail (ZTail m t) z = do { z <- middle m z; tail t z }
tail (ZLast l) z = last l z
The types of transfer equations, rewrites, and fixed points are
different for forward and backward problems. To avoid cluttering the
-name space with two versions of every names, other names such as
+name space with two versions of every name, other names such as
zdfSolveFrom are overloaded to work in both forward or backward
directions. This design decision is based on experience with the
-predecessor module, now called ZipDataflow0 and destined for the bit bucket.
+predecessor module, which has been mercifully deleted.
This module is deliberately very abstract. It is a completely general
-- block, so instead of a fact it is given a mapping from BlockId to fact.
data BackwardTransfers middle last a = BackwardTransfers
- { bt_first_in :: a -> BlockId -> a
- , bt_middle_in :: a -> middle -> a
- , bt_last_in :: (BlockId -> a) -> last -> a
+ { bt_first_in :: BlockId -> a -> a
+ , bt_middle_in :: middle -> a -> a
+ , bt_last_in :: last -> (BlockId -> a) -> a
}
-- | For a forward transfer, you're given the fact on a node's
-- block, so instead of a fact it produces a list of (BlockId, fact) pairs.
data ForwardTransfers middle last a = ForwardTransfers
- { ft_first_out :: a -> BlockId -> a
- , ft_middle_out :: a -> middle -> a
- , ft_last_outs :: a -> last -> LastOutFacts a
- , ft_exit_out :: a -> a
+ { ft_first_out :: BlockId -> a -> a
+ , ft_middle_out :: middle -> a -> a
+ , ft_last_outs :: last -> a -> LastOutFacts a
+ , ft_exit_out :: a -> a
}
newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
-- but instead of producing a fact, it produces a replacement graph or Nothing.
data BackwardRewrites middle last a = BackwardRewrites
- { br_first :: a -> BlockId -> Maybe (AGraph middle last)
- , br_middle :: a -> middle -> Maybe (AGraph middle last)
- , br_last :: (BlockId -> a) -> last -> Maybe (AGraph middle last)
+ { br_first :: BlockId -> a -> Maybe (AGraph middle last)
+ , br_middle :: middle -> a -> Maybe (AGraph middle last)
+ , br_last :: last -> (BlockId -> a) -> Maybe (AGraph middle last)
, br_exit :: Maybe (AGraph middle last)
}
-- but instead of producing a fact, it produces a replacement graph or Nothing.
data ForwardRewrites middle last a = ForwardRewrites
- { fr_first :: a -> BlockId -> Maybe (AGraph middle last)
- , fr_middle :: a -> middle -> Maybe (AGraph middle last)
- , fr_last :: a -> last -> Maybe (AGraph middle last)
- , fr_exit :: a -> Maybe (AGraph middle last)
+ { fr_first :: BlockId -> a -> Maybe (AGraph middle last)
+ , fr_middle :: middle -> a -> Maybe (AGraph middle last)
+ , fr_last :: last -> a -> Maybe (AGraph middle last)
+ , fr_exit :: a -> Maybe (AGraph middle last)
}
{- ===================== FIXED POINTS =================== -}
-- forward and backward directions.
--
-- The type parameters of the class include not only transfer
--- functions and the fixed point but also rewrites and the type
--- constructor (here called 'graph') for making rewritten graphs. As
--- above, in the definitoins of the rewrites, it might simplify
--- matters if 'graph' were replaced with 'AGraph'.
+-- functions and the fixed point but also rewrites.
--
-- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom'
--- with additional parameters and a different result. Of course the
--- rewrites are an additional parameter, but there are further
--- parameters which reflect the fact that rewriting consumes both
--- OptimizationFuel and Uniqs.
---
--- The result type is changed to reflect fuel consumption, and also
--- the resulting fixed point containts a rewritten graph.
---
--- John Dias is going to improve the management of Uniqs and Fuel so
--- that it doesn't make us sick to look at the types.
+-- with the rewrites and a rewriting depth as additional parameters,
+-- as well as a different result, which contains a rewritten graph.
class DataflowSolverDirection transfers fixedpt =>
DataflowDirection transfers fixedpt rewrites where
zdfRewriteFrom :: (DebugNodes m l, Outputable a)
=> RewritingDepth -- whether to rewrite a rewritten graph
- -> BlockEnv a -- initial facts (unbound == botton)
+ -> BlockEnv a -- initial facts (unbound == bottom)
-> PassName
-> DataflowLattice a
-> transfers m l a
quickGraph :: LastNode l => LGraph m l -> Graph m l
quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g
-quickLGraph :: LastNode l => Int -> Graph m l -> FuelMonad (LGraph m l)
-quickLGraph args (Graph (ZLast (LastOther l)) blockenv)
- | isBranchNode l = return $ LGraph (branchNodeTarget l) args blockenv
-quickLGraph args g = F.lGraphOfGraph g args
+quickLGraph :: LastNode l => Graph m l -> FuelMonad (LGraph m l)
+quickLGraph (Graph (ZLast (LastOther l)) blockenv)
+ | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv
+quickLGraph g = F.lGraphOfGraph g
-fixptWithLGraph :: LastNode l => Int -> CommonFixedPoint m l fact (Graph m l) ->
+fixptWithLGraph :: LastNode l => CommonFixedPoint m l fact (Graph m l) ->
FuelMonad (CommonFixedPoint m l fact (LGraph m l))
-fixptWithLGraph args cfp =
- do fp_c <- quickLGraph args $ fp_contents cfp
+fixptWithLGraph cfp =
+ do fp_c <- quickLGraph $ fp_contents cfp
return $ cfp {fp_contents = fp_c}
-ffixptWithLGraph :: LastNode l => Int -> ForwardFixedPoint m l fact (Graph m l) ->
+ffixptWithLGraph :: LastNode l => ForwardFixedPoint m l fact (Graph m l) ->
FuelMonad (ForwardFixedPoint m l fact (LGraph m l))
-ffixptWithLGraph args fp =
- do common <- fixptWithLGraph args $ ffp_common fp
+ffixptWithLGraph fp =
+ do common <- fixptWithLGraph $ ffp_common fp
return $ fp {ffp_common = common}
zdfFRewriteFromL :: (DebugNodes m l, Outputable a)
=> RewritingDepth -- whether to rewrite a rewritten graph
- -> BlockEnv a -- initial facts (unbound == botton)
+ -> BlockEnv a -- initial facts (unbound == bottom)
-> PassName
-> DataflowLattice a
-> ForwardTransfers m l a
-> a -- fact flowing in (at entry or exit)
-> LGraph m l
-> FuelMonad (ForwardFixedPoint m l a (LGraph m l))
-zdfFRewriteFromL d b p l t r a g@(LGraph _ args _) =
+zdfFRewriteFromL d b p l t r a g@(LGraph _ _) =
do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
- ffixptWithLGraph args fp
+ ffixptWithLGraph fp
zdfBRewriteFromL :: (DebugNodes m l, Outputable a)
=> RewritingDepth -- whether to rewrite a rewritten graph
- -> BlockEnv a -- initial facts (unbound == botton)
+ -> BlockEnv a -- initial facts (unbound == bottom)
-> PassName
-> DataflowLattice a
-> BackwardTransfers m l a
-> a -- fact flowing in (at entry or exit)
-> LGraph m l
-> FuelMonad (BackwardFixedPoint m l a (LGraph m l))
-zdfBRewriteFromL d b p l t r a g@(LGraph _ args _) =
+zdfBRewriteFromL d b p l t r a g@(LGraph _ _) =
do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
- fixptWithLGraph args fp
+ fixptWithLGraph fp
data RewritingDepth = RewriteShallow | RewriteDeep
-- introduces an unnecessary basic block at each rewrite, and we don't
-- want to stress out the finite map more than necessary
lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
-lgraphToGraph (LGraph eid _ blocks) =
+lgraphToGraph (LGraph eid blocks) =
if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then
Graph (ZLast (mkBranchNode eid)) blocks
else -- common case: entry is not a branch target
- let Block _ _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
+ let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
in Graph entry (delFromBlockEnv blocks eid)
solve finish in_fact (Graph entry blockenv) fuel =
let blocks = G.postorder_dfs_from blockenv entry
set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv)
- set_successor_facts (Block id _ tail) fuel =
+ set_successor_facts (Block id tail) fuel =
do { idfact <- getFact id
; (last_outs, fuel) <-
- case check_maybe fuel $ fr_first rewrites idfact id of
- Nothing -> solve_tail (ft_first_out transfers idfact id) tail 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' $
}
solve_tail in' (G.ZTail m t) fuel =
- case check_maybe fuel $ fr_middle rewrites in' m of
- Nothing -> solve_tail (ft_middle_out transfers in' 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' $
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 in' l, fuel)
+ 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 ->
; return (fp, fuel)
}
- either_last rewrites in' (LastExit) = fr_exit rewrites in'
- either_last rewrites in' (LastOther l) = fr_last rewrites in' l
+ either_last rewrites in' (LastExit) = fr_exit rewrites in'
+ either_last rewrites in' (LastOther l) = fr_last rewrites l in'
in fixed_point
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
+ rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
; a <- finish
- ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel)
+ ; 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
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
+ rewrite_blocks (G.Block id t : bs) rewritten fuel =
+ do let h = ZFirst id
a <- getFact id
- case check_maybe fuel $ fr_first rewrites a id of
+ case check_maybe fuel $ fr_first rewrites id a of
Nothing -> do { (rewritten, fuel) <-
- rew_tail h (ft_first_out transfers a id)
+ rew_tail h (ft_first_out transfers id a)
t rewritten fuel
; rewrite_blocks bs rewritten fuel }
Just g -> do { markGraphRewritten
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
+ 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
Just g -> do { markGraphRewritten
; g <- areturn 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
+ either_last rewrites in' (LastOther l) = fr_last rewrites l in'
check_facts in' (LastOther l) =
- let LastOutFacts last_outs = ft_last_outs transfers in' l
+ let LastOutFacts last_outs = ft_last_outs transfers l in'
in mapM (uncurry checkFactMatch) last_outs
check_facts _ LastExit = return []
in fixed_pt_and_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_in env (LastOther l) = bt_last_in transfers l env
last_rew _env (LastExit) = br_exit rewrites
- last_rew env (LastOther l) = br_last rewrites env l
+ last_rew env (LastOther l) = br_last rewrites l env
set_block_fact block fuel =
let (h, l) = G.goto_end (G.unzip block) in
do { env <- factsEnv
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
+ ; fuel <- set_block_fact (Block eid 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
+ set_head_fact (G.ZFirst id) a fuel =
+ case check_maybe fuel $ br_first rewrites id a 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
+ ppr (bt_first_in transfers id a)) $
+ setFact id $ bt_first_in transfers id a
; 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
+ ; setFact id $ bt_first_in transfers id a
; 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
+ case check_maybe fuel $ br_middle rewrites m a of
+ Nothing -> set_head_fact h (bt_middle_in transfers m a) fuel
Just g -> do { g' <- areturn g
; (a, fuel) <- my_trace "analysis rewrites middle node"
(ppr m <+> pprGraph g') $
; (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
+ rewrite_blocks False [Block eid 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)
+ ; return (in_fact, lgraphToGraph (LGraph eid rewritten), fuel)
} -- Remember: the entry fact computed by @solve@ accounts for rewriting
don't_rewrite facts g exit_fact fuel =
do { (fp, _) <-
; 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
+ either_last env (LastOther l) = br_last rewrites l env
last_in _env (LastExit) = exit_fact
- last_in env (LastOther l) = bt_last_in transfers env l
+ last_in env (LastOther l) = bt_last_in transfers l env
propagate check fuel (ZHead h m) a tail rewritten =
- case maybeRewriteWithFuel fuel $ br_middle rewrites a m of
+ case maybeRewriteWithFuel fuel $ br_middle rewrites m a of
Nothing ->
- propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
+ propagate check fuel h (bt_middle_in transfers m a) (ZTail m tail) rewritten
Just g ->
do { markGraphRewritten
; g <- areturn g
; 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
+ propagate check fuel (ZFirst id) a tail rewritten =
+ case maybeRewriteWithFuel fuel $ br_first rewrites id a of
Nothing -> do { if check then
- checkFactMatch id $ bt_first_in transfers a id
+ checkFactMatch id $ bt_first_in transfers id a
else return ()
- ; return (insertBlock (Block id off tail) rewritten, fuel) }
+ ; return (insertBlock (Block id 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)
+ ; if check then checkFactMatch id (bt_first_in transfers id a)
else return ()
; let Graph t newblocks = G.splice_tail g tail
- ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten)
+ ; let r = insertBlock (Block id t) (newblocks `plusBlockEnv` rewritten)
; return (r, fuel) }
in fixed_pt_and_fuel
dump_things :: Bool
-dump_things = False
+dump_things = True
my_trace :: String -> SDoc -> a -> a
my_trace = if dump_things then pprTrace else \_ _ a -> a
unchanged depth =
my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
- graphId = case blocks of { Block id _ _ : _ -> ppr id ; [] -> text "<empty>" }
+ graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
- pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t))
+ pprBlock (Block id t) = nest 2 (pprFact (id, t))
pprFacts depth n env =
my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
(nest 2 $ vcat $ map pprFact $ blockEnvToList env))
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
- pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a)
f4sep :: [SDoc] -> SDoc
mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
check_already_done retId updfr_sz
= mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
- (mkLabel retId emptyStackInfo
- <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
+ (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
<*> -- Set mod_reg to 1 to record that we've been here
mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
import Util
import FastString
import Outputable
+import UniqSupply
------------------------------------------------------------------------
-- cgExpr: the main function
cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
emitReturn [CmmLit cmm_lit]
-cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
-cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr }
+cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
+cgExpr (StgLetNoEscape _ _ binds expr) =
+ do { us <- newUniqSupply
+ ; let join_id = mkBlockId (uniqFromSupply us)
+ ; cgLneBinds join_id binds
+ ; cgExpr expr
+ ; emit $ mkLabel join_id}
cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
cgCase expr bndr srt alt_type alts
execute *next*, just like the scrutinee of a case. -}
-------------------------
-cgLneBinds :: StgBinding -> FCode ()
-cgLneBinds (StgNonRec bndr rhs)
- = do { local_cc <- saveCurrentCostCentre
- -- See Note [Saving the current cost centre]
- ; info <- cgLetNoEscapeRhs local_cc bndr rhs
- ; addBindC (cg_id info) info }
-
-cgLneBinds (StgRec pairs)
- = do { local_cc <- saveCurrentCostCentre
- ; new_bindings <- fixC (\ new_bindings -> do
- { addBindsC new_bindings
- ; listFCs [ cgLetNoEscapeRhs local_cc b e
- | (b,e) <- pairs ] })
-
- ; addBindsC new_bindings }
+cgLneBinds :: BlockId -> StgBinding -> FCode ()
+cgLneBinds join_id (StgNonRec bndr rhs)
+ = do { local_cc <- saveCurrentCostCentre
+ -- See Note [Saving the current cost centre]
+ ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs
+ ; addBindC (cg_id info) info }
+
+cgLneBinds join_id (StgRec pairs)
+ = do { local_cc <- saveCurrentCostCentre
+ ; new_bindings <- fixC (\ new_bindings -> do
+ { addBindsC new_bindings
+ ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e
+ | (b,e) <- pairs ] })
+ ; addBindsC new_bindings }
-------------------------
-cgLetNoEscapeRhs, cgLetNoEscapeRhsBody
- :: Maybe LocalReg -- Saved cost centre
+cgLetNoEscapeRhs
+ :: BlockId -- join point for successor of let-no-escape
+ -> Maybe LocalReg -- Saved cost centre
-> Id
-> StgRhs
-> FCode CgIdInfo
-cgLetNoEscapeRhs local_cc bndr rhs =
+cgLetNoEscapeRhs join_id local_cc bndr rhs =
do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs
; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
- ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body)
+ ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id)
; return info
}
+cgLetNoEscapeRhsBody
+ :: Maybe LocalReg -- Saved cost centre
+ -> Id
+ -> StgRhs
+ -> FCode CgIdInfo
cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
= cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
do_checks checkStack alloc do_gc
= withFreshLabel "gc" $ \ loop_id ->
withFreshLabel "gc" $ \ gc_id ->
- mkLabel loop_id emptyStackInfo
+ mkLabel loop_id
<*> (let hpCheck = if alloc == 0 then mkNop
else mkAssign hpReg bump_hp <*>
mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
else hpCheck)
<*> mkComment (mkFastString "outOfLine should follow:")
- <*> outOfLine (mkLabel gc_id emptyStackInfo
+ <*> outOfLine (mkLabel gc_id
<*> mkComment (mkFastString "outOfLine here")
<*> do_gc
<*> mkBranch loop_id)
emitReturn results
= do { sequel <- getSequel;
; updfr_off <- getUpdFrameOff
- ; emit $ mkComment $ mkFastString "emitReturn"
+ ; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel)
; case sequel of
Return _ ->
do { adjustHpBackwards
= do { adjustHpBackwards
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
- ; emit $ mkComment $ mkFastString "emitCall"
+ ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
; case sequel of
Return _ -> emit (mkForeignJump conv fun args updfr_off)
AssignTo res_regs _ -> emit (mkCall fun conv res_regs args updfr_off)
-- space that's unused on this path?
-- We need to do this only if the expression may
-- allocate (e.g. it's a foreign call or allocating primOp)
+instance Show Sequel where
+ show (Return _) = "Sequel: Return"
+ show (AssignTo _ _) = "Sequel: Assign"
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
= do { info_down <- getInfoDown
; us <- newUniqSupply
; state <- getState
- ; let info_down' = info_down { cgd_sequel = initSequel }
+ ; let info_down' = info_down -- { cgd_sequel = initSequel }
fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
(result, fork_state_out) = doFCode body_code info_down' fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out
emitProcWithConvention conv info lbl args blocks
= do { us <- newUniqSupply
; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
- blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks
- ; let proc_block = CmmProc info lbl args blks
+ blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
+ ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
cgStmtsToBlocks stmts
= do { us <- newUniqSupply
- ; return (initUs_ us (lgraphOfAGraph 0 stmts)) }
+ ; return (initUs_ us (lgraphOfAGraph stmts)) }
import Cmm
import CmmExpr
import MkZipCfgCmm
-import ZipCfg hiding (last, unzip, zip)
import CLabel
import CmmUtils
import PprCmm ( {- instances -} )
mk_switch tag_expr' (sortLe le branches) mb_deflt
lo_tag hi_tag via_C
-- Sort the branches before calling mk_switch
- <*> mkLabel join_lbl emptyStackInfo
+ <*> mkLabel join_lbl
where
(t1,_) `le` (t2,_) = t1 <= t2
label_code join_lbl deflt $ \ deflt ->
label_branches join_lbl branches $ \ branches ->
mk_lit_switch scrut' deflt (sortLe le branches)
- <*> mkLabel join_lbl emptyStackInfo
+ <*> mkLabel join_lbl
where
le (t1,_) (t2,_) = t1 <= t2
-- [L: code; goto J] fun L
label_code join_lbl code thing_inside
= withFreshLabel "switch" $ \lbl ->
- outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl)
+ outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
<*> thing_inside lbl
stg_binds hpc_info
--- Optionally run experimental Cmm transformations ---
- cmms <- optionallyConvertAndOrCPS hsc_env cmms
+ -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
-- unless certain dflags are on, the identity function
------------------ Code output -----------------------
rawcmms <- cmmToRawCmm cmms
+ dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
(_stub_h_exists, stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
dependencies rawcmms
; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
-- Control flow optimisation, again
- ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprCmms prog)
-
; let prog' = map cmmOfZgraph prog
- ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr prog')
+ ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
; return prog' }
let cvt = cmmOfZgraph $ cfopts $ chosen_graph
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
return cvt
- -- return cmm -- don't use the conversion
myCoreToStg :: DynFlags -> Module -> [CoreBind]
-> IO ( [(StgBinding,[(Id,[Id])])] -- output program
canShortcut _ = Nothing
+-- The helper ensures that we don't follow cycles.
shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
-shortcutJump fn insn@(JXX cc id) =
- case fn id of
- Nothing -> insn
- Just (DestBlockId id') -> shortcutJump fn (JXX cc id')
- Just (DestImm imm) -> shortcutJump fn (JXX_GBL cc imm)
-
-shortcutJump _ other = other
+shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn
+ where shortcutJump' fn seen insn@(JXX cc id) =
+ if elemBlockSet id seen then insn
+ else case fn id of
+ Nothing -> insn
+ Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
+ Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm)
+ where seen' = extendBlockSet seen id
+ shortcutJump' _ _ other = other
-- Here because it knows about JumpDest
if [ "$CPUS" = "" ]; then
threads=2
else
- threads=`expr $CPUS + 1`
+ threads=$((($CPUS + 1) * 2)) # `expr $CPUS + 1`
fi
if [ $testsuite_only -eq 0 ]; then
projects / ghc-hetmet.git / commitdiff