-- | An architecture independent description of a register.
--      This needs to stay architecture independent because it is used
--      by NCGMonad and the register allocators, which are shared
--      by all architectures.
--
module GHC.Platform.Reg (
        RegNo,
        Reg(..),
        regPair,
        regSingle,
        isRealReg,      takeRealReg,
        isVirtualReg,   takeVirtualReg,

        VirtualReg(..),
        renameVirtualReg,
        classOfVirtualReg,
        getHiVirtualRegFromLo,
        getHiVRegFromLo,

        RealReg(..),
        regNosOfRealReg,
        realRegsAlias,

        liftPatchFnToRegReg
)

where

import GHC.Prelude

import GHC.Utils.Outputable
import GHC.Types.Unique
import GHC.Platform.Reg.Class
import Data.List (intersect)

-- | An identifier for a primitive real machine register.
type RegNo
        = Int

-- VirtualRegs are virtual registers.  The register allocator will
--      eventually have to map them into RealRegs, or into spill slots.
--
--      VirtualRegs are allocated on the fly, usually to represent a single
--      value in the abstract assembly code (i.e. dynamic registers are
--      usually single assignment).
--
--      The  single assignment restriction isn't necessary to get correct code,
--      although a better register allocation will result if single
--      assignment is used -- because the allocator maps a VirtualReg into
--      a single RealReg, even if the VirtualReg has multiple live ranges.
--
--      Virtual regs can be of either class, so that info is attached.
--
data VirtualReg
        = VirtualRegI  {-# UNPACK #-} !Unique
        | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register
        | VirtualRegF  {-# UNPACK #-} !Unique
        | VirtualRegD  {-# UNPACK #-} !Unique

        deriving (VirtualReg -> VirtualReg -> Bool
(VirtualReg -> VirtualReg -> Bool)
-> (VirtualReg -> VirtualReg -> Bool) -> Eq VirtualReg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VirtualReg -> VirtualReg -> Bool
$c/= :: VirtualReg -> VirtualReg -> Bool
== :: VirtualReg -> VirtualReg -> Bool
$c== :: VirtualReg -> VirtualReg -> Bool
External instance of the constraint type Eq Unique
External instance of the constraint type Eq Unique
Eq, RegNo -> VirtualReg -> ShowS
[VirtualReg] -> ShowS
VirtualReg -> String
(RegNo -> VirtualReg -> ShowS)
-> (VirtualReg -> String)
-> ([VirtualReg] -> ShowS)
-> Show VirtualReg
forall a.
(RegNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VirtualReg] -> ShowS
$cshowList :: [VirtualReg] -> ShowS
show :: VirtualReg -> String
$cshow :: VirtualReg -> String
showsPrec :: RegNo -> VirtualReg -> ShowS
$cshowsPrec :: RegNo -> VirtualReg -> ShowS
External instance of the constraint type Show Unique
External instance of the constraint type Show Unique
External instance of the constraint type Ord RegNo
External instance of the constraint type Ord RegNo
Show)

-- This is laborious, but necessary. We can't derive Ord because
-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
-- implementation. See Note [No Ord for Unique]
-- This is non-deterministic but we do not currently support deterministic
-- code-generation. See Note [Unique Determinism and code generation]
instance Ord VirtualReg where
  compare :: VirtualReg -> VirtualReg -> Ordering
compare (VirtualRegI Unique
a) (VirtualRegI Unique
b) = Unique -> Unique -> Ordering
nonDetCmpUnique Unique
a Unique
b
  compare (VirtualRegHi Unique
a) (VirtualRegHi Unique
b) = Unique -> Unique -> Ordering
nonDetCmpUnique Unique
a Unique
b
  compare (VirtualRegF Unique
a) (VirtualRegF Unique
b) = Unique -> Unique -> Ordering
nonDetCmpUnique Unique
a Unique
b
  compare (VirtualRegD Unique
a) (VirtualRegD Unique
b) = Unique -> Unique -> Ordering
nonDetCmpUnique Unique
a Unique
b

  compare VirtualRegI{} VirtualReg
_ = Ordering
LT
  compare VirtualReg
_ VirtualRegI{} = Ordering
GT
  compare VirtualRegHi{} VirtualReg
_ = Ordering
LT
  compare VirtualReg
_ VirtualRegHi{} = Ordering
GT
  compare VirtualRegF{} VirtualReg
_ = Ordering
LT
  compare VirtualReg
_ VirtualRegF{} = Ordering
GT



instance Uniquable VirtualReg where
        getUnique :: VirtualReg -> Unique
getUnique VirtualReg
reg
         = case VirtualReg
reg of
                VirtualRegI Unique
u   -> Unique
u
                VirtualRegHi Unique
u  -> Unique
u
                VirtualRegF Unique
u   -> Unique
u
                VirtualRegD Unique
u   -> Unique
u

instance Outputable VirtualReg where
        ppr :: VirtualReg -> SDoc
ppr VirtualReg
reg
         = case VirtualReg
reg of
                VirtualRegI  Unique
u  -> String -> SDoc
text String
"%vI_"   SDoc -> SDoc -> SDoc
<> Unique -> SDoc
pprUniqueAlways Unique
u
                VirtualRegHi Unique
u  -> String -> SDoc
text String
"%vHi_"  SDoc -> SDoc -> SDoc
<> Unique -> SDoc
pprUniqueAlways Unique
u
                -- this code is kinda wrong on x86
                -- because float and double occupy the same register set
                -- namely SSE2 register xmm0 .. xmm15
                VirtualRegF  Unique
u  -> String -> SDoc
text String
"%vFloat_"   SDoc -> SDoc -> SDoc
<> Unique -> SDoc
pprUniqueAlways Unique
u
                VirtualRegD  Unique
u  -> String -> SDoc
text String
"%vDouble_"   SDoc -> SDoc -> SDoc
<> Unique -> SDoc
pprUniqueAlways Unique
u



renameVirtualReg :: Unique -> VirtualReg -> VirtualReg
renameVirtualReg :: Unique -> VirtualReg -> VirtualReg
renameVirtualReg Unique
u VirtualReg
r
 = case VirtualReg
r of
        VirtualRegI Unique
_   -> Unique -> VirtualReg
VirtualRegI  Unique
u
        VirtualRegHi Unique
_  -> Unique -> VirtualReg
VirtualRegHi Unique
u
        VirtualRegF Unique
_   -> Unique -> VirtualReg
VirtualRegF  Unique
u
        VirtualRegD Unique
_   -> Unique -> VirtualReg
VirtualRegD  Unique
u


classOfVirtualReg :: VirtualReg -> RegClass
classOfVirtualReg :: VirtualReg -> RegClass
classOfVirtualReg VirtualReg
vr
 = case VirtualReg
vr of
        VirtualRegI{}   -> RegClass
RcInteger
        VirtualRegHi{}  -> RegClass
RcInteger
        VirtualRegF{}   -> RegClass
RcFloat
        VirtualRegD{}   -> RegClass
RcDouble



-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform
-- when supplied with the vreg for the lower-half of the quantity.
-- (NB. Not reversible).
getHiVirtualRegFromLo :: VirtualReg -> VirtualReg
getHiVirtualRegFromLo :: VirtualReg -> VirtualReg
getHiVirtualRegFromLo VirtualReg
reg
 = case VirtualReg
reg of
        -- makes a pseudo-unique with tag 'H'
        VirtualRegI Unique
u   -> Unique -> VirtualReg
VirtualRegHi (Unique -> Char -> Unique
newTagUnique Unique
u Char
'H')
        VirtualReg
_               -> String -> VirtualReg
forall a. String -> a
panic String
"Reg.getHiVirtualRegFromLo"

getHiVRegFromLo :: Reg -> Reg
getHiVRegFromLo :: Reg -> Reg
getHiVRegFromLo Reg
reg
 = case Reg
reg of
        RegVirtual  VirtualReg
vr  -> VirtualReg -> Reg
RegVirtual (VirtualReg -> VirtualReg
getHiVirtualRegFromLo VirtualReg
vr)
        RegReal RealReg
_       -> String -> Reg
forall a. String -> a
panic String
"Reg.getHiVRegFromLo"


------------------------------------------------------------------------------------
-- | RealRegs are machine regs which are available for allocation, in
--      the usual way.  We know what class they are, because that's part of
--      the processor's architecture.
--
--      RealRegPairs are pairs of real registers that are allocated together
--      to hold a larger value, such as with Double regs on SPARC.
--
data RealReg
        = RealRegSingle {-# UNPACK #-} !RegNo
        | RealRegPair   {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo
        deriving (RealReg -> RealReg -> Bool
(RealReg -> RealReg -> Bool)
-> (RealReg -> RealReg -> Bool) -> Eq RealReg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RealReg -> RealReg -> Bool
$c/= :: RealReg -> RealReg -> Bool
== :: RealReg -> RealReg -> Bool
$c== :: RealReg -> RealReg -> Bool
External instance of the constraint type Eq RegNo
Eq, RegNo -> RealReg -> ShowS
[RealReg] -> ShowS
RealReg -> String
(RegNo -> RealReg -> ShowS)
-> (RealReg -> String) -> ([RealReg] -> ShowS) -> Show RealReg
forall a.
(RegNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RealReg] -> ShowS
$cshowList :: [RealReg] -> ShowS
show :: RealReg -> String
$cshow :: RealReg -> String
showsPrec :: RegNo -> RealReg -> ShowS
$cshowsPrec :: RegNo -> RealReg -> ShowS
External instance of the constraint type Show RegNo
External instance of the constraint type Show RegNo
External instance of the constraint type Ord RegNo
External instance of the constraint type Ord RegNo
Show, Eq RealReg
Eq RealReg
-> (RealReg -> RealReg -> Ordering)
-> (RealReg -> RealReg -> Bool)
-> (RealReg -> RealReg -> Bool)
-> (RealReg -> RealReg -> Bool)
-> (RealReg -> RealReg -> Bool)
-> (RealReg -> RealReg -> RealReg)
-> (RealReg -> RealReg -> RealReg)
-> Ord RealReg
RealReg -> RealReg -> Bool
RealReg -> RealReg -> Ordering
RealReg -> RealReg -> RealReg
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 :: RealReg -> RealReg -> RealReg
$cmin :: RealReg -> RealReg -> RealReg
max :: RealReg -> RealReg -> RealReg
$cmax :: RealReg -> RealReg -> RealReg
>= :: RealReg -> RealReg -> Bool
$c>= :: RealReg -> RealReg -> Bool
> :: RealReg -> RealReg -> Bool
$c> :: RealReg -> RealReg -> Bool
<= :: RealReg -> RealReg -> Bool
$c<= :: RealReg -> RealReg -> Bool
< :: RealReg -> RealReg -> Bool
$c< :: RealReg -> RealReg -> Bool
compare :: RealReg -> RealReg -> Ordering
$ccompare :: RealReg -> RealReg -> Ordering
External instance of the constraint type Ord RegNo
External instance of the constraint type Ord RegNo
Instance of class: Eq of the constraint type Eq RealReg
External instance of the constraint type Ord RegNo
Instance of class: Ord of the constraint type Ord RealReg
Instance of class: Eq of the constraint type Eq RealReg
Ord)

instance Uniquable RealReg where
        getUnique :: RealReg -> Unique
getUnique RealReg
reg
         = case RealReg
reg of
                RealRegSingle RegNo
i         -> RegNo -> Unique
mkRegSingleUnique RegNo
i
                RealRegPair RegNo
r1 RegNo
r2       -> RegNo -> Unique
mkRegPairUnique (RegNo
r1 RegNo -> RegNo -> RegNo
forall a. Num a => a -> a -> a
External instance of the constraint type Num RegNo
* RegNo
65536 RegNo -> RegNo -> RegNo
forall a. Num a => a -> a -> a
External instance of the constraint type Num RegNo
+ RegNo
r2)

instance Outputable RealReg where
        ppr :: RealReg -> SDoc
ppr RealReg
reg
         = case RealReg
reg of
                RealRegSingle RegNo
i         -> String -> SDoc
text String
"%r"  SDoc -> SDoc -> SDoc
<> RegNo -> SDoc
int RegNo
i
                RealRegPair RegNo
r1 RegNo
r2       -> String -> SDoc
text String
"%r(" SDoc -> SDoc -> SDoc
<> RegNo -> SDoc
int RegNo
r1
                                           SDoc -> SDoc -> SDoc
<> SDoc
vbar SDoc -> SDoc -> SDoc
<> RegNo -> SDoc
int RegNo
r2 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
")"

regNosOfRealReg :: RealReg -> [RegNo]
regNosOfRealReg :: RealReg -> [RegNo]
regNosOfRealReg RealReg
rr
 = case RealReg
rr of
        RealRegSingle RegNo
r1        -> [RegNo
r1]
        RealRegPair   RegNo
r1 RegNo
r2     -> [RegNo
r1, RegNo
r2]


realRegsAlias :: RealReg -> RealReg -> Bool
realRegsAlias :: RealReg -> RealReg -> Bool
realRegsAlias RealReg
rr1 RealReg
rr2
        = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [RegNo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null ([RegNo] -> Bool) -> [RegNo] -> Bool
forall a b. (a -> b) -> a -> b
$ [RegNo] -> [RegNo] -> [RegNo]
forall a. Eq a => [a] -> [a] -> [a]
External instance of the constraint type Eq RegNo
intersect (RealReg -> [RegNo]
regNosOfRealReg RealReg
rr1) (RealReg -> [RegNo]
regNosOfRealReg RealReg
rr2)

--------------------------------------------------------------------------------
-- | A register, either virtual or real
data Reg
        = RegVirtual !VirtualReg
        | RegReal    !RealReg
        deriving (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
Instance of class: Eq of the constraint type Eq VirtualReg
Instance of class: Eq of the constraint type Eq RealReg
Eq, Eq Reg
Eq Reg
-> (Reg -> Reg -> Ordering)
-> (Reg -> Reg -> Bool)
-> (Reg -> Reg -> Bool)
-> (Reg -> Reg -> Bool)
-> (Reg -> Reg -> Bool)
-> (Reg -> Reg -> Reg)
-> (Reg -> Reg -> Reg)
-> Ord Reg
Reg -> Reg -> Bool
Reg -> Reg -> Ordering
Reg -> Reg -> Reg
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 :: Reg -> Reg -> Reg
$cmin :: Reg -> Reg -> Reg
max :: Reg -> Reg -> Reg
$cmax :: Reg -> Reg -> Reg
>= :: Reg -> Reg -> Bool
$c>= :: Reg -> Reg -> Bool
> :: Reg -> Reg -> Bool
$c> :: Reg -> Reg -> Bool
<= :: Reg -> Reg -> Bool
$c<= :: Reg -> Reg -> Bool
< :: Reg -> Reg -> Bool
$c< :: Reg -> Reg -> Bool
compare :: Reg -> Reg -> Ordering
$ccompare :: Reg -> Reg -> Ordering
Instance of class: Eq of the constraint type Eq Reg
Instance of class: Ord of the constraint type Ord VirtualReg
Instance of class: Ord of the constraint type Ord RealReg
Instance of class: Ord of the constraint type Ord Reg
Instance of class: Eq of the constraint type Eq Reg
Ord)

regSingle :: RegNo -> Reg
regSingle :: RegNo -> Reg
regSingle RegNo
regNo         = RealReg -> Reg
RegReal (RealReg -> Reg) -> RealReg -> Reg
forall a b. (a -> b) -> a -> b
$ RegNo -> RealReg
RealRegSingle RegNo
regNo

regPair :: RegNo -> RegNo -> Reg
regPair :: RegNo -> RegNo -> Reg
regPair RegNo
regNo1 RegNo
regNo2   = RealReg -> Reg
RegReal (RealReg -> Reg) -> RealReg -> Reg
forall a b. (a -> b) -> a -> b
$ RegNo -> RegNo -> RealReg
RealRegPair RegNo
regNo1 RegNo
regNo2


-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets
-- in the register allocator.
instance Uniquable Reg where
        getUnique :: Reg -> Unique
getUnique Reg
reg
         = case Reg
reg of
                RegVirtual VirtualReg
vr   -> VirtualReg -> Unique
forall a. Uniquable a => a -> Unique
Instance of class: Uniquable of the constraint type Uniquable VirtualReg
getUnique VirtualReg
vr
                RegReal    RealReg
rr   -> RealReg -> Unique
forall a. Uniquable a => a -> Unique
Instance of class: Uniquable of the constraint type Uniquable RealReg
getUnique RealReg
rr

-- | Print a reg in a generic manner
--      If you want the architecture specific names, then use the pprReg
--      function from the appropriate Ppr module.
instance Outputable Reg where
        ppr :: Reg -> SDoc
ppr Reg
reg
         = case Reg
reg of
                RegVirtual VirtualReg
vr   -> VirtualReg -> SDoc
forall a. Outputable a => a -> SDoc
Instance of class: Outputable of the constraint type Outputable VirtualReg
ppr VirtualReg
vr
                RegReal    RealReg
rr   -> RealReg -> SDoc
forall a. Outputable a => a -> SDoc
Instance of class: Outputable of the constraint type Outputable RealReg
ppr RealReg
rr


isRealReg :: Reg -> Bool
isRealReg :: Reg -> Bool
isRealReg Reg
reg
 = case Reg
reg of
        RegReal RealReg
_       -> Bool
True
        RegVirtual VirtualReg
_    -> Bool
False

takeRealReg :: Reg -> Maybe RealReg
takeRealReg :: Reg -> Maybe RealReg
takeRealReg Reg
reg
 = case Reg
reg of
        RegReal RealReg
rr      -> RealReg -> Maybe RealReg
forall a. a -> Maybe a
Just RealReg
rr
        Reg
_               -> Maybe RealReg
forall a. Maybe a
Nothing


isVirtualReg :: Reg -> Bool
isVirtualReg :: Reg -> Bool
isVirtualReg Reg
reg
 = case Reg
reg of
        RegReal RealReg
_       -> Bool
False
        RegVirtual VirtualReg
_    -> Bool
True

takeVirtualReg :: Reg -> Maybe VirtualReg
takeVirtualReg :: Reg -> Maybe VirtualReg
takeVirtualReg Reg
reg
 = case Reg
reg of
        RegReal RealReg
_       -> Maybe VirtualReg
forall a. Maybe a
Nothing
        RegVirtual VirtualReg
vr   -> VirtualReg -> Maybe VirtualReg
forall a. a -> Maybe a
Just VirtualReg
vr


-- | The patch function supplied by the allocator maps VirtualReg to RealReg
--      regs, but sometimes we want to apply it to plain old Reg.
--
liftPatchFnToRegReg  :: (VirtualReg -> RealReg) -> (Reg -> Reg)
liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> Reg -> Reg
liftPatchFnToRegReg VirtualReg -> RealReg
patchF Reg
reg
 = case Reg
reg of
        RegVirtual VirtualReg
vr   -> RealReg -> Reg
RegReal (VirtualReg -> RealReg
patchF VirtualReg
vr)
        RegReal RealReg
_       -> Reg
reg