summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs13
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Main.hs15
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs27
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs52
5 files changed, 82 insertions, 26 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 8cec8271a2..f07cccffe0 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -542,6 +542,7 @@ Library
RegAlloc.Linear.StackMap
RegAlloc.Linear.Base
RegAlloc.Linear.X86.FreeRegs
+ RegAlloc.Linear.X86_64.FreeRegs
RegAlloc.Linear.PPC.FreeRegs
RegAlloc.Linear.SPARC.FreeRegs
diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
index 887af1758a..4a5af75ce8 100644
--- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
@@ -33,9 +33,10 @@ import Platform
-- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
-- allocateReg f r = filter (/= r) f
-import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
-import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
-import qualified RegAlloc.Linear.X86.FreeRegs as X86
+import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs as X86
+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64
import qualified PPC.Instr
import qualified SPARC.Instr
@@ -53,6 +54,12 @@ instance FR X86.FreeRegs where
frInitFreeRegs = X86.initFreeRegs
frReleaseReg = \_ -> X86.releaseReg
+instance FR X86_64.FreeRegs where
+ frAllocateReg = \_ -> X86_64.allocateReg
+ frGetFreeRegs = X86_64.getFreeRegs
+ frInitFreeRegs = X86_64.initFreeRegs
+ frReleaseReg = \_ -> X86_64.releaseReg
+
instance FR PPC.FreeRegs where
frAllocateReg = \_ -> PPC.allocateReg
frGetFreeRegs = \_ -> PPC.getFreeRegs
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index c2f89de641..bf0f5aae32 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -106,9 +106,10 @@ import RegAlloc.Linear.StackMap
import RegAlloc.Linear.FreeRegs
import RegAlloc.Linear.Stats
import RegAlloc.Linear.JoinToTargets
-import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
-import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
-import qualified RegAlloc.Linear.X86.FreeRegs as X86
+import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs as X86
+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64
import TargetReg
import RegAlloc.Liveness
import Instruction
@@ -188,10 +189,10 @@ linearRegAlloc
linearRegAlloc dflags first_id block_live sccs
= let platform = targetPlatform dflags
in case platformArch platform of
- ArchX86 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs
- ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs
- ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs
- ArchPPC -> linearRegAlloc' platform (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs
+ ArchX86 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs
+ ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86_64.FreeRegs) first_id block_live sccs
+ ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs
+ ArchPPC -> linearRegAlloc' platform (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs
ArchARM _ _ _ -> panic "linearRegAlloc ArchARM"
ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64"
ArchUnknown -> panic "linearRegAlloc ArchUnknown"
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
index 6309b24b45..0fcd658120 100644
--- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
@@ -1,5 +1,5 @@
--- | Free regs map for i386 and x86_64
+-- | Free regs map for i386
module RegAlloc.Linear.X86.FreeRegs
where
@@ -12,29 +12,25 @@ import Platform
import Data.Word
import Data.Bits
-type FreeRegs
-#ifdef i386_TARGET_ARCH
- = Word32
-#else
- = Word64
-#endif
+newtype FreeRegs = FreeRegs Word32
+ deriving Show
noFreeRegs :: FreeRegs
-noFreeRegs = 0
+noFreeRegs = FreeRegs 0
releaseReg :: RealReg -> FreeRegs -> FreeRegs
-releaseReg (RealRegSingle n) f
- = f .|. (1 `shiftL` n)
+releaseReg (RealRegSingle n) (FreeRegs f)
+ = FreeRegs (f .|. (1 `shiftL` n))
releaseReg _ _
- = panic "RegAlloc.Linear.X86.FreeRegs.realeaseReg: no reg"
+ = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg"
initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform
= foldr releaseReg noFreeRegs (allocatableRegs platform)
-getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazilly
-getFreeRegs platform cls f = go f 0
+getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
+getFreeRegs platform cls (FreeRegs f) = go f 0
where go 0 _ = []
go n m
@@ -47,10 +43,9 @@ getFreeRegs platform cls f = go f 0
-- in order to find a floating-point one.
allocateReg :: RealReg -> FreeRegs -> FreeRegs
-allocateReg (RealRegSingle r) f
- = f .&. complement (1 `shiftL` r)
+allocateReg (RealRegSingle r) (FreeRegs f)
+ = FreeRegs (f .&. complement (1 `shiftL` r))
allocateReg _ _
= panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg"
-
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
new file mode 100644
index 0000000000..c04fce9645
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
@@ -0,0 +1,52 @@
+
+-- | Free regs map for x86_64
+module RegAlloc.Linear.X86_64.FreeRegs
+where
+
+import X86.Regs
+import RegClass
+import Reg
+import Panic
+import Platform
+
+import Data.Word
+import Data.Bits
+
+newtype FreeRegs = FreeRegs Word64
+ deriving Show
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0
+
+releaseReg :: RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle n) (FreeRegs f)
+ = FreeRegs (f .|. (1 `shiftL` n))
+
+releaseReg _ _
+ = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg"
+
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform
+ = foldr releaseReg noFreeRegs (allocatableRegs platform)
+
+getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
+getFreeRegs platform cls (FreeRegs f) = go f 0
+
+ where go 0 _ = []
+ go n m
+ | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
+ = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))
+
+ | otherwise
+ = go (n `shiftR` 1) $! (m+1)
+ -- ToDo: there's no point looking through all the integer registers
+ -- in order to find a floating-point one.
+
+allocateReg :: RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs f)
+ = FreeRegs (f .&. complement (1 `shiftL` r))
+
+allocateReg _ _
+ = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg"
+
+
View Lorry Controller Status