+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- Machine-specific parts of the register allocator
regUsage,
patchRegs,
jumpDests,
+ isJumpish,
patchJump,
isRegRegMove,
+ JumpDest, canShortcut, shortcutJump, shortcutStatic,
+
maxSpillSlots,
mkSpillInstr,
mkLoadInstr,
#include "HsVersions.h"
-import Cmm ( BlockId )
-import MachOp ( MachRep(..), wordRep )
+import BlockId
+import Cmm
+import CLabel
import MachInstrs
import MachRegs
import Outputable
import Constants ( rESERVED_C_STACK_BYTES )
-import FastTypes
+import FastBool
-- -----------------------------------------------------------------------------
-- RegUsage type
#if alpha_TARGET_ARCH
regUsage instr = case instr of
+ SPILL reg slot -> usage ([reg], [])
+ RELOAD slot reg -> usage ([], [reg])
LD B reg addr -> usage (regAddr addr, [reg, t9])
LD Bu reg addr -> usage (regAddr addr, [reg, t9])
-- LD W reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED
IDIV sz op -> mkRU (eax:edx:use_R op) [eax,edx]
AND sz src dst -> usageRM src dst
OR sz src dst -> usageRM src dst
+ XOR sz (OpReg src) (OpReg dst)
+ | src == dst -> mkRU [] [dst]
XOR sz src dst -> usageRM src dst
NOT sz op -> usageM op
NEGI sz op -> usageM op
CMP sz src dst -> mkRUR (use_R src ++ use_R dst)
SETCC cond op -> mkRU [] (def_W op)
JXX cond lbl -> mkRU [] []
+ JXX_GBL cond lbl -> mkRU [] []
JMP op -> mkRUR (use_R op)
JMP_TBL op ids -> mkRUR (use_R op)
CALL (Left imm) params -> mkRU params callClobberedRegs
GMUL sz s1 s2 dst -> mkRU [s1,s2] [dst]
GDIV sz s1 s2 dst -> mkRU [s1,s2] [dst]
- GCMP sz src1 src2 -> mkRUR [src1,src2]
- GABS sz src dst -> mkRU [src] [dst]
- GNEG sz src dst -> mkRU [src] [dst]
- GSQRT sz src dst -> mkRU [src] [dst]
- GSIN sz src dst -> mkRU [src] [dst]
- GCOS sz src dst -> mkRU [src] [dst]
- GTAN sz src dst -> mkRU [src] [dst]
+ GCMP sz src1 src2 -> mkRUR [src1,src2]
+ GABS sz src dst -> mkRU [src] [dst]
+ GNEG sz src dst -> mkRU [src] [dst]
+ GSQRT sz src dst -> mkRU [src] [dst]
+ GSIN sz _ _ src dst -> mkRU [src] [dst]
+ GCOS sz _ _ src dst -> mkRU [src] [dst]
+ GTAN sz _ _ src dst -> mkRU [src] [dst]
#endif
#if x86_64_TARGET_ARCH
CVTSS2SD src dst -> mkRU [src] [dst]
CVTSD2SS src dst -> mkRU [src] [dst]
- CVTSS2SI src dst -> mkRU (use_R src) [dst]
- CVTSD2SI src dst -> mkRU (use_R src) [dst]
+ CVTTSS2SIQ src dst -> mkRU (use_R src) [dst]
+ CVTTSD2SIQ src dst -> mkRU (use_R src) [dst]
CVTSI2SS src dst -> mkRU (use_R src) [dst]
CVTSI2SD src dst -> mkRU (use_R src) [dst]
FDIV sz src dst -> usageRM src dst
COMMENT _ -> noUsage
DELTA _ -> noUsage
+ SPILL reg slot -> mkRU [reg] []
+ RELOAD slot reg -> mkRU [] [reg]
_other -> panic "regUsage: unrecognised instr"
where
-#if x86_64_TARGET_ARCH
- -- call parameters: include %eax, because it is used
- -- to pass the number of SSE reg arguments to varargs fns.
- params = eax : allArgRegs ++ allFPArgRegs
-#endif
-
-- 2 operand form; first operand Read; second Written
usageRW :: Operand -> Operand -> RegUsage
usageRW op (OpReg reg) = mkRU (use_R op) [reg]
#if sparc_TARGET_ARCH
regUsage instr = case instr of
+ SPILL reg slot -> usage ([reg], [])
+ RELOAD slot reg -> usage ([], [reg])
+
LD sz addr reg -> usage (regAddr addr, [reg])
ST sz reg addr -> usage (reg : regAddr addr, [])
ADD x cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
SUB x cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
UMUL cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
SMUL cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ UDIV cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SDIV cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
RDY rd -> usage ([], [rd])
+ WRY r1 r2 -> usage ([r1, r2], [])
AND b r1 ar r2 -> usage (r1 : regRI ar, [r2])
ANDN b r1 ar r2 -> usage (r1 : regRI ar, [r2])
OR b r1 ar r2 -> usage (r1 : regRI ar, [r2])
FSUB s r1 r2 r3 -> usage ([r1, r2], [r3])
FxTOy s1 s2 r1 r2 -> usage ([r1], [r2])
- -- We assume that all local jumps will be BI/BF. JMP must be out-of-line.
- JMP addr -> usage (regAddr addr, [])
+ JMP addr -> usage (regAddr addr, [])
+ JMP_TBL addr ids -> usage (regAddr addr, [])
CALL (Left imm) n True -> noUsage
CALL (Left imm) n False -> usage (argRegs n, callClobberedRegs)
#if powerpc_TARGET_ARCH
regUsage instr = case instr of
+ SPILL reg slot -> usage ([reg], [])
+ RELOAD slot reg -> usage ([], [reg])
+
LD sz reg addr -> usage (regAddr addr, [reg])
LA sz reg addr -> usage (regAddr addr, [reg])
ST sz reg addr -> usage (reg : regAddr addr, [])
CMP sz reg ri -> usage (reg : regRI ri,[])
CMPL sz reg ri -> usage (reg : regRI ri,[])
BCC cond lbl -> noUsage
+ BCCFAR cond lbl -> noUsage
MTCTR reg -> usage ([reg],[])
BCTR targets -> noUsage
BL imm params -> usage (params, callClobberedRegs)
JMP_TBL _ ids -> ids ++ acc
#elif powerpc_TARGET_ARCH
BCC _ id -> id : acc
+ BCCFAR _ id -> id : acc
BCTR targets -> targets ++ acc
+#elif sparc_TARGET_ARCH
+ BI _ _ id -> id : acc
+ BF _ _ id -> id : acc
+ JMP_TBL _ ids -> ids ++ acc
+#else
+#error "RegAllocInfo.jumpDests not finished"
#endif
_other -> acc
-patchJump :: Instr -> BlockId -> BlockId -> Instr
+-- | Check whether a particular instruction is a jump, branch or call instruction (jumpish)
+-- We can't just use jumpDests above because the jump might take its arg,
+-- so the instr won't contain a blockid.
+--
+isJumpish :: Instr -> Bool
+isJumpish instr
+ = case instr of
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
+ JMP{} -> True
+ JXX{} -> True
+ JXX_GBL{} -> True
+ JMP_TBL{} -> True
+ CALL{} -> True
+
+#elif powerpc_TARGET_ARCH
+ BCC{} -> True
+ BCCFAR{} -> True
+ JMP{} -> True
+
+#elif sparc_TARGET_ARCH
+ BI{} -> True
+ BF{} -> True
+ JMP{} -> True
+ JMP_TBL{} -> True
+ CALL{} -> True
+#else
+#error "RegAllocInfo.isJumpish: not implemented for this architecture"
+#endif
+ _ -> False
+
+
+-- | Change the destination of this jump instruction
+-- Used in joinToTargets in the linear allocator, when emitting fixup code
+-- for join points.
+patchJump :: Instr -> BlockId -> BlockId -> Instr
patchJump insn old new
= case insn of
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
JMP_TBL op ids -> error "Cannot patch JMP_TBL"
#elif powerpc_TARGET_ARCH
BCC cc id | id == old -> BCC cc new
+ BCCFAR cc id | id == old -> BCCFAR cc new
BCTR targets -> error "Cannot patch BCTR"
+#elif sparc_TARGET_ARCH
+ BI cc annul id
+ | id == old -> BI cc annul new
+
+ BF cc annul id
+ | id == old -> BF cc annul new
+#else
+#error "RegAllocInfo.patchJump not finished"
#endif
_other -> insn
+data JumpDest = DestBlockId BlockId | DestImm Imm
+
+canShortcut :: Instr -> Maybe JumpDest
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
+canShortcut (JXX ALWAYS id) = Just (DestBlockId id)
+canShortcut (JMP (OpImm imm)) = Just (DestImm imm)
+#endif
+canShortcut _ = Nothing
+
+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
+shortcutJump fn insn@(JXX cc id) =
+ case fn id of
+ Nothing -> insn
+ Just (DestBlockId id') -> shortcutJump fn (JXX cc id')
+ Just (DestImm imm) -> shortcutJump fn (JXX_GBL cc imm)
+#endif
+shortcutJump fn other = other
+
+-- Here because it knows about JumpDest
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+ | Just uq <- maybeAsmTemp lab
+ = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq)))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
+ | Just uq <- maybeAsmTemp lbl1
+ = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off)
+ -- slightly dodgy, we're ignoring the second label, but this
+ -- works with the way we use CmmLabelDiffOff for jump tables now.
+shortcutStatic fn other_static
+ = other_static
+
+shortBlockId fn blockid@(BlockId uq) =
+ case fn blockid of
+ Nothing -> mkAsmTempLabel uq
+ Just (DestBlockId blockid') -> shortBlockId fn blockid'
+ Just (DestImm (ImmCLbl lbl)) -> lbl
+ _other -> panic "shortBlockId"
+
-- -----------------------------------------------------------------------------
-- 'patchRegs' function
#if alpha_TARGET_ARCH
patchRegs instr env = case instr of
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
LD sz reg addr -> LD sz (env reg) (fixAddr addr)
LDA reg addr -> LDA (env reg) (fixAddr addr)
LDAH reg addr -> LDAH (env reg) (fixAddr addr)
GABS sz src dst -> GABS sz (env src) (env dst)
GNEG sz src dst -> GNEG sz (env src) (env dst)
GSQRT sz src dst -> GSQRT sz (env src) (env dst)
- GSIN sz src dst -> GSIN sz (env src) (env dst)
- GCOS sz src dst -> GCOS sz (env src) (env dst)
- GTAN sz src dst -> GTAN sz (env src) (env dst)
+ GSIN sz l1 l2 src dst -> GSIN sz l1 l2 (env src) (env dst)
+ GCOS sz l1 l2 src dst -> GCOS sz l1 l2 (env src) (env dst)
+ GTAN sz l1 l2 src dst -> GTAN sz l1 l2 (env src) (env dst)
#endif
#if x86_64_TARGET_ARCH
CVTSS2SD src dst -> CVTSS2SD (env src) (env dst)
CVTSD2SS src dst -> CVTSD2SS (env src) (env dst)
- CVTSS2SI src dst -> CVTSS2SI (patchOp src) (env dst)
- CVTSD2SI src dst -> CVTSD2SI (patchOp src) (env dst)
+ CVTTSS2SIQ src dst -> CVTTSS2SIQ (patchOp src) (env dst)
+ CVTTSD2SIQ src dst -> CVTTSD2SIQ (patchOp src) (env dst)
CVTSI2SS src dst -> CVTSI2SS (patchOp src) (env dst)
CVTSI2SD src dst -> CVTSI2SD (patchOp src) (env dst)
FDIV sz src dst -> FDIV sz (patchOp src) (patchOp dst)
NOP -> instr
COMMENT _ -> instr
DELTA _ -> instr
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
+
JXX _ _ -> instr
+ JXX_GBL _ _ -> instr
CLTD _ -> instr
_other -> panic "patchRegs: unrecognised instr"
#if sparc_TARGET_ARCH
patchRegs instr env = case instr of
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
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)
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 addr -> JMP (fixAddr addr)
+ JMP_TBL addr ids -> JMP_TBL (fixAddr addr) ids
+
CALL (Left i) n t -> CALL (Left i) n t
CALL (Right r) n t -> CALL (Right (env r)) n t
_ -> instr
#if powerpc_TARGET_ARCH
patchRegs instr env = case instr of
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
+
LD sz reg addr -> LD sz (env reg) (fixAddr addr)
LA sz reg addr -> LA sz (env reg) (fixAddr addr)
ST sz reg addr -> ST sz (env reg) (fixAddr addr)
CMP sz reg ri -> CMP sz (env reg) (fixRI ri)
CMPL sz reg ri -> CMPL sz (env reg) (fixRI ri)
BCC cond lbl -> BCC cond lbl
+ BCCFAR cond lbl -> BCCFAR cond lbl
MTCTR reg -> MTCTR (env reg)
BCTR targets -> BCTR targets
BL imm argRegs -> BL imm argRegs -- argument regs
-- by assigning the src and dest temporaries to the same real register.
isRegRegMove :: Instr -> Maybe (Reg,Reg)
+
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-- TMP:
isRegRegMove (MOV _ (OpReg r1) (OpReg r2)) = Just (r1,r2)
+
#elif powerpc_TARGET_ARCH
isRegRegMove (MR dst src) = Just (src,dst)
-#else
-#warning ToDo: isRegRegMove
+
+#elif sparc_TARGET_ARCH
+isRegRegMove instr
+ = case instr of
+ ADD False False src (RIReg src2) dst
+ | g0 == src2 -> Just (src, dst)
+
+ FMOV FF64 src dst -> Just (src, dst)
+ FMOV FF32 src dst -> Just (src, dst)
+ _ -> Nothing
#endif
-isRegRegMove _ = Nothing
+isRegRegMove _ = Nothing
-- -----------------------------------------------------------------------------
-- Generating spill instructions
mkSpillInstr
- :: Reg -- register to spill (should be a real)
+ :: Reg -- register to spill
-> Int -- current stack delta
-> Int -- spill slot to use
-> Instr
mkSpillInstr reg delta slot
- = ASSERT(isRealReg reg)
- let
- off = spillSlotToOffset slot
+ = let off = spillSlotToOffset slot
in
#ifdef alpha_TARGET_ARCH
{-Alpha: spill below the stack pointer (?)-}
#ifdef i386_TARGET_ARCH
let off_w = (off-delta) `div` 4
in case regClass reg of
- RcInteger -> MOV I32 (OpReg reg) (OpAddr (spRel off_w))
- _ -> GST F80 reg (spRel off_w) {- RcFloat/RcDouble -}
+ RcInteger -> MOV II32 (OpReg reg) (OpAddr (spRel off_w))
+ _ -> GST FF80 reg (spRel off_w) {- RcFloat/RcDouble -}
#endif
#ifdef x86_64_TARGET_ARCH
let off_w = (off-delta) `div` 8
in case regClass reg of
- RcInteger -> MOV I64 (OpReg reg) (OpAddr (spRel off_w))
- RcDouble -> MOV F64 (OpReg reg) (OpAddr (spRel off_w))
+ RcInteger -> MOV II64 (OpReg reg) (OpAddr (spRel off_w))
+ RcDouble -> MOV FF64 (OpReg reg) (OpAddr (spRel off_w))
-- ToDo: will it work to always spill as a double?
-- does that cause a stall if the data was a float?
#endif
{-SPARC: spill below frame pointer leaving 2 words/spill-}
let{off_w = 1 + (off `div` 4);
sz = case regClass reg of {
- RcInteger -> I32;
- RcFloat -> F32;
- RcDouble -> F64}}
- in ST sz reg (fpRel (- off_w))
+ RcInteger -> II32;
+ RcFloat -> FF32;
+ RcDouble -> FF64;}}
+ in ST sz reg (fpRel (negate off_w))
#endif
#ifdef powerpc_TARGET_ARCH
let sz = case regClass reg of
- RcInteger -> I32
- RcDouble -> F64
+ RcInteger -> II32
+ RcDouble -> FF64
in ST sz reg (AddrRegImm sp (ImmInt (off-delta)))
#endif
mkLoadInstr
- :: Reg -- register to load (should be a real)
+ :: Reg -- register to load
-> Int -- current stack delta
-> Int -- spill slot to use
-> Instr
mkLoadInstr reg delta slot
- = ASSERT(isRealReg reg)
- let
- off = spillSlotToOffset slot
+ = let off = spillSlotToOffset slot
in
#if alpha_TARGET_ARCH
LD sz dyn (spRel (- (off `div` 8)))
#if i386_TARGET_ARCH
let off_w = (off-delta) `div` 4
in case regClass reg of {
- RcInteger -> MOV I32 (OpAddr (spRel off_w)) (OpReg reg);
- _ -> GLD F80 (spRel off_w) reg} {- RcFloat/RcDouble -}
+ RcInteger -> MOV II32 (OpAddr (spRel off_w)) (OpReg reg);
+ _ -> GLD FF80 (spRel off_w) reg} {- RcFloat/RcDouble -}
#endif
#if x86_64_TARGET_ARCH
let off_w = (off-delta) `div` 8
in case regClass reg of
- RcInteger -> MOV I64 (OpAddr (spRel off_w)) (OpReg reg)
- _ -> MOV F64 (OpAddr (spRel off_w)) (OpReg reg)
+ RcInteger -> MOV II64 (OpAddr (spRel off_w)) (OpReg reg)
+ _ -> MOV FF64 (OpAddr (spRel off_w)) (OpReg reg)
#endif
#if sparc_TARGET_ARCH
let{off_w = 1 + (off `div` 4);
sz = case regClass reg of {
- RcInteger -> I32;
- RcFloat -> F32;
- RcDouble -> F64}}
+ RcInteger -> II32;
+ RcFloat -> FF32;
+ RcDouble -> FF64}}
in LD sz (fpRel (- off_w)) reg
#endif
#if powerpc_TARGET_ARCH
let sz = case regClass reg of
- RcInteger -> I32
- RcDouble -> F64
+ RcInteger -> II32
+ RcDouble -> FF64
in LD sz reg (AddrRegImm sp (ImmInt (off-delta)))
#endif
mkRegRegMoveInstr src dst
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
= case regClass src of
- RcInteger -> MOV wordRep (OpReg src) (OpReg dst)
+ RcInteger -> MOV wordSize (OpReg src) (OpReg dst)
#if i386_TARGET_ARCH
RcDouble -> GMOV src dst
#else
- RcDouble -> MOV F64 (OpReg src) (OpReg dst)
+ RcDouble -> MOV FF64 (OpReg src) (OpReg dst)
#endif
#elif powerpc_TARGET_ARCH
= MR dst src
+#elif sparc_TARGET_ARCH
+ = case regClass src of
+ RcInteger -> ADD False False src (RIReg g0) dst
+ RcDouble -> FMOV FF64 src dst
+ RcFloat -> FMOV FF32 src dst
+#else
+#error ToDo: mkRegRegMoveInstr
#endif
mkBranchInstr
#endif
#if sparc_TARGET_ARCH
-mkBranchInstr (BlockId id) = [BI ALWAYS False (ImmCLbl (mkAsmTempLabel id)), NOP]
+mkBranchInstr id = [BI ALWAYS False id, NOP]
#endif
#if powerpc_TARGET_ARCH
= 64 + spillSlotSize * slot
| otherwise
= pprPanic "spillSlotToOffset:"
- (text "invalid spill location: " <> int slot)
+ ( text "invalid spill location: " <> int slot
+ $$ text "maxSpillSlots: " <> int maxSpillSlots)
projects / ghc-hetmet.git / blobdiff