X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocInfo.hs;h=57c9ce6e1a7f4a8fa4c38c252600b5eea7bdbd53;hb=a842f3d5e7c9026a642589948ef67dbaf6272396;hp=df7421877a8ad458c339273d727d1360665b2076;hpb=561e57422c9189457e2c837a6329861dbc4231a5;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAllocInfo.hs b/compiler/nativeGen/RegAllocInfo.hs index df74218..57c9ce6 100644 --- a/compiler/nativeGen/RegAllocInfo.hs +++ b/compiler/nativeGen/RegAllocInfo.hs @@ -1,3 +1,10 @@ +{-# 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 @@ -14,9 +21,12 @@ module RegAllocInfo ( regUsage, patchRegs, jumpDests, + isJumpish, patchJump, isRegRegMove, + JumpDest, canShortcut, shortcutJump, shortcutStatic, + maxSpillSlots, mkSpillInstr, mkLoadInstr, @@ -26,13 +36,14 @@ module RegAllocInfo ( #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 @@ -66,6 +77,8 @@ interesting (RealReg i) = isFastTrue (freeReg i) #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 @@ -156,6 +169,8 @@ regUsage instr = case instr of 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 @@ -170,6 +185,7 @@ regUsage instr = case instr of 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 @@ -196,20 +212,20 @@ regUsage instr = case instr of 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 @@ -220,6 +236,8 @@ regUsage instr = case instr of COMMENT _ -> noUsage DELTA _ -> noUsage + SPILL reg slot -> mkRU [reg] [] + RELOAD slot reg -> mkRU [] [reg] _other -> panic "regUsage: unrecognised instr" @@ -269,13 +287,19 @@ regUsage instr = case instr of #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]) @@ -297,8 +321,8 @@ regUsage instr = case instr of 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) @@ -321,6 +345,9 @@ regUsage instr = case instr of #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, []) @@ -331,6 +358,7 @@ regUsage instr = case instr of 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) @@ -395,12 +423,53 @@ jumpDests insn acc 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 @@ -408,10 +477,58 @@ patchJump insn old new 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 @@ -423,6 +540,8 @@ patchRegs :: Instr -> (Reg -> Reg) -> Instr #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) @@ -532,16 +651,16 @@ patchRegs instr env = case instr of 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) @@ -556,7 +675,11 @@ patchRegs instr env = case instr of 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" @@ -585,13 +708,18 @@ patchRegs instr env = case instr of #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) @@ -612,7 +740,10 @@ patchRegs instr env = case instr of 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 @@ -628,6 +759,9 @@ patchRegs instr env = case instr of #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) @@ -638,6 +772,7 @@ patchRegs instr env = case instr of 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 @@ -691,28 +826,36 @@ patchRegs instr env = case instr of -- 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 (?)-} @@ -721,14 +864,14 @@ mkSpillInstr reg delta slot #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 @@ -736,28 +879,26 @@ mkSpillInstr reg delta slot {-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))) @@ -765,27 +906,27 @@ mkLoadInstr reg delta slot #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 @@ -796,14 +937,21 @@ mkRegRegMoveInstr 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 @@ -818,7 +966,7 @@ mkBranchInstr id = [JXX ALWAYS id] #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 @@ -841,4 +989,5 @@ spillSlotToOffset slot = 64 + spillSlotSize * slot | otherwise = pprPanic "spillSlotToOffset:" - (text "invalid spill location: " <> int slot) + ( text "invalid spill location: " <> int slot + $$ text "maxSpillSlots: " <> int maxSpillSlots)