Modules: CmmToAsm (#13009)

3 files changed, 274 insertions, 1 deletions

diff --git a/compiler/GHC/Platform/Reg.hs b/compiler/GHC/Platform/Reg.hs
new file mode 100644
index 0000000000..b856d7c3af
--- /dev/null
+++ b/compiler/GHC/Platform/Reg.hs
@@ -0,0 +1,241 @@
+-- | 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 GhcPrelude
+
+import Outputable
+import 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 (Eq, 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 (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b
+  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b
+  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b
+  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b
+
+  compare VirtualRegI{} _ = LT
+  compare _ VirtualRegI{} = GT
+  compare VirtualRegHi{} _ = LT
+  compare _ VirtualRegHi{} = GT
+  compare VirtualRegF{} _ = LT
+  compare _ VirtualRegF{} = GT
+
+
+
+instance Uniquable VirtualReg where
+        getUnique reg
+         = case reg of
+                VirtualRegI u   -> u
+                VirtualRegHi u  -> u
+                VirtualRegF u   -> u
+                VirtualRegD u   -> u
+
+instance Outputable VirtualReg where
+        ppr reg
+         = case reg of
+                VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u
+                VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u
+                -- this code is kinda wrong on x86
+                -- because float and double occupy the same register set
+                -- namely SSE2 register xmm0 .. xmm15
+                VirtualRegF  u  -> text "%vFloat_"   <> pprUniqueAlways u
+                VirtualRegD  u  -> text "%vDouble_"   <> pprUniqueAlways u
+
+
+
+renameVirtualReg :: Unique -> VirtualReg -> VirtualReg
+renameVirtualReg u r
+ = case r of
+        VirtualRegI _   -> VirtualRegI  u
+        VirtualRegHi _  -> VirtualRegHi u
+        VirtualRegF _   -> VirtualRegF  u
+        VirtualRegD _   -> VirtualRegD  u
+
+
+classOfVirtualReg :: VirtualReg -> RegClass
+classOfVirtualReg vr
+ = case vr of
+        VirtualRegI{}   -> RcInteger
+        VirtualRegHi{}  -> RcInteger
+        VirtualRegF{}   -> RcFloat
+        VirtualRegD{}   -> 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 reg
+ = case reg of
+        -- makes a pseudo-unique with tag 'H'
+        VirtualRegI u   -> VirtualRegHi (newTagUnique u 'H')
+        _               -> panic "Reg.getHiVirtualRegFromLo"
+
+getHiVRegFromLo :: Reg -> Reg
+getHiVRegFromLo reg
+ = case reg of
+        RegVirtual  vr  -> RegVirtual (getHiVirtualRegFromLo vr)
+        RegReal _       -> panic "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 (Eq, Show, Ord)
+
+instance Uniquable RealReg where
+        getUnique reg
+         = case reg of
+                RealRegSingle i         -> mkRegSingleUnique i
+                RealRegPair r1 r2       -> mkRegPairUnique (r1 * 65536 + r2)
+
+instance Outputable RealReg where
+        ppr reg
+         = case reg of
+                RealRegSingle i         -> text "%r"  <> int i
+                RealRegPair r1 r2       -> text "%r(" <> int r1
+                                           <> vbar <> int r2 <> text ")"
+
+regNosOfRealReg :: RealReg -> [RegNo]
+regNosOfRealReg rr
+ = case rr of
+        RealRegSingle r1        -> [r1]
+        RealRegPair   r1 r2     -> [r1, r2]
+
+
+realRegsAlias :: RealReg -> RealReg -> Bool
+realRegsAlias rr1 rr2
+        = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)
+
+--------------------------------------------------------------------------------
+-- | A register, either virtual or real
+data Reg
+        = RegVirtual !VirtualReg
+        | RegReal    !RealReg
+        deriving (Eq, Ord)
+
+regSingle :: RegNo -> Reg
+regSingle regNo         = RegReal $ RealRegSingle regNo
+
+regPair :: RegNo -> RegNo -> Reg
+regPair regNo1 regNo2   = RegReal $ RealRegPair regNo1 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
+         = case reg of
+                RegVirtual vr   -> getUnique vr
+                RegReal    rr   -> getUnique 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
+         = case reg of
+                RegVirtual vr   -> ppr vr
+                RegReal    rr   -> ppr rr
+
+
+isRealReg :: Reg -> Bool
+isRealReg reg
+ = case reg of
+        RegReal _       -> True
+        RegVirtual _    -> False
+
+takeRealReg :: Reg -> Maybe RealReg
+takeRealReg reg
+ = case reg of
+        RegReal rr      -> Just rr
+        _               -> Nothing
+
+
+isVirtualReg :: Reg -> Bool
+isVirtualReg reg
+ = case reg of
+        RegReal _       -> False
+        RegVirtual _    -> True
+
+takeVirtualReg :: Reg -> Maybe VirtualReg
+takeVirtualReg reg
+ = case reg of
+        RegReal _       -> Nothing
+        RegVirtual vr   -> Just 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 patchF reg
+ = case reg of
+        RegVirtual vr   -> RegReal (patchF vr)
+        RegReal _       -> reg
diff --git a/compiler/GHC/Platform/Reg/Class.hs b/compiler/GHC/Platform/Reg/Class.hs
new file mode 100644
index 0000000000..225ad05be5
--- /dev/null
+++ b/compiler/GHC/Platform/Reg/Class.hs
@@ -0,0 +1,32 @@
+-- | An architecture independent description of a register's class.
+module GHC.Platform.Reg.Class
+        ( RegClass (..) )
+
+where
+
+import GhcPrelude
+
+import  Outputable
+import  Unique
+
+
+-- | The class of a register.
+--      Used in the register allocator.
+--      We treat all registers in a class as being interchangeable.
+--
+data RegClass
+        = RcInteger
+        | RcFloat
+        | RcDouble
+        deriving Eq
+
+
+instance Uniquable RegClass where
+    getUnique RcInteger = mkRegClassUnique 0
+    getUnique RcFloat   = mkRegClassUnique 1
+    getUnique RcDouble  = mkRegClassUnique 2
+
+instance Outputable RegClass where
+    ppr RcInteger       = Outputable.text "I"
+    ppr RcFloat         = Outputable.text "F"
+    ppr RcDouble        = Outputable.text "D"
diff --git a/compiler/GHC/Platform/Regs.hs b/compiler/GHC/Platform/Regs.hs
index 51f7658db2..d214b0d89f 100644
--- a/compiler/GHC/Platform/Regs.hs
+++ b/compiler/GHC/Platform/Regs.hs
@@ -7,7 +7,7 @@ import GhcPrelude
 
 import GHC.Cmm.Expr
 import GHC.Platform
-import Reg
+import GHC.Platform.Reg
 
 import qualified GHC.Platform.ARM        as ARM
 import qualified GHC.Platform.ARM64      as ARM64