Base.hs

-- | 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)

import Data.List.NonEmpty (NonEmpty (..))

-- 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 (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)


-- | so we can put regs in UniqSets
instance Uniquable Reg where
        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 _ (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)


-- | 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 regsOfClass regAlias neighbors classN classC
 = let  regAliasS regs  = unionManyUniqSets
                        $ map regAlias
                        $ nonDetEltsUniqSet 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           = regsOfClass classN
        regsC           = regsOfClass classC

        -- all the possible subsets of c which have size < m
        regsS           = filter (\s -> not (isEmptyUniqSet s)
                                     && sizeUniqSet s <= neighbors)
                        $ powersetLS regsC

        -- for each of the subsets of C, the regs which conflict
        -- with possibilities for N
        regsS_conflict
                = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS

  in    maximum $ 0 :| 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   :: (RegClass    -> UniqSet Reg)
        -> (Reg         -> UniqSet Reg)
        -> RegClass -> [RegClass] -> Int

bound regsOfClass regAlias classN classesC
 = let  regAliasS regs  = unionManyUniqSets
                        $ map regAlias
                        $ nonDetEltsUFM regs
                        -- See Note [Unique Determinism and code generation]

        regsC_aliases
                = unionManyUniqSets
                $ map (regAliasS . getUniqSet . regsOfClass) classesC

        overlap = intersectUniqSets (regsOfClass classN) regsC_aliases

   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 aliased registers don't get
--   counted twice, as per the paper.
squeese :: (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


-- | powerset (for lists)
powersetL :: [a] -> [[a]]
powersetL       = concatMapM (\x -> [[],[x]])


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