summaryrefslogtreecommitdiff
path: root/compiler/nativeGen/SPARC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/nativeGen/SPARC')
-rw-r--r--compiler/nativeGen/SPARC/CodeGen.hs4
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Amode.hs38
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Base.hs94
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/CondCode.hs50
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Expand.hs197
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Gen32.hs734
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Sanity.hs95
-rw-r--r--compiler/nativeGen/SPARC/Cond.hs50
-rw-r--r--compiler/nativeGen/SPARC/Imm.hs74
-rw-r--r--compiler/nativeGen/SPARC/Instr.hs613
-rw-r--r--compiler/nativeGen/SPARC/Regs.hs282
-rw-r--r--compiler/nativeGen/SPARC/ShortcutJump.hs31
-rw-r--r--compiler/nativeGen/SPARC/Stack.hs49
13 files changed, 1097 insertions, 1214 deletions
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
View Lorry Controller Status