Commit f0f63a54 authored by benl's avatar benl

De-tabify register allocator code

parent 7b41a694
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
-- | Utils for calculating general worst, bound, squeese and free, functions.
--
-- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"
-- Michael Smith, Normal Ramsey, Glenn Holloway.
-- PLDI 2004
--
-- These general versions are not used in GHC proper because they are too slow.
-- Instead, hand written optimised versions are provided for each architecture
-- in MachRegs*.hs
-- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"
-- Michael Smith, Normal Ramsey, Glenn Holloway.
-- PLDI 2004
--
-- These general versions are not used in GHC proper because they are too slow.
-- Instead, hand written optimised versions are provided for each architecture
-- in MachRegs*.hs
--
-- This code is here because we can test the architecture specific code against it.
-- This code is here because we can test the architecture specific code against it.
--
module RegAlloc.Graph.ArchBase (
RegClass(..),
Reg(..),
RegSub(..),
worst,
bound,
squeese
RegClass(..),
Reg(..),
RegSub(..),
worst,
bound,
squeese
)
where
import UniqSet
import Unique
-- Some basic register classes.
-- These aren't nessesarally in 1-to-1 correspondance with the allocatable
-- RegClasses in MachRegs.hs
-- These aren't nessesarally in 1-to-1 correspondance with the allocatable
-- RegClasses in MachRegs.hs
data RegClass
-- general purpose regs
= ClassG32 -- 32 bit GPRs
| ClassG16 -- 16 bit GPRs
| ClassG8 -- 8 bit GPRs
-- floating point regs
| ClassF64 -- 64 bit FPRs
deriving (Show, Eq, Enum)
-- general purpose regs
= ClassG32 -- 32 bit GPRs
| ClassG16 -- 16 bit GPRs
| ClassG8 -- 8 bit GPRs
-- floating point regs
| ClassF64 -- 64 bit FPRs
deriving (Show, Eq, Enum)
-- | A register of some class
data Reg
-- a register of some class
= Reg RegClass Int
-- a sub-component of one of the other regs
| RegSub RegSub Reg
deriving (Show, Eq)
-- a register of some class
= Reg RegClass Int
-- a sub-component of one of the other regs
| RegSub RegSub Reg
deriving (Show, Eq)
-- | so we can put regs in UniqSets
instance Uniquable Reg where
getUnique (Reg c i)
= mkRegSingleUnique
$ fromEnum c * 1000 + i
getUnique (Reg c i)
= mkRegSingleUnique
$ fromEnum c * 1000 + i
getUnique (RegSub s (Reg c i))
= mkRegSubUnique
$ fromEnum s * 10000 + fromEnum c * 1000 + i
getUnique (RegSub s (Reg c i))
= mkRegSubUnique
$ fromEnum s * 10000 + fromEnum c * 1000 + i
getUnique (RegSub _ (RegSub _ _))
= error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."
getUnique (RegSub _ (RegSub _ _))
= error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."
-- | A subcomponent of another register
data RegSub
= SubL16 -- lowest 16 bits
| SubL8 -- lowest 8 bits
| SubL8H -- second lowest 8 bits
deriving (Show, Enum, Ord, Eq)
= SubL16 -- lowest 16 bits
| SubL8 -- lowest 8 bits
| SubL8H -- second lowest 8 bits
deriving (Show, Enum, Ord, Eq)
-- | Worst case displacement
--
-- a node N of classN has some number of neighbors,
-- all of which are from classC.
-- a node N of classN has some number of neighbors,
-- all of which are from classC.
--
-- (worst neighbors classN classC) is the maximum number of potential
-- colors for N that can be lost by coloring its neighbors.
-- (worst neighbors classN classC) is the maximum number of potential
-- colors for N that can be lost by coloring its neighbors.
-- This should be hand coded/cached for each particular architecture,
-- because the compute time is very long..
-- because the compute time is very long..
worst
:: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg)
-> Int -> RegClass -> RegClass -> Int
:: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg)
-> Int -> RegClass -> RegClass -> Int
worst regsOfClass regAlias neighbors classN classC
= let regAliasS regs = unionManyUniqSets
$ map regAlias
$ uniqSetToList regs
= let regAliasS regs = unionManyUniqSets
$ map regAlias
$ uniqSetToList regs
-- all the regs in classes N, C
regsN = regsOfClass classN
regsC = regsOfClass classC
-- all the possible subsets of c which have size < m
regsS = filter (\s -> sizeUniqSet s >= 1 && sizeUniqSet s <= neighbors)
$ powersetLS regsC
-- all the regs in classes N, C
regsN = regsOfClass classN
regsC = regsOfClass classC
-- all the possible subsets of c which have size < m
regsS = filter (\s -> sizeUniqSet s >= 1 && sizeUniqSet s <= neighbors)
$ powersetLS regsC
-- for each of the subsets of C, the regs which conflict with posiblities for N
regsS_conflict
= map (\s -> intersectUniqSets regsN (regAliasS s)) regsS
-- for each of the subsets of C, the regs which conflict with posiblities for N
regsS_conflict
= map (\s -> intersectUniqSets regsN (regAliasS s)) regsS
in maximum $ map sizeUniqSet $ regsS_conflict
in maximum $ map sizeUniqSet $ regsS_conflict
-- | For a node N of classN and neighbors of classesC
-- (bound classN classesC) is the maximum number of potential
-- colors for N that can be lost by coloring its neighbors.
-- (bound classN classesC) is the maximum number of potential
-- colors for N that can be lost by coloring its neighbors.
bound
:: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg)
-> RegClass -> [RegClass] -> Int
:: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg)
-> RegClass -> [RegClass] -> Int
bound regsOfClass regAlias classN classesC
= let regAliasS regs = unionManyUniqSets
$ map regAlias
$ uniqSetToList regs
= let regAliasS regs = unionManyUniqSets
$ map regAlias
$ uniqSetToList regs
regsC_aliases
= unionManyUniqSets
$ map (regAliasS . regsOfClass) classesC
regsC_aliases
= unionManyUniqSets
$ map (regAliasS . regsOfClass) classesC
overlap = intersectUniqSets (regsOfClass classN) regsC_aliases
overlap = intersectUniqSets (regsOfClass classN) regsC_aliases
in sizeUniqSet overlap
in sizeUniqSet overlap
-- | The total squeese on a particular node with a list of neighbors.
--
-- A version of this should be constructed for each particular architecture,
-- possibly including uses of bound, so that alised registers don't get counted
-- twice, as per the paper.
-- A version of this should be constructed for each particular architecture,
-- possibly including uses of bound, so that alised registers don't get counted
-- twice, as per the paper.
squeese
:: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg)
-> RegClass -> [(Int, RegClass)] -> Int
:: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg)
-> RegClass -> [(Int, RegClass)] -> Int
squeese regsOfClass regAlias classN countCs
= sum (map (\(i, classC) -> worst regsOfClass regAlias i classN classC) countCs)
= sum (map (\(i, classC) -> worst regsOfClass regAlias i classN classC) countCs)
-- | powerset (for lists)
powersetL :: [a] -> [[a]]
powersetL = map concat . mapM (\x -> [[],[x]])
powersetL = map concat . mapM (\x -> [[],[x]])
-- | powersetLS (list of sets)
powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
powersetLS s = map mkUniqSet $ powersetL $ uniqSetToList s
powersetLS s = map mkUniqSet $ powersetL $ uniqSetToList s
{-
-- | unions (for sets)
unionsS :: Ord a => Set (Set a) -> Set a
unionsS ss = Set.unions $ Set.toList ss
unionsS ss = Set.unions $ Set.toList ss
-}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
-- | A description of the register set of the X86.
-- This isn't used directly in GHC proper.
-- This isn't used directly in GHC proper.
--
-- See RegArchBase.hs for the reference.
-- See MachRegs.hs for the actual trivColorable function used in GHC.
-- See RegArchBase.hs for the reference.
-- See MachRegs.hs for the actual trivColorable function used in GHC.
--
module RegAlloc.Graph.ArchX86 (
classOfReg,
regsOfClass,
regName,
regAlias,
worst,
squeese,
classOfReg,
regsOfClass,
regName,
regAlias,
worst,
squeese,
) where
import RegAlloc.Graph.ArchBase (Reg(..), RegSub(..), RegClass(..))
import RegAlloc.Graph.ArchBase (Reg(..), RegSub(..), RegClass(..))
import UniqSet
......@@ -30,85 +22,85 @@ import UniqSet
classOfReg :: Reg -> RegClass
classOfReg reg
= case reg of
Reg c _ -> c
RegSub SubL16 _ -> ClassG16
RegSub SubL8 _ -> ClassG8
RegSub SubL8H _ -> ClassG8
Reg c _ -> c
RegSub SubL16 _ -> ClassG16
RegSub SubL8 _ -> ClassG8
RegSub SubL8H _ -> ClassG8
-- | Determine all the regs that make up a certain class.
regsOfClass :: RegClass -> UniqSet Reg
regsOfClass c
= case c of
ClassG32
-> mkUniqSet [ Reg ClassG32 i | i <- [0..7] ]
ClassG32
-> mkUniqSet [ Reg ClassG32 i | i <- [0..7] ]
ClassG16
-> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) | i <- [0..7] ]
ClassG16
-> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) | i <- [0..7] ]
ClassG8
-> unionUniqSets
(mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ])
(mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])
ClassF64
-> mkUniqSet [ Reg ClassF64 i | i <- [0..5] ]
ClassG8
-> unionUniqSets
(mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ])
(mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])
ClassF64
-> mkUniqSet [ Reg ClassF64 i | i <- [0..5] ]
-- | Determine the common name of a reg
-- returns Nothing if this reg is not part of the machine.
-- returns Nothing if this reg is not part of the machine.
regName :: Reg -> Maybe String
regName reg
= case reg of
Reg ClassG32 i
| i <= 7 -> Just ([ "eax", "ebx", "ecx", "edx", "ebp", "esi", "edi", "esp" ] !! i)
Reg ClassG32 i
| i <= 7 -> Just ([ "eax", "ebx", "ecx", "edx", "ebp", "esi", "edi", "esp" ] !! i)
RegSub SubL16 (Reg ClassG32 i)
| i <= 7 -> Just ([ "ax", "bx", "cx", "dx", "bp", "si", "di", "sp"] !! i)
RegSub SubL8 (Reg ClassG32 i)
| i <= 3 -> Just ([ "al", "bl", "cl", "dl"] !! i)
RegSub SubL8H (Reg ClassG32 i)
| i <= 3 -> Just ([ "ah", "bh", "ch", "dh"] !! i)
RegSub SubL16 (Reg ClassG32 i)
| i <= 7 -> Just ([ "ax", "bx", "cx", "dx", "bp", "si", "di", "sp"] !! i)
RegSub SubL8 (Reg ClassG32 i)
| i <= 3 -> Just ([ "al", "bl", "cl", "dl"] !! i)
RegSub SubL8H (Reg ClassG32 i)
| i <= 3 -> Just ([ "ah", "bh", "ch", "dh"] !! i)
_ -> Nothing
_ -> Nothing
-- | Which regs alias what other regs
regAlias :: Reg -> UniqSet Reg
regAlias reg
= case reg of
-- 32 bit regs alias all of the subregs
Reg ClassG32 i
-- for eax, ebx, ecx, eds
| i <= 3
-> mkUniqSet $ [ Reg ClassG32 i, RegSub SubL16 reg, RegSub SubL8 reg, RegSub SubL8H reg ]
-- for esi, edi, esp, ebp
| 4 <= i && i <= 7
-> mkUniqSet $ [ Reg ClassG32 i, RegSub SubL16 reg ]
-- 16 bit subregs alias the whole reg
RegSub SubL16 r@(Reg ClassG32 _)
-> regAlias r
-- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg
RegSub SubL8 r@(Reg ClassG32 _)
-> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]
RegSub SubL8H r@(Reg ClassG32 _)
-> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
-- fp
Reg ClassF64 _
-> unitUniqSet reg
_ -> error "regAlias: invalid register"
-- 32 bit regs alias all of the subregs
Reg ClassG32 i
-- for eax, ebx, ecx, eds
| i <= 3
-> mkUniqSet $ [ Reg ClassG32 i, RegSub SubL16 reg, RegSub SubL8 reg, RegSub SubL8H reg ]
-- for esi, edi, esp, ebp
| 4 <= i && i <= 7
-> mkUniqSet $ [ Reg ClassG32 i, RegSub SubL16 reg ]
-- 16 bit subregs alias the whole reg
RegSub SubL16 r@(Reg ClassG32 _)
-> regAlias r
-- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg
RegSub SubL8 r@(Reg ClassG32 _)
-> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]
RegSub SubL8H r@(Reg ClassG32 _)
-> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
-- fp
Reg ClassF64 _
-> unitUniqSet reg
_ -> error "regAlias: invalid register"
-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86
......@@ -116,36 +108,36 @@ regAlias reg
worst :: Int -> RegClass -> RegClass -> Int
worst n classN classC
= case classN of
ClassG32
-> case classC of
ClassG32 -> min n 8
ClassG16 -> min n 8
ClassG8 -> min n 4
ClassF64 -> 0
ClassG16
-> case classC of
ClassG32 -> min n 8
ClassG16 -> min n 8
ClassG8 -> min n 4
ClassF64 -> 0
ClassG8
-> case classC of
ClassG32 -> min (n*2) 8
ClassG16 -> min (n*2) 8
ClassG8 -> min n 8
ClassF64 -> 0
ClassF64
-> case classC of
ClassF64 -> min n 6
_ -> 0
ClassG32
-> case classC of
ClassG32 -> min n 8
ClassG16 -> min n 8
ClassG8 -> min n 4
ClassF64 -> 0
ClassG16
-> case classC of
ClassG32 -> min n 8
ClassG16 -> min n 8
ClassG8 -> min n 4
ClassF64 -> 0
ClassG8
-> case classC of
ClassG32 -> min (n*2) 8
ClassG16 -> min (n*2) 8
ClassG8 -> min n 8
ClassF64 -> 0
ClassF64
-> case classC of
ClassF64 -> min n 6
_ -> 0
squeese :: RegClass -> [(Int, RegClass)] -> Int
squeese classN countCs
= sum (map (\(i, classC) -> worst i classN classC) countCs)
= sum (map (\(i, classC) -> worst i classN classC) countCs)
......
-- | Register coalescing.
--
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module RegAlloc.Graph.Coalesce (
regCoalesce,
slurpJoinMovs
regCoalesce,
slurpJoinMovs
)
where
......@@ -29,67 +21,67 @@ import UniqSupply
import Data.List
-- | Do register coalescing on this top level thing
-- For Reg -> Reg moves, if the first reg dies at the same time the second reg is born
-- then the mov only serves to join live ranges. The two regs can be renamed to be
-- the same and the move instruction safely erased.
-- For Reg -> Reg moves, if the first reg dies at the same time the second reg is born
-- then the mov only serves to join live ranges. The two regs can be renamed to be
-- the same and the move instruction safely erased.
regCoalesce
:: Instruction instr
=> [LiveCmmDecl statics instr]
-> UniqSM [LiveCmmDecl statics instr]
:: Instruction instr
=> [LiveCmmDecl statics instr]
-> UniqSM [LiveCmmDecl statics instr]
regCoalesce code
= do
let joins = foldl' unionBags emptyBag
$ map slurpJoinMovs code
= do
let joins = foldl' unionBags emptyBag
$ map slurpJoinMovs code
let alloc = foldl' buildAlloc emptyUFM
$ bagToList joins
let alloc = foldl' buildAlloc emptyUFM
$ bagToList joins
let patched = map (patchEraseLive (sinkReg alloc)) code
return patched
let patched = map (patchEraseLive (sinkReg alloc)) code
return patched
buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
buildAlloc fm (r1, r2)
= let rmin = min r1 r2
rmax = max r1 r2
in addToUFM fm rmax rmin
= let rmin = min r1 r2
rmax = max r1 r2
in addToUFM fm rmax rmin
sinkReg :: UniqFM Reg -> Reg -> Reg
sinkReg fm r
= case lookupUFM fm r of
Nothing -> r
Just r' -> sinkReg fm r'
Nothing -> r
Just r' -> sinkReg fm r'
-- | Slurp out mov instructions that only serve to join live ranges.
-- During a mov, if the source reg dies and the destiation reg is born
-- then we can rename the two regs to the same thing and eliminate the move.
-- During a mov, if the source reg dies and the destiation reg is born
-- then we can rename the two regs to the same thing and eliminate the move.
slurpJoinMovs
:: Instruction instr
=> LiveCmmDecl statics instr
-> Bag (Reg, Reg)
:: Instruction instr
=> LiveCmmDecl statics instr
-> Bag (Reg, Reg)
slurpJoinMovs live
= slurpCmm emptyBag live
where
slurpCmm rs CmmData{} = rs
slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs)
slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs
= slurpCmm emptyBag live
where
slurpCmm rs CmmData{} = rs
slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flatte