Commit 25628e27 authored by dias@eecs.harvard.edu's avatar dias@eecs.harvard.edu

Cmm back end upgrades

Several changes in this patch, partially bug fixes, partially new code:
o bug fixes in ZipDataflow
   - added some checks to verify that facts converge
   - removed some erroneous checks of convergence on entry nodes
   - added some missing applications of transfer functions
o changed dataflow clients to use ZipDataflow, making ZipDataflow0 obsolete
o eliminated DFA monad (no need for separate analysis and rewriting monads with ZipDataflow)
o started stack layout changes
   - no longer generating CopyIn and CopyOut nodes (not yet fully expunged though)
   - still not using proper calling conventions
o simple new optimizations:
   - common block elimination
      -- have not yet tried to move the Adams opt out of CmmProcPointZ
   - block concatenation
o piped optimization fuel up to the HscEnv
   - can be limited by a command-line flag
   - not tested, and probably not yet properly used by clients
o added unique supply to FuelMonad, also lifted unique supply to DFMonad
parent f0ffb7da
......@@ -42,10 +42,10 @@ import FastString
import Data.Word
import ZipCfg ( BlockId(..), mkBlockId
, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
, BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
)
import StackSlot ( BlockId(..), mkBlockId
, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
, BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
)
-- A [[BlockId]] is a local label.
-- Local labels must be unique within an entire compilation unit, not
......@@ -274,6 +274,10 @@ instance UserOfLocalRegs CmmCallTarget where
foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
foldRegsUsed _ set (CmmPrim {}) = set
instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmKinded a) where
foldRegsDefd f z (CmmKinded x _) = foldRegsDefd f z x
--just look like a tuple, since it was a tuple before
-- ... is that a good idea? --Isaac Dupree
instance (Outputable a) => Outputable (CmmKinded a) where
......@@ -334,6 +338,7 @@ data CmmCallTarget
| CmmPrim -- Call a "primitive" (eg. sin, cos)
CallishMachOp -- These might be implemented as inline
-- code by the backend.
deriving Eq
-----------------------------------------------------------------------------
-- Static Data
......
......@@ -6,6 +6,7 @@ module CmmCPSZ (
) where
import Cmm
import CmmCommonBlockElimZ
import CmmContFlowOpt
import CmmProcPointZ
import CmmSpillReload
......@@ -14,67 +15,78 @@ import DFMonad
import PprCmmZ()
import ZipCfg hiding (zip, unzip)
import ZipCfgCmmRep
import ZipDataflow0
import DynFlags
import ErrUtils
import FiniteMap
import HscTypes
import Monad
import Outputable
import UniqSupply
import Data.IORef
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
-> CmmZ -- ^ Input C-- with Proceedures
-> IO CmmZ -- ^ Output CPS transformed C--
protoCmmCPSZ dflags (Cmm tops)
| not (dopt Opt_RunCPSZ dflags)
protoCmmCPSZ :: HscEnv -- Compilation env including
-- dynamic flags: -dcmm-lint -ddump-cps-cmm
-> CmmZ -- Input C-- with Proceedures
-> IO CmmZ -- Output CPS transformed C--
protoCmmCPSZ hsc_env (Cmm tops)
| not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
= return (Cmm tops) -- Only if -frun-cps
| otherwise
= do { showPass dflags "CPSZ"
; u <- mkSplitUniqSupply 'p'
; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel]
; fuel_ref <- newIORef (tankFilledTo maxBound) -- XXX see [Note global fuel]
; let txtops = initUs_ u $ mapM cpsTop tops
; tops <- runFuelIO pass_ref fuel_ref (sequence txtops)
; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr (Cmm tops))
; return $ Cmm tops
}
= do let dflags = hsc_dflags hsc_env
showPass dflags "CPSZ"
tops <- mapM (cpsTop hsc_env) tops
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
return $ Cmm tops
{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
In a correct world, the identity and the last pass would be stored in
mutable reference cells associated with an 'HscEnv' and would be
global to one compiler session. Unfortunately the 'HscEnv' is not
plumbed sufficiently close to this function; only the DynFlags are
plumbed here. One day the plumbing will be extended, in which case
this pass will use the global 'pass_ref' and 'fuel_ref' instead of the
bogus facsimiles in place here.
The identity and the last pass are stored in
mutable reference cells in an 'HscEnv' and are
global to one compiler session.
-}
cpsTop :: CmmTopZ -> UniqSM (FuelMonad CmmTopZ)
cpsTop p@(CmmData {}) = return (return p)
cpsTop (CmmProc h l args g) =
let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
g' = addProcPointProtocols procPoints args g
g'' = map_nodes id NotSpillOrReload id g'
cpsTop :: HscEnv -> CmmTopZ -> IO CmmTopZ
cpsTop _ p@(CmmData {}) = return p
cpsTop hsc_env (CmmProc h l args g) =
do dump Opt_D_dump_cmmz "Pre Proc Points Added" g
let callPPs = callProcPoints g
procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
let varSlots = emptyFM
g <- return $ map_nodes id NotSpillOrReload id g
-- Change types of middle nodes to allow spill/reload
g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
(dualLivenessWithInsertion emptyBlockSet) g
(varSlots, g) <- trim g >>= run . elimSpillAndReload varSlots
g <- run $ addProcPointProtocols callPPs procPoints args g
dump Opt_D_dump_cmmz "Post Proc Points Added" g
g <- return $ map_nodes id NotSpillOrReload id g
-- Change types of middle nodes to allow spill/reload
in do { u1 <- getUs; u2 <- getUs; u3 <- getUs
; entry <- getUniqueUs >>= return . BlockId
; return $
do { g <- return g''
; g <- dual_rewrite u1 dualLivenessWithInsertion g
-- Insert spills at defns; reloads at return points
; g <- insertLateReloads' u2 (extend g)
-- Duplicate reloads just before uses
; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g)
-- Remove redundant reloads (and any other redundant asst)
; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g
}
}
where dual_rewrite u pass g = runDFM u dualLiveLattice $ b_rewrite pass g
extend (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
trim _ (Graph (ZLast (LastOther (LastBranch id))) blocks) = LGraph id blocks
trim e (Graph tail blocks) = LGraph e (insertBlock (Block e tail) blocks)
g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
(dualLivenessWithInsertion procPoints) g
-- Insert spills at defns; reloads at return points
g <- run $ insertLateReloads' g -- Duplicate reloads just before uses
dump Opt_D_dump_cmmz "Post late reloads" g
g <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
(removeDeadAssignmentsAndReloads procPoints)
-- Remove redundant reloads (and any other redundant asst)
(_, g) <- trim g >>= run . elimSpillAndReload varSlots
gs <- run $ splitAtProcPoints args l procPoints g
gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g
g <- return $ elimCommonBlocks g
dump Opt_D_dump_cmmz "Post common block elimination" g
return $ CmmProc h l args (runTx cmmCfgOptsZ g)
where dflags = hsc_dflags hsc_env
dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
run = runFuelIO (hsc_OptFuel hsc_env)
dual_rewrite flag txt pass g =
do dump flag ("Pre " ++ txt) g
g <- run $ pass (graphOfLGraph g) >>= lGraphOfGraph
dump flag ("Post " ++ txt) $ g
return $ graphOfLGraph g
trim (Graph (ZLast (LastOther (LastBranch id))) blocks) = return $ LGraph id blocks
trim (Graph tail blocks) =
do entry <- liftM BlockId $ run $ getUniqueM
return $ LGraph entry (insertBlock (Block entry tail) blocks)
module CmmCommonBlockElimZ
( elimCommonBlocks
)
where
import Cmm hiding (blockId)
import CmmExpr
import Prelude hiding (iterate, zip, unzip)
import ZipCfg
import ZipCfgCmmRep
import FastString
import FiniteMap
import List hiding (iterate)
import Monad
import Outputable
import UniqFM
import Unique
my_trace :: String -> SDoc -> a -> a
my_trace = if True then pprTrace else \_ _ a -> a
-- Eliminate common blocks:
-- If two blocks are identical except for the label on the first node,
-- then we can eliminate one of the blocks. To ensure that the semantics
-- of the program are preserved, we have to rewrite each predecessor of the
-- eliminated block to proceed with the block we keep.
-- The algorithm iterates over the blocks in the graph,
-- checking whether it has seen another block that is equal modulo labels.
-- If so, then it adds an entry in a map indicating that the new block
-- is made redundant by the old block.
-- Otherwise, it is added to the useful blocks.
-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g =
upd_graph g . snd $ iterate common_block reset hashed_blocks (emptyUFM, emptyFM)
where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
reset (_, subst) = (emptyUFM, subst)
-- Iterate over the blocks until convergence
iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t
iterate upd reset blocks state =
case foldl upd' (False, state) blocks of
(True, state') -> iterate upd reset blocks (reset state')
(False, state') -> state'
where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes
-- Try to find a block that is equal (or ``common'') to b.
type BidMap = FiniteMap BlockId BlockId
type State = (UniqFM [CmmBlock], BidMap)
common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State)
common_block (bmap, subst) (hash, b) =
case lookupUFM bmap $ my_trace "common_block" (ppr bid <+> ppr subst <+> ppr hash) $ hash of
Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, lookupFM subst bid) of
(Just b', Nothing) -> addSubst b'
(Just b', Just b'') | blockId b' /= b'' -> addSubst b'
_ -> (False, (addToUFM bmap hash (b : bs), subst))
Nothing -> (False, (addToUFM bmap hash [b], subst))
where bid = blockId b
addSubst b' = my_trace "found new common block" (ppr (blockId b')) $
(True, (bmap, addToFM subst bid (blockId b')))
-- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
upd_graph :: CmmGraph -> BidMap -> CmmGraph
upd_graph g subst = map_nodes id middle last g
where middle m = m
last (LastBranch bid) = LastBranch $ sub bid
last (LastCondBranch p t f) = cond p (sub t) (sub f)
last (LastCall t bid) = LastCall t $ liftM sub bid
last (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs
last l = l
cond p t f = if t == f then LastBranch t else LastCondBranch p t f
sub = lookupBid subst
-- To speed up comparisons, we hash each basic block modulo labels.
-- 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_tail t 0
where hash_mid (MidComment (FastString u _ _ _ _)) = u
hash_mid (MidAssign r e) = hash_reg r + hash_e e
hash_mid (MidStore e e') = hash_e e + hash_e e'
hash_mid (MidUnsafeCall t _ as) = hash_tgt t + hash_as as
hash_mid (MidAddToContext e es) = hash_e e + hash_lst hash_e es
hash_mid (CopyIn _ fs _) = hash_fs fs
hash_mid (CopyOut _ as) = hash_as as
hash_reg (CmmLocal l) = hash_local l
hash_reg (CmmGlobal _) = 19
hash_reg (CmmStack _) = 13
hash_local (LocalReg _ _ _) = 117
hash_e (CmmLit l) = hash_lit l
hash_e (CmmLoad e _) = 67 + hash_e e
hash_e (CmmReg r) = hash_reg r
hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
hash_e (CmmRegOff r i) = hash_reg r + i
hash_lit (CmmInt i _) = fromInteger i
hash_lit (CmmFloat r _) = truncate r
hash_lit (CmmLabel _) = 119 -- ugh
hash_lit (CmmLabelOff _ i) = 199 + i
hash_lit (CmmLabelDiffOff _ _ i) = 299 + i
hash_tgt (CmmCallee e _) = hash_e e
hash_tgt (CmmPrim _) = 31 -- lots of these
hash_as = hash_lst $ hash_kinded hash_e
hash_fs = hash_lst $ hash_kinded hash_local
hash_kinded f (CmmKinded x _) = f x
hash_lst f = foldl (\z x -> f x + z) 0
hash_last (LastBranch _) = 23 -- would be great to hash these properly
hash_last (LastCondBranch p _ _) = hash_e p
hash_last LastReturn = 17 -- better ideas?
hash_last (LastJump 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 * 2
hash_tail (ZLast (LastOther l)) v = hash_last l + (v * 2)
hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v * 2))
-- Utilities: equality and substitution on the graph.
-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
eqBid :: BidMap -> BlockId -> BlockId -> Bool
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
lookupBid :: BidMap -> BlockId -> BlockId
lookupBid subst bid = case lookupFM subst bid of
Just bid -> lookupBid subst bid
Nothing -> bid
-- 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 _ t) (Block _ t') = eqTailWith eqBid t t'
type CmmTail = ZTail Middle Last
eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t'
eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True
eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l'
eqTailWith _ _ _ = False
eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
eqLastWith eqBid (LastBranch bid) (LastBranch bid') = eqBid bid bid'
eqLastWith eqBid c@(LastCondBranch _ _ _) c'@(LastCondBranch _ _ _) =
eqBid (cml_true c) (cml_true c') && eqBid (cml_false c) (cml_false c')
eqLastWith _ LastReturn LastReturn = True
eqLastWith _ (LastJump e) (LastJump e') = e == e'
eqLastWith eqBid c@(LastCall _ _) c'@(LastCall _ _) =
cml_target c == cml_target c' && eqMaybeWith eqBid (cml_cont c) (cml_cont c')
eqLastWith eqBid (LastSwitch e bs) (LastSwitch e' bs') =
e == e' && eqLstWith (eqMaybeWith eqBid) bs bs'
eqLastWith _ _ _ = False
eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
eqMaybeWith _ Nothing Nothing = True
eqMaybeWith _ _ _ = False
module CmmContFlowOpt
( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
, branchChainElimZ, removeUnreachableBlocksZ
, branchChainElimZ, removeUnreachableBlocksZ, predMap
, replaceLabelsZ
)
where
import Cmm
import CmmTx
import qualified ZipCfg as G
import StackSlot
import ZipCfgCmmRep
import Maybes
import Monad
import Panic
import Prelude hiding (unzip, zip)
import Util
import UniqFM
......@@ -23,7 +29,8 @@ cmmCfgOpts :: Tx (ListGraph CmmStmt)
cmmCfgOptsZ :: Tx CmmGraph
cmmCfgOpts = branchChainElim -- boring, but will get more exciting later
cmmCfgOptsZ = branchChainElimZ `seqTx` removeUnreachableBlocksZ
cmmCfgOptsZ =
branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
......@@ -82,15 +89,15 @@ branchChainElimZ g@(G.LGraph eid _)
else
Nothing
in mapMaybe loop_to lone_branch_blocks
lookup id = G.lookupBlockEnv env id `orElse` id
lookup id = lookupBlockEnv env id `orElse` id
isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.BlockId) CmmBlock
isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
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 G.BlockId -> CmmGraph -> CmmGraph
replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceLabelsZ env = replace_eid . G.map_nodes id id last
where
replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
......@@ -99,7 +106,43 @@ replaceLabelsZ env = replace_eid . G.map_nodes id id last
last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl)
last (LastCall tgt (Just id)) = LastCall tgt (Just $ lookup id)
last exit_jump_return = exit_jump_return
lookup id = G.lookupBlockEnv env id `orElse` id
lookup id = lookupBlockEnv env id `orElse` id
----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
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' =
extendBlockEnv env b' $
extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
----------------------------------------------------------------
blockConcatZ :: Tx CmmGraph
-- If a block B branches to a label L, and L has no other predecessors,
-- then we can splice the block starting with L onto the end of B.
-- Because this optmization can be inhibited by unreachable blocks,
-- we bundle it with a pass that drops unreachable blocks.
-- Order matters, so we work bottom up (reverse postorder DFS).
-- Note: This optimization does _not_ subsume branch chain elimination.
blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
blockConcatZ' :: Tx CmmGraph
blockConcatZ' g@(G.LGraph eid blocks) = tx $ G.LGraph eid blocks'
where (changed, blocks') = foldr maybe_concat (False, blocks) $ G.postorder_dfs g
maybe_concat b@(G.Block bid _) (changed, blocks') =
let unchanged = (changed, extendBlockEnv blocks' bid b)
in case G.goto_end $ G.unzip b of
(h, G.LastOther (LastBranch b')) ->
if num_preds b' == 1 then
(True, extendBlockEnv blocks' bid $ splice blocks' h b')
else unchanged
_ -> unchanged
num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
backEdges = predMap g
splice blocks' h bid' =
case lookupBlockEnv blocks' bid' of
Just (G.Block _ t) -> G.zip $ G.ZBlock h t
Nothing -> panic "unknown successor block"
tx = if changed then aTx else noTx
----------------------------------------------------------------
mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
......
......@@ -6,6 +6,7 @@ where
import Cmm
import CmmExpr
import MkZipCfg
import MkZipCfgCmm hiding (CmmGraph)
import ZipCfgCmmRep -- imported for reverse conversion
import CmmZipUtil
......@@ -14,6 +15,7 @@ import PprCmmZ()
import qualified ZipCfg as G
import FastString
import Monad
import Outputable
import Panic
import UniqSet
......@@ -24,14 +26,18 @@ import Maybe
cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
cmmToZgraph = cmmMapGraphM toZgraph
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
toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) =
labelAGraph id $ mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph
toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph
toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
labelAGraph id $ mkMiddles (mkEntry id undefined args) <*>
mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
where addBlock (BasicBlock id ss) g = mkLabel id <*> mkStmts ss <*> g
mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
......@@ -102,7 +108,7 @@ ofZgraph g = ListGraph $ swallow blocks
-> tail id prev' out t bs -- optimize out redundant labels
_ -> if isNothing out then endblock (CmmBranch tgt)
else pprPanic "can't convert LGraph with pending CopyOut"
(ppr g)
(text "target" <+> ppr tgt <+> ppr g)
LastCondBranch expr tid fid ->
if isJust out then pprPanic "CopyOut before conditional branch" (ppr g)
else
......@@ -156,13 +162,13 @@ ofZgraph g = ListGraph $ swallow blocks
single_preds =
let add b single =
let id = G.blockId b
in case G.lookupBlockEnv preds id of
in case lookupBlockEnv preds id of
Nothing -> single
Just s -> if sizeUniqSet s == 1 then
G.extendBlockSet single id
extendBlockSet single id
else single
in G.fold_blocks add G.emptyBlockSet g
unique_pred id = G.elemBlockSet id single_preds
in G.fold_blocks add emptyBlockSet g
unique_pred id = elemBlockSet id single_preds
call_succs =
let add b succs =
case G.last (G.unzip b) of
......
......@@ -5,16 +5,22 @@ module CmmExpr
, CmmLit(..), cmmLitRep
, LocalReg(..), localRegRep, localRegGCFollow, GCKind(..)
, GlobalReg(..), globalRegRep, spReg, hpReg, spLimReg, nodeReg, node
, UserOfLocalRegs, foldRegsUsed, filterRegsUsed
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet
, StackSlotMap, getSlot
)
where
import CLabel
import FiniteMap
import MachOp
import Monad
import Panic
import StackSlot
import Unique
import UniqSet
import UniqSupply
-----------------------------------------------------------------------------
-- CmmExpr
......@@ -36,7 +42,8 @@ data CmmExpr
data CmmReg
= CmmLocal LocalReg
| CmmGlobal GlobalReg
deriving( Eq )
| CmmStack StackSlot
deriving( Eq, Ord )
data CmmLit
= CmmInt Integer MachRep
......@@ -62,6 +69,9 @@ data CmmLit
instance Eq LocalReg where
(LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
instance Ord LocalReg where
compare (LocalReg u1 _ _) (LocalReg u2 _ _) = compare u1 u2
instance Uniquable LocalReg where
getUnique (LocalReg uniq _ _) = uniq
......@@ -105,6 +115,25 @@ minusRegSet = minusUniqSet
plusRegSet = unionUniqSets
timesRegSet = intersectUniqSets
-----------------------------------------------------------------------------
-- Stack slots
-----------------------------------------------------------------------------
mkVarSlot :: Unique -> CmmReg -> StackSlot
mkVarSlot id r = StackSlot (mkStackArea (mkBlockId id) [r] Nothing) 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 CmmReg StackSlot
getSlot :: MonadUnique m => StackSlotMap -> CmmReg -> m (StackSlotMap, StackSlot)
getSlot map r = case lookupFM map r of
Just s -> return (map, s)
Nothing -> do id <- getUniqueM
let s = mkVarSlot id r
return (addToFM map r s, s)
-----------------------------------------------------------------------------
-- Register-use information for expressions and other types
-----------------------------------------------------------------------------
......@@ -112,6 +141,9 @@ timesRegSet = intersectUniqSets
class UserOfLocalRegs a where
foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
class DefinerOfLocalRegs a where
foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
filterRegsUsed p e =
foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
......@@ -120,10 +152,19 @@ filterRegsUsed p e =
instance UserOfLocalRegs CmmReg where
foldRegsUsed f z (CmmLocal reg) = f z reg
foldRegsUsed _ z (CmmGlobal _) = z
foldRegsUsed _ z (CmmStack _) = z
instance DefinerOfLocalRegs CmmReg where
foldRegsDefd f z (CmmLocal reg) = f z reg
foldRegsDefd _ z (CmmGlobal _) = z
foldRegsDefd _ z (CmmStack _) = z
instance UserOfLocalRegs LocalReg where
foldRegsUsed f z r = f z r
instance DefinerOfLocalRegs LocalReg where
foldRegsDefd f z r = f z r
instance UserOfLocalRegs RegSet where
foldRegsUsed f = foldUniqSet (flip f)
......@@ -139,6 +180,10 @@ instance UserOfLocalRegs a => UserOfLocalRegs [a] where
foldRegsUsed _ set [] = set
foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
foldRegsDefd _ set [] = set
foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
-----------------------------------------------------------------------------
-- MachRep
-----------------------------------------------------------------------------
......@@ -153,8 +198,9 @@ cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op
cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
cmmRegRep :: CmmReg -> MachRep
cmmRegRep (CmmLocal reg) = localRegRep reg
cmmRegRep (CmmLocal reg) = localRegRep reg
cmmRegRep (CmmGlobal reg) = globalRegRep reg
cmmRegRep (CmmStack _) = panic "cmmRegRep not yet defined on stack slots"
localRegRep :: LocalReg -> MachRep
localRegRep (LocalReg _ rep _) = rep
......@@ -214,7 +260,7 @@ data GlobalReg
-- from platform to platform (see module PositionIndependentCode).
| PicBaseReg
deriving( Eq , Show )
deriving( Eq, Ord, Show )
-- convenient aliases
spReg, hpReg, spLimReg, nodeReg :: CmmReg
......
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
......@@ -53,6 +52,7 @@ lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
lintCmmTop (CmmData {})
= return ()
lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr (getUnique id)) $
mapM_ (lintCmmStmt labels) stmts
......@@ -85,6 +85,7 @@ lintCmmExpr expr =
return (cmmExprRep expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> CmmLint MachRep
cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
| isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset (CmmMachOp op args)
......@@ -97,17 +98,20 @@ cmmCheckMachOp op@(MO_U_Conv from to) args
cmmCheckMachOp op _args
= return (resultRepOfMachOp op)
isWordOffsetReg :: CmmReg -> Bool
isWordOffsetReg (CmmGlobal Sp) = True
-- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
--isWordOffsetReg (CmmGlobal Hp) = True
isWordOffsetReg _ = False
isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
cmmCheckWordAddress :: CmmExpr -> CmmLint ()
cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
......@@ -119,6 +123,7 @@ cmmCheckWordAddress _
-- No warnings for unaligned arithmetic with the node register,
-- which is used to extract fields from tagged constructor closures.
notNodeReg :: CmmExpr -> Bool
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _ = True
......@@ -155,6 +160,7 @@ lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
lintTarget (CmmPrim {}) = return ()
checkCond :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
......
......@@ -7,13 +7,15 @@ module CmmLiveZ
)
where
import Cmm
import CmmExpr
import CmmTx
import DFMonad
import Monad
import PprCmm()
import PprCmmZ()
import ZipDataflow0
import StackSlot
import ZipCfg
import ZipDataflow