-- | 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.Builtin.Uniques
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
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
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]
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
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
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
         forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum RegClass
c forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
+ Int
i

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

        getUnique (RegSub RegSub
_ (RegSub RegSub
_ Reg
_))
          = 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
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]
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
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
Ord, RegSub -> RegSub -> Bool
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  = forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
                        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Reg -> UniqSet Reg
regAlias
                        forall a b. (a -> b) -> a -> b
$ 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           = forall a. (a -> Bool) -> [a] -> [a]
filter (\UniqSet Reg
s -> forall a. UniqSet a -> Int
sizeUniqSet UniqSet Reg
s forall a. Ord a => a -> a -> Bool
>= Int
1
                                     Bool -> Bool -> Bool
&& forall a. UniqSet a -> Int
sizeUniqSet UniqSet Reg
s forall a. Ord a => a -> a -> Bool
<= Int
neighbors)
                        forall a b. (a -> b) -> a -> b
$ 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
                = forall a b. (a -> b) -> [a] -> [b]
map (\UniqSet Reg
s -> forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets UniqSet Reg
regsN (UniqSet Reg -> UniqSet Reg
regAliasS UniqSet Reg
s)) [UniqSet Reg]
regsS

  in    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. UniqSet a -> Int
sizeUniqSet 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 Reg Reg -> UniqSet Reg
regAliasS UniqFM Reg Reg
regs  = forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
                        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Reg -> UniqSet Reg
regAlias
                        forall a b. (a -> b) -> a -> b
$ forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM Reg Reg
regs
                        -- See Note [Unique Determinism and code generation]

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

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

   in   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 aliased 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
        = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
        forall a b. (a -> b) -> a -> b
$ 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)
        forall a b. (a -> b) -> a -> b
$ [(Int, RegClass)]
countCs


-- | powerset (for lists)
powersetL :: [a] -> [[a]]
powersetL :: forall a. [a] -> [[a]]
powersetL       = 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 :: forall a. Uniquable a => UniqSet a -> [UniqSet a]
powersetLS UniqSet a
s    = forall a b. (a -> b) -> [a] -> [b]
map forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
powersetL forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet a
s
  -- See Note [Unique Determinism and code generation]