diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2022-01-26 20:36:20 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2022-01-29 14:52:55 -0500 |
| commit | 0a1d0944d68265cb48cdb8e42f658d58c1cfdac7 (patch) | |
| tree | 90ca07256ce280a9fa23bc022f1240bff53bf54f | |
| parent | 268efcc9a45da36458442d9203c66a415b48f2b3 (diff) | |
| download | haskell-0a1d0944d68265cb48cdb8e42f658d58c1cfdac7.tar.gz | |
Drop SPARC NCG
27 files changed, 10 insertions, 4237 deletions
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 13b168db37..d59f716e95 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -82,7 +82,6 @@ import GHC.Prelude import qualified GHC.CmmToAsm.X86 as X86 import qualified GHC.CmmToAsm.PPC as PPC -import qualified GHC.CmmToAsm.SPARC as SPARC import qualified GHC.CmmToAsm.AArch64 as AArch64 import GHC.CmmToAsm.Reg.Liveness @@ -161,8 +160,6 @@ nativeCodeGen logger config modLoc h us cmms ArchX86_64 -> nCG' (X86.ncgX86_64 config) ArchPPC -> nCG' (PPC.ncgPPC config) ArchPPC_64 _ -> nCG' (PPC.ncgPPC config) - ArchSPARC -> nCG' (SPARC.ncgSPARC config) - ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64" ArchS390X -> panic "nativeCodeGen: No NCG for S390X" ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" ArchAArch64 -> nCG' (AArch64.ncgAArch64 config) diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs index cd4208bc89..547d13fff7 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -107,7 +107,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl ArchX86 -> 3 ArchX86_64 -> 5 ArchPPC -> 16 - ArchSPARC -> 14 + ArchSPARC -> panic "trivColorable ArchSPARC" ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 15 ArchARM _ _ _ -> panic "trivColorable ArchARM" @@ -142,7 +142,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus ArchX86 -> 0 ArchX86_64 -> 0 ArchPPC -> 0 - ArchSPARC -> 22 + ArchSPARC -> panic "trivColorable ArchSPARC" ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 0 ArchARM _ _ _ -> panic "trivColorable ArchARM" @@ -179,7 +179,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu -- "dont need to solve conflicts" count that -- was chosen at some point in the past. ArchPPC -> 26 - ArchSPARC -> 11 + ArchSPARC -> panic "trivColorable ArchSPARC" ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs index 4fb50fceb2..dd2c73bc98 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -111,7 +111,6 @@ import GHC.CmmToAsm.Reg.Linear.FreeRegs import GHC.CmmToAsm.Reg.Linear.Stats import GHC.CmmToAsm.Reg.Linear.JoinToTargets import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC -import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 @@ -217,7 +216,7 @@ linearRegAlloc config entry_ids block_live sccs ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) ArchS390X -> panic "linearRegAlloc ArchS390X" - ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) + ArchSPARC -> panic "linearRegAlloc ArchSPARC" ArchSPARC64 -> panic "linearRegAlloc ArchSPARC64" ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs index 3ae0fa140d..a9355f32e1 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -26,13 +26,11 @@ import GHC.Platform -- allocateReg f r = filter (/= r) f import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC -import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr -import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr import qualified GHC.CmmToAsm.X86.Instr as X86.Instr import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr @@ -66,19 +64,13 @@ instance FR AArch64.FreeRegs where frInitFreeRegs = AArch64.initFreeRegs frReleaseReg = \_ -> AArch64.releaseReg -instance FR SPARC.FreeRegs where - frAllocateReg = SPARC.allocateReg - frGetFreeRegs = \_ -> SPARC.getFreeRegs - frInitFreeRegs = SPARC.initFreeRegs - frReleaseReg = SPARC.releaseReg - maxSpillSlots :: NCGConfig -> Int maxSpillSlots config = case platformArch (ncgPlatform config) of ArchX86 -> X86.Instr.maxSpillSlots config ArchX86_64 -> X86.Instr.maxSpillSlots config ArchPPC -> PPC.Instr.maxSpillSlots config ArchS390X -> panic "maxSpillSlots ArchS390X" - ArchSPARC -> SPARC.Instr.maxSpillSlots config + ArchSPARC -> panic "maxSpillSlots ArchSPARC" ArchSPARC64 -> panic "maxSpillSlots ArchSPARC64" ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" ArchAArch64 -> AArch64.Instr.maxSpillSlots config diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs deleted file mode 100644 index 31e9a9dca0..0000000000 --- a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Free regs map for SPARC -module GHC.CmmToAsm.Reg.Linear.SPARC where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Regs -import GHC.Platform.Reg.Class -import GHC.Platform.Reg - -import GHC.Platform.Regs -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Platform - -import Data.Word - - --------------------------------------------------------------------------------- --- SPARC is like PPC, except for twinning of floating point regs. --- When we allocate a double reg we must take an even numbered --- float reg, as well as the one after it. - - --- Holds bitmaps showing what registers are currently allocated. --- The float and double reg bitmaps overlap, but we only alloc --- float regs into the float map, and double regs into the double map. --- --- Free regs have a bit set in the corresponding bitmap. --- -data FreeRegs - = FreeRegs - !Word32 -- int reg bitmap regs 0..31 - !Word32 -- float reg bitmap regs 32..63 - !Word32 -- double reg bitmap regs 32..63 - -instance Show FreeRegs where - show = showFreeRegs - -instance Outputable FreeRegs where - ppr = text . showFreeRegs - --- | A reg map where no regs are free to be allocated. -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 0 0 - - --- | The initial set of free regs. -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform - = foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs - - --- | Get all the free registers of this class. -getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs cls (FreeRegs g f d) - | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 - | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 - | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) -#endif - where - go _ _ 0 _ - = [] - - go step bitmap mask ix - | bitmap .&. mask /= 0 - = ix : (go step bitmap (mask `shiftL` step) $! ix + step) - - | otherwise - = go step bitmap (mask `shiftL` step) $! ix + step - - --- | Grab a register. -allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs -allocateReg platform - reg@(RealRegSingle r) - (FreeRegs g f d) - - -- can't allocate free regs - | not $ freeReg platform r - = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) - - -- a general purpose reg - | r <= 31 - = let mask = complement (bitMask r) - in FreeRegs - (g .&. mask) - f - d - - -- a float reg - | r >= 32, r <= 63 - = let mask = complement (bitMask (r - 32)) - - -- the mask of the double this FP reg aliases - maskLow = if r `mod` 2 == 0 - then complement (bitMask (r - 32)) - else complement (bitMask (r - 32 - 1)) - in FreeRegs - g - (f .&. mask) - (d .&. maskLow) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - -allocateReg _ - reg@(RealRegPair r1 r2) - (FreeRegs g f d) - - | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 - , r2 >= 32, r2 <= 63 - = let mask1 = complement (bitMask (r1 - 32)) - mask2 = complement (bitMask (r2 - 32)) - in - FreeRegs - g - ((f .&. mask1) .&. mask2) - (d .&. mask1) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - - - --- | Release a register from allocation. --- The register liveness information says that most regs die after a C call, --- but we still don't want to allocate to some of them. --- -releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs -releaseReg platform - reg@(RealRegSingle r) - regs@(FreeRegs g f d) - - -- don't release pinned reg - | not $ freeReg platform r - = regs - - -- a general purpose reg - | r <= 31 - = let mask = bitMask r - in FreeRegs (g .|. mask) f d - - -- a float reg - | r >= 32, r <= 63 - = let mask = bitMask (r - 32) - - -- the mask of the double this FP reg aliases - maskLow = if r `mod` 2 == 0 - then bitMask (r - 32) - else bitMask (r - 32 - 1) - in FreeRegs - g - (f .|. mask) - (d .|. maskLow) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - -releaseReg _ - reg@(RealRegPair r1 r2) - (FreeRegs g f d) - - | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 - , r2 >= 32, r2 <= 63 - = let mask1 = bitMask (r1 - 32) - mask2 = bitMask (r2 - 32) - in - FreeRegs - g - ((f .|. mask1) .|. mask2) - (d .|. mask1) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - - - -bitMask :: Int -> Word32 -bitMask n = 1 `shiftL` n - - -showFreeRegs :: FreeRegs -> String -showFreeRegs regs - = "FreeRegs\n" - ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" - ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" - ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" diff --git a/compiler/GHC/CmmToAsm/Reg/Target.hs b/compiler/GHC/CmmToAsm/Reg/Target.hs index 22b22e21cc..d834cee651 100644 --- a/compiler/GHC/CmmToAsm/Reg/Target.hs +++ b/compiler/GHC/CmmToAsm/Reg/Target.hs @@ -33,7 +33,6 @@ import GHC.Platform import qualified GHC.CmmToAsm.X86.Regs as X86 import qualified GHC.CmmToAsm.X86.RegInfo as X86 import qualified GHC.CmmToAsm.PPC.Regs as PPC -import qualified GHC.CmmToAsm.SPARC.Regs as SPARC import qualified GHC.CmmToAsm.AArch64.Regs as AArch64 @@ -44,7 +43,7 @@ targetVirtualRegSqueeze platform ArchX86_64 -> X86.virtualRegSqueeze ArchPPC -> PPC.virtualRegSqueeze ArchS390X -> panic "targetVirtualRegSqueeze ArchS390X" - ArchSPARC -> SPARC.virtualRegSqueeze + ArchSPARC -> panic "targetVirtualRegSqueeze ArchSPARC" ArchSPARC64 -> panic "targetVirtualRegSqueeze ArchSPARC64" ArchPPC_64 _ -> PPC.virtualRegSqueeze ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" @@ -64,7 +63,7 @@ targetRealRegSqueeze platform ArchX86_64 -> X86.realRegSqueeze ArchPPC -> PPC.realRegSqueeze ArchS390X -> panic "targetRealRegSqueeze ArchS390X" - ArchSPARC -> SPARC.realRegSqueeze + ArchSPARC -> panic "targetRealRegSqueeze ArchSPARC" ArchSPARC64 -> panic "targetRealRegSqueeze ArchSPARC64" ArchPPC_64 _ -> PPC.realRegSqueeze ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" @@ -83,7 +82,7 @@ targetClassOfRealReg platform ArchX86_64 -> X86.classOfRealReg platform ArchPPC -> PPC.classOfRealReg ArchS390X -> panic "targetClassOfRealReg ArchS390X" - ArchSPARC -> SPARC.classOfRealReg + ArchSPARC -> panic "targetClassOfRealReg ArchSPARC" ArchSPARC64 -> panic "targetClassOfRealReg ArchSPARC64" ArchPPC_64 _ -> PPC.classOfRealReg ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" @@ -102,7 +101,7 @@ targetMkVirtualReg platform ArchX86_64 -> X86.mkVirtualReg ArchPPC -> PPC.mkVirtualReg ArchS390X -> panic "targetMkVirtualReg ArchS390X" - ArchSPARC -> SPARC.mkVirtualReg + ArchSPARC -> panic "targetMkVirtualReg ArchSPARC" ArchSPARC64 -> panic "targetMkVirtualReg ArchSPARC64" ArchPPC_64 _ -> PPC.mkVirtualReg ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" @@ -121,7 +120,7 @@ targetRegDotColor platform ArchX86_64 -> X86.regDotColor platform ArchPPC -> PPC.regDotColor ArchS390X -> panic "targetRegDotColor ArchS390X" - ArchSPARC -> SPARC.regDotColor + ArchSPARC -> panic "targetRegDotColor ArchSPARC" ArchSPARC64 -> panic "targetRegDotColor ArchSPARC64" ArchPPC_64 _ -> PPC.regDotColor ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" diff --git a/compiler/GHC/CmmToAsm/SPARC.hs b/compiler/GHC/CmmToAsm/SPARC.hs deleted file mode 100644 index 7d8379371e..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Native code generator for SPARC architectures -module GHC.CmmToAsm.SPARC - ( ncgSPARC - ) -where - -import GHC.Prelude -import GHC.Utils.Panic - -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Config -import GHC.CmmToAsm.Types -import GHC.CmmToAsm.Instr - -import qualified GHC.CmmToAsm.SPARC.Instr as SPARC -import qualified GHC.CmmToAsm.SPARC.Ppr as SPARC -import qualified GHC.CmmToAsm.SPARC.CodeGen as SPARC -import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC -import qualified GHC.CmmToAsm.SPARC.Regs as SPARC -import qualified GHC.CmmToAsm.SPARC.ShortcutJump as SPARC - - -ncgSPARC :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr SPARC.JumpDest -ncgSPARC config = NcgImpl - { ncgConfig = config - , cmmTopCodeGen = SPARC.cmmTopCodeGen - , generateJumpTableForInstr = SPARC.generateJumpTableForInstr platform - , getJumpDestBlockId = SPARC.getJumpDestBlockId - , canShortcut = SPARC.canShortcut - , shortcutStatics = SPARC.shortcutStatics - , shortcutJump = SPARC.shortcutJump - , pprNatCmmDecl = SPARC.pprNatCmmDecl config - , maxSpillSlots = SPARC.maxSpillSlots config - , allocatableRegs = SPARC.allocatableRegs - , ncgExpandTop = map SPARC.expandTop - , ncgMakeFarBranches = const id - , extractUnwindPoints = const [] - , invertCondBranches = \_ _ -> id - -- Allocating more stack space for spilling isn't currently supported for the - -- linear register allocator on SPARC, hence the panic below. - , ncgAllocMoreStack = noAllocMoreStack - } - where - platform = ncgPlatform config - - noAllocMoreStack amount _ - = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n" - ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" - ++ " is a known limitation in the linear allocator.\n" - ++ "\n" - ++ " Try enabling the graph colouring allocator with -fregs-graph instead." - ++ " You can still file a bug report if you like.\n" - - --- | instance for sparc instruction set -instance Instruction SPARC.Instr where - regUsageOfInstr = SPARC.regUsageOfInstr - patchRegsOfInstr = SPARC.patchRegsOfInstr - isJumpishInstr = SPARC.isJumpishInstr - jumpDestsOfInstr = SPARC.jumpDestsOfInstr - patchJumpInstr = SPARC.patchJumpInstr - mkSpillInstr = SPARC.mkSpillInstr - mkLoadInstr = SPARC.mkLoadInstr - takeDeltaInstr = SPARC.takeDeltaInstr - isMetaInstr = SPARC.isMetaInstr - mkRegRegMoveInstr = SPARC.mkRegRegMoveInstr - takeRegRegMoveInstr = SPARC.takeRegRegMoveInstr - mkJumpInstr = SPARC.mkJumpInstr - pprInstr = SPARC.pprInstr - mkComment = pure . SPARC.COMMENT - mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" - mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" diff --git a/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs b/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs deleted file mode 100644 index b99b75f5eb..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs +++ /dev/null @@ -1,44 +0,0 @@ - -module GHC.CmmToAsm.SPARC.AddrMode ( - AddrMode(..), - addrOffset -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Base -import GHC.Platform.Reg - --- addressing modes ------------------------------------------------------------ - --- | Represents a memory address in an instruction. --- Being a RISC machine, the SPARC addressing modes are very regular. --- -data AddrMode - = AddrRegReg Reg Reg -- addr = r1 + r2 - | AddrRegImm Reg Imm -- addr = r1 + imm - - --- | Add an integer offset to the address in an AddrMode. --- -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - AddrRegImm r (ImmInt n) - | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2)) - | otherwise -> Nothing - where n2 = n + off - - AddrRegImm r (ImmInteger n) - | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) - | otherwise -> Nothing - where n2 = n + toInteger off - - AddrRegReg r (RegReal (RealRegSingle 0)) - | fits13Bits off -> Just (AddrRegImm r (ImmInt off)) - | otherwise -> Nothing - - _ -> Nothing diff --git a/compiler/GHC/CmmToAsm/SPARC/Base.hs b/compiler/GHC/CmmToAsm/SPARC/Base.hs deleted file mode 100644 index 14d3069c74..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/Base.hs +++ /dev/null @@ -1,70 +0,0 @@ - --- | Bits and pieces on the bottom of the module dependency tree. --- Also import the required constants, so we know what we're using. --- --- In the interests of cross-compilation, we want to free ourselves --- from the autoconf generated modules like "GHC.Settings.Constants" - -module GHC.CmmToAsm.SPARC.Base ( - wordLength, - wordLengthInBits, - spillSlotSize, - extraStackArgsHere, - fits13Bits, - is32BitInteger, - largeOffsetError -) - -where - -import GHC.Prelude - -import GHC.Utils.Panic - -import Data.Int - - --- On 32 bit SPARC, pointers are 32 bits. -wordLength :: Int -wordLength = 4 - -wordLengthInBits :: Int -wordLengthInBits - = wordLength * 8 - --- | We need 8 bytes because our largest registers are 64 bit. -spillSlotSize :: Int -spillSlotSize = 8 - - --- | We (allegedly) put the first six C-call arguments in registers; --- where do we start putting the rest of them? -extraStackArgsHere :: Int -extraStackArgsHere = 23 - - -{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-} --- | Check whether an offset is representable with 13 bits. -fits13Bits :: Integral a => a -> Bool -fits13Bits x = x >= -4096 && x < 4096 - --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -is32BitInteger :: Integer -> Bool -is32BitInteger i - = i64 <= 0x7fffffff && i64 >= -0x80000000 - where i64 = fromIntegral i :: Int64 - - --- | Sadness. -largeOffsetError :: (Show a) => a -> b -largeOffsetError i - = panic ("ERROR: SPARC native-code generator cannot handle large offset (" - ++ show i ++ ");\nprobably because of large constant data structures;" ++ - "\nworkaround: use -fllvm on this module.\n") - - diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs deleted file mode 100644 index ae8ee37cf9..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ /dev/null @@ -1,739 +0,0 @@ - - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2013 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GADTs #-} -module GHC.CmmToAsm.SPARC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) - -where - --- NCG stuff: -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.SPARC.CodeGen.Sanity -import GHC.CmmToAsm.SPARC.CodeGen.Amode -import GHC.CmmToAsm.SPARC.CodeGen.CondCode -import GHC.CmmToAsm.SPARC.CodeGen.Gen64 -import GHC.CmmToAsm.SPARC.CodeGen.Gen32 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Stack -import GHC.CmmToAsm.Types -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig ) -import GHC.CmmToAsm.Config - --- Our intermediate code: -import GHC.Cmm.BlockId -import GHC.Cmm -import GHC.Cmm.Utils -import GHC.Cmm.Switch -import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Graph -import GHC.CmmToAsm.PIC -import GHC.Platform.Reg -import GHC.Cmm.CLabel -import GHC.CmmToAsm.CPrim - --- The rest: -import GHC.Types.Basic -import GHC.Data.FastString -import GHC.Data.OrdList -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Platform - -import Control.Monad ( mapAndUnzipM ) - --- | Top level code generation -cmmTopCodeGen :: RawCmmDecl - -> NatM [NatCmmDecl RawCmmStatics Instr] - -cmmTopCodeGen (CmmProc info lab live graph) - = do let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - let tops = proc : concat statics - - return tops - -cmmTopCodeGen (CmmData sec dat) = - return [CmmData sec dat] -- no translation, we just use CmmStatic - - --- | Do code generation on a single block of CMM code. --- code generation may introduce new basic block boundaries, which --- are indicated by the NEWBLOCK instruction. We must split up the --- instruction stream into basic blocks again. Also, we extract --- LDATAs here too. -basicBlockCodeGen :: CmmBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl RawCmmStatics Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - platform <- getPlatform - mid_instrs <- stmtsToInstrs stmts - tail_instrs <- stmtToInstrs tail - let instrs = mid_instrs `appOL` tail_instrs - let - (top,other_blocks,statics) - = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - - -- do intra-block sanity checking - blocksChecked - = map (checkBlock platform block) - $ BasicBlock id top : other_blocks - - return (blocksChecked, statics) - - --- | Convert some Cmm statements to SPARC instructions. -stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock -stmtsToInstrs stmts - = do instrss <- mapM stmtToInstrs stmts - return (concatOL instrss) - - -stmtToInstrs :: CmmNode e x -> NatM InstrBlock -stmtToInstrs stmt = do - platform <- getPlatform - config <- getConfig - case stmt of - CmmComment s -> return (unitOL (COMMENT $ ftext s)) - CmmTick {} -> return nilOL - CmmUnwind {} -> return nilOL - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType platform src - format = cmmTypeFormat ty - - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args - - CmmBranch id -> genBranch id - CmmCondBranch arg true false _ -> do - b1 <- genCondJump true arg - b2 <- genBranch false - return (b1 `appOL` b2) - CmmSwitch arg ids -> genSwitch config arg ids - CmmCall { cml_target = arg } -> genJump arg - - _ - -> panic "stmtToInstrs: statement should have been cps'd away" - - -{- -Now, given a tree (the argument to a CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - - - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: Platform -> Maybe BlockId -> CmmStatic -jumpTableEntry platform Nothing = CmmStaticLit (CmmInt 0 (wordWidth platform)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = blockLbl blockid - - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_IntCode pk addr src = do - (srcReg, code) <- getSomeReg src - Amode dstAddr addr_code <- getAmode addr - return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr - - -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_IntCode _ reg src = do - platform <- getPlatform - r <- getRegister src - let dst = getRegisterReg platform reg - return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst - - - --- Floating point assignment to memory -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_FltCode pk addr src = do - platform <- getPlatform - Amode dst__2 code1 <- getAmode addr - (src__2, code2) <- getSomeReg src - tmp1 <- getNewRegNat pk - let - pk__2 = cmmExprType platform src - code__2 = code1 `appOL` code2 `appOL` - if formatToWidth pk == typeWidth pk__2 - then unitOL (ST pk src__2 dst__2) - else toOL [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1 - , ST pk tmp1 dst__2] - return code__2 - --- Floating point assignment to a register/temporary -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_FltCode pk dstCmmReg srcCmmExpr = do - platform <- getPlatform - srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg platform dstCmmReg - - return $ case srcRegister of - Any _ code -> code dstReg - Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg - - - - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock - -genJump (CmmLit (CmmLabel lbl)) - = return (toOL [CALL (Left target) 0 True, NOP]) - where - target = ImmCLbl lbl - -genJump tree - = do - (target, code) <- getSomeReg tree - return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> NatM InstrBlock -genBranch = return . toOL . mkJumpInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. - -SPARC: First, we have to ensure that the condition codes are set -according to the supplied comparison operation. We generate slightly -different code for floating point comparisons, because a floating -point operation cannot directly precede a @BF@. We assume the worst -and fill that slot with a @NOP@. - -SPARC: Do not fill the delay slots here; you will confuse the register -allocator. --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - - - -genCondJump bid bool = do - CondCode is_float cond code <- getCondCode bool - return ( - code `appOL` - toOL ( - if is_float - then [NOP, BF cond False bid, NOP] - else [BI cond False bid, NOP] - ) - ) - - - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch config expr targets - | ncgPIC config - = error "MachCodeGen: sparc genSwitch PIC not finished\n" - - | otherwise - = do (e_reg, e_code) <- getSomeReg indexExpr - - base_reg <- getNewRegNat II32 - offset_reg <- getNewRegNat II32 - dst <- getNewRegNat II32 - - label <- getNewLabelNat - - return $ e_code `appOL` - toOL - [ -- load base of jump table - SETHI (HI (ImmCLbl label)) base_reg - , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg - - -- the addrs in the table are 32 bits wide.. - , SLL e_reg (RIImm $ ImmInt 2) offset_reg - - -- load and jump to the destination - , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label - , NOP ] - where - indexExpr = cmmOffset platform exprWidened offset - -- We widen to a native-width register to santize the high bits - exprWidened = CmmMachOp - (MO_UU_Conv (cmmExprWidth platform expr) - (platformWordWidth platform)) - [expr] - (offset, ids) = switchTargetsToTable targets - platform = ncgPlatform config - -generateJumpTableForInstr :: Platform -> Instr - -> Maybe (NatCmmDecl RawCmmStatics Instr) -generateJumpTableForInstr platform (JMP_TBL _ ids label) = - let jumpTable = map (jumpTableEntry platform) ids - in Just (CmmData (Section ReadOnlyData label) (CmmStaticsRaw label jumpTable)) -generateJumpTableForInstr _ _ = Nothing - - - --- ----------------------------------------------------------------------------- --- Generating C calls - -{- - Now the biggest nightmare---calls. Most of the nastiness is buried in - @get_arg@, which moves the arguments to the correct registers/stack - locations. Apart from that, the code is easy. - - The SPARC calling convention is an absolute - nightmare. The first 6x32 bits of arguments are mapped into - %o0 through %o5, and the remaining arguments are dumped to the - stack, beginning at [%sp+92]. (Note that %o6 == %sp.) - - If we have to put args on the stack, move %o6==%sp down by - the number of words to go on the stack, to ensure there's enough space. - - According to Fraser and Hanson's lcc book, page 478, fig 17.2, - 16 words above the stack pointer is a word for the address of - a structure return value. I use this as a temporary location - for moving values from float to int regs. Certainly it isn't - safe to put anything in the 16 words starting at %sp, since - this area can get trashed at any time due to window overflows - caused by signal handlers. - - A final complication (if the above isn't enough) is that - we can't blithely calculate the arguments one by one into - %o0 .. %o5. Consider the following nested calls: - - fff a (fff b c) - - Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately - the inner call will itself use %o0, which trashes the value put there - in preparation for the outer call. Upshot: we need to calculate the - args into temporary regs, and move those to arg regs or onto the - stack only immediately prior to the call proper. Sigh. --} - -genCCall - :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - - - --- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream --- are guaranteed to take place before writes afterwards (unlike on PowerPC). --- Ref: Section 8.4 of the SPARC V9 Architecture manual. --- --- In the SPARC case we don't need a barrier. --- -genCCall (PrimTarget MO_ReadBarrier) _ _ - = return $ nilOL -genCCall (PrimTarget MO_WriteBarrier) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ - = return $ nilOL - -genCCall target dest_regs args - = do -- work out the arguments, and assign them to integer regs - argcode_and_vregs <- mapM arg_to_int_vregs args - let (argcodes, vregss) = unzip argcode_and_vregs - let vregs = concat vregss - - let n_argRegs = length allArgRegs - let n_argRegs_used = min (length vregs) n_argRegs - - - -- deal with static vs dynamic call targets - callinsns <- case target of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - ForeignTarget expr _ - -> do (dyn_c, dyn_rs) <- arg_to_int_vregs expr - let dyn_r = case dyn_rs of - [dyn_r'] -> dyn_r' - _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - PrimTarget mop - -> do res <- outOfLineMachOp mop - case res of - Left lbl -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - Right mopExpr -> do - (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr - let dyn_r = case dyn_rs of - [dyn_r'] -> dyn_r' - _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - let argcode = concatOL argcodes - - let (move_sp_down, move_sp_up) - = let diff = length vregs - n_argRegs - nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment - in if nn <= 0 - then (nilOL, nilOL) - else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) - - let transfer_code - = toOL (move_final vregs allArgRegs extraStackArgsHere) - - platform <- getPlatform - return - $ argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - move_sp_up `appOL` - assign_code platform dest_regs - - --- | Generate code to calculate an argument, and move it into one --- or two integer vregs. -arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg = do platform <- getPlatform - arg_to_int_vregs' platform arg - -arg_to_int_vregs' :: Platform -> CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs' platform arg - - -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType platform arg) - = do (ChildCode64 code r_lo) <- iselExpr64 arg - let r_hi = getHiVRegFromLo r_lo - return (code, [r_hi, r_lo]) - - | otherwise - = do (src, code) <- getSomeReg arg - let pk = cmmExprType platform arg - - case cmmTypeFormat pk of - - -- Load a 64 bit float return value into two integer regs. - FF64 -> do - v1 <- getNewRegNat II32 - v2 <- getNewRegNat II32 - - let code2 = - code `snocOL` - FMOV FF64 src f0 `snocOL` - ST FF32 f0 (spRel 16) `snocOL` - LD II32 (spRel 16) v1 `snocOL` - ST FF32 f1 (spRel 16) `snocOL` - LD II32 (spRel 16) v2 - - return (code2, [v1,v2]) - - -- Load a 32 bit float return value into an integer reg - FF32 -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - ST FF32 src (spRel 16) `snocOL` - LD II32 (spRel 16) v1 - - return (code2, [v1]) - - -- Move an integer return value into its destination reg. - _ -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - OR False g0 (RIReg src) v1 - - return (code2, [v1]) - - --- | Move args from the integer vregs into which they have been --- marshalled, into %o0 .. %o5, and the rest onto the stack. --- -move_final :: [Reg] -> [Reg] -> Int -> [Instr] - --- all args done -move_final [] _ _ - = [] - --- out of aregs; move to stack -move_final (v:vs) [] offset - = ST II32 v (spRel offset) - : move_final vs [] (offset+1) - --- move into an arg (%o[0..5]) reg -move_final (v:vs) (a:az) offset - = OR False g0 (RIReg v) a - : move_final vs az offset - - --- | Assign results returned from the call into their --- destination regs. --- -assign_code :: Platform -> [LocalReg] -> OrdList Instr - -assign_code _ [] = nilOL - -assign_code platform [dest] - = let rep = localRegType dest - width = typeWidth rep - r_dest = getRegisterReg platform (CmmLocal dest) - - result - | isFloatType rep - , W32 <- width - = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest - - | isFloatType rep - , W64 <- width - = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest - - | not $ isFloatType rep - , W32 <- width - = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest - - | not $ isFloatType rep - , W64 <- width - , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] - - | otherwise - = panic "SPARC.CodeGen.GenCCall: no match" - - in result - -assign_code _ _ - = panic "SPARC.CodeGen.GenCCall: no match" - - - --- | Generate a call to implement an out-of-line floating point operation -outOfLineMachOp - :: CallishMachOp - -> NatM (Either CLabel CmmExpr) - -outOfLineMachOp mop - = do let functionName - = outOfLineMachOp_table mop - - config <- getConfig - mopExpr <- cmmMakeDynamicReference config CallReference - $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction - - let mopLabelOrExpr - = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - - return mopLabelOrExpr - - --- | Decide what C function to use to implement a CallishMachOp --- -outOfLineMachOp_table - :: CallishMachOp - -> FastString - -outOfLineMachOp_table mop - = case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_ExpM1 -> fsLit "expm1f" - MO_F32_Log -> fsLit "logf" - MO_F32_Log1P -> fsLit "log1pf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Fabs -> unsupported - MO_F32_Pwr -> fsLit "powf" - - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F32_Asinh -> fsLit "asinhf" - MO_F32_Acosh -> fsLit "acoshf" - MO_F32_Atanh -> fsLit "atanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_ExpM1 -> fsLit "expm1" - MO_F64_Log -> fsLit "log" - MO_F64_Log1P -> fsLit "log1p" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Fabs -> unsupported - MO_F64_Pwr -> fsLit "pow" - - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_F64_Asinh -> fsLit "asinh" - MO_F64_Acosh -> fsLit "acosh" - MO_F64_Atanh -> fsLit "atanh" - - MO_I64_ToI -> fsLit "hs_int64ToInt" - MO_I64_FromI -> fsLit "hs_intToInt64" - MO_W64_ToW -> fsLit "hs_word64ToWord" - MO_W64_FromW -> fsLit "hs_wordToWord64" - MO_x64_Neg -> fsLit "hs_neg64" - MO_x64_Add -> fsLit "hs_add64" - MO_x64_Sub -> fsLit "hs_sub64" - MO_x64_Mul -> fsLit "hs_mul64" - MO_I64_Quot -> fsLit "hs_quotInt64" - MO_I64_Rem -> fsLit "hs_remInt64" - MO_W64_Quot -> fsLit "hs_quotWord64" - MO_W64_Rem -> fsLit "hs_remWord64" - MO_x64_And -> fsLit "hs_and64" - MO_x64_Or -> fsLit "hs_or64" - MO_x64_Xor -> fsLit "hs_xor64" - MO_x64_Not -> fsLit "hs_not64" - MO_x64_Shl -> fsLit "hs_uncheckedShiftL64" - MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64" - MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64" - MO_x64_Eq -> fsLit "hs_eq64" - MO_x64_Ne -> fsLit "hs_ne64" - MO_I64_Ge -> fsLit "hs_geInt64" - MO_I64_Gt -> fsLit "hs_gtInt64" - MO_I64_Le -> fsLit "hs_leInt64" - MO_I64_Lt -> fsLit "hs_ltInt64" - MO_W64_Ge -> fsLit "hs_geWord64" - MO_W64_Gt -> fsLit "hs_gtWord64" - MO_W64_Le -> fsLit "hs_leWord64" - MO_W64_Lt -> fsLit "hs_ltWord64" - - MO_UF_Conv w -> word2FloatLabel w - - MO_Memcpy _ -> fsLit "memcpy" - MO_Memset _ -> fsLit "memset" - MO_Memmove _ -> fsLit "memmove" - MO_Memcmp _ -> fsLit "memcmp" - - MO_SuspendThread -> fsLit "suspendThread" - MO_ResumeThread -> fsLit "resumeThread" - - MO_BSwap w -> bSwapLabel w - MO_BRev w -> bRevLabel w - MO_PopCnt w -> popCntLabel w - MO_Pdep w -> pdepLabel w - MO_Pext w -> pextLabel w - MO_Clz w -> clzLabel w - MO_Ctz w -> ctzLabel w - MO_AtomicRMW w amop -> atomicRMWLabel w amop - MO_Cmpxchg w -> cmpxchgLabel w - MO_Xchg w -> xchgLabel w - MO_AtomicRead w -> atomicReadLabel w - MO_AtomicWrite w -> atomicWriteLabel w - - MO_S_Mul2 {} -> unsupported - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_AddWordC {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _) -> unsupported - where unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported here") - diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs deleted file mode 100644 index 87fb09d7d6..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs +++ /dev/null @@ -1,74 +0,0 @@ -module GHC.CmmToAsm.SPARC.CodeGen.Amode ( - getAmode -) - -where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Format - -import GHC.Cmm - -import GHC.Data.OrdList - - --- | Generate code to reference a memory address. -getAmode - :: CmmExpr -- ^ expr producing an address - -> NatM Amode - -getAmode tree@(CmmRegOff _ _) - = do platform <- getPlatform - getAmode (mangleIndexTree platform tree) - -getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)]) - | fits13Bits (-i) - = do - (reg, code) <- getSomeReg x - let - off = ImmInt (-(fromInteger i)) - return (Amode (AddrRegImm reg off) code) - - -getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) - | fits13Bits i - = do - (reg, code) <- getSomeReg x - let - off = ImmInt (fromInteger i) - return (Amode (AddrRegImm reg off) code) - -getAmode (CmmMachOp (MO_Add _) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - let - code = codeX `appOL` codeY - return (Amode (AddrRegReg regX regY) code) - -getAmode (CmmLit lit) - = do - let imm__2 = litToImm lit - tmp1 <- getNewRegNat II32 - tmp2 <- getNewRegNat II32 - - let code = toOL [ SETHI (HI imm__2) tmp1 - , OR False tmp1 (RIImm (LO imm__2)) tmp2] - - return (Amode (AddrRegReg tmp2 g0) code) - -getAmode other - = do - (reg, code) <- getSomeReg other - let - off = ImmInt 0 - return (Amode (AddrRegImm reg off) code) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs deleted file mode 100644 index dc132211bc..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs +++ /dev/null @@ -1,119 +0,0 @@ -module GHC.CmmToAsm.SPARC.CodeGen.Base ( - InstrBlock, - CondCode(..), - ChildCode64(..), - Amode(..), - - Register(..), - setFormatOfRegister, - - getRegisterReg, - mangleIndexTree -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.Format -import GHC.Platform.Reg - -import GHC.Platform.Regs -import GHC.Cmm -import GHC.Cmm.Ppr.Expr () -- For Outputable instances -import GHC.Platform - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.OrdList - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - - --- | Condition codes passed up the tree. --- -data CondCode - = CondCode Bool Cond InstrBlock - - --- | a.k.a \"Register64\" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. --- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified --- -data ChildCode64 - = ChildCode64 - InstrBlock - Reg - - --- | Holds code that references a memory address. -data Amode - = Amode - -- the AddrMode we can use in the instruction - -- that does the real load\/store. - AddrMode - - -- other setup code we have to run first before we can use the - -- above AddrMode. - InstrBlock - - - --------------------------------------------------------------------------------- --- | Code to produce a result into a register. --- If the result must go in a specific register, it comes out as Fixed. --- Otherwise, the parent can decide which register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - - --- | Change the format field in a Register. -setFormatOfRegister - :: Register -> Format -> Register - -setFormatOfRegister reg format - = case reg of - Fixed _ reg code -> Fixed format reg code - Any _ codefn -> Any format codefn - - --------------------------------------------------------------------------------- --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> CmmReg -> Reg - -getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) - -getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of - Just reg -> RegReal reg - Nothing -> pprPanic - "SPARC.CodeGen.Base.getRegisterReg: global is in memory" - (ppr $ CmmGlobal mid) - - --- Expand CmmRegOff. ToDo: should we do it this way around, or convert --- CmmExprs into CmmRegOff? -mangleIndexTree :: Platform -> CmmExpr -> CmmExpr - -mangleIndexTree platform (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType platform reg) - -mangleIndexTree _ _ - = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs deleted file mode 100644 index 3ddc23a568..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs +++ /dev/null @@ -1,115 +0,0 @@ -module GHC.CmmToAsm.SPARC.CodeGen.CondCode ( - getCondCode, - condIntCode, - condFltCode -) - -where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Format - -import GHC.Cmm - -import GHC.Data.OrdList -import GHC.Utils.Outputable -import GHC.Utils.Panic - - -getCondCode :: CmmExpr -> NatM CondCode -getCondCode (CmmMachOp mop [x, y]) - = - case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y - MO_F_Ge W32 -> condFltCode GE x y - MO_F_Lt W32 -> condFltCode LTT x y - MO_F_Le W32 -> condFltCode LE x y - - MO_F_Eq W64 -> condFltCode EQQ x y - MO_F_Ne W64 -> condFltCode NE x y - MO_F_Gt W64 -> condFltCode GTT x y - MO_F_Ge W64 -> condFltCode GE x y - MO_F_Lt W64 -> condFltCode LTT x y - MO_F_Le W64 -> condFltCode LE x y - - MO_Eq _ -> condIntCode EQQ x y - MO_Ne _ -> condIntCode NE x y - - MO_S_Gt _ -> condIntCode GTT x y - MO_S_Ge _ -> condIntCode GE x y - MO_S_Lt _ -> condIntCode LTT x y - MO_S_Le _ -> condIntCode LE x y - - MO_U_Gt _ -> condIntCode GU x y - MO_U_Ge _ -> condIntCode GEU x y - MO_U_Lt _ -> condIntCode LU x y - MO_U_Le _ -> condIntCode LEU x y - - _ -> do - platform <- getPlatform - pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform (CmmMachOp mop [x,y])) - -getCondCode other = do - platform <- getPlatform - pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform other) - - - - - --- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be --- passed back up the tree. - -condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condIntCode cond x (CmmLit (CmmInt y _)) - | fits13Bits y - = do - (src1, code) <- getSomeReg x - let - src2 = ImmInt (fromInteger y) - code' = code `snocOL` SUB False True src1 (RIImm src2) g0 - return (CondCode False cond code') - -condIntCode cond x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 = code1 `appOL` code2 `snocOL` - SUB False True src1 (RIReg src2) g0 - return (CondCode False cond code__2) - - -condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condFltCode cond x y = do - platform <- getPlatform - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - tmp <- getNewRegNat FF64 - let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType platform x - pk2 = cmmExprType platform y - - code__2 = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - FCMP True (cmmTypeFormat pk1) src1 src2 - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - FCMP True FF64 tmp src2 - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - FCMP True FF64 src1 tmp - return (CondCode True cond code__2) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs deleted file mode 100644 index a36f893ce3..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | Expand out synthetic instructions into single machine instrs. -module GHC.CmmToAsm.SPARC.CodeGen.Expand ( - expandTop -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Types -import GHC.Cmm - -import GHC.Platform.Reg - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.OrdList - --- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr -expandTop top@(CmmData{}) - = top - -expandTop (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map expandBlock blocks) - - --- | Expand out synthetic instructions in this block -expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr - -expandBlock (BasicBlock label instrs) - = let instrs_ol = expandBlockInstrs instrs - instrs' = fromOL instrs_ol - in BasicBlock label instrs' - - --- | Expand out some instructions -expandBlockInstrs :: [Instr] -> OrdList Instr -expandBlockInstrs [] = nilOL - -expandBlockInstrs (ii:is) - = let ii_doubleRegs = remapRegPair ii - is_misaligned = expandMisalignedDoubles ii_doubleRegs - - in is_misaligned `appOL` expandBlockInstrs is - - - --- | In the SPARC instruction set the FP register pairs that are used --- to hold 64 bit floats are referred to by just the first reg --- of the pair. Remap our internal reg pairs to the appropriate reg. --- --- For example: --- ldd [%l1], (%f0 | %f1) --- --- gets mapped to --- ldd [$l1], %f0 --- -remapRegPair :: Instr -> Instr -remapRegPair instr - = let patchF reg - = case reg of - RegReal (RealRegSingle _) - -> reg - - RegReal (RealRegPair r1 r2) - - -- sanity checking - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - , r2 == r1 + 1 - -> RegReal (RealRegSingle r1) - - | otherwise - -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) - - RegVirtual _ - -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) - - in patchRegsOfInstr instr patchF - - - - --- Expand out 64 bit load/stores into individual instructions to handle --- possible double alignment problems. --- --- TODO: It'd be better to use a scratch reg instead of the add/sub thing. --- We might be able to do this faster if we use the UA2007 instr set --- instead of restricting ourselves to SPARC V9. --- -expandMisalignedDoubles :: Instr -> OrdList Instr -expandMisalignedDoubles instr - - -- Translate to: - -- add g1,g2,g1 - -- ld [g1],%fn - -- ld [g1+4],%f(n+1) - -- sub g1,g2,g1 -- to restore g1 - | LD FF64 (AddrRegReg r1 r2) fReg <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , LD FF32 (AddrRegReg r1 g0) fReg - , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | LD FF64 addr fReg <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ LD FF32 addr fReg - , LD FF32 addr' (fRegHi fReg) ] - - -- Translate to: - -- add g1,g2,g1 - -- st %fn,[g1] - -- st %f(n+1),[g1+4] - -- sub g1,g2,g1 -- to restore g1 - | ST FF64 fReg (AddrRegReg r1 r2) <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , ST FF32 fReg (AddrRegReg r1 g0) - , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | ST FF64 fReg addr <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ ST FF32 fReg addr - , ST FF32 (fRegHi fReg) addr' ] - - -- some other instr - | otherwise - = unitOL instr - - - --- | The high partner for this float reg. -fRegHi :: Reg -> Reg -fRegHi (RegReal (RealRegSingle r1)) - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - = (RegReal $ RealRegSingle (r1 + 1)) - --- Can't take high partner for non-low reg. -fRegHi reg - = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs deleted file mode 100644 index f07cbec9a8..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs +++ /dev/null @@ -1,690 +0,0 @@ --- | Evaluation of 32 bit values. -module GHC.CmmToAsm.SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.CodeGen.CondCode -import GHC.CmmToAsm.SPARC.CodeGen.Amode -import GHC.CmmToAsm.SPARC.CodeGen.Gen64 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.Stack -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Format -import GHC.Platform.Reg - -import GHC.Cmm - -import Control.Monad (liftM) -import GHC.Data.OrdList -import GHC.Utils.Panic - --- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - - - --- | Make code to evaluate a 32 bit expression. --- -getRegister :: CmmExpr -> NatM Register - -getRegister (CmmReg reg) - = do platform <- getPlatform - return (Fixed (cmmTypeFormat (cmmRegType platform reg)) - (getRegisterReg platform reg) nilOL) - -getRegister tree@(CmmRegOff _ _) - = do platform <- getPlatform - getRegister (mangleIndexTree platform tree) - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - - --- Load a literal float into a float register. --- The actual literal is stored in a new data area, and we load it --- at runtime. -getRegister (CmmLit (CmmFloat f W32)) = do - - -- a label for the new data area - lbl <- getNewLabelNat - tmp <- getNewRegNat II32 - - let code dst = toOL [ - -- the data area - LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl - [CmmStaticLit (CmmFloat f W32)], - - -- load the literal - SETHI (HI (ImmCLbl lbl)) tmp, - LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - - return (Any FF32 code) - -getRegister (CmmLit (CmmFloat d W64)) = do - lbl <- getNewLabelNat - tmp <- getNewRegNat II32 - let code dst = toOL [ - LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl - [CmmStaticLit (CmmFloat d W64)], - SETHI (HI (ImmCLbl lbl)) tmp, - LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - return (Any FF64 code) - - --- Unary machine ops -getRegister (CmmMachOp mop [x]) - = case mop of - -- Floating point negation ------------------------- - MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x - MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x - - - -- Integer negation -------------------------------- - MO_S_Neg rep -> trivialUCode (intFormat rep) (SUB False False g0) x - MO_Not rep -> trivialUCode (intFormat rep) (XNOR False g0) x - - - -- Float word size conversion ---------------------- - MO_FF_Conv W64 W32 -> coerceDbl2Flt x - MO_FF_Conv W32 W64 -> coerceFlt2Dbl x - - - -- Float <-> Signed Int conversion ----------------- - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x - - - -- Unsigned integer word size conversions ---------- - - -- If it's the same size, then nothing needs to be done. - MO_UU_Conv from to - | from == to -> conversionNop (intFormat to) x - - -- To narrow an unsigned word, mask out the high bits to simulate what would - -- happen if we copied the value into a smaller register. - MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - - -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 - -- case because the only way we can load it is via SETHI, which needs 2 ops. - -- Do some shifts to chop out the high bits instead. - MO_UU_Conv W32 W16 - -> do tmpReg <- getNewRegNat II32 - (xReg, xCode) <- getSomeReg x - let code dst - = xCode - `appOL` toOL - [ SLL xReg (RIImm $ ImmInt 16) tmpReg - , SRL tmpReg (RIImm $ ImmInt 16) dst] - - return $ Any II32 code - - -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - - -- To widen an unsigned word we don't have to do anything. - -- Just leave it in the same register and mark the result as the new size. - MO_UU_Conv W8 W16 -> conversionNop (intFormat W16) x - MO_UU_Conv W8 W32 -> conversionNop (intFormat W32) x - MO_UU_Conv W16 W32 -> conversionNop (intFormat W32) x - - - -- Signed integer word size conversions ------------ - - -- Mask out high bits when narrowing them - MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - - -- Sign extend signed words when widening them. - MO_SS_Conv W8 W16 -> integerExtend W8 W16 x - MO_SS_Conv W8 W32 -> integerExtend W8 W32 x - MO_SS_Conv W16 W32 -> integerExtend W16 W32 x - - _ -> panic ("Unknown unary mach op: " ++ show mop) - - --- Binary machine ops -getRegister (CmmMachOp mop [x, y]) - = case mop of - MO_Eq _ -> condIntReg EQQ x y - MO_Ne _ -> condIntReg NE x y - - MO_S_Gt _ -> condIntReg GTT x y - MO_S_Ge _ -> condIntReg GE x y - MO_S_Lt _ -> condIntReg LTT x y - MO_S_Le _ -> condIntReg LE x y - - MO_U_Gt W32 -> condIntReg GU x y - MO_U_Ge W32 -> condIntReg GEU x y - MO_U_Lt W32 -> condIntReg LU x y - MO_U_Le W32 -> condIntReg LEU x y - - MO_U_Gt W16 -> condIntReg GU x y - MO_U_Ge W16 -> condIntReg GEU x y - MO_U_Lt W16 -> condIntReg LU x y - MO_U_Le W16 -> condIntReg LEU x y - - MO_Add W32 -> trivialCode W32 (ADD False False) x y - MO_Sub W32 -> trivialCode W32 (SUB False False) x y - - MO_S_MulMayOflo rep -> imulMayOflo rep x y - - MO_S_Quot W32 -> idiv True False x y - MO_U_Quot W32 -> idiv False False x y - - MO_S_Rem W32 -> irem True x y - MO_U_Rem W32 -> irem False x y - - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y - - MO_F_Gt _ -> condFltReg GTT x y - MO_F_Ge _ -> condFltReg GE x y - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y - - MO_F_Add w -> trivialFCode w FADD x y - MO_F_Sub w -> trivialFCode w FSUB x y - MO_F_Mul w -> trivialFCode w FMUL x y - MO_F_Quot w -> trivialFCode w FDIV x y - - MO_And rep -> trivialCode rep (AND False) x y - MO_Or rep -> trivialCode rep (OR False) x y - MO_Xor rep -> trivialCode rep (XOR False) x y - - MO_Mul rep -> trivialCode rep (SMUL False) x y - - MO_Shl rep -> trivialCode rep SLL x y - MO_U_Shr rep -> trivialCode rep SRL x y - MO_S_Shr rep -> trivialCode rep SRA x y - - _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) - -getRegister (CmmLoad mem pk) = do - Amode src code <- getAmode mem - let - code__2 dst = code `snocOL` LD (cmmTypeFormat pk) src dst - return (Any (cmmTypeFormat pk) code__2) - -getRegister (CmmLit (CmmInt i _)) - | fits13Bits i - = let - src = ImmInt (fromInteger i) - code dst = unitOL (OR False g0 (RIImm src) dst) - in - return (Any II32 code) - -getRegister (CmmLit lit) - = let imm = litToImm lit - code dst = toOL [ - SETHI (HI imm) dst, - OR False dst (RIImm (LO imm)) dst] - in return (Any II32 code) - - -getRegister _ - = panic "SPARC.CodeGen.Gen32.getRegister: no match" - - --- | sign extend and widen -integerExtend - :: Width -- ^ width of source expression - -> Width -- ^ width of result - -> CmmExpr -- ^ source expression - -> NatM Register - -integerExtend from to expr - = do -- load the expr into some register - (reg, e_code) <- getSomeReg expr - tmp <- getNewRegNat II32 - let bitCount - = case (from, to) of - (W8, W32) -> 24 - (W16, W32) -> 16 - (W8, W16) -> 24 - _ -> panic "SPARC.CodeGen.Gen32: no match" - let code dst - = e_code - - -- local shift word left to load the sign bit - `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp - - -- arithmetic shift right to sign extend - `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst - - return (Any (intFormat to) code) - - --- | For nop word format conversions we set the resulting value to have the --- required size, but don't need to generate any actual code. --- -conversionNop - :: Format -> CmmExpr -> NatM Register - -conversionNop new_rep expr - = do e_code <- getRegister expr - return (setFormatOfRegister e_code new_rep) - - - --- | Generate an integer division instruction. -idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned division with a 32 bit numerator, --- we can just clear the Y register. -idiv False cc x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - - --- For _signed_ division with a 32 bit numerator, --- we have to sign extend the numerator into the Y register. -idiv True cc x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend - , SRA tmp (RIImm (ImmInt 16)) tmp - - , WRY tmp g0 - , SDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - - --- | Do an integer remainder. --- --- NOTE: The SPARC v8 architecture manual says that integer division --- instructions _may_ generate a remainder, depending on the implementation. --- If so it is _recommended_ that the remainder is placed in the Y register. --- --- The UltraSparc 2007 manual says Y is _undefined_ after division. --- --- The SPARC T2 doesn't store the remainder, not sure about the others. --- It's probably best not to worry about it, and just generate our own --- remainders. --- -irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned operands: --- Division is between a 64 bit numerator and a 32 bit denominator, --- so we still have to clear the Y register. -irem False x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV False a_reg (RIReg b_reg) tmp_reg - , UMUL False tmp_reg (RIReg b_reg) tmp_reg - , SUB False False a_reg (RIReg tmp_reg) dst] - - return (Any II32 code) - - - --- For signed operands: --- Make sure to sign extend into the Y register, or the remainder --- will have the wrong sign when the numerator is negative. --- --- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, --- not the full 32. Not sure why this is, something to do with overflow? --- If anyone cares enough about the speed of signed remainder they --- can work it out themselves (then tell me). -- BL 2009/01/20 -irem True x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp1_reg <- getNewRegNat II32 - tmp2_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , WRY tmp1_reg g0 - - , SDIV False a_reg (RIReg b_reg) tmp2_reg - , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg - , SUB False False a_reg (RIReg tmp2_reg) dst] - - return (Any II32 code) - - -imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register -imulMayOflo rep a b - = do - (a_reg, a_code) <- getSomeReg a - (b_reg, b_code) <- getSomeReg b - res_lo <- getNewRegNat II32 - res_hi <- getNewRegNat II32 - - let shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" - - let code dst = a_code `appOL` b_code `appOL` - toOL [ - SMUL False a_reg (RIReg b_reg) res_lo, - RDY res_hi, - SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, - SUB False False res_lo (RIReg res_hi) dst - ] - return (Any II32 code) - - --- ----------------------------------------------------------------------------- --- 'trivial*Code': deal with trivial instructions - --- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', --- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. --- Only look for constants on the right hand side, because that's --- where the generic optimizer will have put them. - --- Similarly, for unary instructions, we don't have to worry about --- matching an StInt as the argument, because genericOpt will already --- have handled the constant-folding. - -trivialCode - :: Width - -> (Reg -> RI -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialCode _ instr x (CmmLit (CmmInt y _)) - | fits13Bits y - = do - (src1, code) <- getSomeReg x - let - src2 = ImmInt (fromInteger y) - code__2 dst = code `snocOL` instr src1 (RIImm src2) dst - return (Any II32 code__2) - - -trivialCode _ instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `snocOL` - instr src1 (RIReg src2) dst - return (Any II32 code__2) - - -trivialFCode - :: Width - -> (Format -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialFCode pk instr x y = do - platform <- getPlatform - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - tmp <- getNewRegNat FF64 - let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType platform x - pk2 = cmmExprType platform y - - code__2 dst = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - instr (floatFormat pk) src1 src2 dst - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - instr FF64 tmp src2 dst - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - instr FF64 src1 tmp dst - return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) - code__2) - - - -trivialUCode - :: Format - -> (RI -> Reg -> Instr) - -> CmmExpr - -> NatM Register - -trivialUCode format instr x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `snocOL` instr (RIReg src) dst - return (Any format code__2) - - -trivialUFCode - :: Format - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register - -trivialUFCode pk instr x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `snocOL` instr src dst - return (Any pk code__2) - - - - --- Coercions ------------------------------------------------------------------- - --- | Coerce a integer value to floating point -coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP width1 width2 x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - ST (intFormat width1) src (spRel (-2)), - LD (intFormat width1) (spRel (-2)) dst, - FxTOy (intFormat width1) (floatFormat width2) dst dst] - return (Any (floatFormat $ width2) code__2) - - - --- | Coerce a floating point value to integer --- --- NOTE: On sparc v9 there are no instructions to move a value from an --- FP register directly to an int register, so we have to use a load/store. --- -coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int width1 width2 x - = do let fformat1 = floatFormat width1 - fformat2 = floatFormat width2 - - iformat2 = intFormat width2 - - (fsrc, code) <- getSomeReg x - fdst <- getNewRegNat fformat2 - - let code2 dst - = code - `appOL` toOL - -- convert float to int format, leaving it in a float reg. - [ FxTOy fformat1 iformat2 fsrc fdst - - -- store the int into mem, then load it back to move - -- it into an actual int reg. - , ST fformat2 fdst (spRel (-2)) - , LD iformat2 (spRel (-2)) dst] - - return (Any iformat2 code2) - - --- | Coerce a double precision floating point value to single precision. -coerceDbl2Flt :: CmmExpr -> NatM Register -coerceDbl2Flt x = do - (src, code) <- getSomeReg x - return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) - - --- | Coerce a single precision floating point value to double precision -coerceFlt2Dbl :: CmmExpr -> NatM Register -coerceFlt2Dbl x = do - (src, code) <- getSomeReg x - return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst)) - - - - --- Condition Codes ------------------------------------------------------------- --- --- Evaluate a comparison, and get the result into a register. --- --- Do not fill the delay slots here. you will confuse the register allocator. --- -condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - return (Any II32 code__2) - -condIntReg EQQ x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - return (Any II32 code__2) - -condIntReg NE x (CmmLit (CmmInt 0 _)) = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - return (Any II32 code__2) - -condIntReg NE x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - return (Any II32 code__2) - -condIntReg cond x y = do - bid1 <- liftM (\a -> seq a a) getBlockIdNat - bid2 <- liftM (\a -> seq a a) getBlockIdNat - CondCode _ cond cond_code <- condIntCode cond x y - let - code__2 dst - = cond_code - `appOL` toOL - [ BI cond False bid1 - , NOP - - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid2] - - return (Any II32 code__2) - - -condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condFltReg cond x y = do - bid1 <- liftM (\a -> seq a a) getBlockIdNat - bid2 <- liftM (\a -> seq a a) getBlockIdNat - - CondCode _ cond cond_code <- condFltCode cond x y - let - code__2 dst - = cond_code - `appOL` toOL - [ NOP - , BF cond False bid1 - , NOP - - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid2 ] - - return (Any II32 code__2) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot deleted file mode 100644 index cf9553a63c..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ - -module GHC.CmmToAsm.SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister -) - -where - -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.Monad -import GHC.Platform.Reg - -import GHC.Cmm - -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getRegister :: CmmExpr -> NatM Register diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs deleted file mode 100644 index f4c1f6db88..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +++ /dev/null @@ -1,214 +0,0 @@ --- | Evaluation of 64 bit values on 32 bit platforms. -module GHC.CmmToAsm.SPARC.CodeGen.Gen64 ( - assignMem_I64Code, - assignReg_I64Code, - iselExpr64 -) - -where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.CodeGen.Amode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Format -import GHC.Platform.Reg - -import GHC.Cmm - -import GHC.Data.OrdList -import GHC.Utils.Outputable -import GHC.Utils.Panic - --- | Code to assign a 64 bit value to memory. -assignMem_I64Code - :: CmmExpr -- ^ expr producing the destination address - -> CmmExpr -- ^ expr producing the source value. - -> NatM InstrBlock - -assignMem_I64Code addrTree valueTree - = do - ChildCode64 vcode rlo <- iselExpr64 valueTree - - (src, acode) <- getSomeReg addrTree - let - rhi = getHiVRegFromLo rlo - - -- Big-endian store - mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0)) - mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4)) - - code = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo - -{- pprTrace "assignMem_I64Code" - (vcat [ text "addrTree: " <+> ppr addrTree - , text "valueTree: " <+> ppr valueTree - , text "vcode:" - , vcat $ map ppr $ fromOL vcode - , text "" - , text "acode:" - , vcat $ map ppr $ fromOL acode ]) - $ -} - return code - - --- | Code to assign a 64 bit value to a register. -assignReg_I64Code - :: CmmReg -- ^ the destination register - -> CmmExpr -- ^ expr producing the source value - -> NatM InstrBlock - -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree - = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let - r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk) - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - - return (vcode `snocOL` mov_hi `snocOL` mov_lo) - -assignReg_I64Code _ _ - = panic "assignReg_I64Code(sparc): invalid lvalue" - - - - --- | Get the value of an expression into a 64 bit register. - -iselExpr64 :: CmmExpr -> NatM ChildCode64 - --- Load a 64 bit word -iselExpr64 (CmmLoad addrTree ty) - | isWord64 ty - = do Amode amode addr_code <- getAmode addrTree - let result - - | AddrRegReg r1 r2 <- amode - = do rlo <- getNewRegNat II32 - tmp <- getNewRegNat II32 - let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code - `appOL` toOL - [ ADD False False r1 (RIReg r2) tmp - , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi - , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ]) - rlo - - | AddrRegImm r1 (ImmInt i) <- amode - = do rlo <- getNewRegNat II32 - let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code - `appOL` toOL - [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi - , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ]) - rlo - - | otherwise - = panic "SPARC.CodeGen.Gen64: no match" - - result - - --- Add a literal to a 64 bit integer -iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) - = do ChildCode64 code1 r1_lo <- iselExpr64 e1 - let r1_hi = getHiVRegFromLo r1_lo - - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - let code = code1 - `appOL` toOL - [ ADD False True r1_lo (RIImm (ImmInteger i)) r_dst_lo - , ADD True False r1_hi (RIReg g0) r_dst_hi ] - - return $ ChildCode64 code r_dst_lo - - --- Addition of II64 -iselExpr64 (CmmMachOp (MO_Add _) [e1, e2]) - = do ChildCode64 code1 r1_lo <- iselExpr64 e1 - let r1_hi = getHiVRegFromLo r1_lo - - ChildCode64 code2 r2_lo <- iselExpr64 e2 - let r2_hi = getHiVRegFromLo r2_lo - - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - let code = code1 - `appOL` code2 - `appOL` toOL - [ ADD False True r1_lo (RIReg r2_lo) r_dst_lo - , ADD True False r1_hi (RIReg r2_hi) r_dst_hi ] - - return $ ChildCode64 code r_dst_lo - - -iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) - | isWord64 ty - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = RegVirtual $ mkVirtualReg uq II32 - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - return ( - ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo - ) - --- Convert something into II64 -iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - -- compute expr and load it into r_dst_lo - (a_reg, a_code) <- getSomeReg expr - - platform <- getPlatform - let code = a_code - `appOL` toOL - [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits - , mkRegRegMoveInstr platform a_reg r_dst_lo ] - - return $ ChildCode64 code r_dst_lo - --- only W32 supported for now -iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - -- compute expr and load it into r_dst_lo - (a_reg, a_code) <- getSomeReg expr - - platform <- getPlatform - let code = a_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi - , mkRegRegMoveInstr platform a_reg r_dst_lo ] - - return $ ChildCode64 code r_dst_lo - - -iselExpr64 expr - = do - platform <- getPlatform - pprPanic "iselExpr64(sparc)" (pdoc platform expr) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs deleted file mode 100644 index 2284c4cb81..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | One ounce of sanity checking is worth 10000000000000000 ounces --- of staring blindly at assembly code trying to find the problem.. -module GHC.CmmToAsm.SPARC.CodeGen.Sanity ( - checkBlock -) - -where - -import GHC.Prelude -import GHC.Platform - -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Ppr () -- For Outputable instances -import GHC.CmmToAsm.Types - -import GHC.Cmm - -import GHC.Utils.Outputable -import GHC.Utils.Panic - - --- | Enforce intra-block invariants. --- -checkBlock :: Platform - -> CmmBlock - -> NatBasicBlock Instr - -> NatBasicBlock Instr - -checkBlock platform cmm block@(BasicBlock _ instrs) - | checkBlockInstrs instrs - = block - - | otherwise - = pprPanic - ("SPARC.CodeGen: bad block\n") - ( vcat [ text " -- cmm -----------------\n" - , pdoc platform cmm - , text " -- native code ---------\n" - , pdoc platform block ]) - - -checkBlockInstrs :: [Instr] -> Bool -checkBlockInstrs ii - - -- An unconditional jumps end the block. - -- There must be an unconditional jump in the block, otherwise - -- the register liveness determinator will get the liveness - -- information wrong. - -- - -- If the block ends with a cmm call that never returns - -- then there can be unreachable instructions after the jump, - -- but we don't mind here. - -- - | instr : NOP : _ <- ii - , isUnconditionalJump instr - = True - - -- All jumps must have a NOP in their branch delay slot. - -- The liveness determinator and register allocators aren't smart - -- enough to handle branch delay slots. - -- - | instr : NOP : is <- ii - , isJumpishInstr instr - = checkBlockInstrs is - - -- keep checking - | _:i2:is <- ii - = checkBlockInstrs (i2:is) - - -- this block is no good - | otherwise - = False diff --git a/compiler/GHC/CmmToAsm/SPARC/Cond.hs b/compiler/GHC/CmmToAsm/SPARC/Cond.hs deleted file mode 100644 index 01d5baad75..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/Cond.hs +++ /dev/null @@ -1,27 +0,0 @@ -module GHC.CmmToAsm.SPARC.Cond ( - Cond(..), -) - -where - -import GHC.Prelude - --- | Branch condition codes. -data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | NEVER - | POS - | VC - | VS - deriving Eq diff --git a/compiler/GHC/CmmToAsm/SPARC/Imm.hs b/compiler/GHC/CmmToAsm/SPARC/Imm.hs deleted file mode 100644 index 35ff7a31cd..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/Imm.hs +++ /dev/null @@ -1,68 +0,0 @@ -module GHC.CmmToAsm.SPARC.Imm ( - -- immediate values - Imm(..), - strImmLit, - litToImm -) - -where - -import GHC.Prelude - -import GHC.Cmm -import GHC.Cmm.CLabel - -import GHC.Utils.Outputable -import GHC.Utils.Panic - --- | An immediate value. --- Not all of these are directly representable by the machine. --- Things like ImmLit are slurped out and put in a data segment instead. --- -data Imm - = ImmInt Int - - -- Sigh. - | ImmInteger Integer - - -- AbstractC Label (with baggage) - | ImmCLbl CLabel - - -- Simple string - | ImmLit SDoc - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - - | LO Imm - | HI Imm - - --- | Create a ImmLit containing this string. -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) - - --- | Convert a CmmLit to an Imm. --- Narrow to the width: a CmmInt might be out of --- range, but we assume that ImmInteger only contains --- in-range values. A signed value should be fine here. --- -litToImm :: CmmLit -> Imm -litToImm lit - = case lit of - CmmInt i w -> ImmInteger (narrowS w i) - CmmFloat f W32 -> ImmFloat f - CmmFloat f W64 -> ImmDouble f - CmmLabel l -> ImmCLbl l - CmmLabelOff l off -> ImmIndex l off - - CmmLabelDiffOff l1 l2 off _ - -> ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) - - _ -> panic "SPARC.Regs.litToImm: no match" diff --git a/compiler/GHC/CmmToAsm/SPARC/Instr.hs b/compiler/GHC/CmmToAsm/SPARC/Instr.hs deleted file mode 100644 index 6881b06de0..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/Instr.hs +++ /dev/null @@ -1,470 +0,0 @@ - - ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ -module GHC.CmmToAsm.SPARC.Instr - ( Instr(..) - , RI(..) - , riZero - , fpRelEA - , moveSp - , isUnconditionalJump - , maxSpillSlots - , patchRegsOfInstr - , patchJumpInstr - , mkRegRegMoveInstr - , mkLoadInstr - , mkSpillInstr - , mkJumpInstr - , takeDeltaInstr - , isMetaInstr - , isJumpishInstr - , jumpDestsOfInstr - , takeRegRegMoveInstr - , regUsageOfInstr - ) -where - -import GHC.Prelude -import GHC.Platform - -import GHC.CmmToAsm.SPARC.Stack -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.Reg.Target -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Config -import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) - -import GHC.Platform.Reg.Class -import GHC.Platform.Reg -import GHC.Platform.Regs - -import GHC.Cmm.CLabel -import GHC.Cmm.BlockId -import GHC.Cmm -import GHC.Utils.Outputable -import GHC.Utils.Panic - - --- | Register or immediate -data RI - = RIReg Reg - | RIImm Imm - --- | Check if a RI represents a zero value. --- - a literal zero --- - register %g0, which is always zero. --- -riZero :: RI -> Bool -riZero (RIImm (ImmInt 0)) = True -riZero (RIImm (ImmInteger 0)) = True -riZero (RIReg (RegReal (RealRegSingle 0))) = True -riZero _ = False - - --- | Calculate the effective address which would be used by the --- corresponding fpRel sequence. -fpRelEA :: Int -> Reg -> Instr -fpRelEA n dst - = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst - - --- | Code to shift the stack pointer by n words. -moveSp :: Int -> Instr -moveSp n - = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp - --- | An instruction that will cause the one after it never to be exectuted -isUnconditionalJump :: Instr -> Bool -isUnconditionalJump ii - = case ii of - CALL{} -> True - JMP{} -> True - JMP_TBL{} -> True - BI ALWAYS _ _ -> True - BF ALWAYS _ _ -> True - _ -> False - - --- | SPARC instruction set. --- Not complete. This is only the ones we need. --- -data Instr - - -- meta ops -------------------------------------------------- - -- comment pseudo-op - = COMMENT SDoc - - -- some static data spat out during code generation. - -- Will be extracted before pretty-printing. - | LDATA Section RawCmmStatics - - -- Start a new basic block. Useful during codegen, removed later. - -- Preceding instruction should be a jump, as per the invariants - -- for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for benefit of subsequent passes. - | DELTA Int - - -- real instrs ----------------------------------------------- - -- Loads and stores. - | LD Format AddrMode Reg -- format, src, dst - | ST Format Reg AddrMode -- format, src, dst - - -- Int Arithmetic. - -- x: add/sub with carry bit. - -- In SPARC V9 addx and friends were renamed addc. - -- - -- cc: modify condition codes - -- - | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - - | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst - | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst - - - -- The SPARC divide instructions perform 64bit by 32bit division - -- The Y register is xored into the first operand. - - -- On _some implementations_ the Y register is overwritten by - -- the remainder, so we have to make sure it is 0 each time. - - -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 - | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst - | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst - - | RDY Reg -- move contents of Y register to reg - | WRY Reg Reg -- Y <- src1 `xor` src2 - - -- Logic operations. - | AND Bool Reg RI Reg -- cc?, src1, src2, dst - | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst - | OR Bool Reg RI Reg -- cc?, src1, src2, dst - | ORN Bool Reg RI Reg -- cc?, src1, src2, dst - | XOR Bool Reg RI Reg -- cc?, src1, src2, dst - | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst - | SLL Reg RI Reg -- src1, src2, dst - | SRL Reg RI Reg -- src1, src2, dst - | SRA Reg RI Reg -- src1, src2, dst - - -- Load immediates. - | SETHI Imm Reg -- src, dst - - -- Do nothing. - -- Implemented by the assembler as SETHI 0, %g0, but worth an alias - | NOP - - -- Float Arithmetic. - -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single - -- instructions right up until we spit them out. - -- - | FABS Format Reg Reg -- src dst - | FADD Format Reg Reg Reg -- src1, src2, dst - | FCMP Bool Format Reg Reg -- exception?, src1, src2, dst - | FDIV Format Reg Reg Reg -- src1, src2, dst - | FMOV Format Reg Reg -- src, dst - | FMUL Format Reg Reg Reg -- src1, src2, dst - | FNEG Format Reg Reg -- src, dst - | FSQRT Format Reg Reg -- src, dst - | FSUB Format Reg Reg Reg -- src1, src2, dst - | FxTOy Format Format Reg Reg -- src, dst - - -- Jumping around. - | BI Cond Bool BlockId -- cond, annul?, target - | BF Cond Bool BlockId -- cond, annul?, target - - | JMP AddrMode -- target - - -- With a tabled jump we know all the possible destinations. - -- We also need this info so we can work out what regs are live across the jump. - -- - | JMP_TBL AddrMode [Maybe BlockId] CLabel - - | CALL (Either Imm Reg) Int Bool -- target, args, terminal - - --- | regUsage returns the sets of src and destination registers used --- by a particular instruction. Machine registers that are --- pre-allocated to stgRegs are filtered out, because they are --- uninteresting from a register allocation standpoint. (We wouldn't --- want them to end up on the free list!) As far as we are concerned, --- the fixed registers simply don't exist (for allocation purposes, --- anyway). - --- regUsage doesn't need to do any trickery for jumps and such. Just --- state precisely the regs read and written by that insn. The --- consequences of control flow transfers, as far as register --- allocation goes, are taken care of by the register allocator. --- -regUsageOfInstr :: Platform -> Instr -> RegUsage -regUsageOfInstr platform instr - = case instr of - LD _ addr reg -> usage (regAddr addr, [reg]) - ST _ reg addr -> usage (reg : regAddr addr, []) - ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - RDY rd -> usage ([], [rd]) - WRY r1 r2 -> usage ([r1, r2], []) - AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SETHI _ reg -> usage ([], [reg]) - FABS _ r1 r2 -> usage ([r1], [r2]) - FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FCMP _ _ r1 r2 -> usage ([r1, r2], []) - FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV _ r1 r2 -> usage ([r1], [r2]) - FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FNEG _ r1 r2 -> usage ([r1], [r2]) - FSQRT _ r1 r2 -> usage ([r1], [r2]) - FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FxTOy _ _ r1 r2 -> usage ([r1], [r2]) - - JMP addr -> usage (regAddr addr, []) - JMP_TBL addr _ _ -> usage (regAddr addr, []) - - CALL (Left _ ) _ True -> noUsage - CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) - CALL (Right reg) _ True -> usage ([reg], []) - CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) - _ -> noUsage - - where - usage (src, dst) - = RU (filter (interesting platform) src) - (filter (interesting platform) dst) - - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] - - regRI (RIReg r) = [r] - regRI _ = [] - - --- | Interesting regs are virtuals, or ones that are allocatable --- by the register allocator. -interesting :: Platform -> Reg -> Bool -interesting platform reg - = case reg of - RegVirtual _ -> True - RegReal (RealRegSingle r1) -> freeReg platform r1 - RegReal (RealRegPair r1 _) -> freeReg platform r1 - - - --- | Apply a given mapping to tall the register references in this instruction. -patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr -patchRegsOfInstr instr env = case instr of - LD fmt addr reg -> LD fmt (fixAddr addr) (env reg) - ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) - - ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) - SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) - UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) - SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) - UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) - SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) - RDY rd -> RDY (env rd) - WRY r1 r2 -> WRY (env r1) (env r2) - AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) - ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) - OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) - ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) - XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) - XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - - SETHI imm reg -> SETHI imm (env reg) - - FABS s r1 r2 -> FABS s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMOV s r1 r2 -> FMOV s (env r1) (env r2) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) - - JMP addr -> JMP (fixAddr addr) - JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l - - CALL (Left i) n t -> CALL (Left i) n t - CALL (Right r) n t -> CALL (Right (env r)) n t - _ -> instr - - where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - - --------------------------------------------------------------------------------- -isJumpishInstr :: Instr -> Bool -isJumpishInstr instr - = case instr of - BI{} -> True - BF{} -> True - JMP{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False - -jumpDestsOfInstr :: Instr -> [BlockId] -jumpDestsOfInstr insn - = case insn of - BI _ _ id -> [id] - BF _ _ id -> [id] - JMP_TBL _ ids _ -> [id | Just id <- ids] - _ -> [] - - -patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr -patchJumpInstr insn patchF - = case insn of - BI cc annul id -> BI cc annul (patchF id) - BF cc annul id -> BF cc annul (patchF id) - JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l - _ -> insn - - --------------------------------------------------------------------------------- --- | Make a spill instruction. --- On SPARC we spill below frame pointer leaving 2 words/spill -mkSpillInstr - :: NCGConfig - -> Reg -- ^ register to spill - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> [Instr] - -mkSpillInstr config reg _ slot - = let platform = ncgPlatform config - off = spillSlotToOffset config slot - off_w = 1 + (off `div` 4) - fmt = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - - in [ST fmt reg (fpRel (negate off_w))] - - --- | Make a spill reload instruction. -mkLoadInstr - :: NCGConfig - -> Reg -- ^ register to load into - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> [Instr] - -mkLoadInstr config reg _ slot - = let platform = ncgPlatform config - off = spillSlotToOffset config slot - off_w = 1 + (off `div` 4) - fmt = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - - in [LD fmt (fpRel (- off_w)) reg] - - --------------------------------------------------------------------------------- --- | See if this instruction is telling us the current C stack delta -takeDeltaInstr - :: Instr - -> Maybe Int - -takeDeltaInstr instr - = case instr of - DELTA i -> Just i - _ -> Nothing - - -isMetaInstr - :: Instr - -> Bool - -isMetaInstr instr - = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - - --- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. --- -mkRegRegMoveInstr - :: Platform - -> Reg - -> Reg - -> Instr - -mkRegRegMoveInstr platform src dst - | srcClass <- targetClassOfReg platform src - , dstClass <- targetClassOfReg platform dst - , srcClass == dstClass - = case srcClass of - RcInteger -> ADD False False src (RIReg g0) dst - RcDouble -> FMOV FF64 src dst - RcFloat -> FMOV FF32 src dst - - | otherwise - = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" - - --- | Check whether an instruction represents a reg-reg move. --- The register allocator attempts to eliminate reg->reg moves whenever it can, --- by assigning the src and dest temporaries to the same real register. --- -takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) -takeRegRegMoveInstr instr - = case instr of - ADD False False src (RIReg src2) dst - | g0 == src2 -> Just (src, dst) - - FMOV FF64 src dst -> Just (src, dst) - FMOV FF32 src dst -> Just (src, dst) - _ -> Nothing - - --- | Make an unconditional branch instruction. -mkJumpInstr - :: BlockId - -> [Instr] - -mkJumpInstr id - = [BI ALWAYS False id - , NOP] -- fill the branch delay slot. diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs deleted file mode 100644 index 2b0d9675fd..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ /dev/null @@ -1,660 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - - ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module GHC.CmmToAsm.SPARC.Ppr ( - pprNatCmmDecl, - pprBasicBlock, - pprData, - pprInstr, - pprFormat, - pprImm, - pprDataItem -) - -where - -import GHC.Prelude - -import Data.Word -import qualified Data.Array.Unsafe as U ( castSTUArray ) -import Data.Array.ST - -import Control.Monad.ST - -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Base -import GHC.Platform.Reg -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Ppr -import GHC.CmmToAsm.Config -import GHC.CmmToAsm.Types -import GHC.CmmToAsm.Utils - -import GHC.Cmm hiding (topInfoTable) -import GHC.Cmm.Ppr() -- For Outputable instances -import GHC.Cmm.BlockId -import GHC.Cmm.CLabel -import GHC.Cmm.Dataflow.Label -import GHC.Cmm.Dataflow.Collections - -import GHC.Types.Unique ( pprUniqueAlways ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Platform - --- ----------------------------------------------------------------------------- --- Printing this stuff out - -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc -pprNatCmmDecl config (CmmData section dats) = - pprSectionAlign config section - $$ pprDatas (ncgPlatform config) dats - -pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - let platform = ncgPlatform config in - case topInfoTable proc of - Nothing -> - -- special case for code without info table: - pprSectionAlign config (Section Text lbl) $$ - pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock platform top_info) blocks) - - Just (CmmStaticsRaw info_lbl _) -> - (if platformHasSubsectionsViaSymbols platform - then pprSectionAlign config dspSection $$ - pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map (pprBasicBlock platform top_info) blocks) $$ - -- above: Even the first block gets a label, because with branch-chain - -- elimination, it might be the target of a goto. - (if platformHasSubsectionsViaSymbols platform - then - -- See Note [Subsections Via Symbols] in X86/Ppr.hs - text "\t.long " - <+> pdoc platform info_lbl - <+> char '-' - <+> pdoc platform (mkDeadStripPreventer info_lbl) - else empty) - -dspSection :: Section -dspSection = Section Text $ - panic "subsections-via-symbols doesn't combine with split-sections" - -pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock platform info_env (BasicBlock blockid instrs) - = maybe_infotable $$ - pprLabel platform (blockLbl blockid) $$ - vcat (map (pprInstr platform) instrs) - where - maybe_infotable = case mapLookup blockid info_env of - Nothing -> empty - Just (CmmStaticsRaw info_lbl info) -> - pprAlignForSection Text $$ - vcat (map (pprData platform) info) $$ - pprLabel platform info_lbl - - -pprDatas :: Platform -> RawCmmStatics -> SDoc --- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) - | lbl == mkIndStaticInfoLabel - , let labelInd (CmmLabelOff l _) = Just l - labelInd (CmmLabel l) = Just l - labelInd _ = Nothing - , Just ind' <- labelInd ind - , alias `mayRedirectTo` ind' - = pprGloblDecl platform alias - $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind') -pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) - -pprData :: Platform -> CmmStatic -> SDoc -pprData platform d = case d of - CmmString str -> pprString str - CmmFileEmbed path -> pprFileEmbed path - CmmUninitialised bytes -> text ".skip " <> int bytes - CmmStaticLit lit -> pprDataItem platform lit - -pprGloblDecl :: Platform -> CLabel -> SDoc -pprGloblDecl platform lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".global " <> pdoc platform lbl - -pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc -pprTypeAndSizeDecl platform lbl - = if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then text ".type " <> pdoc platform lbl <> text ", @object" - else empty - -pprLabel :: Platform -> CLabel -> SDoc -pprLabel platform lbl = - pprGloblDecl platform lbl - $$ pprTypeAndSizeDecl platform lbl - $$ (pdoc platform lbl <> char ':') - --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - -instance OutputableP Platform Instr where - pdoc = pprInstr - - --- | Pretty print a register. -pprReg :: Reg -> SDoc -pprReg reg - = case reg of - RegVirtual vr - -> case vr of - VirtualRegI u -> text "%vI_" <> pprUniqueAlways u - VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u - VirtualRegF u -> text "%vF_" <> pprUniqueAlways u - VirtualRegD u -> text "%vD_" <> pprUniqueAlways u - - - RegReal rr - -> case rr of - RealRegSingle r1 - -> pprReg_ofRegNo r1 - - RealRegPair r1 r2 - -> text "(" <> pprReg_ofRegNo r1 - <> vbar <> pprReg_ofRegNo r2 - <> text ")" - - - --- | Pretty print a register name, based on this register number. --- The definition has been unfolded so we get a jump-table in the --- object code. This function is called quite a lot when emitting --- the asm file.. --- -pprReg_ofRegNo :: Int -> SDoc -pprReg_ofRegNo i - = case i of { - 0 -> text "%g0"; 1 -> text "%g1"; - 2 -> text "%g2"; 3 -> text "%g3"; - 4 -> text "%g4"; 5 -> text "%g5"; - 6 -> text "%g6"; 7 -> text "%g7"; - 8 -> text "%o0"; 9 -> text "%o1"; - 10 -> text "%o2"; 11 -> text "%o3"; - 12 -> text "%o4"; 13 -> text "%o5"; - 14 -> text "%o6"; 15 -> text "%o7"; - 16 -> text "%l0"; 17 -> text "%l1"; - 18 -> text "%l2"; 19 -> text "%l3"; - 20 -> text "%l4"; 21 -> text "%l5"; - 22 -> text "%l6"; 23 -> text "%l7"; - 24 -> text "%i0"; 25 -> text "%i1"; - 26 -> text "%i2"; 27 -> text "%i3"; - 28 -> text "%i4"; 29 -> text "%i5"; - 30 -> text "%i6"; 31 -> text "%i7"; - 32 -> text "%f0"; 33 -> text "%f1"; - 34 -> text "%f2"; 35 -> text "%f3"; - 36 -> text "%f4"; 37 -> text "%f5"; - 38 -> text "%f6"; 39 -> text "%f7"; - 40 -> text "%f8"; 41 -> text "%f9"; - 42 -> text "%f10"; 43 -> text "%f11"; - 44 -> text "%f12"; 45 -> text "%f13"; - 46 -> text "%f14"; 47 -> text "%f15"; - 48 -> text "%f16"; 49 -> text "%f17"; - 50 -> text "%f18"; 51 -> text "%f19"; - 52 -> text "%f20"; 53 -> text "%f21"; - 54 -> text "%f22"; 55 -> text "%f23"; - 56 -> text "%f24"; 57 -> text "%f25"; - 58 -> text "%f26"; 59 -> text "%f27"; - 60 -> text "%f28"; 61 -> text "%f29"; - 62 -> text "%f30"; 63 -> text "%f31"; - _ -> text "very naughty sparc register" } - - --- | Pretty print a format for an instruction suffix. -pprFormat :: Format -> SDoc -pprFormat x - = case x of - II8 -> text "ub" - II16 -> text "uh" - II32 -> text "" - II64 -> text "d" - FF32 -> text "" - FF64 -> text "d" - - --- | Pretty print a format for an instruction suffix. --- eg LD is 32bit on sparc, but LDD is 64 bit. -pprStFormat :: Format -> SDoc -pprStFormat x - = case x of - II8 -> text "b" - II16 -> text "h" - II32 -> text "" - II64 -> text "x" - FF32 -> text "" - FF64 -> text "d" - - - --- | Pretty print a condition code. -pprCond :: Cond -> SDoc -pprCond c - = case c of - ALWAYS -> text "" - NEVER -> text "n" - GEU -> text "geu" - LU -> text "lu" - EQQ -> text "e" - GTT -> text "g" - GE -> text "ge" - GU -> text "gu" - LTT -> text "l" - LE -> text "le" - LEU -> text "leu" - NE -> text "ne" - NEG -> text "neg" - POS -> text "pos" - VC -> text "vc" - VS -> text "vs" - - --- | Pretty print an address mode. -pprAddr :: Platform -> AddrMode -> SDoc -pprAddr platform am - = case am of - AddrRegReg r1 (RegReal (RealRegSingle 0)) - -> pprReg r1 - - AddrRegReg r1 r2 - -> hcat [ pprReg r1, char '+', pprReg r2 ] - - AddrRegImm r1 (ImmInt i) - | i == 0 -> pprReg r1 - | not (fits13Bits i) -> largeOffsetError i - | otherwise -> hcat [ pprReg r1, pp_sign, int i ] - where - pp_sign = if i > 0 then char '+' else empty - - AddrRegImm r1 (ImmInteger i) - | i == 0 -> pprReg r1 - | not (fits13Bits i) -> largeOffsetError i - | otherwise -> hcat [ pprReg r1, pp_sign, integer i ] - where - pp_sign = if i > 0 then char '+' else empty - - AddrRegImm r1 imm - -> hcat [ pprReg r1, char '+', pprImm platform imm ] - - --- | Pretty print an immediate value. -pprImm :: Platform -> Imm -> SDoc -pprImm platform imm - = case imm of - ImmInt i -> int i - ImmInteger i -> integer i - ImmCLbl l -> pdoc platform l - ImmIndex l i -> pdoc platform l <> char '+' <> int i - ImmLit s -> s - - ImmConstantSum a b - -> pprImm platform a <> char '+' <> pprImm platform b - - ImmConstantDiff a b - -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen - - LO i - -> hcat [ text "%lo(", pprImm platform i, rparen ] - - HI i - -> hcat [ text "%hi(", pprImm platform i, rparen ] - - -- these should have been converted to bytes and placed - -- in the data section. - ImmFloat _ -> text "naughty float immediate" - ImmDouble _ -> text "naughty double immediate" - - --- | Pretty print a section \/ segment header. --- On SPARC all the data sections must be at least 8 byte aligned --- incase we store doubles in them. --- -pprSectionAlign :: NCGConfig -> Section -> SDoc -pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec $$ - pprAlignForSection seg - --- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - case seg of - Text -> text ".align 4" - Data -> text ".align 8" - ReadOnlyData -> text ".align 8" - RelocatableReadOnlyData -> text ".align 8" - UninitialisedData -> text ".align 8" - ReadOnlyData16 -> text ".align 16" - -- TODO: This is copied from the ReadOnlyData case, but it can likely be - -- made more efficient. - CString -> text ".align 8" - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" - --- | Pretty print a data item. -pprDataItem :: Platform -> CmmLit -> SDoc -pprDataItem platform lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) - where - imm = litToImm lit - - ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] - - ppr_item FF32 (CmmFloat r _) - = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs - - ppr_item FF64 (CmmFloat r _) - = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs - - ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm] - ppr_item II64 _ = [text "\t.quad\t" <> pprImm platform imm] - ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" - -floatToBytes :: Float -> [Int] -floatToBytes f - = runST (do - arr <- newArray_ ((0::Int),3) - writeArray arr 0 f - arr <- castFloatToWord8Array arr - i0 <- readArray arr 0 - i1 <- readArray arr 1 - i2 <- readArray arr 2 - i3 <- readArray arr 3 - return (map fromIntegral [i0,i1,i2,i3]) - ) - -castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8) -castFloatToWord8Array = U.castSTUArray - - -asmComment :: SDoc -> SDoc -asmComment c = whenPprDebug $ text "#" <+> c - - --- | Pretty print an instruction. -pprInstr :: Platform -> Instr -> SDoc -pprInstr platform = \case - COMMENT s -> asmComment s - DELTA d -> asmComment $ text ("\tdelta = " ++ show d) - - -- Newblocks and LData should have been slurped out before producing the .s file. - NEWBLOCK _ -> panic "X86.Ppr.pprInstr: NEWBLOCK" - LDATA _ _ -> panic "PprMach.pprInstr: LDATA" - - -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand - LD FF64 _ reg - | RegReal (RealRegSingle{}) <- reg - -> panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" - - LD format addr reg - -> hcat [ - text "\tld", - pprFormat format, - char '\t', - lbrack, - pprAddr platform addr, - pp_rbracket_comma, - pprReg reg - ] - - -- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand - ST FF64 reg _ - | RegReal (RealRegSingle{}) <- reg - -> panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" - - -- no distinction is made between signed and unsigned bytes on stores for the - -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), - -- so we call a special-purpose pprFormat for ST.. - ST format reg addr - -> hcat [ - text "\tst", - pprStFormat format, - char '\t', - pprReg reg, - pp_comma_lbracket, - pprAddr platform addr, - rbrack - ] - - - ADD x cc reg1 ri reg2 - | not x && not cc && riZero ri - -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] - - | otherwise - -> pprRegRIReg platform (if x then text "addx" else text "add") cc reg1 ri reg2 - - - SUB x cc reg1 ri reg2 - | not x && cc && reg2 == g0 - -> hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI platform ri ] - - | not x && not cc && riZero ri - -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] - - | otherwise - -> pprRegRIReg platform (if x then text "subx" else text "sub") cc reg1 ri reg2 - - AND b reg1 ri reg2 -> pprRegRIReg platform (text "and") b reg1 ri reg2 - - ANDN b reg1 ri reg2 -> pprRegRIReg platform (text "andn") b reg1 ri reg2 - - OR b reg1 ri reg2 - | not b && reg1 == g0 - -> let doit = hcat [ text "\tmov\t", pprRI platform ri, comma, pprReg reg2 ] - in case ri of - RIReg rrr | rrr == reg2 -> empty - _ -> doit - - | otherwise - -> pprRegRIReg platform (text "or") b reg1 ri reg2 - - ORN b reg1 ri reg2 -> pprRegRIReg platform (text "orn") b reg1 ri reg2 - - XOR b reg1 ri reg2 -> pprRegRIReg platform (text "xor") b reg1 ri reg2 - XNOR b reg1 ri reg2 -> pprRegRIReg platform (text "xnor") b reg1 ri reg2 - - SLL reg1 ri reg2 -> pprRegRIReg platform (text "sll") False reg1 ri reg2 - SRL reg1 ri reg2 -> pprRegRIReg platform (text "srl") False reg1 ri reg2 - SRA reg1 ri reg2 -> pprRegRIReg platform (text "sra") False reg1 ri reg2 - - RDY rd -> text "\trd\t%y," <> pprReg rd - WRY reg1 reg2 - -> text "\twr\t" - <> pprReg reg1 - <> char ',' - <> pprReg reg2 - <> char ',' - <> text "%y" - - SMUL b reg1 ri reg2 -> pprRegRIReg platform (text "smul") b reg1 ri reg2 - UMUL b reg1 ri reg2 -> pprRegRIReg platform (text "umul") b reg1 ri reg2 - SDIV b reg1 ri reg2 -> pprRegRIReg platform (text "sdiv") b reg1 ri reg2 - UDIV b reg1 ri reg2 -> pprRegRIReg platform (text "udiv") b reg1 ri reg2 - - SETHI imm reg - -> hcat [ - text "\tsethi\t", - pprImm platform imm, - comma, - pprReg reg - ] - - NOP -> text "\tnop" - - FABS format reg1 reg2 - -> pprFormatRegReg (text "fabs") format reg1 reg2 - - FADD format reg1 reg2 reg3 - -> pprFormatRegRegReg (text "fadd") format reg1 reg2 reg3 - - FCMP e format reg1 reg2 - -> pprFormatRegReg (if e then text "fcmpe" else text "fcmp") - format reg1 reg2 - - FDIV format reg1 reg2 reg3 - -> pprFormatRegRegReg (text "fdiv") format reg1 reg2 reg3 - - FMOV format reg1 reg2 - -> pprFormatRegReg (text "fmov") format reg1 reg2 - - FMUL format reg1 reg2 reg3 - -> pprFormatRegRegReg (text "fmul") format reg1 reg2 reg3 - - FNEG format reg1 reg2 - -> pprFormatRegReg (text "fneg") format reg1 reg2 - - FSQRT format reg1 reg2 - -> pprFormatRegReg (text "fsqrt") format reg1 reg2 - - FSUB format reg1 reg2 reg3 - -> pprFormatRegRegReg (text "fsub") format reg1 reg2 reg3 - - FxTOy format1 format2 reg1 reg2 - -> hcat [ - text "\tf", - (case format1 of - II32 -> text "ito" - FF32 -> text "sto" - FF64 -> text "dto" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - (case format2 of - II32 -> text "i\t" - II64 -> text "x\t" - FF32 -> text "s\t" - FF64 -> text "d\t" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - pprReg reg1, comma, pprReg reg2 - ] - - - BI cond b blockid - -> hcat [ - text "\tb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - pdoc platform (blockLbl blockid) - ] - - BF cond b blockid - -> hcat [ - text "\tfb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - pdoc platform (blockLbl blockid) - ] - - JMP addr -> text "\tjmp\t" <> pprAddr platform addr - JMP_TBL op _ _ -> pprInstr platform (JMP op) - - CALL (Left imm) n _ - -> hcat [ text "\tcall\t", pprImm platform imm, comma, int n ] - - CALL (Right reg) n _ - -> hcat [ text "\tcall\t", pprReg reg, comma, int n ] - - --- | Pretty print a RI -pprRI :: Platform -> RI -> SDoc -pprRI platform = \case - RIReg r -> pprReg r - RIImm r -> pprImm platform r - - --- | Pretty print a two reg instruction. -pprFormatRegReg :: SDoc -> Format -> Reg -> Reg -> SDoc -pprFormatRegReg name format reg1 reg2 - = hcat [ - char '\t', - name, - (case format of - FF32 -> text "s\t" - FF64 -> text "d\t" - _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), - - pprReg reg1, - comma, - pprReg reg2 - ] - - --- | Pretty print a three reg instruction. -pprFormatRegRegReg :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc -pprFormatRegRegReg name format reg1 reg2 reg3 - = hcat [ - char '\t', - name, - (case format of - FF32 -> text "s\t" - FF64 -> text "d\t" - _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), - pprReg reg1, - comma, - pprReg reg2, - comma, - pprReg reg3 - ] - - --- | Pretty print an instruction of two regs and a ri. -pprRegRIReg :: Platform -> SDoc -> Bool -> Reg -> RI -> Reg -> SDoc -pprRegRIReg platform name b reg1 ri reg2 - = hcat [ - char '\t', - name, - if b then text "cc\t" else char '\t', - pprReg reg1, - comma, - pprRI platform ri, - comma, - pprReg reg2 - ] - -{- -pprRIReg :: SDoc -> Bool -> RI -> Reg -> SDoc -pprRIReg name b ri reg1 - = hcat [ - char '\t', - name, - if b then text "cc\t" else char '\t', - pprRI ri, - comma, - pprReg reg1 - ] --} - -{- -pp_ld_lbracket :: SDoc -pp_ld_lbracket = text "\tld\t[" --} - -pp_rbracket_comma :: SDoc -pp_rbracket_comma = text "]," - - -pp_comma_lbracket :: SDoc -pp_comma_lbracket = text ",[" - - -pp_comma_a :: SDoc -pp_comma_a = text ",a" diff --git a/compiler/GHC/CmmToAsm/SPARC/Regs.hs b/compiler/GHC/CmmToAsm/SPARC/Regs.hs deleted file mode 100644 index 0325814c6b..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/Regs.hs +++ /dev/null @@ -1,260 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1994-2004 --- --- ----------------------------------------------------------------------------- - -module GHC.CmmToAsm.SPARC.Regs ( - -- registers - showReg, - virtualRegSqueeze, - realRegSqueeze, - classOfRealReg, - allRealRegs, - - -- machine specific info - gReg, iReg, lReg, oReg, fReg, - fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, - - -- allocatable - allocatableRegs, - - -- args - argRegs, - allArgRegs, - callClobberedRegs, - - -- - mkVirtualReg, - regDotColor -) - -where - - -import GHC.Prelude - -import GHC.Platform.SPARC -import GHC.Platform.Reg -import GHC.Platform.Reg.Class -import GHC.CmmToAsm.Format - -import GHC.Types.Unique -import GHC.Utils.Outputable -import GHC.Utils.Panic - -{- - The SPARC has 64 registers of interest; 32 integer registers and 32 - floating point registers. The mapping of STG registers to SPARC - machine registers is defined in StgRegs.h. We are, of course, - prepared for any eventuality. - - The whole fp-register pairing thing on sparcs is a huge nuisance. See - rts/include/stg/MachRegs.h for a description of what's going on - here. --} - - --- | Get the standard name for the register with this number. -showReg :: RegNo -> String -showReg n - | n >= 0 && n < 8 = "%g" ++ show n - | n >= 8 && n < 16 = "%o" ++ show (n-8) - | n >= 16 && n < 24 = "%l" ++ show (n-16) - | n >= 24 && n < 32 = "%i" ++ show (n-24) - | n >= 32 && n < 64 = "%f" ++ show (n-32) - | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" - - --- Get the register class of a certain real reg -classOfRealReg :: RealReg -> RegClass -classOfRealReg reg - = case reg of - RealRegSingle i - | i < 32 -> RcInteger - | otherwise -> RcFloat - - RealRegPair{} -> RcDouble - - --- | regSqueeze_class reg --- Calculate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. --- -{-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> Int - -virtualRegSqueeze cls vr - = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> 1 - VirtualRegHi{} -> 1 - _other -> 0 - - RcFloat - -> case vr of - VirtualRegF{} -> 1 - VirtualRegD{} -> 2 - _other -> 0 - - RcDouble - -> case vr of - VirtualRegF{} -> 1 - VirtualRegD{} -> 1 - _other -> 0 - - -{-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> Int - -realRegSqueeze cls rr - = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 1 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcFloat - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 2 - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 1 - - --- | All the allocatable registers in the machine, --- including register pairs. -allRealRegs :: [RealReg] -allRealRegs - = [ (RealRegSingle i) | i <- [0..63] ] - ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] - - --- | Get the regno for this sort of reg -gReg, lReg, iReg, oReg, fReg :: Int -> RegNo - -gReg x = x -- global regs -oReg x = (8 + x) -- output regs -lReg x = (16 + x) -- local regs -iReg x = (24 + x) -- input regs -fReg x = (32 + x) -- float regs - - --- | Some specific regs used by the code generator. -g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg - -f6 = RegReal (RealRegSingle (fReg 6)) -f8 = RegReal (RealRegSingle (fReg 8)) -f22 = RegReal (RealRegSingle (fReg 22)) -f26 = RegReal (RealRegSingle (fReg 26)) -f27 = RegReal (RealRegSingle (fReg 27)) - --- g0 is always zero, and writes to it vanish. -g0 = RegReal (RealRegSingle (gReg 0)) -g1 = RegReal (RealRegSingle (gReg 1)) -g2 = RegReal (RealRegSingle (gReg 2)) - --- FP, SP, int and float return (from C) regs. -fp = RegReal (RealRegSingle (iReg 6)) -sp = RegReal (RealRegSingle (oReg 6)) -o0 = RegReal (RealRegSingle (oReg 0)) -o1 = RegReal (RealRegSingle (oReg 1)) -f0 = RegReal (RealRegSingle (fReg 0)) -f1 = RegReal (RealRegSingle (fReg 1)) - --- | Produce the second-half-of-a-double register given the first half. -{- -fPair :: Reg -> Maybe Reg -fPair (RealReg n) - | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) - -fPair (VirtualRegD u) - = Just (VirtualRegHi u) - -fPair reg - = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) - Nothing --} - - --- | All the regs that the register allocator can allocate to, --- with the fixed use regs removed. --- -allocatableRegs :: [RealReg] -allocatableRegs - = let isFree rr - = case rr of - RealRegSingle r -> freeReg r - RealRegPair r1 r2 -> freeReg r1 && freeReg r2 - in filter isFree allRealRegs - - --- | The registers to place arguments for function calls, --- for some number of arguments. --- -argRegs :: RegNo -> [Reg] -argRegs r - = case r of - 0 -> [] - 1 -> map (RegReal . RealRegSingle . oReg) [0] - 2 -> map (RegReal . RealRegSingle . oReg) [0,1] - 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] - 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] - 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] - 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] - _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" - - --- | All the regs that could possibly be returned by argRegs --- -allArgRegs :: [Reg] -allArgRegs - = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] - - --- These are the regs that we cannot assume stay alive over a C call. --- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 --- -callClobberedRegs :: [Reg] -callClobberedRegs - = map (RegReal . RealRegSingle) - ( oReg 7 : - [oReg i | i <- [0..5]] ++ - [gReg i | i <- [1..7]] ++ - [fReg i | i <- [0..31]] ) - - - --- | Make a virtual reg with this format. -mkVirtualReg :: Unique -> Format -> VirtualReg -mkVirtualReg u format - | not (isFloatFormat format) - = VirtualRegI u - - | otherwise - = case format of - FF32 -> VirtualRegF u - FF64 -> VirtualRegD u - _ -> panic "mkVReg" - - -regDotColor :: RealReg -> SDoc -regDotColor reg - = case classOfRealReg reg of - RcInteger -> text "blue" - RcFloat -> text "red" - _other -> text "green" diff --git a/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs b/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs deleted file mode 100644 index 2c5b90d964..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs +++ /dev/null @@ -1,74 +0,0 @@ -module GHC.CmmToAsm.SPARC.ShortcutJump ( - JumpDest(..), getJumpDestBlockId, - canShortcut, - shortcutJump, - shortcutStatics, - shortBlockId -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Imm - -import GHC.Cmm.CLabel -import GHC.Cmm.BlockId -import GHC.Cmm - -import GHC.Utils.Panic -import GHC.Utils.Outputable - -data JumpDest - = DestBlockId BlockId - | DestImm Imm - --- Debug Instance -instance Outputable JumpDest where - ppr (DestBlockId bid) = text "blk:" <> ppr bid - ppr (DestImm _bid) = text "imm:?" - -getJumpDestBlockId :: JumpDest -> Maybe BlockId -getJumpDestBlockId (DestBlockId bid) = Just bid -getJumpDestBlockId _ = Nothing - - -canShortcut :: Instr -> Maybe JumpDest -canShortcut _ = Nothing - - -shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump _ other = other - - - -shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics -shortcutStatics fn (CmmStaticsRaw lbl statics) - = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. - -shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel -shortcutLabel fn lab - | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId - | otherwise = lab - -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) --- slightly dodgy, we're ignoring the second label, but this --- works with the way we use CmmLabelDiffOff for jump tables now. -shortcutStatic _ other_static - = other_static - - -shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel -shortBlockId fn blockid = - case fn blockid of - Nothing -> blockLbl blockid - Just (DestBlockId blockid') -> shortBlockId fn blockid' - Just (DestImm (ImmCLbl lbl)) -> lbl - _other -> panic "shortBlockId" diff --git a/compiler/GHC/CmmToAsm/SPARC/Stack.hs b/compiler/GHC/CmmToAsm/SPARC/Stack.hs deleted file mode 100644 index be51164da1..0000000000 --- a/compiler/GHC/CmmToAsm/SPARC/Stack.hs +++ /dev/null @@ -1,60 +0,0 @@ -module GHC.CmmToAsm.SPARC.Stack ( - spRel, - fpRel, - spillSlotToOffset, - maxSpillSlots -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.Config - -import GHC.Utils.Outputable -import GHC.Utils.Panic - --- | Get an AddrMode relative to the address in sp. --- This gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. --- -spRel :: Int -- ^ stack offset in words, positive or negative - -> AddrMode - -spRel n = AddrRegImm sp (ImmInt (n * wordLength)) - - --- | Get an address relative to the frame pointer. --- This doesn't work work for offsets greater than 13 bits; we just hope for the best --- -fpRel :: Int -> AddrMode -fpRel n - = AddrRegImm fp (ImmInt (n * wordLength)) - - --- | Convert a spill slot number to a *byte* offset, with no sign. --- -spillSlotToOffset :: NCGConfig -> Int -> Int -spillSlotToOffset config slot - | slot >= 0 && slot < maxSpillSlots config - = 64 + spillSlotSize * slot - - | otherwise - = pprPanic "spillSlotToOffset:" - ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots config)) - - --- | The maximum number of spill slots available on the C stack. --- If we use up all of the slots, then we're screwed. --- --- Why do we reserve 64 bytes, instead of using the whole thing?? --- -- BL 2009/02/15 --- -maxSpillSlots :: NCGConfig -> Int -maxSpillSlots config - = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize) - 1 diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs index 71cfdd9dec..2642a2a9af 100644 --- a/compiler/GHC/Driver/Backend.hs +++ b/compiler/GHC/Driver/Backend.hs @@ -103,7 +103,6 @@ platformNcgSupported platform = if ArchX86_64 -> True ArchPPC -> True ArchPPC_64 {} -> True - ArchSPARC -> True ArchAArch64 -> True _ -> False diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 689d291755..5e898894a3 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -242,7 +242,6 @@ Library GHC.CmmToAsm.Reg.Linear.FreeRegs GHC.CmmToAsm.Reg.Linear.JoinToTargets GHC.CmmToAsm.Reg.Linear.PPC - GHC.CmmToAsm.Reg.Linear.SPARC GHC.CmmToAsm.Reg.Linear.StackMap GHC.CmmToAsm.Reg.Linear.State GHC.CmmToAsm.Reg.Linear.Stats @@ -251,24 +250,6 @@ Library GHC.CmmToAsm.Reg.Liveness GHC.CmmToAsm.Reg.Target GHC.CmmToAsm.Reg.Utils - GHC.CmmToAsm.SPARC - GHC.CmmToAsm.SPARC.AddrMode - GHC.CmmToAsm.SPARC.Base - GHC.CmmToAsm.SPARC.CodeGen - GHC.CmmToAsm.SPARC.CodeGen.Amode - GHC.CmmToAsm.SPARC.CodeGen.Base - GHC.CmmToAsm.SPARC.CodeGen.CondCode - GHC.CmmToAsm.SPARC.CodeGen.Expand - GHC.CmmToAsm.SPARC.CodeGen.Gen32 - GHC.CmmToAsm.SPARC.CodeGen.Gen64 - GHC.CmmToAsm.SPARC.CodeGen.Sanity - GHC.CmmToAsm.SPARC.Cond - GHC.CmmToAsm.SPARC.Imm - GHC.CmmToAsm.SPARC.Instr - GHC.CmmToAsm.SPARC.Ppr - GHC.CmmToAsm.SPARC.Regs - GHC.CmmToAsm.SPARC.ShortcutJump - GHC.CmmToAsm.SPARC.Stack GHC.CmmToAsm.Types GHC.CmmToAsm.Utils GHC.CmmToAsm.X86 |