summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CmmExpr.hs141
-rw-r--r--compiler/cmm/CmmLayoutStack.hs12
-rw-r--r--compiler/cmm/CmmLint.hs23
-rw-r--r--compiler/cmm/CmmLive.hs78
-rw-r--r--compiler/cmm/CmmNode.hs60
-rw-r--r--compiler/cmm/CmmRewriteAssignments.hs62
-rw-r--r--compiler/cmm/CmmSink.hs30
-rw-r--r--compiler/cmm/OldCmm.hs28
8 files changed, 267 insertions, 167 deletions
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 128eb1ca62..87713c6b0d 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -1,16 +1,24 @@
+{-# 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
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index de9f35a798..c7e6e3ae6e 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -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 }
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 87a3ebfb5e..da7b094643 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -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)
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index f0163fefc4..7d674b76a2 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -1,10 +1,14 @@
+{-# 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
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index b7bb270bd6..6fa3007fbe 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -1,5 +1,7 @@
-- 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
-----------------------------------
diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs
index 0f2aeaa939..8381d12e7c 100644
--- a/compiler/cmm/CmmRewriteAssignments.hs
+++ b/compiler/cmm/CmmRewriteAssignments.hs
@@ -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
-- 2. Look for all assignments that reference this register and
-- invalidate them.
-middleAssignment _ (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
- = invalidateUsersOf reg . deleteSinks n $ assign
+middleAssignment dflags (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
+ = invalidateUsersOf reg . deleteSinks dflags n $ assign
-- Algorithm for unannotated assignments of *local* registers: do
-- nothing (it's a reload, so no state should have changed)
@@ -351,7 +351,7 @@ middleAssignment _ (Plain (CmmAssign (CmmLocal _) _)) assign = assign
-- 2. Look for all assignments that load from memory locations that
-- were clobbered by this store and invalidate them.
middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign
- = let m = deleteSinks n assign
+ = let m = deleteSinks dflags n assign
in foldUFM_Directly f m m -- [foldUFM performance]
where f u (xassign -> Just x) m | clobbers dflags (lhs, rhs) (u, x) = addToUFM_Directly m u NeverOptimize
f _ _ m = m
@@ -373,7 +373,7 @@ middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign
-- store extra information about expressions that allow this and other
-- checks to be done cheaply.)
middleAssignment dflags (Plain n@(CmmUnsafeForeignCall{})) assign
- = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
+ = deleteCallerSaves (foldLocalRegsDefd dflags (\m r -> addToUFM m r NeverOptimize) (deleteSinks dflags n assign) n)
where deleteCallerSaves m = foldUFM_Directly f m m
f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
f _ _ m = m
@@ -442,10 +442,10 @@ overlaps (_, o, w) (_, o', w') =
s' = o' - w'
in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK
-lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
-lastAssignment (Plain (CmmCall _ (Just k) _ _ _ _)) assign = [(k, invalidateVolatile k assign)]
-lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)]
-lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l
+lastAssignment :: DynFlags -> WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
+lastAssignment _ (Plain (CmmCall _ (Just k) _ _ _ _)) assign = [(k, invalidateVolatile k assign)]
+lastAssignment _ (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)]
+lastAssignment dflags l assign = map (\id -> (id, deleteSinks dflags l assign)) $ successors l
-- Invalidates any expressions that have volatile contents: essentially,
-- all terminals volatile except for literals and loads of stack slots
@@ -471,7 +471,7 @@ assignmentTransfer :: DynFlags
assignmentTransfer dflags
= mkFTransfer3 (flip const)
(middleAssignment dflags)
- ((mkFactBase assignmentLattice .) . lastAssignment)
+ ((mkFactBase assignmentLattice .) . lastAssignment dflags)
-- Note [Soundness of inlining]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -533,8 +533,8 @@ assignmentTransfer dflags
-- values from the assignment map, due to reassignment of the local
-- register.) This is probably not locally sound.
-assignmentRewrite :: FwdRewrite UniqSM (WithRegUsage CmmNode) AssignmentMap
-assignmentRewrite = mkFRewrite3 first middle last
+assignmentRewrite :: DynFlags -> FwdRewrite UniqSM (WithRegUsage CmmNode) AssignmentMap
+assignmentRewrite dflags = mkFRewrite3 first middle last
where
first _ _ = return Nothing
middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O
@@ -543,7 +543,7 @@ assignmentRewrite = mkFRewrite3 first middle last
last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l
-- Tuple is (inline?, reloads for sinks)
precompute :: AssignmentMap -> CmmNode O x -> (Bool, [WithRegUsage CmmNode O O])
- precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless
+ precompute assign n = foldLocalRegsUsed dflags f (False, []) n -- duplicates are harmless
where f (i, l) r = case lookupUFM assign r of
Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l)
Just (AlwaysInline _) -> (True, l)
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 7553e37325..2a080c2e58 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -125,7 +125,7 @@ type Assignment = (LocalReg, CmmExpr, AbsMem)
cmmSink :: DynFlags -> CmmGraph -> CmmGraph
cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
where
- liveness = cmmLiveness graph
+ liveness = cmmLocalLiveness dflags graph
getLive l = mapFindWithDefault Set.empty l liveness
blocks = postorderDfs graph
@@ -147,8 +147,8 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- the node. This will help us decide whether we can inline
-- an assignment in the current node or not.
live = Set.unions (map getLive succs)
- live_middle = gen_kill last live
- ann_middles = annotate live_middle (blockToList middle)
+ live_middle = gen_kill dflags last live
+ ann_middles = annotate dflags live_middle (blockToList middle)
-- Now sink and inline in this block
(middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
@@ -187,7 +187,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
upd set | r `Set.member` set = set `Set.union` live_rhs
| otherwise = set
- live_rhs = foldRegsUsed extendRegSet emptyRegSet rhs
+ live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs
final_middle = foldl blockSnoc middle' dropped_last
@@ -215,9 +215,9 @@ isTrivial _ = False
--
-- annotate each node with the set of registers live *after* the node
--
-annotate :: RegSet -> [CmmNode O O] -> [(RegSet, CmmNode O O)]
-annotate live nodes = snd $ foldr ann (live,[]) nodes
- where ann n (live,nodes) = (gen_kill n live, (live,n) : nodes)
+annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]
+annotate dflags live nodes = snd $ foldr ann (live,[]) nodes
+ where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)
--
-- Find the blocks that have multiple successors (join points)
@@ -234,7 +234,7 @@ findJoinPoints blocks = mapFilter (>1) succ_counts
-- filter the list of assignments to remove any assignments that
-- are not live in a continuation.
--
-filterAssignments :: DynFlags -> RegSet -> [Assignment] -> [Assignment]
+filterAssignments :: DynFlags -> LocalRegSet -> [Assignment] -> [Assignment]
filterAssignments dflags live assigs = reverse (go assigs [])
where go [] kept = kept
go (a@(r,_,_):as) kept | needed = go as (a:kept)
@@ -251,7 +251,7 @@ filterAssignments dflags live assigs = reverse (go assigs [])
-- as we go.
walk :: DynFlags
- -> [(RegSet, CmmNode O O)] -- nodes of the block, annotated with
+ -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with
-- the set of registers live *after*
-- this node.
@@ -310,7 +310,7 @@ shouldSink _ _other = Nothing
-- out of inlining, but the inliner will see that r is live
-- after the instruction and choose not to inline r in the rhs.
--
-shouldDiscard :: CmmNode e x -> RegSet -> Bool
+shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool
shouldDiscard node live
= case node of
CmmAssign r (CmmReg r') | r == r' -> True
@@ -346,7 +346,7 @@ dropAssignments dflags should_drop state assigs
tryToInline
:: DynFlags
- -> RegSet -- set of registers live after this
+ -> LocalRegSet -- set of registers live after this
-- node. We cannot inline anything
-- that is live after the node, unless
-- it is small enough to duplicate.
@@ -360,7 +360,7 @@ tryToInline
tryToInline dflags live node assigs = go usages node [] assigs
where
usages :: UniqFM Int
- usages = foldRegsUsed addUsage emptyUFM node
+ usages = foldRegsUsed dflags addUsage emptyUFM node
go _usages node _skipped [] = (node, [])
@@ -371,14 +371,14 @@ tryToInline dflags live node assigs = go usages node [] assigs
| otherwise = dont_inline
where
inline_and_discard = go usages' inl_node skipped rest
- where usages' = foldRegsUsed addUsage usages rhs
+ where usages' = foldRegsUsed dflags addUsage usages rhs
dont_inline = keep node -- don't inline the assignment, keep it
inline_and_keep = keep inl_node -- inline the assignment, keep it
keep node' = (final_node, a : rest')
where (final_node, rest') = go usages' node' (l:skipped) rest
- usages' = foldRegsUsed (\m r -> addToUFM m r 2) usages rhs
+ usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2) usages rhs
-- we must not inline anything that is mentioned in the RHS
-- of a binding that we have already skipped, so we set the
-- usages of the regs on the RHS to 2.
@@ -458,7 +458,7 @@ conflicts dflags (r, rhs, addr) node
-- (1) an assignment to a register conflicts with a use of the register
| CmmAssign reg _ <- node, reg `regUsedIn` rhs = True
- | foldRegsUsed (\b r' -> r == r' || b) False node = True
+ | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True
-- (2) a store to an address conflicts with a read of the same memory
| CmmStore addr' e <- node
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index 00f88a4e35..8d5c0398cf 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
-----------------------------------------------------------------------------
--
-- Old-style Cmm data types
@@ -86,8 +88,8 @@ type RawCmmDecl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt
data GenBasicBlock i = BasicBlock BlockId [i]
type CmmBasicBlock = GenBasicBlock CmmStmt
-instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where
- foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l
+instance UserOfRegs r i => UserOfRegs r (GenBasicBlock i) where
+ foldRegsUsed dflags f set (BasicBlock _ l) = foldRegsUsed dflags f set l
-- | The branch block id is that of the first block in
-- the branch, which is that branch's entry point
@@ -187,8 +189,8 @@ data CmmSafety
| CmmInterruptible
-- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]'
-instance UserOfLocalRegs CmmStmt where
- foldRegsUsed f (set::b) s = stmt s set
+instance UserOfRegs LocalReg CmmStmt where
+ foldRegsUsed dflags f (set::b) s = stmt s set
where
stmt :: CmmStmt -> b -> b
stmt (CmmNop) = id
@@ -202,18 +204,18 @@ instance UserOfLocalRegs CmmStmt where
stmt (CmmJump e _) = gen e
stmt (CmmReturn) = id
- gen :: UserOfLocalRegs a => a -> b -> b
- gen a set = foldRegsUsed f set a
+ gen :: UserOfRegs LocalReg a => a -> b -> b
+ gen a set = foldRegsUsed dflags f set a
-instance UserOfLocalRegs CmmCallTarget where
- foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
- foldRegsUsed f set (CmmPrim _ mStmts) = foldRegsUsed f set mStmts
+instance UserOfRegs LocalReg CmmCallTarget where
+ foldRegsUsed dflags f set (CmmCallee e _) = foldRegsUsed dflags f set e
+ foldRegsUsed dflags f set (CmmPrim _ mStmts) = foldRegsUsed dflags f set mStmts
-instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where
- foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a)
+instance UserOfRegs r a => UserOfRegs r (CmmHinted a) where
+ foldRegsUsed dflags f set a = foldRegsUsed dflags f set (hintlessCmm a)
-instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where
- foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a)
+instance DefinerOfRegs r a => DefinerOfRegs r (CmmHinted a) where
+ foldRegsDefd dflags f set a = foldRegsDefd dflags f set (hintlessCmm a)
{-
Discussion
View Lorry Controller Status