Commit 535a88e1 authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Marge Bot
Browse files

Add loop level analysis to the NCG backend.

For backends maintaining the CFG during codegen
we can now find loops and their nesting level.

This is based on the Cmm CFG and dominator analysis.

As a result we can estimate edge frequencies a lot better
for methods, resulting in far better code layout.

Speedup on nofib: ~1.5%
Increase in compile times: ~1.9%

To make this feasible this commit adds:
* Dominator analysis based on the Lengauer-Tarjan Algorithm.
* An algorithm estimating global edge frequences from branch
probabilities - In CFG.hs

A few static branch prediction heuristics:

* Expect to take the backedge in loops.
* Expect to take the branch NOT exiting a loop.
* Expect integer vs constant comparisons to be false.

We also treat heap/stack checks special for branch prediction
to avoid them being treated as loops.
parent 9c11f817
Pipeline #11446 passed with stages
in 496 minutes and 26 seconds
......@@ -6,8 +6,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
--
-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
-- and Norman Ramsey
......@@ -108,6 +106,7 @@ analyzeCmm
-> FactBase f
-> FactBase f
analyzeCmm dir lattice transfer cmmGraph initFact =
{-# SCC analyzeCmm #-}
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap =
......@@ -169,7 +168,7 @@ rewriteCmm
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm dir lattice rwFun cmmGraph initFact = do
rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap1 =
......
......@@ -593,6 +593,7 @@ Library
Instruction
BlockLayout
CFG
Dominators
Format
Reg
RegClass
......
......@@ -562,7 +562,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
Opt_D_dump_asm_native "Native code"
(vcat $ map (pprNatCmmDecl ncgImpl) native)
dumpIfSet_dyn dflags
when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Weights"
(pprEdgeWeights nativeCfgWeights)
......@@ -691,7 +691,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "generateJumpTables" #-}
generateJumpTables ncgImpl alloced
dumpIfSet_dyn dflags
when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Update information"
( text "stack:" <+> ppr stack_updt_blks $$
text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
......@@ -705,8 +705,9 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
optimizedCFG =
optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG
maybe (return ())
(dumpIfSet_dyn dflags Opt_D_dump_cfg_weights "CFG Final Weights" . pprEdgeWeights)
maybe (return ()) (\cfg->
dumpIfSet_dyn dflags Opt_D_dump_cfg_weights "CFG Final Weights"
( pprEdgeWeights cfg ))
optimizedCFG
--TODO: Partially check validity of the cfg.
......
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-}
module RegAlloc.Graph.SpillCost (
SpillCostRecord,
plusSpillCostRecord,
......@@ -23,6 +23,7 @@ import Reg
import GraphBase
import Hoopl.Collections (mapLookup)
import Hoopl.Label
import Cmm
import UniqFM
import UniqSet
......@@ -49,9 +50,6 @@ type SpillCostRecord
type SpillCostInfo
= UniqFM SpillCostRecord
-- | Block membership in a loop
type LoopMember = Bool
type SpillCostState = State (UniqFM SpillCostRecord) ()
-- | An empty map of spill costs.
......@@ -88,45 +86,49 @@ slurpSpillCostInfo platform cfg cmm
where
countCmm CmmData{} = return ()
countCmm (CmmProc info _ _ sccs)
= mapM_ (countBlock info)
= mapM_ (countBlock info freqMap)
$ flattenSCCs sccs
where
LiveInfo _ entries _ _ = info
freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg
-- Lookup the regs that are live on entry to this block in
-- the info table from the CmmProc.
countBlock info (BasicBlock blockId instrs)
countBlock info freqMap (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive _ <- info
, Just rsLiveEntry <- mapLookup blockId blockLive
, rsLiveEntry_virt <- takeVirtuals rsLiveEntry
= countLIs (loopMember blockId) rsLiveEntry_virt instrs
= countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs
| otherwise
= error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
countLIs :: LoopMember -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
countLIs _ _ []
= return ()
-- Skip over comment and delta pseudo instrs.
countLIs inLoop rsLive (LiveInstr instr Nothing : lis)
countLIs scale rsLive (LiveInstr instr Nothing : lis)
| isMetaInstr instr
= countLIs inLoop rsLive lis
= countLIs scale rsLive lis
| otherwise
= pprPanic "RegSpillCost.slurpSpillCostInfo"
$ text "no liveness information on instruction " <> ppr instr
countLIs inLoop rsLiveEntry (LiveInstr instr (Just live) : lis)
countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis)
= do
-- Increment the lifetime counts for regs live on entry to this instr.
mapM_ (incLifetime (loopCount inLoop)) $ nonDetEltsUniqSet rsLiveEntry
mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
-- Increment counts for what regs were read/written from.
let (RU read written) = regUsageOfInstr platform instr
mapM_ (incUses (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub read
mapM_ (incDefs (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub written
mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read
mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written
-- Compute liveness for entry to next instruction.
let liveDieRead_virt = takeVirtuals (liveDieRead live)
......@@ -140,21 +142,18 @@ slurpSpillCostInfo platform cfg cmm
= (rsLiveAcross `unionUniqSets` liveBorn_virt)
`minusUniqSet` liveDieWrite_virt
countLIs inLoop rsLiveNext lis
countLIs scale rsLiveNext lis
loopCount inLoop
| inLoop = 10
| otherwise = 1
incDefs count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0)
incUses count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0)
incLifetime count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, count)
incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)
loopBlocks = CFG.loopMembers <$> cfg
loopMember bid
| Just isMember <- join (mapLookup bid <$> loopBlocks)
= isMember
blockFreq :: Maybe (LabelMap Double) -> Label -> Double
blockFreq freqs bid
| Just freq <- join (mapLookup bid <$> freqs)
= max 1.0 (10000 * freq)
| otherwise
= False
= 1.0 -- Only if no cfg given
-- | Take all the virtual registers from this set.
takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
......@@ -215,31 +214,39 @@ chooseSpill info graph
-- Without live range splitting, its's better to spill from the outside
-- in so set the cost of very long live ranges to zero
--
{-
spillCost_chaitin
:: SpillCostInfo
-> Graph Reg RegClass Reg
-> Reg
-> Float
spillCost_chaitin info graph reg
-- Spilling a live range that only lives for 1 instruction
-- isn't going to help us at all - and we definitely want to avoid
-- trying to re-spill previously inserted spill code.
| lifetime <= 1 = 1/0
-- It's unlikely that we'll find a reg for a live range this long
-- better to spill it straight up and not risk trying to keep it around
-- and have to go through the build/color cycle again.
| lifetime > allocatableRegsInClass (regClass reg) * 10
= 0
-- spillCost_chaitin
-- :: SpillCostInfo
-- -> Graph VirtualReg RegClass RealReg
-- -> VirtualReg
-- -> Float
-- spillCost_chaitin info graph reg
-- -- Spilling a live range that only lives for 1 instruction
-- -- isn't going to help us at all - and we definitely want to avoid
-- -- trying to re-spill previously inserted spill code.
-- | lifetime <= 1 = 1/0
-- -- It's unlikely that we'll find a reg for a live range this long
-- -- better to spill it straight up and not risk trying to keep it around
-- -- and have to go through the build/color cycle again.
-- -- To facility this we scale down the spill cost of long ranges.
-- -- This makes sure long ranges are still spilled first.
-- -- But this way spill cost remains relevant for long live
-- -- ranges.
-- | lifetime >= 128
-- = (spillCost / conflicts) / 10.0
-- -- Otherwise revert to chaitin's regular cost function.
-- | otherwise = (spillCost / conflicts)
-- where
-- !spillCost = fromIntegral (uses + defs) :: Float
-- conflicts = fromIntegral (nodeDegree classOfVirtualReg graph reg)
-- (_, defs, uses, lifetime)
-- = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
-- Otherwise revert to chaitin's regular cost function.
| otherwise = fromIntegral (uses + defs)
/ fromIntegral (nodeDegree graph reg)
where (_, defs, uses, lifetime)
= fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
-}
-- Just spill the longest live range.
spillCost_length
......
......@@ -3529,7 +3529,7 @@ invertCondBranches (Just cfg) keep bs =
, Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg
-- Both jumps come from the same cmm statement
, transitionSource edgeInfo1 == transitionSource edgeInfo2
, (CmmSource cmmCondBranch) <- transitionSource edgeInfo1
, CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1
--Int comparisons are invertable
, CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch
......
{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}
{- |
Module : Dominators
Copyright : (c) Matt Morrow 2009
License : BSD3
Maintainer : <morrow@moonpatio.com>
Stability : experimental
Portability : portable
Taken from the dom-lt package.
The Lengauer-Tarjan graph dominators algorithm.
\[1\] Lengauer, Tarjan,
/A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.
\[2\] Muchnick,
/Advanced Compiler Design and Implementation/, 1997.
\[3\] Brisk, Sarrafzadeh,
/Interference Graphs for Procedures in Static Single/
/Information Form are Interval Graphs/, 2007.
Originally taken from the dom-lt package.
-}
module Dominators (
Node,Path,Edge
,Graph,Rooted
,idom,ipdom
,domTree,pdomTree
,dom,pdom
,pddfs,rpddfs
,fromAdj,fromEdges
,toAdj,toEdges
,asTree,asGraph
,parents,ancestors
) where
import GhcPrelude
import Data.Bifunctor
import Data.Tuple (swap)
import Data.Tree
import Data.IntMap(IntMap)
import Data.IntSet(IntSet)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Control.Monad
import Control.Monad.ST.Strict
import Data.Array.ST
import Data.Array.Base
(unsafeNewArray_
,unsafeWrite,unsafeRead)
-----------------------------------------------------------------------------
type Node = Int
type Path = [Node]
type Edge = (Node,Node)
type Graph = IntMap IntSet
type Rooted = (Node, Graph)
-----------------------------------------------------------------------------
-- | /Dominators/.
-- Complexity as for @idom@
dom :: Rooted -> [(Node, Path)]
dom = ancestors . domTree
-- | /Post-dominators/.
-- Complexity as for @idom@.
pdom :: Rooted -> [(Node, Path)]
pdom = ancestors . pdomTree
-- | /Dominator tree/.
-- Complexity as for @idom@.
domTree :: Rooted -> Tree Node
domTree a@(r,_) =
let is = filter ((/=r).fst) (idom a)
tg = fromEdges (fmap swap is)
in asTree (r,tg)
-- | /Post-dominator tree/.
-- Complexity as for @idom@.
pdomTree :: Rooted -> Tree Node
pdomTree a@(r,_) =
let is = filter ((/=r).fst) (ipdom a)
tg = fromEdges (fmap swap is)
in asTree (r,tg)
-- | /Immediate dominators/.
-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is
-- \"a functional inverse of Ackermann's function\".
--
-- This Complexity bound assumes /O(1)/ indexing. Since we're
-- using @IntMap@, it has an additional /lg |V|/ factor
-- somewhere in there. I'm not sure where.
idom :: Rooted -> [(Node,Node)]
idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
-- | /Immediate post-dominators/.
-- Complexity as for @idom@.
ipdom :: Rooted -> [(Node,Node)]
ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))
-----------------------------------------------------------------------------
-- | /Post-dominated depth-first search/.
pddfs :: Rooted -> [Node]
pddfs = reverse . rpddfs
-- | /Reverse post-dominated depth-first search/.
rpddfs :: Rooted -> [Node]
rpddfs = concat . levels . pdomTree
-----------------------------------------------------------------------------
type Dom s a = S s (Env s) a
type NodeSet = IntSet
type NodeMap a = IntMap a
data Env s = Env
{succE :: !Graph
,predE :: !Graph
,bucketE :: !Graph
,dfsE :: {-# UNPACK #-}!Int
,zeroE :: {-# UNPACK #-}!Node
,rootE :: {-# UNPACK #-}!Node
,labelE :: {-# UNPACK #-}!(Arr s Node)
,parentE :: {-# UNPACK #-}!(Arr s Node)
,ancestorE :: {-# UNPACK #-}!(Arr s Node)
,childE :: {-# UNPACK #-}!(Arr s Node)
,ndfsE :: {-# UNPACK #-}!(Arr s Node)
,dfnE :: {-# UNPACK #-}!(Arr s Int)
,sdnoE :: {-# UNPACK #-}!(Arr s Int)
,sizeE :: {-# UNPACK #-}!(Arr s Int)
,domE :: {-# UNPACK #-}!(Arr s Node)
,rnE :: {-# UNPACK #-}!(Arr s Node)}
-----------------------------------------------------------------------------
idomM :: Dom s [(Node,Node)]
idomM = do
dfsDom =<< rootM
n <- gets dfsE
forM_ [n,n-1..1] (\i-> do
w <- ndfsM i
sw <- sdnoM w
ps <- predsM w
forM_ ps (\v-> do
u <- eval v
su <- sdnoM u
when (su < sw)
(store sdnoE w su))
z <- ndfsM =<< sdnoM w
modify(\e->e{bucketE=IM.adjust
(w`IS.insert`)
z (bucketE e)})
pw <- parentM w
link pw w
bps <- bucketM pw
forM_ bps (\v-> do
u <- eval v
su <- sdnoM u
sv <- sdnoM v
let dv = case su < sv of
True-> u
False-> pw
store domE v dv))
forM_ [1..n] (\i-> do
w <- ndfsM i
j <- sdnoM w
z <- ndfsM j
dw <- domM w
when (dw /= z)
(do ddw <- domM dw
store domE w ddw))
fromEnv
-----------------------------------------------------------------------------
eval :: Node -> Dom s Node
eval v = do
n0 <- zeroM
a <- ancestorM v
case a==n0 of
True-> labelM v
False-> do
compress v
a <- ancestorM v
l <- labelM v
la <- labelM a
sl <- sdnoM l
sla <- sdnoM la
case sl <= sla of
True-> return l
False-> return la
compress :: Node -> Dom s ()
compress v = do
n0 <- zeroM
a <- ancestorM v
aa <- ancestorM a
when (aa /= n0) (do
compress a
a <- ancestorM v
aa <- ancestorM a
l <- labelM v
la <- labelM a
sl <- sdnoM l
sla <- sdnoM la
when (sla < sl)
(store labelE v la)
store ancestorE v aa)
-----------------------------------------------------------------------------
link :: Node -> Node -> Dom s ()
link v w = do
n0 <- zeroM
lw <- labelM w
slw <- sdnoM lw
let balance s = do
c <- childM s
lc <- labelM c
slc <- sdnoM lc
case slw < slc of
False-> return s
True-> do
zs <- sizeM s
zc <- sizeM c
cc <- childM c
zcc <- sizeM cc
case 2*zc <= zs+zcc of
True-> do
store ancestorE c s
store childE s cc
balance s
False-> do
store sizeE c zs
store ancestorE s c
balance c
s <- balance w
lw <- labelM w
zw <- sizeM w
store labelE s lw
store sizeE v . (+zw) =<< sizeM v
let follow s = do
when (s /= n0) (do
store ancestorE s v
follow =<< childM s)
zv <- sizeM v
follow =<< case zv < 2*zw of
False-> return s
True-> do
cv <- childM v
store childE v s
return cv
-----------------------------------------------------------------------------
dfsDom :: Node -> Dom s ()
dfsDom i = do
_ <- go i
n0 <- zeroM
r <- rootM
store parentE r n0
where go i = do
n <- nextM
store dfnE i n
store sdnoE i n
store ndfsE n i
store labelE i i
ss <- succsM i
forM_ ss (\j-> do
s <- sdnoM j
case s==0 of
False-> return()
True-> do
store parentE j i
go j)
-----------------------------------------------------------------------------
initEnv :: Rooted -> ST s (Env s)
initEnv (r0,g0) = do
let (g,rnmap) = renum 1 g0
pred = predG g
r = rnmap IM.! r0
n = IM.size g
ns = [0..n]
m = n+1
let bucket = IM.fromList
(zip ns (repeat mempty))
rna <- newI m
writes rna (fmap swap
(IM.toList rnmap))
doms <- newI m
sdno <- newI m
size <- newI m
parent <- newI m
ancestor <- newI m
child <- newI m
label <- newI m
ndfs <- newI m
dfn <- newI m
forM_ [0..n] (doms.=0)
forM_ [0..n] (sdno.=0)
forM_ [1..n] (size.=1)
forM_ [0..n] (ancestor.=0)
forM_ [0..n] (child.=0)
(doms.=r) r
(size.=0) 0
(label.=0) 0
return (Env
{rnE = rna
,dfsE = 0
,zeroE = 0
,rootE = r
,labelE = label
,parentE = parent
,ancestorE = ancestor
,childE = child
,ndfsE = ndfs
,dfnE = dfn
,sdnoE = sdno
,sizeE = size
,succE = g
,predE = pred
,bucketE = bucket
,domE = doms})
fromEnv :: Dom s [(Node,Node)]
fromEnv = do
dom <- gets domE
rn <- gets rnE
-- r <- gets rootE
(_,n) <- st (getBounds dom)
forM [1..n] (\i-> do
j <- st(rn!:i)
d <- st(dom!:i)
k <- st(rn!:d)
return (j,k))
-----------------------------------------------------------------------------