--- -----------------------------------------------------------------------------
--- 'patchRegs' function
-
--- 'patchRegs' takes an instruction and applies the given mapping to
--- all the register references.
-
-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)
- LDGP reg addr -> LDGP (env reg) (fixAddr addr)
- LDI sz reg imm -> LDI sz (env reg) imm
- ST sz reg addr -> ST sz (env reg) (fixAddr addr)
- CLR reg -> CLR (env reg)
- ABS sz ar reg -> ABS sz (fixRI ar) (env reg)
- NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg)
- ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2)
- SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2)
- SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2)
- SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2)
- MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2)
- DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2)
- REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2)
- NOT ar reg -> NOT (fixRI ar) (env reg)
- AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2)
- ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2)
- OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2)
- ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2)
- XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2)
- XORNOT r1 ar r2 -> XORNOT (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)
- ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2)
- ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2)
- CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2)
- FCLR reg -> FCLR (env reg)
- FABS r1 r2 -> FABS (env r1) (env r2)
- FNEG s r1 r2 -> FNEG s (env r1) (env r2)
- FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
- FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
- FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
- FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
- CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2)
- FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3)
- FMOV r1 r2 -> FMOV (env r1) (env r2)
- BI cond reg lbl -> BI cond (env reg) lbl
- BF cond reg lbl -> BF cond (env reg) lbl
- JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint
- JSR reg addr i -> JSR (env reg) (fixAddr addr) i
- _ -> instr
- where
- fixAddr (AddrReg r1) = AddrReg (env r1)
- fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
- fixAddr other = other
-
- fixRI (RIReg r) = RIReg (env r)
- fixRI other = other
-
-#endif /* alpha_TARGET_ARCH */
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
-patchRegs instr env = case instr of
- MOV sz src dst -> patch2 (MOV sz) src dst
- MOVZxL sz src dst -> patch2 (MOVZxL sz) src dst
- MOVSxL sz src dst -> patch2 (MOVSxL sz) src dst
- LEA sz src dst -> patch2 (LEA sz) src dst
- ADD sz src dst -> patch2 (ADD sz) src dst
- ADC sz src dst -> patch2 (ADC sz) src dst
- SUB sz src dst -> patch2 (SUB sz) src dst
- IMUL sz src dst -> patch2 (IMUL sz) src dst
- IMUL2 sz src -> patch1 (IMUL2 sz) src
- MUL sz src dst -> patch2 (MUL sz) src dst
- IDIV sz op -> patch1 (IDIV sz) op
- DIV sz op -> patch1 (DIV sz) op
- AND sz src dst -> patch2 (AND sz) src dst
- OR sz src dst -> patch2 (OR sz) src dst
- XOR sz src dst -> patch2 (XOR sz) src dst
- NOT sz op -> patch1 (NOT sz) op
- NEGI sz op -> patch1 (NEGI sz) op
- SHL sz imm dst -> patch1 (SHL sz imm) dst
- SAR sz imm dst -> patch1 (SAR sz imm) dst
- SHR sz imm dst -> patch1 (SHR sz imm) dst
- BT sz imm src -> patch1 (BT sz imm) src
- TEST sz src dst -> patch2 (TEST sz) src dst
- CMP sz src dst -> patch2 (CMP sz) src dst
- PUSH sz op -> patch1 (PUSH sz) op
- POP sz op -> patch1 (POP sz) op
- SETCC cond op -> patch1 (SETCC cond) op
- JMP op -> patch1 JMP op
- JMP_TBL op ids -> patch1 JMP_TBL op $ ids
-
-#if i386_TARGET_ARCH
- GMOV src dst -> GMOV (env src) (env dst)
- GLD sz src dst -> GLD sz (lookupAddr src) (env dst)
- GST sz src dst -> GST sz (env src) (lookupAddr dst)
-
- GLDZ dst -> GLDZ (env dst)
- GLD1 dst -> GLD1 (env dst)
-
- GFTOI src dst -> GFTOI (env src) (env dst)
- GDTOI src dst -> GDTOI (env src) (env dst)
-
- GITOF src dst -> GITOF (env src) (env dst)
- GITOD src dst -> GITOD (env src) (env dst)
-
- GADD sz s1 s2 dst -> GADD sz (env s1) (env s2) (env dst)
- GSUB sz s1 s2 dst -> GSUB sz (env s1) (env s2) (env dst)
- GMUL sz s1 s2 dst -> GMUL sz (env s1) (env s2) (env dst)
- GDIV sz s1 s2 dst -> GDIV sz (env s1) (env s2) (env dst)
-
- GCMP sz src1 src2 -> GCMP sz (env src1) (env src2)
- 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 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)
- 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)
-#endif
-
- CALL (Left imm) _ -> instr
- CALL (Right reg) p -> CALL (Right (env reg)) p
-
- FETCHGOT reg -> FETCHGOT (env reg)
- FETCHPC reg -> FETCHPC (env reg)
-
- 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"
-
- where
- patch1 insn op = insn $! patchOp op
- patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
-
- patchOp (OpReg reg) = OpReg $! env reg
- patchOp (OpImm imm) = OpImm imm
- patchOp (OpAddr ea) = OpAddr $! lookupAddr ea
-
- lookupAddr (ImmAddr imm off) = ImmAddr imm off
- lookupAddr (AddrBaseIndex base index disp)
- = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp
- where
- lookupBase EABaseNone = EABaseNone
- lookupBase EABaseRip = EABaseRip
- lookupBase (EABaseReg r) = EABaseReg (env r)
-
- lookupIndex EAIndexNone = EAIndexNone
- lookupIndex (EAIndex r i) = EAIndex (env r) i
-
-#endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH*/
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#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)
- 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 -> 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
- where
- 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
-
-#endif /* sparc_TARGET_ARCH */
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#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)
- STU sz reg addr -> STU sz (env reg) (fixAddr addr)
- LIS reg imm -> LIS (env reg) imm
- LI reg imm -> LI (env reg) imm
- MR reg1 reg2 -> MR (env reg1) (env reg2)
- 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
- BCTRL argRegs -> BCTRL argRegs -- cannot be remapped
- ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri)
- ADDC reg1 reg2 reg3-> ADDC (env reg1) (env reg2) (env reg3)
- ADDE reg1 reg2 reg3-> ADDE (env reg1) (env reg2) (env reg3)
- ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm
- SUBF reg1 reg2 reg3-> SUBF (env reg1) (env reg2) (env reg3)
- MULLW reg1 reg2 ri -> MULLW (env reg1) (env reg2) (fixRI ri)
- DIVW reg1 reg2 reg3-> DIVW (env reg1) (env reg2) (env reg3)
- DIVWU reg1 reg2 reg3-> DIVWU (env reg1) (env reg2) (env reg3)
- MULLW_MayOflo reg1 reg2 reg3
- -> MULLW_MayOflo (env reg1) (env reg2) (env reg3)
- AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri)
- OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri)
- XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri)
- XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm
- EXTS sz reg1 reg2 -> EXTS sz (env reg1) (env reg2)
- NEG reg1 reg2 -> NEG (env reg1) (env reg2)
- NOT reg1 reg2 -> NOT (env reg1) (env reg2)
- SLW reg1 reg2 ri -> SLW (env reg1) (env reg2) (fixRI ri)
- SRW reg1 reg2 ri -> SRW (env reg1) (env reg2) (fixRI ri)
- SRAW reg1 reg2 ri -> SRAW (env reg1) (env reg2) (fixRI ri)
- RLWINM reg1 reg2 sh mb me
- -> RLWINM (env reg1) (env reg2) sh mb me
- FADD sz r1 r2 r3 -> FADD sz (env r1) (env r2) (env r3)
- FSUB sz r1 r2 r3 -> FSUB sz (env r1) (env r2) (env r3)
- FMUL sz r1 r2 r3 -> FMUL sz (env r1) (env r2) (env r3)
- FDIV sz r1 r2 r3 -> FDIV sz (env r1) (env r2) (env r3)
- FNEG r1 r2 -> FNEG (env r1) (env r2)
- FCMP r1 r2 -> FCMP (env r1) (env r2)
- FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2)
- FRSP r1 r2 -> FRSP (env r1) (env r2)
- MFCR reg -> MFCR (env reg)
- MFLR reg -> MFLR (env reg)
- FETCHPC reg -> FETCHPC (env reg)
- _ -> instr
- where
- 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
-#endif /* powerpc_TARGET_ARCH */
-
--- -----------------------------------------------------------------------------
--- Detecting reg->reg moves
-
--- The register allocator attempts to eliminate reg->reg moves whenever it can,
--- 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)
-
-#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
-
--- -----------------------------------------------------------------------------
--- Generating spill instructions
-
-mkSpillInstr
- :: Reg -- register to spill
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
-mkSpillInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
-#ifdef alpha_TARGET_ARCH
- {-Alpha: spill below the stack pointer (?)-}
- ST sz dyn (spRel (- (off `div` 8)))
-#endif
-#ifdef i386_TARGET_ARCH
- let off_w = (off-delta) `div` 4
- in case regClass reg of
- 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 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
-#ifdef sparc_TARGET_ARCH
- {-SPARC: spill below frame pointer leaving 2 words/spill-}
- let{off_w = 1 + (off `div` 4);
- sz = case regClass reg of {
- 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 -> II32
- RcDouble -> FF64
- in ST sz reg (AddrRegImm sp (ImmInt (off-delta)))
-#endif
-
-
-mkLoadInstr
- :: Reg -- register to load
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
-mkLoadInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
-#if alpha_TARGET_ARCH
- LD sz dyn (spRel (- (off `div` 8)))
-#endif
-#if i386_TARGET_ARCH
- let off_w = (off-delta) `div` 4
- in case regClass reg of {
- 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 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 -> II32;
- RcFloat -> FF32;
- RcDouble -> FF64}}
- in LD sz (fpRel (- off_w)) reg
-#endif
-#if powerpc_TARGET_ARCH
- let sz = case regClass reg of
- RcInteger -> II32
- RcDouble -> FF64
- in LD sz reg (AddrRegImm sp (ImmInt (off-delta)))
-#endif
-
-mkRegRegMoveInstr
- :: Reg
- -> Reg
- -> Instr
-mkRegRegMoveInstr src dst
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
- = case regClass src of
- RcInteger -> MOV wordSize (OpReg src) (OpReg dst)
-#if i386_TARGET_ARCH
- RcDouble -> GMOV src dst
-#else
- 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
- :: BlockId
- -> [Instr]
-#if alpha_TARGET_ARCH
-mkBranchInstr id = [BR id]
-#endif
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-mkBranchInstr id = [JXX ALWAYS id]
-#endif
-
-#if sparc_TARGET_ARCH
-mkBranchInstr id = [BI ALWAYS False id, NOP]
-#endif
-
-#if powerpc_TARGET_ARCH
-mkBranchInstr id = [BCC ALWAYS id]
-#endif
projects / ghc-hetmet.git / commitdiff