projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2006-01-09 14:25:44 by simonmar]
[ghc-hetmet.git] / ghc / compiler / nativeGen / MachRegs.lhs
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index 44448f6..b1a5de9 100644 (file)
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -33,7 +33,7 @@ module MachRegs (
 
        -- * Global registers
         get_GlobalReg_reg_or_addr,
-       callerSaves,
+       callerSaves, callerSaveVolatileRegs,
 
        -- * Machine-dependent register-related stuff
         allocatableRegs, argRegs, allArgRegs, callClobberedRegs,
@@ -41,17 +41,18 @@ module MachRegs (
        spRel,
 
 #if alpha_TARGET_ARCH
-       allArgRegs,
        fits8Bits,
        fReg,
        gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh,
 #endif
 #if i386_TARGET_ARCH
+       EABase(..), EAIndex(..),
        eax, ebx, ecx, edx, esi, edi, ebp, esp,
        fake0, fake1, fake2, fake3, fake4, fake5,
        addrModeRegs,
 #endif
 #if x86_64_TARGET_ARCH
+       EABase(..), EAIndex(..), ripRel,
        rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp,
        eax, ebx, ecx, edx, esi, edi, ebp, esp,
        r8, r9, r10, r11, r12, r13, r14, r15,
@@ -87,7 +88,6 @@ import Cmm
 import MachOp          ( MachRep(..) )
 
 import CLabel           ( CLabel, mkMainCapabilityLabel )
-import Unique          ( Unique )
 import Pretty
 import Outputable      ( Outputable(..), pprPanic, panic )
 import qualified Outputable
@@ -151,11 +151,11 @@ data AddrMode
 #endif
 
 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-  = AddrBaseIndex      Base Index Displacement
+  = AddrBaseIndex      EABase EAIndex Displacement
   | ImmAddr            Imm Int
 
-type Base         = Maybe Reg
-type Index        = Maybe (Reg, Int)   -- Int is 2, 4 or 8
+data EABase       = EABaseNone  | EABaseReg Reg | EABaseRip
+data EAIndex      = EAIndexNone | EAIndex Reg Int
 type Displacement = Imm
 #endif
 
@@ -173,8 +173,8 @@ type Displacement = Imm
 addrModeRegs :: AddrMode -> [Reg]
 addrModeRegs (AddrBaseIndex b i _) =  b_regs ++ i_regs
   where
-   b_regs = case b of { Just r -> [r]; _ -> [] }
-   i_regs = case i of { Just (r,_) -> [r]; _ -> [] }
+   b_regs = case b of { EABaseReg r -> [r]; _ -> [] }
+   i_regs = case i of { EAIndex r _ -> [r]; _ -> [] }
 addrModeRegs _ = []
 #endif
 
@@ -290,9 +290,9 @@ spRel :: Int        -- desired stack offset in words, positive or negative
 
 spRel n
 #if defined(i386_TARGET_ARCH)
-  = AddrBaseIndex (Just esp) Nothing (ImmInt (n * wORD_SIZE))
+  = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt (n * wORD_SIZE))
 #elif defined(x86_64_TARGET_ARCH)
-  = AddrBaseIndex (Just rsp) Nothing (ImmInt (n * wORD_SIZE))
+  = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt (n * wORD_SIZE))
 #else
   = AddrRegImm sp (ImmInt (n * wORD_SIZE))
 #endif
@@ -305,6 +305,9 @@ fpRel n
   = AddrRegImm fp (ImmInt (n * wORD_SIZE))
 #endif
 
+#if x86_64_TARGET_ARCH
+ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm
+#endif
 
 -- -----------------------------------------------------------------------------
 -- Global registers
@@ -339,6 +342,39 @@ get_Regtable_addr_from_offset rep offset
                  Nothing -> regTableOffset offset
                  Just _  -> CmmRegOff (CmmGlobal BaseReg) offset
 
+-- -----------------------------------------------------------------------------
+-- caller-save registers
+
+-- Here we generate the sequence of saves/restores required around a
+-- foreign call instruction.
+
+callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
+callerSaveVolatileRegs vols = (caller_save, caller_load)
+  where
+    caller_save = foldr ($!) [] (map callerSaveGlobalReg    regs_to_save)
+    caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
+
+    system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
+                  {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
+
+    regs_to_save = system_regs ++ vol_list
+
+    vol_list = case vols of Nothing -> []; Just regs -> regs
+
+    callerSaveGlobalReg reg next
+       | callerSaves reg = 
+               CmmStore (get_GlobalReg_addr reg) 
+                        (CmmReg (CmmGlobal reg)) : next
+       | otherwise = next
+
+    callerRestoreGlobalReg reg next
+       | callerSaves reg = 
+               CmmAssign (CmmGlobal reg)
+                         (CmmLoad (get_GlobalReg_addr reg) (globalRegRep reg))
+                       : next
+       | otherwise = next
+
+
 -- ---------------------------------------------------------------------------
 -- Registers
 
@@ -391,6 +427,9 @@ instance Uniquable Reg where
    getUnique (VirtualRegF u)  = u
    getUnique (VirtualRegD u)  = u
 
+unRealReg (RealReg i) = i
+unRealReg vreg        = pprPanic "unRealReg on VirtualReg" (ppr vreg)
+
 mkVReg :: Unique -> MachRep -> Reg
 mkVReg u rep
    = case rep of
@@ -583,7 +622,7 @@ regNames
 
 showReg :: RegNo -> String
 showReg n
-  | n >= 16 = "%xmm" ++ show n  
+  | n >= 16 = "%xmm" ++ show (n-16)
   | n >= 8  = "%r" ++ show n
   | otherwise = regNames !! n
 
@@ -1238,72 +1277,72 @@ baseRegOffset _                   = panic "baseRegOffset:other"
 callerSaves :: GlobalReg -> Bool
 
 #ifdef CALLER_SAVES_Base
-callerSaves BaseReg                    = True
+callerSaves BaseReg            = True
 #endif
 #ifdef CALLER_SAVES_R1
-callerSaves (VanillaReg _ ILIT(1))     = True
+callerSaves (VanillaReg 1)     = True
 #endif
 #ifdef CALLER_SAVES_R2
-callerSaves (VanillaReg _ ILIT(2))     = True
+callerSaves (VanillaReg 2)     = True
 #endif
 #ifdef CALLER_SAVES_R3
-callerSaves (VanillaReg _ ILIT(3))     = True
+callerSaves (VanillaReg 3)     = True
 #endif
 #ifdef CALLER_SAVES_R4
-callerSaves (VanillaReg _ ILIT(4))     = True
+callerSaves (VanillaReg 4)     = True
 #endif
 #ifdef CALLER_SAVES_R5
-callerSaves (VanillaReg _ ILIT(5))     = True
+callerSaves (VanillaReg 5)     = True
 #endif
 #ifdef CALLER_SAVES_R6
-callerSaves (VanillaReg _ ILIT(6))     = True
+callerSaves (VanillaReg 6)     = True
 #endif
 #ifdef CALLER_SAVES_R7
-callerSaves (VanillaReg _ ILIT(7))     = True
+callerSaves (VanillaReg 7)     = True
 #endif
 #ifdef CALLER_SAVES_R8
-callerSaves (VanillaReg _ ILIT(8))     = True
+callerSaves (VanillaReg 8)     = True
 #endif
 #ifdef CALLER_SAVES_F1
-callerSaves (FloatReg 1#)              = True
+callerSaves (FloatReg 1)       = True
 #endif
 #ifdef CALLER_SAVES_F2
-callerSaves (FloatReg 2#)              = True
+callerSaves (FloatReg 2)       = True
 #endif
 #ifdef CALLER_SAVES_F3
-callerSaves (FloatReg 3#)              = True
+callerSaves (FloatReg 3)       = True
 #endif
 #ifdef CALLER_SAVES_F4
-callerSaves (FloatReg 4#)              = True
+callerSaves (FloatReg 4)       = True
 #endif
 #ifdef CALLER_SAVES_D1
-callerSaves (DoubleReg 1#)             = True
+callerSaves (DoubleReg 1)      = True
 #endif
 #ifdef CALLER_SAVES_D2
-callerSaves (DoubleReg 2#)             = True
+callerSaves (DoubleReg 2)      = True
 #endif
 #ifdef CALLER_SAVES_L1
-callerSaves (LongReg _ ILIT(1))                = True
+callerSaves (LongReg 1)                = True
 #endif
 #ifdef CALLER_SAVES_Sp
-callerSaves Sp                         = True
+callerSaves Sp                 = True
 #endif
 #ifdef CALLER_SAVES_SpLim
-callerSaves SpLim                      = True
+callerSaves SpLim              = True
 #endif
 #ifdef CALLER_SAVES_Hp
-callerSaves Hp                         = True
+callerSaves Hp                 = True
 #endif
 #ifdef CALLER_SAVES_HpLim
-callerSaves HpLim                      = True
+callerSaves HpLim              = True
 #endif
 #ifdef CALLER_SAVES_CurrentTSO
-callerSaves CurrentTSO                 = True
+callerSaves CurrentTSO         = True
 #endif
 #ifdef CALLER_SAVES_CurrentNursery
-callerSaves CurrentNursery             = True
+callerSaves CurrentNursery     = True
 #endif
-callerSaves _                          = False
+callerSaves _                  = False
 
 
 --  | Returns 'Nothing' if this global register is not stored
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)