-- | 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
--
--   This code is here because we can test the architecture specific code against
--   it.
--
module GHC.CmmToAsm.Reg.Graph.Base (
        RegClass(..),
        Reg(..),
        RegSub(..),

        worst,
        bound,
        squeese
) where

import GHC.Prelude

import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import GHC.Types.Unique
import GHC.Utils.Monad (concatMapM)


-- Some basic register classes.
--      These aren't necessarily in 1-to-1 correspondence 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 (Int -> RegClass -> ShowS
[RegClass] -> ShowS
RegClass -> String
(Int -> RegClass -> ShowS)
-> (RegClass -> String) -> ([RegClass] -> ShowS) -> Show RegClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegClass] -> ShowS
$cshowList :: [RegClass] -> ShowS
show :: RegClass -> String
$cshow :: RegClass -> String
showsPrec :: Int -> RegClass -> ShowS
$cshowsPrec :: Int -> RegClass -> ShowS
Show, RegClass -> RegClass -> Bool
(RegClass -> RegClass -> Bool)
-> (RegClass -> RegClass -> Bool) -> Eq RegClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegClass -> RegClass -> Bool
$c/= :: RegClass -> RegClass -> Bool
== :: RegClass -> RegClass -> Bool
$c== :: RegClass -> RegClass -> Bool
Eq, Int -> RegClass
RegClass -> Int
RegClass -> [RegClass]
RegClass -> RegClass
RegClass -> RegClass -> [RegClass]
RegClass -> RegClass -> RegClass -> [RegClass]
(RegClass -> RegClass)
-> (RegClass -> RegClass)
-> (Int -> RegClass)
-> (RegClass -> Int)
-> (RegClass -> [RegClass])
-> (RegClass -> RegClass -> [RegClass])
-> (RegClass -> RegClass -> [RegClass])
-> (RegClass -> RegClass -> RegClass -> [RegClass])
-> Enum RegClass
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: RegClass -> RegClass -> RegClass -> [RegClass]
$cenumFromThenTo :: RegClass -> RegClass -> RegClass -> [RegClass]
enumFromTo :: RegClass -> RegClass -> [RegClass]
$cenumFromTo :: RegClass -> RegClass -> [RegClass]
enumFromThen :: RegClass -> RegClass -> [RegClass]
$cenumFromThen :: RegClass -> RegClass -> [RegClass]
enumFrom :: RegClass -> [RegClass]
$cenumFrom :: RegClass -> [RegClass]
fromEnum :: RegClass -> Int
$cfromEnum :: RegClass -> Int
toEnum :: Int -> RegClass
$ctoEnum :: Int -> RegClass
pred :: RegClass -> RegClass
$cpred :: RegClass -> RegClass
succ :: RegClass -> RegClass
$csucc :: RegClass -> RegClass
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 (Int -> Reg -> ShowS
[Reg] -> ShowS
Reg -> String
(Int -> Reg -> ShowS)
-> (Reg -> String) -> ([Reg] -> ShowS) -> Show Reg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reg] -> ShowS
$cshowList :: [Reg] -> ShowS
show :: Reg -> String
$cshow :: Reg -> String
showsPrec :: Int -> Reg -> ShowS
$cshowsPrec :: Int -> Reg -> ShowS
Show, Reg -> Reg -> Bool
(Reg -> Reg -> Bool) -> (Reg -> Reg -> Bool) -> Eq Reg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reg -> Reg -> Bool
$c/= :: Reg -> Reg -> Bool
== :: Reg -> Reg -> Bool
$c== :: Reg -> Reg -> Bool
Eq)


-- | so we can put regs in UniqSets
instance Uniquable Reg where
        getUnique :: Reg -> Unique
getUnique (Reg RegClass
c Int
i)
         = Int -> Unique
mkRegSingleUnique
         (Int -> Unique) -> Int -> Unique
forall a b. (a -> b) -> a -> b
$ RegClass -> Int
forall a. Enum a => a -> Int
fromEnum RegClass
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i

        getUnique (RegSub RegSub
s (Reg RegClass
c Int
i))
         = Int -> Unique
mkRegSubUnique
         (Int -> Unique) -> Int -> Unique
forall a b. (a -> b) -> a -> b
$ RegSub -> Int
forall a. Enum a => a -> Int
fromEnum RegSub
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RegClass -> Int
forall a. Enum a => a -> Int
fromEnum RegClass
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i

        getUnique (RegSub RegSub
_ (RegSub RegSub
_ Reg
_))
          = String -> Unique
forall a. HasCallStack => String -> a
error String
"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 (Int -> RegSub -> ShowS
[RegSub] -> ShowS
RegSub -> String
(Int -> RegSub -> ShowS)
-> (RegSub -> String) -> ([RegSub] -> ShowS) -> Show RegSub
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegSub] -> ShowS
$cshowList :: [RegSub] -> ShowS
show :: RegSub -> String
$cshow :: RegSub -> String
showsPrec :: Int -> RegSub -> ShowS
$cshowsPrec :: Int -> RegSub -> ShowS
Show, Int -> RegSub
RegSub -> Int
RegSub -> [RegSub]
RegSub -> RegSub
RegSub -> RegSub -> [RegSub]
RegSub -> RegSub -> RegSub -> [RegSub]
(RegSub -> RegSub)
-> (RegSub -> RegSub)
-> (Int -> RegSub)
-> (RegSub -> Int)
-> (RegSub -> [RegSub])
-> (RegSub -> RegSub -> [RegSub])
-> (RegSub -> RegSub -> [RegSub])
-> (RegSub -> RegSub -> RegSub -> [RegSub])
-> Enum RegSub
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: RegSub -> RegSub -> RegSub -> [RegSub]
$cenumFromThenTo :: RegSub -> RegSub -> RegSub -> [RegSub]
enumFromTo :: RegSub -> RegSub -> [RegSub]
$cenumFromTo :: RegSub -> RegSub -> [RegSub]
enumFromThen :: RegSub -> RegSub -> [RegSub]
$cenumFromThen :: RegSub -> RegSub -> [RegSub]
enumFrom :: RegSub -> [RegSub]
$cenumFrom :: RegSub -> [RegSub]
fromEnum :: RegSub -> Int
$cfromEnum :: RegSub -> Int
toEnum :: Int -> RegSub
$ctoEnum :: Int -> RegSub
pred :: RegSub -> RegSub
$cpred :: RegSub -> RegSub
succ :: RegSub -> RegSub
$csucc :: RegSub -> RegSub
Enum, Eq RegSub
Eq RegSub
-> (RegSub -> RegSub -> Ordering)
-> (RegSub -> RegSub -> Bool)
-> (RegSub -> RegSub -> Bool)
-> (RegSub -> RegSub -> Bool)
-> (RegSub -> RegSub -> Bool)
-> (RegSub -> RegSub -> RegSub)
-> (RegSub -> RegSub -> RegSub)
-> Ord RegSub
RegSub -> RegSub -> Bool
RegSub -> RegSub -> Ordering
RegSub -> RegSub -> RegSub
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RegSub -> RegSub -> RegSub
$cmin :: RegSub -> RegSub -> RegSub
max :: RegSub -> RegSub -> RegSub
$cmax :: RegSub -> RegSub -> RegSub
>= :: RegSub -> RegSub -> Bool
$c>= :: RegSub -> RegSub -> Bool
> :: RegSub -> RegSub -> Bool
$c> :: RegSub -> RegSub -> Bool
<= :: RegSub -> RegSub -> Bool
$c<= :: RegSub -> RegSub -> Bool
< :: RegSub -> RegSub -> Bool
$c< :: RegSub -> RegSub -> Bool
compare :: RegSub -> RegSub -> Ordering
$ccompare :: RegSub -> RegSub -> Ordering
$cp1Ord :: Eq RegSub
Ord, RegSub -> RegSub -> Bool
(RegSub -> RegSub -> Bool)
-> (RegSub -> RegSub -> Bool) -> Eq RegSub
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegSub -> RegSub -> Bool
$c/= :: RegSub -> RegSub -> Bool
== :: RegSub -> RegSub -> Bool
$c== :: RegSub -> RegSub -> Bool
Eq)


-- | Worst case displacement
--
--      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.
--
-- This should be hand coded/cached for each particular architecture,
--      because the compute time is very long..
worst   :: (RegClass    -> UniqSet Reg)
        -> (Reg         -> UniqSet Reg)
        -> Int -> RegClass -> RegClass -> Int

worst :: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg) -> Int -> RegClass -> RegClass -> Int
worst RegClass -> UniqSet Reg
regsOfClass Reg -> UniqSet Reg
regAlias Int
neighbors RegClass
classN RegClass
classC
 = let  regAliasS :: UniqSet Reg -> UniqSet Reg
regAliasS UniqSet Reg
regs  = [UniqSet Reg] -> UniqSet Reg
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
                        ([UniqSet Reg] -> UniqSet Reg) -> [UniqSet Reg] -> UniqSet Reg
forall a b. (a -> b) -> a -> b
$ (Reg -> UniqSet Reg) -> [Reg] -> [UniqSet Reg]
forall a b. (a -> b) -> [a] -> [b]
map Reg -> UniqSet Reg
regAlias
                        ([Reg] -> [UniqSet Reg]) -> [Reg] -> [UniqSet Reg]
forall a b. (a -> b) -> a -> b
$ UniqSet Reg -> [Reg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Reg
regs
                        -- This is non-deterministic but we do not
                        -- currently support deterministic code-generation.
                        -- See Note [Unique Determinism and code generation]

        -- all the regs in classes N, C
        regsN :: UniqSet Reg
regsN           = RegClass -> UniqSet Reg
regsOfClass RegClass
classN
        regsC :: UniqSet Reg
regsC           = RegClass -> UniqSet Reg
regsOfClass RegClass
classC

        -- all the possible subsets of c which have size < m
        regsS :: [UniqSet Reg]
regsS           = (UniqSet Reg -> Bool) -> [UniqSet Reg] -> [UniqSet Reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\UniqSet Reg
s -> UniqSet Reg -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet Reg
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
                                     Bool -> Bool -> Bool
&& UniqSet Reg -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet Reg
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
neighbors)
                        ([UniqSet Reg] -> [UniqSet Reg]) -> [UniqSet Reg] -> [UniqSet Reg]
forall a b. (a -> b) -> a -> b
$ UniqSet Reg -> [UniqSet Reg]
forall a. Uniquable a => UniqSet a -> [UniqSet a]
powersetLS UniqSet Reg
regsC

        -- for each of the subsets of C, the regs which conflict
        -- with posiblities for N
        regsS_conflict :: [UniqSet Reg]
regsS_conflict
                = (UniqSet Reg -> UniqSet Reg) -> [UniqSet Reg] -> [UniqSet Reg]
forall a b. (a -> b) -> [a] -> [b]
map (\UniqSet Reg
s -> UniqSet Reg -> UniqSet Reg -> UniqSet Reg
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets UniqSet Reg
regsN (UniqSet Reg -> UniqSet Reg
regAliasS UniqSet Reg
s)) [UniqSet Reg]
regsS

  in    [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (UniqSet Reg -> Int) -> [UniqSet Reg] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map UniqSet Reg -> Int
forall a. UniqSet a -> Int
sizeUniqSet ([UniqSet Reg] -> [Int]) -> [UniqSet Reg] -> [Int]
forall a b. (a -> b) -> a -> b
$ [UniqSet Reg]
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   :: (RegClass    -> UniqSet Reg)
        -> (Reg         -> UniqSet Reg)
        -> RegClass -> [RegClass] -> Int

bound :: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg) -> RegClass -> [RegClass] -> Int
bound RegClass -> UniqSet Reg
regsOfClass Reg -> UniqSet Reg
regAlias RegClass
classN [RegClass]
classesC
 = let  regAliasS :: UniqFM key Reg -> UniqSet Reg
regAliasS UniqFM key Reg
regs  = [UniqSet Reg] -> UniqSet Reg
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
                        ([UniqSet Reg] -> UniqSet Reg) -> [UniqSet Reg] -> UniqSet Reg
forall a b. (a -> b) -> a -> b
$ (Reg -> UniqSet Reg) -> [Reg] -> [UniqSet Reg]
forall a b. (a -> b) -> [a] -> [b]
map Reg -> UniqSet Reg
regAlias
                        ([Reg] -> [UniqSet Reg]) -> [Reg] -> [UniqSet Reg]
forall a b. (a -> b) -> a -> b
$ UniqFM key Reg -> [Reg]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM key Reg
regs
                        -- See Note [Unique Determinism and code generation]

        regsC_aliases :: UniqSet Reg
regsC_aliases
                = [UniqSet Reg] -> UniqSet Reg
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
                ([UniqSet Reg] -> UniqSet Reg) -> [UniqSet Reg] -> UniqSet Reg
forall a b. (a -> b) -> a -> b
$ (RegClass -> UniqSet Reg) -> [RegClass] -> [UniqSet Reg]
forall a b. (a -> b) -> [a] -> [b]
map (UniqFM Reg Reg -> UniqSet Reg
forall key. UniqFM key Reg -> UniqSet Reg
regAliasS (UniqFM Reg Reg -> UniqSet Reg)
-> (RegClass -> UniqFM Reg Reg) -> RegClass -> UniqSet Reg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqSet Reg -> UniqFM Reg Reg
forall a. UniqSet a -> UniqFM a a
getUniqSet (UniqSet Reg -> UniqFM Reg Reg)
-> (RegClass -> UniqSet Reg) -> RegClass -> UniqFM Reg Reg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegClass -> UniqSet Reg
regsOfClass) [RegClass]
classesC

        overlap :: UniqSet Reg
overlap = UniqSet Reg -> UniqSet Reg -> UniqSet Reg
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets (RegClass -> UniqSet Reg
regsOfClass RegClass
classN) UniqSet Reg
regsC_aliases

   in   UniqSet Reg -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet Reg
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.
squeese :: (RegClass    -> UniqSet Reg)
        -> (Reg         -> UniqSet Reg)
        -> RegClass -> [(Int, RegClass)] -> Int

squeese :: (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg) -> RegClass -> [(Int, RegClass)] -> Int
squeese RegClass -> UniqSet Reg
regsOfClass Reg -> UniqSet Reg
regAlias RegClass
classN [(Int, RegClass)]
countCs
        = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
        ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, RegClass) -> Int) -> [(Int, RegClass)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, RegClass
classC) -> (RegClass -> UniqSet Reg)
-> (Reg -> UniqSet Reg) -> Int -> RegClass -> RegClass -> Int
worst RegClass -> UniqSet Reg
regsOfClass Reg -> UniqSet Reg
regAlias Int
i RegClass
classN RegClass
classC)
        ([(Int, RegClass)] -> [Int]) -> [(Int, RegClass)] -> [Int]
forall a b. (a -> b) -> a -> b
$ [(Int, RegClass)]
countCs


-- | powerset (for lists)
powersetL :: [a] -> [[a]]
powersetL :: [a] -> [[a]]
powersetL       = (a -> [[a]]) -> [a] -> [[a]]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (\a
x -> [[],[a
x]])


-- | powersetLS (list of sets)
powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
powersetLS :: UniqSet a -> [UniqSet a]
powersetLS UniqSet a
s    = ([a] -> UniqSet a) -> [[a]] -> [UniqSet a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> UniqSet a
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([[a]] -> [UniqSet a]) -> [[a]] -> [UniqSet a]
forall a b. (a -> b) -> a -> b
$ [a] -> [[a]]
forall a. [a] -> [[a]]
powersetL ([a] -> [[a]]) -> [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ UniqSet a -> [a]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet a
s
  -- See Note [Unique Determinism and code generation]