Generalize register sets and liveness calculations.

We would like to calculate register liveness for global registers as well as
local registers, so this patch generalizes the existing infrastructure to set
the stage.
parent 3db02542
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module CmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
, GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
, GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
, VGcPtr(..), vgcFlag -- Temporary!
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
, regSetToList
, DefinerOfRegs, UserOfRegs
, foldRegsDefd, foldRegsUsed, filterRegsUsed
, foldLocalRegsDefd, foldLocalRegsUsed
, RegSet, LocalRegSet, GlobalRegSet
, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
, regSetToList
, regUsedIn
, Area(..)
, module CmmMachOp
, module CmmType
......@@ -177,7 +185,7 @@ localRegType (LocalReg _ rep) = rep
-- Register-use information for expressions and other types
-----------------------------------------------------------------------------
-- | Sets of local registers
-- | Sets of registers
-- These are used for dataflow facts, and a common operation is taking
-- the union of two RegSets and then asking whether the union is the
......@@ -185,16 +193,19 @@ localRegType (LocalReg _ rep) = rep
-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
-- Sets.
type RegSet = Set LocalReg
emptyRegSet :: RegSet
nullRegSet :: RegSet -> Bool
elemRegSet :: LocalReg -> RegSet -> Bool
extendRegSet :: RegSet -> LocalReg -> RegSet
deleteFromRegSet :: RegSet -> LocalReg -> RegSet
mkRegSet :: [LocalReg] -> RegSet
minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet
sizeRegSet :: RegSet -> Int
regSetToList :: RegSet -> [LocalReg]
type RegSet r = Set r
type LocalRegSet = RegSet LocalReg
type GlobalRegSet = RegSet GlobalReg
emptyRegSet :: Ord r => RegSet r
nullRegSet :: Ord r => RegSet r -> Bool
elemRegSet :: Ord r => r -> RegSet r -> Bool
extendRegSet :: Ord r => RegSet r -> r -> RegSet r
deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r
mkRegSet :: Ord r => [r] -> RegSet r
minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
sizeRegSet :: Ord r => RegSet r -> Int
regSetToList :: Ord r => RegSet r -> [r]
emptyRegSet = Set.empty
nullRegSet = Set.null
......@@ -208,58 +219,75 @@ timesRegSet = Set.intersection
sizeRegSet = Set.size
regSetToList = Set.toList
class UserOfLocalRegs a where
foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
class Ord r => UserOfRegs r a where
foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b
foldLocalRegsUsed :: UserOfRegs LocalReg a
=> DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed = foldRegsUsed
class DefinerOfLocalRegs a where
foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
class Ord r => DefinerOfRegs r a where
foldRegsDefd :: DynFlags -> (b -> r -> 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)
foldLocalRegsDefd :: DefinerOfRegs LocalReg a
=> DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsDefd = foldRegsDefd
filterRegsUsed :: UserOfRegs r e => DynFlags -> (r -> Bool) -> e -> RegSet r
filterRegsUsed dflags p e =
foldRegsUsed dflags
(\regs r -> if p r then extendRegSet regs r else regs)
emptyRegSet e
instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where
foldRegsUsed f z (Just x) = foldRegsUsed f z x
foldRegsUsed _ z Nothing = z
instance UserOfRegs LocalReg CmmReg where
foldRegsUsed _ f z (CmmLocal reg) = f z reg
foldRegsUsed _ _ z (CmmGlobal _) = z
instance DefinerOfRegs LocalReg CmmReg where
foldRegsDefd _ f z (CmmLocal reg) = f z reg
foldRegsDefd _ _ z (CmmGlobal _) = z
instance UserOfLocalRegs CmmReg where
foldRegsUsed f z (CmmLocal reg) = f z reg
foldRegsUsed _ z (CmmGlobal _) = z
instance UserOfRegs GlobalReg CmmReg where
foldRegsUsed _ _ z (CmmLocal _) = z
foldRegsUsed _ f z (CmmGlobal reg) = f z reg
instance DefinerOfLocalRegs CmmReg where
foldRegsDefd f z (CmmLocal reg) = f z reg
foldRegsDefd _ z (CmmGlobal _) = z
instance DefinerOfRegs GlobalReg CmmReg where
foldRegsDefd _ _ z (CmmLocal _) = z
foldRegsDefd _ f z (CmmGlobal reg) = f z reg
instance UserOfLocalRegs LocalReg where
foldRegsUsed f z r = f z r
instance Ord r => UserOfRegs r r where
foldRegsUsed _ f z r = f z r
instance DefinerOfLocalRegs LocalReg where
foldRegsDefd f z r = f z r
instance Ord r => DefinerOfRegs r r where
foldRegsDefd _ f z r = f z r
instance UserOfLocalRegs RegSet where
foldRegsUsed f = Set.fold (flip f)
instance Ord r => UserOfRegs r (RegSet r) where
foldRegsUsed _ f = Set.fold (flip f)
instance UserOfLocalRegs CmmExpr where
foldRegsUsed f z e = expr z e
instance UserOfRegs r CmmReg => UserOfRegs r CmmExpr where
foldRegsUsed dflags f z e = expr z e
where expr z (CmmLit _) = z
expr z (CmmLoad addr _) = foldRegsUsed f z addr
expr z (CmmReg r) = foldRegsUsed f z r
expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
expr z (CmmRegOff r _) = foldRegsUsed f z r
expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr
expr z (CmmReg r) = foldRegsUsed dflags f z r
expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
expr z (CmmRegOff r _) = foldRegsUsed dflags f z r
expr z (CmmStackSlot _ _) = z
instance UserOfLocalRegs a => UserOfLocalRegs [a] where
foldRegsUsed _ set [] = set
foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
instance UserOfRegs r a => UserOfRegs r (Maybe a) where
foldRegsUsed dflags f z (Just x) = foldRegsUsed dflags f z x
foldRegsUsed _ _ z Nothing = z
instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
foldRegsDefd _ set [] = set
foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
instance UserOfRegs r a => UserOfRegs r [a] where
foldRegsUsed _ _ set [] = set
foldRegsUsed dflags f set (x:xs) = foldRegsUsed dflags f (foldRegsUsed dflags f set x) xs
instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
foldRegsDefd _ set Nothing = set
foldRegsDefd f set (Just x) = foldRegsDefd f set x
instance DefinerOfRegs r a => DefinerOfRegs r [a] where
foldRegsDefd _ _ set [] = set
foldRegsDefd dflags f set (x:xs) = foldRegsDefd dflags f (foldRegsDefd dflags f set x) xs
instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where
foldRegsDefd _ _ set Nothing = set
foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x
-----------------------------------------------------------------------------
-- Another reg utility
......@@ -424,3 +452,10 @@ globalRegType dflags Hp = gcWord dflags
-- The initialiser for all
-- dynamically allocated closures
globalRegType dflags _ = bWord dflags
isArgReg :: GlobalReg -> Bool
isArgReg (VanillaReg {}) = True
isArgReg (FloatReg {}) = True
isArgReg (DoubleReg {}) = True
isArgReg (LongReg {}) = True
isArgReg _ = False
......@@ -111,9 +111,9 @@ cmmLayoutStack dflags procpoints entry_args
-- We need liveness info. We could do removeDeadAssignments at
-- the same time, but it buys nothing over doing cmmSink later,
-- and costs a lot more than just cmmLiveness.
-- and costs a lot more than just cmmLocalLiveness.
-- (graph, liveness) <- removeDeadAssignments graph0
let (graph, liveness) = (graph0, cmmLiveness graph0)
let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0)
-- pprTrace "liveness" (ppr liveness) $ return ()
let blocks = postorderDfs graph
......@@ -132,7 +132,7 @@ cmmLayoutStack dflags procpoints entry_args
layout :: DynFlags
-> BlockSet -- proc points
-> BlockEnv CmmLive -- liveness
-> BlockEnv CmmLocalLive -- liveness
-> BlockId -- entry
-> ByteOff -- stack args on entry
......@@ -319,7 +319,7 @@ getStackLoc (Young l) n stackmaps =
-- extra code that goes *after* the Sp adjustment.
handleLastNode
:: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff
:: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
-> BlockEnv StackMap -> StackMap
-> Block CmmNode O O
-> CmmNode O C
......@@ -499,7 +499,7 @@ fixupStack old_stack new_stack = concatMap move new_locs
setupStackFrame
:: DynFlags
-> BlockId -- label of continuation
-> BlockEnv CmmLive -- liveness
-> BlockEnv CmmLocalLive -- liveness
-> ByteOff -- updfr
-> ByteOff -- bytes of return values on stack
-> StackMap -- current StackMap
......@@ -602,7 +602,7 @@ futureContinuation middle = foldBlockNodesB f middle Nothing
-- on the stack and return the new StackMap and the assignments to do
-- the saving.
--
allocate :: DynFlags -> ByteOff -> RegSet -> StackMap
allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
-> (StackMap, [CmmNode O O])
allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
, sm_regs = regs0 }
......
......@@ -32,10 +32,10 @@ import Data.Maybe
cmmLint :: (Outputable d, Outputable h)
=> DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops
cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g
cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint dflags l p =
......@@ -46,18 +46,19 @@ runCmmLint dflags l p =
nest 2 (ppr p)])
Right _ -> Nothing
lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl (CmmProc _ lbl g)
= addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g
lintCmmDecl (CmmData {})
lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl dflags (CmmProc _ lbl _ g)
= addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
lintCmmDecl _ (CmmData {})
= return ()
lintCmmGraph :: CmmGraph -> CmmLint ()
lintCmmGraph g = cmmLiveness g `seq` mapM_ (lintCmmBlock labels) blocks
-- cmmLiveness throws an error if there are registers
-- live on entry to the graph (i.e. undefined
-- variables)
lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
lintCmmGraph dflags g =
cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks
-- cmmLiveness throws an error if there are registers
-- live on entry to the graph (i.e. undefined
-- variables)
where
blocks = toBlockList g
labels = setFromList (map entryLabel blocks)
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmLive
( CmmLive
, cmmLiveness
( CmmLocalLive
, CmmGlobalLive
, cmmLocalLiveness
, cmmGlobalLiveness
, liveLattice
, noLiveOnEntry, xferLive, gen, kill, gen_kill
, removeDeadAssignments
......@@ -12,6 +16,7 @@ module CmmLive
where
import UniqSupply
import DynFlags
import BlockId
import Cmm
import CmmUtils
......@@ -26,10 +31,14 @@ import Outputable
-----------------------------------------------------------------------------
-- | The variables live on entry to a block
type CmmLive = RegSet
type CmmLive r = RegSet r
type CmmLocalLive = CmmLive LocalReg
type CmmGlobalLive = CmmLive GlobalReg
-- | The dataflow lattice
liveLattice :: DataflowLattice CmmLive
liveLattice :: Ord r => DataflowLattice (CmmLive r)
{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}
{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}
liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
where add _ (OldFact old) (NewFact new) =
(changeIf $ sizeRegSet join > sizeRegSet old, join)
......@@ -37,58 +46,73 @@ liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
-- | A mapping from block labels to the variables live on entry
type BlockEntryLiveness = BlockEnv CmmLive
type BlockEntryLiveness r = BlockEnv (CmmLive r)
-----------------------------------------------------------------------------
-- | Calculated liveness info for a CmmGraph
-----------------------------------------------------------------------------
cmmLiveness :: CmmGraph -> BlockEntryLiveness
cmmLiveness graph =
check $ dataflowAnalBwd graph [] $ analBwd liveLattice xferLive
cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness dflags graph =
check $ dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags)
where entry = g_entry graph
check facts = noLiveOnEntry entry
(expectJust "check" $ mapLookup entry facts) facts
cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg
cmmGlobalLiveness dflags graph =
dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags)
-- | On entry to the procedure, there had better not be any LocalReg's live-in.
noLiveOnEntry :: BlockId -> CmmLive -> a -> a
noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
noLiveOnEntry bid in_fact x =
if nullRegSet in_fact then x
else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
-- | The transfer equations use the traditional 'gen' and 'kill'
-- notations, which should be familiar from the Dragon Book.
gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
gen a live = foldRegsUsed extendRegSet live a
kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
kill a live = foldRegsDefd deleteFromRegSet live a
gen :: UserOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r
{-# INLINE gen #-}
gen dflags a live = foldRegsUsed dflags extendRegSet live a
kill :: DefinerOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r
{-# INLINE kill #-}
kill dflags a live = foldRegsDefd dflags deleteFromRegSet live a
gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a)
=> a -> CmmLive -> CmmLive
gen_kill a = gen a . kill a
gen_kill :: (DefinerOfRegs r a, UserOfRegs r a)
=> DynFlags -> a -> CmmLive r -> CmmLive r
{-# INLINE gen_kill #-}
gen_kill dflags a = gen dflags a . kill dflags a
-- | The transfer function
xferLive :: BwdTransfer CmmNode CmmLive
xferLive = mkBTransfer3 fst mid lst
xferLive :: forall r . ( UserOfRegs r (CmmNode O O)
, DefinerOfRegs r (CmmNode O O)
, UserOfRegs r (CmmNode O C)
, DefinerOfRegs r (CmmNode O C))
=> DynFlags -> BwdTransfer CmmNode (CmmLive r)
{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive LocalReg) #-}
{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive GlobalReg) #-}
xferLive dflags = mkBTransfer3 fst mid lst
where fst _ f = f
mid :: CmmNode O O -> CmmLive -> CmmLive
mid n f = gen_kill n f
lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
lst n f = gen_kill n $ joinOutFacts liveLattice n f
mid :: CmmNode O O -> CmmLive r -> CmmLive r
mid n f = gen_kill dflags n f
lst :: CmmNode O C -> FactBase (CmmLive r) -> CmmLive r
lst n f = gen_kill dflags n $ joinOutFacts liveLattice n f
-----------------------------------------------------------------------------
-- Removing assignments to dead variables
-----------------------------------------------------------------------------
removeDeadAssignments :: CmmGraph -> UniqSM (CmmGraph, BlockEnv CmmLive)
removeDeadAssignments g =
dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites
removeDeadAssignments :: DynFlags -> CmmGraph
-> UniqSM (CmmGraph, BlockEnv CmmLocalLive)
removeDeadAssignments dflags g =
dataflowPassBwd g [] $ analRewBwd liveLattice (xferLive dflags) rewrites
where rewrites = mkBRewrite3 nothing middle nothing
-- SDM: no need for deepBwdRw here, we only rewrite to empty
-- Beware: deepBwdRw with one polymorphic function seems more
-- reasonable here, but GHC panics while compiling, see bug
-- #4045.
middle :: CmmNode O O -> Fact O CmmLive -> CmmReplGraph O O
middle :: CmmNode O O -> Fact O CmmLocalLive -> CmmReplGraph O O
middle (CmmAssign (CmmLocal reg') _) live
| not (reg' `elemRegSet` live)
= return $ Just emptyGraph
......@@ -99,5 +123,5 @@ removeDeadAssignments g =
= return $ Just emptyGraph
middle _ _ = return Nothing
nothing :: CmmNode e x -> Fact x CmmLive -> CmmReplGraph e x
nothing :: CmmNode e x -> Fact x CmmLocalLive -> CmmReplGraph e x
nothing _ _ = return Nothing
-- CmmNode type for representation using Hoopl graphs.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
......@@ -16,7 +18,9 @@ module CmmNode (
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
) where
import CodeGen.Platform
import CmmExpr
import DynFlags
import FastString
import ForeignCall
import SMRep
......@@ -280,8 +284,8 @@ data ForeignTarget -- The target of a foreign call
--------------------------------------------------
-- Instances of register and slot users / definers
instance UserOfLocalRegs (CmmNode e x) where
foldRegsUsed f z n = case n of
instance UserOfRegs LocalReg (CmmNode e x) where
foldRegsUsed dflags f z n = case n of
CmmAssign _ expr -> fold f z expr
CmmStore addr rval -> fold f (fold f z addr) rval
CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
......@@ -291,24 +295,58 @@ instance UserOfLocalRegs (CmmNode e x) where
CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
_ -> z
where fold :: forall a b.
UserOfLocalRegs a =>
UserOfRegs LocalReg a =>
(b -> LocalReg -> b) -> b -> a -> b
fold f z n = foldRegsUsed f z n
fold f z n = foldRegsUsed dflags f z n
instance UserOfLocalRegs ForeignTarget where
foldRegsUsed _f z (PrimTarget _) = z
foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
instance UserOfRegs GlobalReg (CmmNode e x) where
foldRegsUsed dflags f z n = case n of
CmmAssign _ expr -> fold f z expr
CmmStore addr rval -> fold f (fold f z addr) rval
CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
CmmCondBranch expr _ _ -> fold f z expr
CmmSwitch expr _ -> fold f z expr
CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
_ -> z
where fold :: forall a b.
UserOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold f z n = foldRegsUsed dflags f z n
instance DefinerOfLocalRegs (CmmNode e x) where
foldRegsDefd f z n = case n of
instance UserOfRegs r CmmExpr => UserOfRegs r ForeignTarget where
foldRegsUsed _ _ z (PrimTarget _) = z
foldRegsUsed dflags f z (ForeignTarget e _) = foldRegsUsed dflags f z e
instance DefinerOfRegs LocalReg (CmmNode e x) where
foldRegsDefd dflags f z n = case n of
CmmAssign lhs _ -> fold f z lhs
CmmUnsafeForeignCall _ fs _ -> fold f z fs
CmmForeignCall {res=res} -> fold f z res
_ -> z
where fold :: forall a b.
DefinerOfLocalRegs a =>
DefinerOfRegs LocalReg a =>
(b -> LocalReg -> b) -> b -> a -> b
fold f z n = foldRegsDefd f z n
fold f z n = foldRegsDefd dflags f z n
instance DefinerOfRegs GlobalReg (CmmNode e x) where
foldRegsDefd dflags f z n = case n of
CmmAssign lhs _ -> fold f z lhs
CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt)
CmmCall {} -> fold f z activeRegs
CmmForeignCall {tgt=tgt} -> fold f z (foreignTargetRegs tgt)
_ -> z
where fold :: forall a b.
DefinerOfRegs GlobalReg a =>
(b -> GlobalReg -> b) -> b -> a -> b
fold f z n = foldRegsDefd dflags f z n
platform = targetPlatform dflags
activeRegs = activeStgRegs platform
activeCallerSavesRegs = filter (callerSaves platform) activeRegs
foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
foreignTargetRegs _ = activeCallerSavesRegs
-----------------------------------
......
......@@ -42,11 +42,11 @@ rewriteAssignments dflags g = do
-- first perform usage analysis and bake this information into the
-- graph (backwards transform), and then do a forwards transform
-- to actually perform inlining and sinking.
g' <- annotateUsage g
g' <- annotateUsage dflags g
g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
analRewFwd assignmentLattice
(assignmentTransfer dflags)
(assignmentRewrite `thenFwdRw` machOpFoldRewrite dflags)
(assignmentRewrite dflags `thenFwdRw` machOpFoldRewrite dflags)
return (modifyGraph eraseRegUsage g'')
----------------------------------------------------------------
......@@ -159,13 +159,13 @@ data WithRegUsage n e x where
Plain :: n e x -> WithRegUsage n e x
AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where
foldRegsUsed f z (Plain n) = foldRegsUsed f z n
foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e
instance UserOfRegs LocalReg (n e x) => UserOfRegs LocalReg (WithRegUsage n e x) where
foldRegsUsed dflags f z (Plain n) = foldRegsUsed dflags f z n
foldRegsUsed dflags f z (AssignLocal _ e _) = foldRegsUsed dflags f z e
instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where
foldRegsDefd f z (Plain n) = foldRegsDefd f z n
foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r
instance DefinerOfRegs LocalReg (n e x) => DefinerOfRegs LocalReg (WithRegUsage n e x) where
foldRegsDefd dflags f z (Plain n) = foldRegsDefd dflags f z n
foldRegsDefd dflags f z (AssignLocal r _ _) = foldRegsDefd dflags f z r
instance NonLocal n => NonLocal (WithRegUsage n) where
entryLabel (Plain n) = entryLabel n
......@@ -190,8 +190,8 @@ usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f)
-- We reuse the names 'gen' and 'kill', although we're doing something
-- slightly different from the Dragon Book
usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap
usageTransfer = mkBTransfer3 first middle last
usageTransfer :: DynFlags -> BwdTransfer (WithRegUsage CmmNode) UsageMap
usageTransfer dflags = mkBTransfer3 first middle last
where first _ f = f
middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap
middle n f = gen_kill n f
......@@ -209,9 +209,9 @@ usageTransfer = mkBTransfer3 first middle last
gen_kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap
gen_kill a = gen a . kill a
gen :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap
gen a f = foldRegsUsed increaseUsage f a
gen a f = foldLocalRegsUsed dflags increaseUsage f a
kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap
kill a f = foldRegsDefd delFromUFM f a
kill a f = foldLocalRegsDefd dflags delFromUFM f a
increaseUsage f r = addToUFM_C combine f r SingleUse
where combine _ _ = ManyUse
......@@ -228,11 +228,11 @@ usageRewrite = mkBRewrite3 first middle last
last _ _ = return Nothing
type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
annotateUsage :: CmmGraph -> UniqSM (CmmGraphWithRegUsage)
annotateUsage vanilla_g =
annotateUsage :: DynFlags -> CmmGraph -> UniqSM (CmmGraphWithRegUsage)
annotateUsage dflags vanilla_g =
let g = modifyGraph liftRegUsage vanilla_g
in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
analRewBwd usageLattice usageTransfer usageRewrite
analRewBwd usageLattice (usageTransfer dflags) usageRewrite
----------------------------------------------------------------
--- Assignment tracking
......@@ -286,8 +286,8 @@ assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUF
-- Deletes sinks from assignment map, because /this/ is the place
-- where it will be sunk to.
deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap
deleteSinks n m = foldRegsUsed (adjustUFM f) m n
deleteSinks :: UserOfRegs LocalReg n => DynFlags -> n -> AssignmentMap -> AssignmentMap
deleteSinks dflags n m = foldLocalRegsUsed dflags (adjustUFM f) m n
where f (AlwaysSink _) = NeverOptimize
f old = old
......@@ -319,8 +319,8 @@ middleAssignment :: DynFlags -> WithRegUsage CmmNode O O -> AssignmentMap
-- the correct optimization policy.
-- 3. Look for all assignments that reference that register and
-- invalidate them.
middleAssignment _ n@(AssignLocal r e usage) assign
= invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
middleAssignment dflags n@(AssignLocal r e usage) assign
= invalidateUsersOf (CmmLocal r) . add . deleteSinks dflags n $ assign
where add m = addToUFM m r
$ case usage of
SingleUse -> AlwaysInline e
......@@ -339,8 +339,8 @@ middleAssignment _ n@(AssignLocal r e usage) assign
-- 1. Delete any sinking assignments that were used by this instruction