X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocInfo.hs;h=57c9ce6e1a7f4a8fa4c38c252600b5eea7bdbd53;hb=337d98de1eaf6689269c9788d1983569a98d46a0;hp=80702bd61d2ee3ae83da706cb5dae2ef755794a6;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAllocInfo.hs b/compiler/nativeGen/RegAllocInfo.hs index 80702bd..57c9ce6 100644 --- a/compiler/nativeGen/RegAllocInfo.hs +++ b/compiler/nativeGen/RegAllocInfo.hs @@ -21,6 +21,7 @@ module RegAllocInfo ( regUsage, patchRegs, jumpDests, + isJumpish, patchJump, isRegRegMove, @@ -295,7 +296,10 @@ regUsage instr = case instr of 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]) @@ -317,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) @@ -421,11 +425,51 @@ jumpDests insn acc 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 @@ -435,6 +479,14 @@ patchJump insn old new 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 @@ -664,7 +716,10 @@ patchRegs instr env = case instr of 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) @@ -685,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 @@ -768,15 +826,25 @@ 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 -#error 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 @@ -811,9 +879,9 @@ 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}} + RcInteger -> II32; + RcFloat -> FF32; + RcDouble -> FF64;}} in ST sz reg (fpRel (negate off_w)) #endif #ifdef powerpc_TARGET_ARCH @@ -852,7 +920,7 @@ mkLoadInstr reg delta slot sz = case regClass reg of { RcInteger -> II32; RcFloat -> FF32; - RcDouble -> F64}} + RcDouble -> FF64}} in LD sz (fpRel (- off_w)) reg #endif #if powerpc_TARGET_ARCH @@ -877,6 +945,11 @@ mkRegRegMoveInstr src 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 @@ -893,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