diff options
Diffstat (limited to 'compiler/nativeGen')
28 files changed, 1594 insertions, 1565 deletions
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index e53bb11cc3..3c4a551df3 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -1025,15 +1025,15 @@ cmmExprNative referenceKind expr = do CmmReg (CmmGlobal EagerBlackholeInfo) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_fun"))) other -> return other diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs index a6f4cab7bd..34782dfc1c 100644 --- a/compiler/nativeGen/CPrim.hs +++ b/compiler/nativeGen/CPrim.hs @@ -1,11 +1,16 @@ -- | Generating C symbol names emitted by the compiler. module CPrim - ( popCntLabel + ( atomicReadLabel + , atomicWriteLabel + , atomicRMWLabel + , cmpxchgLabel + , popCntLabel , bSwapLabel , word2FloatLabel ) where import CmmType +import CmmMachOp import Outputable popCntLabel :: Width -> String @@ -31,3 +36,46 @@ word2FloatLabel w = "hs_word2float" ++ pprWidth w pprWidth W32 = "32" pprWidth W64 = "64" pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) + +atomicRMWLabel :: Width -> AtomicMachOp -> String +atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + + pprFunName AMO_Add = "add" + pprFunName AMO_Sub = "sub" + pprFunName AMO_And = "and" + pprFunName AMO_Nand = "nand" + pprFunName AMO_Or = "or" + pprFunName AMO_Xor = "xor" + +cmpxchgLabel :: Width -> String +cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) + +atomicReadLabel :: Width -> String +atomicReadLabel w = "hs_atomicread" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) + +atomicWriteLabel :: Width -> String +atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 91651e6065..014117dd4c 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -813,15 +813,6 @@ genBranch = return . toOL . mkJumpInstr 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. -} @@ -1160,6 +1151,10 @@ genCCall' dflags gcp target dest_regs args0 MO_BSwap w -> (fsLit $ bSwapLabel w, False) MO_PopCnt w -> (fsLit $ popCntLabel w, False) + MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False) + MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) + MO_AtomicRead w -> (fsLit $ atomicReadLabel w, False) + MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False) MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/PPC/Cond.hs b/compiler/nativeGen/PPC/Cond.hs index 2568da5249..0e4b1fd701 100644 --- a/compiler/nativeGen/PPC/Cond.hs +++ b/compiler/nativeGen/PPC/Cond.hs @@ -1,17 +1,9 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.Cond ( - Cond(..), - condNegate, - condUnsigned, - condToSigned, - condToUnsigned, + Cond(..), + condNegate, + condUnsigned, + condToSigned, + condToUnsigned, ) where @@ -19,18 +11,18 @@ where import Panic data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - deriving Eq + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + deriving Eq condNegate :: Cond -> Cond diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index bffa9ea63f..c4724d4193 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -7,20 +7,12 @@ -- (c) The University of Glasgow 1996-2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.RegInfo ( JumpDest( DestBlockId ), getJumpDestBlockId, - canShortcut, - shortcutJump, + canShortcut, + shortcutJump, - shortcutStatics + shortcutStatics ) where @@ -70,14 +62,13 @@ shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) shortcutStatic _ other_static = other_static -shortBlockId - :: (BlockId -> Maybe JumpDest) - -> BlockId - -> CLabel +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> BlockId + -> CLabel shortBlockId fn blockid = case fn blockid of Nothing -> mkAsmTempLabel uq Just (DestBlockId blockid') -> shortBlockId fn blockid' where uq = getUnique blockid - diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs index 77ca7480d6..862306f0bb 100644 --- a/compiler/nativeGen/Reg.hs +++ b/compiler/nativeGen/Reg.hs @@ -1,36 +1,27 @@ - -- | An architecture independent description of a register. --- This needs to stay architecture independent because it is used --- by NCGMonad and the register allocators, which are shared --- by all architectures. +-- This needs to stay architecture independent because it is used +-- by NCGMonad and the register allocators, which are shared +-- by all architectures. -- - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Reg ( - RegNo, - Reg(..), - regPair, - regSingle, - isRealReg, takeRealReg, - isVirtualReg, takeVirtualReg, - - VirtualReg(..), - renameVirtualReg, - classOfVirtualReg, - getHiVirtualRegFromLo, - getHiVRegFromLo, - - RealReg(..), - regNosOfRealReg, - realRegsAlias, - - liftPatchFnToRegReg + RegNo, + Reg(..), + regPair, + regSingle, + isRealReg, takeRealReg, + isVirtualReg, takeVirtualReg, + + VirtualReg(..), + renameVirtualReg, + classOfVirtualReg, + getHiVirtualRegFromLo, + getHiVRegFromLo, + + RealReg(..), + regNosOfRealReg, + realRegsAlias, + + liftPatchFnToRegReg ) where @@ -41,68 +32,68 @@ import RegClass import Data.List -- | An identifier for a primitive real machine register. -type RegNo - = Int +type RegNo + = Int -- VirtualRegs are virtual registers. The register allocator will --- eventually have to map them into RealRegs, or into spill slots. +-- eventually have to map them into RealRegs, or into spill slots. -- --- VirtualRegs are allocated on the fly, usually to represent a single --- value in the abstract assembly code (i.e. dynamic registers are --- usually single assignment). +-- VirtualRegs are allocated on the fly, usually to represent a single +-- value in the abstract assembly code (i.e. dynamic registers are +-- usually single assignment). -- --- The single assignment restriction isn't necessary to get correct code, --- although a better register allocation will result if single --- assignment is used -- because the allocator maps a VirtualReg into --- a single RealReg, even if the VirtualReg has multiple live ranges. +-- The single assignment restriction isn't necessary to get correct code, +-- although a better register allocation will result if single +-- assignment is used -- because the allocator maps a VirtualReg into +-- a single RealReg, even if the VirtualReg has multiple live ranges. -- --- Virtual regs can be of either class, so that info is attached. +-- Virtual regs can be of either class, so that info is attached. -- data VirtualReg - = VirtualRegI {-# UNPACK #-} !Unique - | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register - | VirtualRegF {-# UNPACK #-} !Unique - | VirtualRegD {-# UNPACK #-} !Unique - | VirtualRegSSE {-# UNPACK #-} !Unique - deriving (Eq, Show, Ord) + = VirtualRegI {-# UNPACK #-} !Unique + | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register + | VirtualRegF {-# UNPACK #-} !Unique + | VirtualRegD {-# UNPACK #-} !Unique + | VirtualRegSSE {-# UNPACK #-} !Unique + deriving (Eq, Show, Ord) instance Uniquable VirtualReg where - getUnique reg - = case reg of - VirtualRegI u -> u - VirtualRegHi u -> u - VirtualRegF u -> u - VirtualRegD u -> u - VirtualRegSSE u -> u + getUnique reg + = case reg of + VirtualRegI u -> u + VirtualRegHi u -> u + VirtualRegF u -> u + VirtualRegD u -> u + VirtualRegSSE u -> u instance Outputable VirtualReg where - ppr reg - = case reg of - VirtualRegI u -> text "%vI_" <> pprUnique u - VirtualRegHi u -> text "%vHi_" <> pprUnique u - VirtualRegF u -> text "%vF_" <> pprUnique u - VirtualRegD u -> text "%vD_" <> pprUnique u - VirtualRegSSE u -> text "%vSSE_" <> pprUnique u + ppr reg + = case reg of + VirtualRegI u -> text "%vI_" <> pprUnique u + VirtualRegHi u -> text "%vHi_" <> pprUnique u + VirtualRegF u -> text "%vF_" <> pprUnique u + VirtualRegD u -> text "%vD_" <> pprUnique u + VirtualRegSSE u -> text "%vSSE_" <> pprUnique u renameVirtualReg :: Unique -> VirtualReg -> VirtualReg renameVirtualReg u r = case r of - VirtualRegI _ -> VirtualRegI u - VirtualRegHi _ -> VirtualRegHi u - VirtualRegF _ -> VirtualRegF u - VirtualRegD _ -> VirtualRegD u - VirtualRegSSE _ -> VirtualRegSSE u + VirtualRegI _ -> VirtualRegI u + VirtualRegHi _ -> VirtualRegHi u + VirtualRegF _ -> VirtualRegF u + VirtualRegD _ -> VirtualRegD u + VirtualRegSSE _ -> VirtualRegSSE u classOfVirtualReg :: VirtualReg -> RegClass classOfVirtualReg vr = case vr of - VirtualRegI{} -> RcInteger - VirtualRegHi{} -> RcInteger - VirtualRegF{} -> RcFloat - VirtualRegD{} -> RcDouble - VirtualRegSSE{} -> RcDoubleSSE + VirtualRegI{} -> RcInteger + VirtualRegHi{} -> RcInteger + VirtualRegF{} -> RcFloat + VirtualRegD{} -> RcDouble + VirtualRegSSE{} -> RcDoubleSSE -- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform @@ -111,118 +102,116 @@ classOfVirtualReg vr getHiVirtualRegFromLo :: VirtualReg -> VirtualReg getHiVirtualRegFromLo reg = case reg of - -- makes a pseudo-unique with tag 'H' - VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') - _ -> panic "Reg.getHiVirtualRegFromLo" + -- makes a pseudo-unique with tag 'H' + VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') + _ -> panic "Reg.getHiVirtualRegFromLo" getHiVRegFromLo :: Reg -> Reg getHiVRegFromLo reg = case reg of - RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) - RegReal _ -> panic "Reg.getHiVRegFromLo" - + RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) + RegReal _ -> panic "Reg.getHiVRegFromLo" + ------------------------------------------------------------------------------------ -- | RealRegs are machine regs which are available for allocation, in --- the usual way. We know what class they are, because that's part of --- the processor's architecture. +-- the usual way. We know what class they are, because that's part of +-- the processor's architecture. -- --- RealRegPairs are pairs of real registers that are allocated together --- to hold a larger value, such as with Double regs on SPARC. +-- RealRegPairs are pairs of real registers that are allocated together +-- to hold a larger value, such as with Double regs on SPARC. -- data RealReg - = RealRegSingle {-# UNPACK #-} !RegNo - | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo - deriving (Eq, Show, Ord) + = RealRegSingle {-# UNPACK #-} !RegNo + | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo + deriving (Eq, Show, Ord) instance Uniquable RealReg where - getUnique reg - = case reg of - RealRegSingle i -> mkRegSingleUnique i - RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) + getUnique reg + = case reg of + RealRegSingle i -> mkRegSingleUnique i + RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) instance Outputable RealReg where - ppr reg - = case reg of - RealRegSingle i -> text "%r" <> int i - RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" + ppr reg + = case reg of + RealRegSingle i -> text "%r" <> int i + RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" regNosOfRealReg :: RealReg -> [RegNo] regNosOfRealReg rr = case rr of - RealRegSingle r1 -> [r1] - RealRegPair r1 r2 -> [r1, r2] - + RealRegSingle r1 -> [r1] + RealRegPair r1 r2 -> [r1, r2] + realRegsAlias :: RealReg -> RealReg -> Bool realRegsAlias rr1 rr2 - = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) + = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) -------------------------------------------------------------------------------- -- | A register, either virtual or real data Reg - = RegVirtual !VirtualReg - | RegReal !RealReg - deriving (Eq, Ord) + = RegVirtual !VirtualReg + | RegReal !RealReg + deriving (Eq, Ord) regSingle :: RegNo -> Reg -regSingle regNo = RegReal $ RealRegSingle regNo +regSingle regNo = RegReal $ RealRegSingle regNo regPair :: RegNo -> RegNo -> Reg -regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 +regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 --- We like to have Uniques for Reg so that we can make UniqFM and UniqSets +-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets -- in the register allocator. instance Uniquable Reg where - getUnique reg - = case reg of - RegVirtual vr -> getUnique vr - RegReal rr -> getUnique rr - + getUnique reg + = case reg of + RegVirtual vr -> getUnique vr + RegReal rr -> getUnique rr + -- | Print a reg in a generic manner --- If you want the architecture specific names, then use the pprReg --- function from the appropriate Ppr module. +-- If you want the architecture specific names, then use the pprReg +-- function from the appropriate Ppr module. instance Outputable Reg where - ppr reg - = case reg of - RegVirtual vr -> ppr vr - RegReal rr -> ppr rr + ppr reg + = case reg of + RegVirtual vr -> ppr vr + RegReal rr -> ppr rr isRealReg :: Reg -> Bool -isRealReg reg +isRealReg reg = case reg of - RegReal _ -> True - RegVirtual _ -> False + RegReal _ -> True + RegVirtual _ -> False takeRealReg :: Reg -> Maybe RealReg takeRealReg reg = case reg of - RegReal rr -> Just rr - _ -> Nothing + RegReal rr -> Just rr + _ -> Nothing isVirtualReg :: Reg -> Bool isVirtualReg reg = case reg of - RegReal _ -> False - RegVirtual _ -> True + RegReal _ -> False + RegVirtual _ -> True takeVirtualReg :: Reg -> Maybe VirtualReg takeVirtualReg reg = case reg of - RegReal _ -> Nothing - RegVirtual vr -> Just vr + RegReal _ -> Nothing + RegVirtual vr -> Just vr -- | The patch function supplied by the allocator maps VirtualReg to RealReg --- regs, but sometimes we want to apply it to plain old Reg. +-- regs, but sometimes we want to apply it to plain old Reg. -- liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) liftPatchFnToRegReg patchF reg = case reg of - RegVirtual vr -> RegReal (patchF vr) - RegReal _ -> reg - - + RegVirtual vr -> RegReal (patchF vr) + RegReal _ -> reg diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index ee43d25aa3..fa47a17ac0 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -158,11 +158,11 @@ regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) , Nothing ) regAlloc dflags (CmmProc static lbl live sccs) - | LiveInfo info (Just first_id) (Just block_live) _ <- static + | LiveInfo info entry_ids@(first_id:_) (Just block_live) _ <- static = do -- do register allocation on each component. (final_blocks, stats, stack_use) - <- linearRegAlloc dflags first_id block_live sccs + <- linearRegAlloc dflags entry_ids block_live sccs -- make sure the block that was first in the input list -- stays at the front of the output @@ -196,46 +196,50 @@ regAlloc _ (CmmProc _ _ _ _) linearRegAlloc :: (Outputable instr, Instruction instr) => DynFlags - -> BlockId -- ^ the first block - -> BlockMap RegSet -- ^ live regs on entry to each basic block - -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> [BlockId] -- ^ entry points + -> BlockMap RegSet + -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] + -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc dflags first_id block_live sccs - = let platform = targetPlatform dflags - in case platformArch platform of - ArchX86 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86_64.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' dflags (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' dflags (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs - ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" - ArchARM64 -> panic "linearRegAlloc ArchARM64" - ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" - ArchAlpha -> panic "linearRegAlloc ArchAlpha" - ArchMipseb -> panic "linearRegAlloc ArchMipseb" - ArchMipsel -> panic "linearRegAlloc ArchMipsel" +linearRegAlloc dflags entry_ids block_live sccs + = case platformArch platform of + ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) + ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) + ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) + ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) + ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" + ArchARM64 -> panic "linearRegAlloc ArchARM64" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchAlpha -> panic "linearRegAlloc ArchAlpha" + ArchMipseb -> panic "linearRegAlloc ArchMipseb" + ArchMipsel -> panic "linearRegAlloc ArchMipsel" ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" + where + go f = linearRegAlloc' dflags f entry_ids block_live sccs + platform = targetPlatform dflags linearRegAlloc' :: (FR freeRegs, Outputable instr, Instruction instr) => DynFlags -> freeRegs - -> BlockId -- ^ the first block + -> [BlockId] -- ^ entry points -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc' dflags initFreeRegs first_id block_live sccs +linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs = do us <- getUs let (_, stack, stats, blocks) = runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us - $ linearRA_SCCs first_id block_live [] sccs + $ linearRA_SCCs entry_ids block_live [] sccs return (blocks, stats, getStackUse stack) linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId + => [BlockId] -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] @@ -244,16 +248,16 @@ linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) linearRA_SCCs _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) +linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) = do blocks' <- processBlock block_live block - linearRA_SCCs first_id block_live + linearRA_SCCs entry_ids block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) False - linearRA_SCCs first_id block_live + blockss' <- process entry_ids block_live blocks [] (return []) False + linearRA_SCCs entry_ids block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -270,7 +274,7 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) -} process :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId + => [BlockId] -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -281,7 +285,7 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) process _ _ [] [] accum _ = return $ reverse accum -process first_id block_live [] next_round accum madeProgress +process entry_ids block_live [] next_round accum madeProgress | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. @@ -291,22 +295,22 @@ process first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process first_id block_live + = process entry_ids block_live next_round [] accum False -process first_id block_live (b@(BasicBlock id _) : blocks) +process entry_ids block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR if isJust (mapLookup id block_assig) - || id == first_id + || id `elem` entry_ids then do b' <- processBlock block_live b - process first_id block_live blocks + process entry_ids block_live blocks next_round (b' : accum) True - else process first_id block_live blocks + else process entry_ids block_live blocks (b : next_round) accum madeProgress diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 1cb6dc8268..d7fd8bdcb4 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -169,10 +169,11 @@ data Liveness -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo = LiveInfo - (BlockEnv CmmStatics) -- cmm info table static stuff - (Maybe BlockId) -- id of the first block - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block - (Map BlockId (Set Int)) -- stack slots live on entry to this block + (BlockEnv CmmStatics) -- cmm info table static stuff + [BlockId] -- entry points (first one is the + -- entry point for the proc). + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block -- | A basic block with liveness information. @@ -223,9 +224,9 @@ instance Outputable instr | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) instance Outputable LiveInfo where - ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) = (ppr mb_static) - $$ text "# firstId = " <> ppr firstId + $$ text "# entryIds = " <> ppr entryIds $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) @@ -480,7 +481,7 @@ stripLive dflags live where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label live sccs) + stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) = let final_blocks = flattenSCCs sccs -- make sure the block that was first in the input list @@ -493,7 +494,7 @@ stripLive dflags live (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label live []) + stripCmm (CmmProc (LiveInfo info [] _ _) label live []) = CmmProc info label live (ListGraph []) -- If the proc has blocks but we don't know what the first one was, then we're dead. @@ -641,16 +642,19 @@ natCmmTopToLive (CmmData i d) = CmmData i d natCmmTopToLive (CmmProc info lbl live (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl live [] + = CmmProc (LiveInfo info [] Nothing Map.empty) lbl live [] natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) = let first_id = blockId first - sccs = sccBlocks blocks (entryBlocks proc) + all_entry_ids = entryBlocks proc + sccs = sccBlocks blocks all_entry_ids + entry_ids = filter (/= first_id) all_entry_ids sccsLive = map (fmap (\(BasicBlock l instrs) -> BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) $ sccs - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl live sccsLive + in CmmProc (LiveInfo info (first_id : entry_ids) Nothing Map.empty) + lbl live sccsLive -- diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs index cac4e64221..0c793173cb 100644 --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -1,41 +1,33 @@ -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - - -- | An architecture independent description of a register's class. -module RegClass - ( RegClass (..) ) +module RegClass + ( RegClass (..) ) where -import Outputable -import Unique +import Outputable +import Unique --- | The class of a register. --- Used in the register allocator. --- We treat all registers in a class as being interchangable. +-- | The class of a register. +-- Used in the register allocator. +-- We treat all registers in a class as being interchangable. -- -data RegClass - = RcInteger - | RcFloat - | RcDouble - | RcDoubleSSE -- x86 only: the SSE regs are a separate class - deriving Eq +data RegClass + = RcInteger + | RcFloat + | RcDouble + | RcDoubleSSE -- x86 only: the SSE regs are a separate class + deriving Eq instance Uniquable RegClass where - getUnique RcInteger = mkRegClassUnique 0 - getUnique RcFloat = mkRegClassUnique 1 - getUnique RcDouble = mkRegClassUnique 2 + getUnique RcInteger = mkRegClassUnique 0 + getUnique RcFloat = mkRegClassUnique 1 + getUnique RcDouble = mkRegClassUnique 2 getUnique RcDoubleSSE = mkRegClassUnique 3 instance Outputable RegClass where - ppr RcInteger = Outputable.text "I" - ppr RcFloat = Outputable.text "F" - ppr RcDouble = Outputable.text "D" - ppr RcDoubleSSE = Outputable.text "S" + ppr RcInteger = Outputable.text "I" + ppr RcFloat = Outputable.text "F" + ppr RcDouble = Outputable.text "D" + ppr RcDoubleSSE = Outputable.text "S" diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index f5e61d0a8f..51f89d629f 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -654,6 +654,10 @@ outOfLineMachOp_table mop MO_BSwap w -> fsLit $ bSwapLabel w MO_PopCnt w -> fsLit $ popCntLabel w + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicRead w -> fsLit $ atomicReadLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index f0aed0d02e..8d9a303f2f 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -1,13 +1,5 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.Amode ( - getAmode + getAmode ) where @@ -28,11 +20,11 @@ import OrdList -- | Generate code to reference a memory address. -getAmode - :: CmmExpr -- ^ expr producing an address - -> NatM Amode +getAmode + :: CmmExpr -- ^ expr producing an address + -> NatM Amode -getAmode tree@(CmmRegOff _ _) +getAmode tree@(CmmRegOff _ _) = do dflags <- getDynFlags getAmode (mangleIndexTree dflags tree) @@ -50,7 +42,7 @@ getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) = do (reg, code) <- getSomeReg x let - off = ImmInt (fromInteger i) + off = ImmInt (fromInteger i) return (Amode (AddrRegImm reg off) code) getAmode (CmmMachOp (MO_Add _) [x, y]) @@ -58,23 +50,23 @@ getAmode (CmmMachOp (MO_Add _) [x, y]) (regX, codeX) <- getSomeReg x (regY, codeY) <- getSomeReg y let - code = codeX `appOL` codeY + 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 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] - let code = toOL [ SETHI (HI imm__2) tmp1 - , OR False tmp1 (RIImm (LO imm__2)) tmp2] - - return (Amode (AddrRegReg tmp2 g0) code) + return (Amode (AddrRegReg tmp2 g0) code) getAmode other = do (reg, code) <- getSomeReg other let - off = ImmInt 0 + off = ImmInt 0 return (Amode (AddrRegImm reg off) code) diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 45b7801960..270fd699b0 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -1,22 +1,14 @@ +module SPARC.CodeGen.Base ( + InstrBlock, + CondCode(..), + ChildCode64(..), + Amode(..), -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details + Register(..), + setSizeOfRegister, -module SPARC.CodeGen.Base ( - InstrBlock, - CondCode(..), - ChildCode64(..), - Amode(..), - - Register(..), - setSizeOfRegister, - - getRegisterReg, - mangleIndexTree + getRegisterReg, + mangleIndexTree ) where @@ -39,63 +31,63 @@ import 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. +-- 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 +type InstrBlock + = OrdList Instr -- | Condition codes passed up the tree. -- -data CondCode - = CondCode Bool Cond InstrBlock +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. +-- 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 +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified -- -data ChildCode64 - = ChildCode64 +data ChildCode64 + = ChildCode64 InstrBlock - Reg + 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 +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 + -- 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. +-- 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 Size Reg InstrBlock - | Any Size (Reg -> InstrBlock) + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) -- | Change the size field in a Register. setSizeOfRegister - :: Register -> Size -> Register + :: Register -> Size -> Register setSizeOfRegister reg size = case reg of - Fixed _ reg code -> Fixed size reg code - Any _ codefn -> Any size codefn + Fixed _ reg code -> Fixed size reg code + Any _ codefn -> Any size codefn -------------------------------------------------------------------------------- @@ -103,7 +95,7 @@ setSizeOfRegister reg size getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) + = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) getRegisterReg platform (CmmGlobal mid) = case globalRegMaybe platform mid of @@ -118,12 +110,8 @@ getRegisterReg platform (CmmGlobal mid) mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr mangleIndexTree dflags (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType dflags reg) mangleIndexTree _ _ - = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" - - - - + = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 2c3dbe6fc0..cb10830f46 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -1,15 +1,7 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.CondCode ( - getCondCode, - condIntCode, - condFltCode + getCondCode, + condIntCode, + condFltCode ) where @@ -32,7 +24,7 @@ import Outputable 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 @@ -86,8 +78,8 @@ 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 + code__2 = code1 `appOL` code2 `snocOL` + SUB False True src1 (RIReg src2) g0 return (CondCode False cond code__2) @@ -98,19 +90,19 @@ condFltCode cond x y = do (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y - - code__2 = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - FCMP True (cmmTypeSize 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 + promote x = FxTOy FF32 FF64 x tmp + + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y + + code__2 = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + FCMP True (cmmTypeSize 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/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index 7ebc2f6630..1d4d1379a5 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -1,14 +1,6 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Expand out synthetic instructions into single machine instrs. module SPARC.CodeGen.Expand ( - expandTop + expandTop ) where @@ -17,7 +9,7 @@ import SPARC.Instr import SPARC.Imm import SPARC.AddrMode import SPARC.Regs -import SPARC.Ppr () +import SPARC.Ppr () import Instruction import Reg import Size @@ -30,139 +22,132 @@ import OrdList -- | Expand out synthetic instructions in this top level thing expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr expandTop top@(CmmData{}) - = top + = top expandTop (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map expandBlock 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' + = let instrs_ol = expandBlockInstrs instrs + instrs' = fromOL instrs_ol + in BasicBlock label instrs' -- | Expand out some instructions expandBlockInstrs :: [Instr] -> OrdList Instr -expandBlockInstrs [] = nilOL - +expandBlockInstrs [] = nilOL + expandBlockInstrs (ii:is) - = let ii_doubleRegs = remapRegPair ii - is_misaligned = expandMisalignedDoubles ii_doubleRegs + = let ii_doubleRegs = remapRegPair ii + is_misaligned = expandMisalignedDoubles ii_doubleRegs + + in is_misaligned `appOL` expandBlockInstrs is - in is_misaligned `appOL` expandBlockInstrs is - -- | In the SPARC instruction set the FP register pairs that are used --- to hold 64 bit floats are refered to by just the first reg --- of the pair. Remap our internal reg pairs to the appropriate reg. +-- to hold 64 bit floats are refered to by just the first reg +-- of the pair. Remap our internal reg pairs to the appropriate reg. -- --- For example: --- ldd [%l1], (%f0 | %f1) +-- For example: +-- ldd [%l1], (%f0 | %f1) -- --- gets mapped to --- ldd [$l1], %f0 +-- gets mapped to +-- ldd [$l1], %f0 -- remapRegPair :: Instr -> Instr remapRegPair instr - = let patchF reg - = case reg of - RegReal (RealRegSingle _) - -> reg + = let patchF reg + = case reg of + RegReal (RealRegSingle _) + -> reg - RegReal (RealRegPair r1 r2) + RegReal (RealRegPair r1 r2) - -- sanity checking - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - , r2 == r1 + 1 - -> RegReal (RealRegSingle r1) + -- 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) + | 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 + 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. +-- 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. +-- 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 the high partner for this float reg. + -- 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 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)) - + | 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) - - - - - - - + = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 43a26e525a..90fb41870d 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -1,15 +1,7 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Evaluation of 32 bit values. module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister + getSomeReg, + getRegister ) where @@ -37,16 +29,16 @@ import OrdList import Outputable -- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. +-- 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) + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) @@ -54,13 +46,13 @@ getSomeReg expr = do -- getRegister :: CmmExpr -> NatM Register -getRegister (CmmReg reg) +getRegister (CmmReg reg) = do dflags <- getDynFlags let platform = targetPlatform dflags return (Fixed (cmmTypeSize (cmmRegType dflags reg)) (getRegisterReg platform reg) nilOL) -getRegister tree@(CmmRegOff _ _) +getRegister tree@(CmmRegOff _ _) = do dflags <- getDynFlags getRegister (mangleIndexTree dflags tree) @@ -80,12 +72,12 @@ getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code + 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. +-- 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 @@ -93,13 +85,13 @@ getRegister (CmmLit (CmmFloat f W32)) = do tmp <- getNewRegNat II32 let code dst = toOL [ - -- the data area - LDATA ReadOnlyData $ Statics lbl - [CmmStaticLit (CmmFloat f W32)], + -- the data area + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal - SETHI (HI (ImmCLbl lbl)) tmp, - LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + SETHI (HI (ImmCLbl lbl)) tmp, + LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF32 code) @@ -107,342 +99,342 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData $ Statics lbl - [CmmStaticLit (CmmFloat d W64)], - SETHI (HI (ImmCLbl lbl)) tmp, - LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + LDATA ReadOnlyData $ Statics 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 + -- 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 (intSize rep) (SUB False False g0) x - MO_Not rep -> trivialUCode (intSize rep) (XNOR False g0) x + -- Integer negation -------------------------------- + MO_S_Neg rep -> trivialUCode (intSize rep) (SUB False False g0) x + MO_Not rep -> trivialUCode (intSize rep) (XNOR False g0) x - -- Float word size conversion ---------------------- - MO_FF_Conv W64 W32 -> coerceDbl2Flt x - MO_FF_Conv W32 W64 -> coerceFlt2Dbl 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 + -- 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 ---------- + -- 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 (intSize to) x + -- If it's the same size, then nothing needs to be done. + MO_UU_Conv from to + | from == to -> conversionNop (intSize 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)) + -- 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)) + -- 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] - -- 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 (intSize W16) x - MO_UU_Conv W8 W32 -> conversionNop (intSize W32) x - MO_UU_Conv W16 W32 -> conversionNop (intSize W32) x + return $ Any II32 code + -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - -- Signed integer word size conversions ------------ + -- 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 (intSize W16) x + MO_UU_Conv W8 W32 -> conversionNop (intSize W32) x + MO_UU_Conv W16 W32 -> conversionNop (intSize W32) x - -- 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 + -- Signed integer word size conversions ------------ - _ -> panic ("Unknown unary mach op: " ++ show mop) + -- 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]) +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_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_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_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_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_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_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 + 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) + _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) where getRegister (CmmLoad mem pk) = do Amode src code <- getAmode mem let - code__2 dst = code `snocOL` LD (cmmTypeSize pk) src dst + code__2 dst = code `snocOL` LD (cmmTypeSize pk) src dst return (Any (cmmTypeSize pk) code__2) getRegister (CmmLit (CmmInt i _)) | fits13Bits i = let - src = ImmInt (fromInteger i) - code dst = unitOL (OR False g0 (RIImm src) dst) + src = ImmInt (fromInteger i) + code dst = unitOL (OR False g0 (RIImm src) dst) in - return (Any II32 code) + 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] + 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" + = 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 + :: 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 (intSize to) code) - + = 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 (intSize 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. +-- required size, but don't need to generate any actual code. -- conversionNop - :: Size -> CmmExpr -> NatM Register + :: Size -> CmmExpr -> NatM Register conversionNop new_rep expr - = do e_code <- getRegister expr - return (setSizeOfRegister e_code new_rep) + = do e_code <- getRegister expr + return (setSizeOfRegister 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 + +-- 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) - + (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 +-- 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) + (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. +-- 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. +-- 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 +-- 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 + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp_reg <- getNewRegNat II32 - 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) - 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. +-- 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 +-- 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) - + (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 +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` + (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) + return (Any II32 code) -- ----------------------------------------------------------------------------- @@ -458,19 +450,19 @@ imulMayOflo rep a b -- have handled the constant-folding. trivialCode - :: Width - -> (Reg -> RI -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - + :: 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 + src2 = ImmInt (fromInteger y) + code__2 dst = code `snocOL` instr src1 (RIImm src2) dst return (Any II32 code__2) @@ -478,17 +470,17 @@ 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 + code__2 dst = code1 `appOL` code2 `snocOL` + instr src1 (RIReg src2) dst return (Any II32 code__2) -trivialFCode - :: Width - -> (Size -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register +trivialFCode + :: Width + -> (Size -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register trivialFCode pk instr x y = do dflags <- getDynFlags @@ -496,49 +488,49 @@ trivialFCode pk instr x y = do (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let - promote x = FxTOy FF32 FF64 x tmp + promote x = FxTOy FF32 FF64 x tmp - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y - code__2 dst = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - instr (floatSize 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 (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) - code__2) + code__2 dst = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + instr (floatSize 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 (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) + code__2) trivialUCode - :: Size - -> (RI -> Reg -> Instr) - -> CmmExpr - -> NatM Register - + :: Size + -> (RI -> Reg -> Instr) + -> CmmExpr + -> NatM Register + trivialUCode size instr x = do (src, code) <- getSomeReg x let - code__2 dst = code `snocOL` instr (RIReg src) dst + code__2 dst = code `snocOL` instr (RIReg src) dst return (Any size code__2) -trivialUFCode - :: Size - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register - +trivialUFCode + :: Size + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register + trivialUFCode pk instr x = do (src, code) <- getSomeReg x let - code__2 dst = code `snocOL` instr src dst + code__2 dst = code `snocOL` instr src dst return (Any pk code__2) @@ -551,10 +543,10 @@ coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register coerceInt2FP width1 width2 x = do (src, code) <- getSomeReg x let - code__2 dst = code `appOL` toOL [ - ST (intSize width1) src (spRel (-2)), - LD (intSize width1) (spRel (-2)) dst, - FxTOy (intSize width1) (floatSize width2) dst dst] + code__2 dst = code `appOL` toOL [ + ST (intSize width1) src (spRel (-2)), + LD (intSize width1) (spRel (-2)) dst, + FxTOy (intSize width1) (floatSize width2) dst dst] return (Any (floatSize $ width2) code__2) @@ -562,37 +554,37 @@ coerceInt2FP width1 width2 x = do -- | 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. +-- 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 fsize1 = floatSize width1 - fsize2 = floatSize width2 - - isize2 = intSize width2 +coerceFP2Int width1 width2 x + = do let fsize1 = floatSize width1 + fsize2 = floatSize width2 + + isize2 = intSize width2 + + (fsrc, code) <- getSomeReg x + fdst <- getNewRegNat fsize2 - (fsrc, code) <- getSomeReg x - fdst <- getNewRegNat fsize2 - - let code2 dst - = code - `appOL` toOL - -- convert float to int format, leaving it in a float reg. - [ FxTOy fsize1 isize2 fsrc fdst + let code2 dst + = code + `appOL` toOL + -- convert float to int format, leaving it in a float reg. + [ FxTOy fsize1 isize2 fsrc fdst - -- store the int into mem, then load it back to move - -- it into an actual int reg. - , ST fsize2 fdst (spRel (-2)) - , LD isize2 (spRel (-2)) dst] + -- store the int into mem, then load it back to move + -- it into an actual int reg. + , ST fsize2 fdst (spRel (-2)) + , LD isize2 (spRel (-2)) dst] - return (Any isize2 code2) + return (Any isize2 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)) + return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) -- | Coerce a single precision floating point value to double precision @@ -607,44 +599,44 @@ coerceFlt2Dbl x = do -- 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] + 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] + 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] + 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] + 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 @@ -652,22 +644,22 @@ condIntReg cond x y = do 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 + code__2 dst + = cond_code + `appOL` toOL + [ BI cond False bid1 + , NOP - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , 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 bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid2] + , NEWBLOCK bid2] return (Any II32 code__2) @@ -679,26 +671,22 @@ condFltReg cond x y = do CondCode _ cond cond_code <- condFltCode cond x y let - code__2 dst - = cond_code - `appOL` toOL - [ NOP - , BF cond False bid1 - , NOP + 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 + , 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 bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid2 ] + , NEWBLOCK bid2 ] return (Any II32 code__2) - - - - diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 5dff9ce704..81641326f2 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -1,22 +1,13 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - --- | One ounce of sanity checking is worth 10000000000000000 ounces --- of staring blindly at assembly code trying to find the problem.. --- +-- | One ounce of sanity checking is worth 10000000000000000 ounces +-- of staring blindly at assembly code trying to find the problem.. module SPARC.CodeGen.Sanity ( - checkBlock + checkBlock ) where import SPARC.Instr -import SPARC.Ppr () +import SPARC.Ppr () import Instruction import Cmm @@ -31,48 +22,46 @@ checkBlock :: CmmBlock -> NatBasicBlock Instr checkBlock cmm block@(BasicBlock _ instrs) - | checkBlockInstrs instrs - = block - - | otherwise - = pprPanic - ("SPARC.CodeGen: bad block\n") - ( vcat [ text " -- cmm -----------------\n" - , ppr cmm - , text " -- native code ---------\n" - , ppr block ]) + | checkBlockInstrs instrs + = block + + | otherwise + = pprPanic + ("SPARC.CodeGen: bad block\n") + ( vcat [ text " -- cmm -----------------\n" + , ppr cmm + , text " -- native code ---------\n" + , ppr 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 - - + -- 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/nativeGen/SPARC/Cond.hs b/compiler/nativeGen/SPARC/Cond.hs index 198e4a7627..da41457950 100644 --- a/compiler/nativeGen/SPARC/Cond.hs +++ b/compiler/nativeGen/SPARC/Cond.hs @@ -1,39 +1,31 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Cond ( - Cond(..), - condUnsigned, - condToSigned, - condToUnsigned + Cond(..), + condUnsigned, + condToSigned, + condToUnsigned ) where -- | Branch condition codes. data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | NEVER - | POS - | VC - | VS - deriving Eq + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + | NEG + | NEVER + | POS + | VC + | VS + deriving Eq condUnsigned :: Cond -> Bool diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index 844a08824b..cb53ba411c 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -1,16 +1,8 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Imm ( - -- immediate values - Imm(..), - strImmLit, - litToImm + -- immediate values + Imm(..), + strImmLit, + litToImm ) where @@ -21,29 +13,29 @@ import CLabel import Outputable -- | 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. +-- 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 + = ImmInt Int - -- Sigh. - | ImmInteger Integer + -- Sigh. + | ImmInteger Integer - -- AbstractC Label (with baggage) - | ImmCLbl CLabel + -- AbstractC Label (with baggage) + | ImmCLbl CLabel - -- Simple string - | ImmLit SDoc - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational + -- Simple string + | ImmLit SDoc + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm - | LO Imm - | HI Imm + | LO Imm + | HI Imm -- | Create a ImmLit containing this string. @@ -52,24 +44,22 @@ 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. +-- 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 + 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) + CmmLabelDiffOff l1 l2 off + -> ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) _ -> panic "SPARC.Regs.litToImm: no match" - - diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 8e4a2b32df..fb8cc0cadc 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -7,28 +7,20 @@ -- (c) The University of Glasgow 1993-2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - #include "HsVersions.h" #include "nativeGen/NCG.h" module SPARC.Instr ( - RI(..), - riZero, - - fpRelEA, - moveSp, - - isUnconditionalJump, - - Instr(..), - maxSpillSlots + RI(..), + riZero, + + fpRelEA, + moveSp, + + isUnconditionalJump, + + Instr(..), + maxSpillSlots ) where @@ -57,23 +49,23 @@ import Platform -- | Register or immediate -data RI - = RIReg Reg - | RIImm Imm +data RI + = RIReg Reg + | RIImm Imm -- | Check if a RI represents a zero value. --- - a literal zero --- - register %g0, which is always zero. +-- - 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 +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. +-- corresponding fpRel sequence. fpRelEA :: Int -> Reg -> Instr fpRelEA n dst = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst @@ -88,294 +80,294 @@ moveSp n isUnconditionalJump :: Instr -> Bool isUnconditionalJump ii = case ii of - CALL{} -> True - JMP{} -> True - JMP_TBL{} -> True - BI ALWAYS _ _ -> True - BF ALWAYS _ _ -> True - _ -> False + CALL{} -> True + JMP{} -> True + JMP_TBL{} -> True + BI ALWAYS _ _ -> True + BF ALWAYS _ _ -> True + _ -> False -- | instance for sparc instruction set instance Instruction 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 + 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 mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" -- | SPARC instruction set. --- Not complete. This is only the ones we need. +-- Not complete. This is only the ones we need. -- data Instr - -- meta ops -------------------------------------------------- - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code generation. - -- Will be extracted before pretty-printing. - | LDATA Section CmmStatics - - -- 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 Size AddrMode Reg -- size, src, dst - | ST Size Reg AddrMode -- size, 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 Size Reg Reg -- src dst - | FADD Size Reg Reg Reg -- src1, src2, dst - | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst - | FDIV Size Reg Reg Reg -- src1, src2, dst - | FMOV Size Reg Reg -- src, dst - | FMUL Size Reg Reg Reg -- src1, src2, dst - | FNEG Size Reg Reg -- src, dst - | FSQRT Size Reg Reg -- src, dst - | FSUB Size Reg Reg Reg -- src1, src2, dst - | FxTOy Size Size 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 + -- meta ops -------------------------------------------------- + -- comment pseudo-op + = COMMENT FastString + + -- some static data spat out during code generation. + -- Will be extracted before pretty-printing. + | LDATA Section CmmStatics + + -- 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 Size AddrMode Reg -- size, src, dst + | ST Size Reg AddrMode -- size, 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 Size Reg Reg -- src dst + | FADD Size Reg Reg Reg -- src1, src2, dst + | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst + | FDIV Size Reg Reg Reg -- src1, src2, dst + | FMOV Size Reg Reg -- src, dst + | FMUL Size Reg Reg Reg -- src1, src2, dst + | FNEG Size Reg Reg -- src, dst + | FSQRT Size Reg Reg -- src, dst + | FSUB Size Reg Reg Reg -- src1, src2, dst + | FxTOy Size Size 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. +-- 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. -- sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage sparc_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 + 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) + usage (src, dst) = RU (filter (interesting platform) src) (filter (interesting platform) dst) - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] - regRI (RIReg r) = [r] - regRI _ = [] + regRI (RIReg r) = [r] + regRI _ = [] --- | Interesting regs are virtuals, or ones that are allocatable --- by the register allocator. +-- | 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) -> isFastTrue (freeReg platform r1) - RegReal (RealRegPair r1 _) -> isFastTrue (freeReg platform r1) + RegVirtual _ -> True + RegReal (RealRegSingle r1) -> isFastTrue (freeReg platform r1) + RegReal (RealRegPair r1 _) -> isFastTrue (freeReg platform r1) -- | Apply a given mapping to tall the register references in this instruction. sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr sparc_patchRegsOfInstr instr env = case instr of - LD sz addr reg -> LD sz (fixAddr addr) (env reg) - ST sz reg addr -> ST sz (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 + LD sz addr reg -> LD sz (fixAddr addr) (env reg) + ST sz reg addr -> ST sz (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 + 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 + fixRI (RIReg r) = RIReg (env r) + fixRI other = other -------------------------------------------------------------------------------- sparc_isJumpishInstr :: Instr -> Bool sparc_isJumpishInstr instr = case instr of - BI{} -> True - BF{} -> True - JMP{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False + BI{} -> True + BF{} -> True + JMP{} -> True + JMP_TBL{} -> True + CALL{} -> True + _ -> False sparc_jumpDestsOfInstr :: Instr -> [BlockId] sparc_jumpDestsOfInstr insn = case insn of - BI _ _ id -> [id] - BF _ _ id -> [id] - JMP_TBL _ ids _ -> [id | Just id <- ids] - _ -> [] + BI _ _ id -> [id] + BF _ _ id -> [id] + JMP_TBL _ ids _ -> [id | Just id <- ids] + _ -> [] sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr sparc_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 + 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 +-- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr :: DynFlags -> Reg -- ^ register to spill @@ -387,12 +379,12 @@ sparc_mkSpillInstr dflags reg _ slot = let platform = targetPlatform dflags off = spillSlotToOffset dflags slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - _ -> panic "sparc_mkSpillInstr" - + sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + _ -> panic "sparc_mkSpillInstr" + in ST sz reg (fpRel (negate off_w)) @@ -407,12 +399,12 @@ sparc_mkLoadInstr sparc_mkLoadInstr dflags reg _ slot = let platform = targetPlatform dflags off = spillSlotToOffset dflags slot - off_w = 1 + (off `div` 4) - sz = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - _ -> panic "sparc_mkLoadInstr" + off_w = 1 + (off `div` 4) + sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + _ -> panic "sparc_mkLoadInstr" in LD sz (fpRel (- off_w)) reg @@ -420,32 +412,32 @@ sparc_mkLoadInstr dflags reg _ slot -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta sparc_takeDeltaInstr - :: Instr - -> Maybe Int - + :: Instr + -> Maybe Int + sparc_takeDeltaInstr instr = case instr of - DELTA i -> Just i - _ -> Nothing + DELTA i -> Just i + _ -> Nothing sparc_isMetaInstr - :: Instr - -> Bool - + :: Instr + -> Bool + sparc_isMetaInstr instr = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - + 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. +-- 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. -- sparc_mkRegRegMoveInstr :: Platform @@ -454,40 +446,39 @@ sparc_mkRegRegMoveInstr -> Instr sparc_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 + | 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 _ -> panic "sparc_mkRegRegMoveInstr" - - | otherwise - = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" + + | 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. +-- The register allocator attempts to eliminate reg->reg moves whenever it can, +-- by assigning the src and dest temporaries to the same real register. -- sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) sparc_takeRegRegMoveInstr instr = case instr of - ADD False False src (RIReg src2) dst - | g0 == src2 -> Just (src, dst) + 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 + FMOV FF64 src dst -> Just (src, dst) + FMOV FF32 src dst -> Just (src, dst) + _ -> Nothing -- | Make an unconditional branch instruction. sparc_mkJumpInstr - :: BlockId - -> [Instr] - -sparc_mkJumpInstr id - = [BI ALWAYS False id - , NOP] -- fill the branch delay slot. + :: BlockId + -> [Instr] +sparc_mkJumpInstr id + = [BI ALWAYS False id + , NOP] -- fill the branch delay slot. diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index 01db0ed3ac..394389c4bf 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -1,39 +1,32 @@ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1994-2004 --- +-- -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module 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 + -- 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 @@ -50,65 +43,65 @@ import FastTypes import FastBool {- - 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 - includes/stg/MachRegs.h for a description of what's going on - here. + 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 + includes/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" + | 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 + RealRegSingle i + | i < 32 -> RcInteger + | otherwise -> RcFloat + + RealRegPair{} -> RcDouble -- | regSqueeze_class reg --- Calculuate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. +-- Calculuate 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 -> FastInt virtualRegSqueeze cls vr = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> _ILIT(1) - VirtualRegHi{} -> _ILIT(1) + RcInteger + -> case vr of + VirtualRegI{} -> _ILIT(1) + VirtualRegHi{} -> _ILIT(1) _other -> _ILIT(0) - RcFloat - -> case vr of - VirtualRegF{} -> _ILIT(1) - VirtualRegD{} -> _ILIT(2) + RcFloat + -> case vr of + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(2) _other -> _ILIT(0) - RcDouble - -> case vr of - VirtualRegF{} -> _ILIT(1) - VirtualRegD{} -> _ILIT(1) + RcDouble + -> case vr of + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(1) _other -> _ILIT(0) _other -> _ILIT(0) @@ -118,48 +111,48 @@ realRegSqueeze :: RegClass -> RealReg -> FastInt realRegSqueeze cls rr = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(1) - | otherwise -> _ILIT(0) - - RealRegPair{} -> _ILIT(0) - - RcFloat - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) - - RealRegPair{} -> _ILIT(2) - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) - - RealRegPair{} -> _ILIT(1) - + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(1) + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcFloat + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(2) + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(1) + _other -> _ILIT(0) - --- | All the allocatable registers in the machine, --- including register pairs. + +-- | 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 ] ] +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 +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. @@ -187,88 +180,87 @@ 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 (RealReg n) + | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) fPair (VirtualRegD u) - = Just (VirtualRegHi u) + = Just (VirtualRegHi u) fPair reg - = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) - Nothing + = 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 the fixed use regs removed. --- +-- | All the regs that the register allocator can allocate to, +-- with the the fixed use regs removed. +-- allocatableRegs :: [RealReg] allocatableRegs - = let isFree rr - = case rr of - RealRegSingle r - -> isFastTrue (freeReg r) + = let isFree rr + = case rr of + RealRegSingle r + -> isFastTrue (freeReg r) - RealRegPair r1 r2 - -> isFastTrue (freeReg r1) - && isFastTrue (freeReg r2) + RealRegPair r1 r2 + -> isFastTrue (freeReg r1) + && isFastTrue (freeReg r2) - in filter isFree allRealRegs + in filter isFree allRealRegs --- | The registers to place arguments for function calls, --- for some number of arguments. +-- | 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!" + 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 all the regs that could possibly be returned by argRegs -- allArgRegs :: [Reg] -allArgRegs - = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] +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 +-- 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]] ) + = 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 size. mkVirtualReg :: Unique -> Size -> VirtualReg mkVirtualReg u size - | not (isFloatSize size) - = VirtualRegI u + | not (isFloatSize size) + = VirtualRegI u - | otherwise - = case size of - FF32 -> VirtualRegF u - FF64 -> VirtualRegD u - _ -> panic "mkVReg" + | otherwise + = case size 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" - + RcInteger -> text "blue" + RcFloat -> text "red" + _other -> text "green" diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 142ec6e65d..123a345130 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -1,17 +1,9 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.ShortcutJump ( - JumpDest(..), getJumpDestBlockId, - canShortcut, - shortcutJump, - shortcutStatics, - shortBlockId + JumpDest(..), getJumpDestBlockId, + canShortcut, + shortcutJump, + shortcutStatics, + shortBlockId ) where @@ -28,9 +20,9 @@ import Unique -data JumpDest - = DestBlockId BlockId - | DestImm Imm +data JumpDest + = DestBlockId BlockId + | DestImm Imm getJumpDestBlockId :: JumpDest -> Maybe BlockId getJumpDestBlockId (DestBlockId bid) = Just bid @@ -59,9 +51,9 @@ shortcutLabel fn lab shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static @@ -75,6 +67,3 @@ shortBlockId fn blockid = Just (DestBlockId blockid') -> shortBlockId fn blockid' Just (DestImm (ImmCLbl lbl)) -> lbl _other -> panic "shortBlockId" - - - diff --git a/compiler/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs index 3560a0fe82..629b18789f 100644 --- a/compiler/nativeGen/SPARC/Stack.hs +++ b/compiler/nativeGen/SPARC/Stack.hs @@ -1,16 +1,8 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Stack ( - spRel, - fpRel, - spillSlotToOffset, - maxSpillSlots + spRel, + fpRel, + spillSlotToOffset, + maxSpillSlots ) where @@ -24,43 +16,42 @@ import DynFlags import Outputable -- | 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. +-- 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 +spRel :: Int -- ^ stack offset in words, positive or negative -> AddrMode -spRel n = AddrRegImm sp (ImmInt (n * wordLength)) +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 +-- 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)) + = AddrRegImm fp (ImmInt (n * wordLength)) -- | Convert a spill slot number to a *byte* offset, with no sign. -- spillSlotToOffset :: DynFlags -> Int -> Int spillSlotToOffset dflags slot - | slot >= 0 && slot < maxSpillSlots dflags - = 64 + spillSlotSize * slot + | slot >= 0 && slot < maxSpillSlots dflags + = 64 + spillSlotSize * slot - | otherwise - = pprPanic "spillSlotToOffset:" - ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) + | otherwise + = pprPanic "spillSlotToOffset:" + ( text "invalid spill location: " <> int slot + $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) -- | The maximum number of spill slots available on the C stack. --- If we use up all of the slots, then we're screwed. +-- 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 +-- Why do we reserve 64 bytes, instead of using the whole thing?? +-- -- BL 2009/02/15 -- maxSpillSlots :: DynFlags -> Int maxSpillSlots dflags - = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 - + = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 1b95ceb98b..8fe590f1e9 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -1,22 +1,15 @@ -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Sizes on this architecture --- A Size is a combination of width and class --- --- TODO: Rename this to "Format" instead of "Size" to reflect --- the fact that it represents floating point vs integer. +-- A Size is a combination of width and class +-- +-- TODO: Rename this to "Format" instead of "Size" to reflect +-- the fact that it represents floating point vs integer. -- --- TODO: Signed vs unsigned? +-- TODO: Signed vs unsigned? -- --- TODO: This module is currenly shared by all architectures because --- NCGMonad need to know about it to make a VReg. It would be better --- to have architecture specific formats, and do the overloading --- properly. eg SPARC doesn't care about FF80. +-- TODO: This module is currenly shared by all architectures because +-- NCGMonad need to know about it to make a VReg. It would be better +-- to have architecture specific formats, and do the overloading +-- properly. eg SPARC doesn't care about FF80. -- module Size ( Size(..), @@ -37,76 +30,76 @@ import Outputable -- significance, here in the native code generator. You can change it -- without global consequences. -- --- A major use is as an opcode qualifier; thus the opcode --- mov.l a b --- might be encoded --- MOV II32 a b +-- A major use is as an opcode qualifier; thus the opcode +-- mov.l a b +-- might be encoded +-- MOV II32 a b -- where the Size field encodes the ".l" part. -- ToDo: it's not clear to me that we need separate signed-vs-unsigned sizes --- here. I've removed them from the x86 version, we'll see what happens --SDM +-- here. I've removed them from the x86 version, we'll see what happens --SDM -- ToDo: quite a few occurrences of Size could usefully be replaced by Width data Size - = II8 - | II16 - | II32 - | II64 - | FF32 - | FF64 - | FF80 - deriving (Show, Eq) + = II8 + | II16 + | II32 + | II64 + | FF32 + | FF64 + | FF80 + deriving (Show, Eq) -- | Get the integer size of this width. intSize :: Width -> Size intSize width = case width of - W8 -> II8 - W16 -> II16 - W32 -> II32 - W64 -> II64 - other -> pprPanic "Size.intSize" (ppr other) + W8 -> II8 + W16 -> II16 + W32 -> II32 + W64 -> II64 + other -> pprPanic "Size.intSize" (ppr other) -- | Get the float size of this width. floatSize :: Width -> Size floatSize width = case width of - W32 -> FF32 - W64 -> FF64 - other -> pprPanic "Size.floatSize" (ppr other) + W32 -> FF32 + W64 -> FF64 + other -> pprPanic "Size.floatSize" (ppr other) -- | Check if a size represents a floating point value. isFloatSize :: Size -> Bool isFloatSize size = case size of - FF32 -> True - FF64 -> True - FF80 -> True - _ -> False + FF32 -> True + FF64 -> True + FF80 -> True + _ -> False -- | Convert a Cmm type to a Size. cmmTypeSize :: CmmType -> Size -cmmTypeSize ty - | isFloatType ty = floatSize (typeWidth ty) - | otherwise = intSize (typeWidth ty) +cmmTypeSize ty + | isFloatType ty = floatSize (typeWidth ty) + | otherwise = intSize (typeWidth ty) -- | Get the Width of a Size. sizeToWidth :: Size -> Width sizeToWidth size = case size of - II8 -> W8 - II16 -> W16 - II32 -> W32 - II64 -> W64 - FF32 -> W32 - FF64 -> W64 - FF80 -> W80 + II8 -> W8 + II16 -> W16 + II32 -> W32 + II64 -> W64 + FF32 -> W32 + FF64 -> W64 + FF80 -> W80 sizeInBytes :: Size -> Int sizeInBytes = widthInBytes . sizeToWidth diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index daf1e254c8..96c1777795 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -1,28 +1,20 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Hard wired things related to registers. --- This is module is preventing the native code generator being able to --- emit code for non-host architectures. +-- This is module is preventing the native code generator being able to +-- emit code for non-host architectures. -- --- TODO: Do a better job of the overloading, and eliminate this module. --- We'd probably do better with a Register type class, and hook this to --- Instruction somehow. +-- TODO: Do a better job of the overloading, and eliminate this module. +-- We'd probably do better with a Register type class, and hook this to +-- Instruction somehow. -- --- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable - +-- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable module TargetReg ( - targetVirtualRegSqueeze, - targetRealRegSqueeze, - targetClassOfRealReg, - targetMkVirtualReg, - targetRegDotColor, - targetClassOfReg + targetVirtualRegSqueeze, + targetRealRegSqueeze, + targetClassOfRealReg, + targetMkVirtualReg, + targetRegDotColor, + targetClassOfReg ) where @@ -132,5 +124,3 @@ targetClassOfReg platform reg = case reg of RegVirtual vr -> classOfVirtualReg vr RegReal rr -> targetClassOfRealReg platform rr - - diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index fa93767fa3..a9ff8f2853 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -41,7 +41,7 @@ import Platform -- Our intermediate code: import BasicTypes import BlockId -import Module ( primPackageId ) +import Module ( primPackageKey ) import PprCmm () import CmmUtils import Cmm @@ -1057,6 +1057,18 @@ getAmode' _ expr = do (reg,code) <- getSomeReg expr return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) +-- | Like 'getAmode', but on 32-bit use simple register addressing +-- (i.e. no index register). This stops us from running out of +-- registers on x86 when using instructions such as cmpxchg, which can +-- use up to three virtual registers and one fixed register. +getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode +getSimpleAmode dflags is32Bit addr + | is32Bit = do + addr_code <- getAnyReg addr + addr_r <- getNewRegNat (intSize (wordWidth dflags)) + let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) + return $! Amode amode (addr_code addr_r) + | otherwise = getAmode addr x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode x86_complex_amode base index shift offset @@ -1749,7 +1761,7 @@ genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] genCCall dflags is32Bit target dest_regs args where size = intSize width - lbl = mkCmmCodeLabel primPackageId (fsLit (popCntLabel width)) + lbl = mkCmmCodeLabel primPackageKey (fsLit (popCntLabel width)) genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do targetExpr <- cmmMakeDynamicReference dflags @@ -1759,7 +1771,97 @@ genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do CmmMayReturn) genCCall dflags is32Bit target dest_regs args where - lbl = mkCmmCodeLabel primPackageId (fsLit (word2FloatLabel width)) + lbl = mkCmmCodeLabel primPackageKey (fsLit (word2FloatLabel width)) + +genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do + Amode amode addr_code <- + if amop `elem` [AMO_Add, AMO_Sub] + then getAmode addr + else getSimpleAmode dflags is32Bit addr -- See genCCall for MO_Cmpxchg + arg <- getNewRegNat size + arg_code <- getAnyReg n + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code <- op_code dst_r arg amode + return $ addr_code `appOL` arg_code arg `appOL` code + where + -- Code for the operation + op_code :: Reg -- Destination reg + -> Reg -- Register containing argument + -> AddrMode -- Address of location to mutate + -> NatM (OrdList Instr) + op_code dst_r arg amode = case amop of + -- In the common case where dst_r is a virtual register the + -- final move should go away, because it's the last use of arg + -- and the first use of dst_r. + AMO_Add -> return $ toOL [ LOCK (XADD size (OpReg arg) (OpAddr amode)) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_Sub -> return $ toOL [ NEGI size (OpReg arg) + , LOCK (XADD size (OpReg arg) (OpAddr amode)) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND size src dst) + AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND size src dst + , NOT size dst + ]) + AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR size src dst) + AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR size src dst) + where + -- Simulate operation that lacks a dedicated instruction using + -- cmpxchg. + cmpxchg_code :: (Operand -> Operand -> OrdList Instr) + -> NatM (OrdList Instr) + cmpxchg_code instrs = do + lbl <- getBlockIdNat + tmp <- getNewRegNat size + return $ toOL + [ MOV size (OpAddr amode) (OpReg eax) + , JXX ALWAYS lbl + , NEWBLOCK lbl + -- Keep old value so we can return it: + , MOV size (OpReg eax) (OpReg dst_r) + , MOV size (OpReg eax) (OpReg tmp) + ] + `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL + [ LOCK (CMPXCHG size (OpReg tmp) (OpAddr amode)) + , JXX NE lbl + ] + + size = intSize width + +genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] = do + load_code <- intLoadCode (MOV (intSize width)) addr + let platform = targetPlatform dflags + use_sse2 <- sse2Enabled + return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst))) + +genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do + code <- assignMem_IntCode (intSize width) addr val + return $ code `snocOL` MFENCE + +genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = do + -- On x86 we don't have enough registers to use cmpxchg with a + -- complicated addressing mode, so on that architecture we + -- pre-compute the address first. + Amode amode addr_code <- getSimpleAmode dflags is32Bit addr + newval <- getNewRegNat size + newval_code <- getAnyReg new + oldval <- getNewRegNat size + oldval_code <- getAnyReg old + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code = toOL + [ MOV size (OpReg oldval) (OpReg eax) + , LOCK (CMPXCHG size (OpReg newval) (OpAddr amode)) + , MOV size (OpReg eax) (OpReg dst_r) + ] + return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval + `appOL` code + where + size = intSize width genCCall _ is32Bit target dest_regs args | is32Bit = genCCall32 target dest_regs args @@ -2385,6 +2487,11 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" MO_BSwap _ -> fsLit "bswap" + MO_AtomicRMW _ _ -> fsLit "atomicrmw" + MO_AtomicRead _ -> fsLit "atomicread" + MO_AtomicWrite _ -> fsLit "atomicwrite" + MO_Cmpxchg _ -> fsLit "cmpxchg" + MO_UF_Conv _ -> unsupported MO_S_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 05fff9be96..172ce93f50 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -327,6 +327,11 @@ data Instr | PREFETCH PrefetchVariant Size Operand -- prefetch Variant, addr size, address to prefetch -- variant can be NTA, Lvl0, Lvl1, or Lvl2 + | LOCK Instr -- lock prefix + | XADD Size Operand Operand -- src (r), dst (r/m) + | CMPXCHG Size Operand Operand -- src (r), dst (r/m), eax implicit + | MFENCE + data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 @@ -337,6 +342,8 @@ data Operand +-- | Returns which registers are read and written as a (read, written) +-- pair. x86_regUsageOfInstr :: Platform -> Instr -> RegUsage x86_regUsageOfInstr platform instr = case instr of @@ -428,10 +435,22 @@ x86_regUsageOfInstr platform instr -- note: might be a better way to do this PREFETCH _ _ src -> mkRU (use_R src []) [] + LOCK i -> x86_regUsageOfInstr platform i + XADD _ src dst -> usageMM src dst + CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) + MFENCE -> noUsage _other -> panic "regUsage: unrecognised instr" - where + -- # Definitions + -- + -- Written: If the operand is a register, it's written. If it's an + -- address, registers mentioned in the address are read. + -- + -- Modified: If the operand is a register, it's both read and + -- written. If it's an address, registers mentioned in the address + -- are read. + -- 2 operand form; first operand Read; second Written usageRW :: Operand -> Operand -> RegUsage usageRW op (OpReg reg) = mkRU (use_R op []) [reg] @@ -444,6 +463,18 @@ x86_regUsageOfInstr platform instr usageRM op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) usageRM _ _ = panic "X86.RegInfo.usageRM: no match" + -- 2 operand form; first operand Modified; second Modified + usageMM :: Operand -> Operand -> RegUsage + usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst] + usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src] + usageMM _ _ = panic "X86.RegInfo.usageMM: no match" + + -- 3 operand form; first operand Read; second Modified; third Modified + usageRMM :: Operand -> Operand -> Operand -> RegUsage + usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg] + usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg] + usageRMM _ _ _ = panic "X86.RegInfo.usageRMM: no match" + -- 1 operand form; operand Modified usageM :: Operand -> RegUsage usageM (OpReg reg) = mkRU [reg] [reg] @@ -476,6 +507,7 @@ x86_regUsageOfInstr platform instr where src' = filter (interesting platform) src dst' = filter (interesting platform) dst +-- | Is this register interesting for the register allocator? interesting :: Platform -> Reg -> Bool interesting _ (RegVirtual _) = True interesting platform (RegReal (RealRegSingle i)) = isFastTrue (freeReg platform i) @@ -483,6 +515,8 @@ interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no re +-- | Applies the supplied function to all registers in instructions. +-- Typically used to change virtual registers to real registers. x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr x86_patchRegsOfInstr instr env = case instr of @@ -571,6 +605,11 @@ x86_patchRegsOfInstr instr env PREFETCH lvl size src -> PREFETCH lvl size (patchOp src) + LOCK i -> LOCK (x86_patchRegsOfInstr i env) + XADD sz src dst -> patch2 (XADD sz) src dst + CMPXCHG sz src dst -> patch2 (CMPXCHG sz) src dst + MFENCE -> instr + _other -> panic "patchRegs: unrecognised instr" where diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 459c041ba5..15d29679b0 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -886,6 +886,16 @@ pprInstr GFREE ptext (sLit "\tffree %st(4) ;ffree %st(5)") ] +-- Atomics + +pprInstr (LOCK i) = ptext (sLit "\tlock") $$ pprInstr i + +pprInstr MFENCE = ptext (sLit "\tmfence") + +pprInstr (XADD size src dst) = pprSizeOpOp (sLit "xadd") size src dst + +pprInstr (CMPXCHG size src dst) = pprSizeOpOp (sLit "cmpxchg") size src dst + pprInstr _ = panic "X86.Ppr.pprInstr: no match" diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 0303295bc6..39535634d7 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -1,14 +1,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module X86.RegInfo ( - mkVirtualReg, - regDotColor + mkVirtualReg, + regDotColor ) where @@ -30,9 +23,9 @@ import X86.Regs mkVirtualReg :: Unique -> Size -> VirtualReg mkVirtualReg u size = case size of - FF32 -> VirtualRegSSE u - FF64 -> VirtualRegSSE u - FF80 -> VirtualRegD u + FF32 -> VirtualRegSSE u + FF64 -> VirtualRegSSE u + FF80 -> VirtualRegD u _other -> VirtualRegI u regDotColor :: Platform -> RealReg -> SDoc @@ -65,11 +58,10 @@ normalRegColors platform fpRegColors :: [(Reg,String)] fpRegColors = [ (fake0, "#ff00ff") - , (fake1, "#ff00aa") - , (fake2, "#aa00ff") - , (fake3, "#aa00aa") - , (fake4, "#ff0055") - , (fake5, "#5500ff") ] - - ++ zip (map regSingle [24..39]) (repeat "red") + , (fake1, "#ff00aa") + , (fake2, "#aa00ff") + , (fake3, "#aa00aa") + , (fake4, "#ff0055") + , (fake5, "#5500ff") ] + ++ zip (map regSingle [24..39]) (repeat "red") |