module PPC.CodeGen (
cmmTopCodeGen,
generateJumpTableForInstr,
InstrBlock
)
where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
#include "../includes/MachDeps.h"
import CodeGen.Platform
import PPC.Instr
import PPC.Cond
import PPC.Regs
import CPrim
import NCGMonad
import Instruction
import PIC
import Format
import RegClass
import Reg
import TargetReg
import Platform
import BlockId
import PprCmm ( pprExpr )
import Cmm
import CmmUtils
import CmmSwitch
import CLabel
import Hoopl
import OrdList
import Outputable
import Unique
import DynFlags
import Control.Monad ( mapAndUnzipM, when )
import Data.Bits
import Data.Word
import BasicTypes
import FastString
import Util
cmmTopCodeGen
:: RawCmmDecl
-> NatM [NatCmmDecl CmmStatics Instr]
cmmTopCodeGen (CmmProc info lab live graph) = do
let blocks = toBlockListEntryFirst graph
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
dflags <- getDynFlags
let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
tops = proc : concat statics
os = platformOS $ targetPlatform dflags
arch = platformArch $ targetPlatform dflags
case arch of
ArchPPC | os == OSAIX -> return tops
| otherwise -> do
picBaseMb <- getPicBaseMaybeNat
case picBaseMb of
Just picBase -> initializePicBase_ppc arch os picBase tops
Nothing -> return tops
ArchPPC_64 ELF_V1 -> return tops
ArchPPC_64 ELF_V2 -> return tops
_ -> panic "PPC.cmmTopCodeGen: unknown arch"
cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec dat]
basicBlockCodeGen
:: Block CmmNode C C
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl CmmStatics Instr])
basicBlockCodeGen block = do
let (_, nodes, tail) = blockSplit block
id = entryLabel block
stmts = blockToList nodes
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
let instrs = mid_instrs `appOL` tail_instrs
let
(top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
= ([], BasicBlock id instrs : blocks, statics)
mkBlocks (LDATA sec dat) (instrs,blocks,statics)
= (instrs, blocks, CmmData sec dat:statics)
mkBlocks instr (instrs,blocks,statics)
= (instr:instrs, blocks, statics)
return (BasicBlock id top : other_blocks, statics)
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs stmts
= do instrss <- mapM stmtToInstrs stmts
return (concatOL instrss)
stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs stmt = do
dflags <- getDynFlags
case stmt of
CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
CmmUnwind {} -> return nilOL
CmmAssign reg src
| isFloatType ty -> assignReg_FltCode format reg src
| target32Bit (targetPlatform dflags) &&
isWord64 ty -> assignReg_I64Code reg src
| otherwise -> assignReg_IntCode format reg src
where ty = cmmRegType dflags reg
format = cmmTypeFormat ty
CmmStore addr src
| isFloatType ty -> assignMem_FltCode format addr src
| target32Bit (targetPlatform dflags) &&
isWord64 ty -> assignMem_I64Code addr src
| otherwise -> assignMem_IntCode format addr src
where ty = cmmExprType dflags src
format = cmmTypeFormat ty
CmmUnsafeForeignCall target result_regs args
-> genCCall target result_regs args
CmmBranch id -> genBranch id
CmmCondBranch arg true false _ -> do
b1 <- genCondJump true arg
b2 <- genBranch false
return (b1 `appOL` b2)
CmmSwitch arg ids -> do dflags <- getDynFlags
genSwitch dflags arg ids
CmmCall { cml_target = arg } -> genJump arg
_ ->
panic "stmtToInstrs: statement should have been cps'd away"
type InstrBlock
= OrdList Instr
data Register
= Fixed Format Reg InstrBlock
| Any Format (Reg -> InstrBlock)
swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
swizzleRegisterRep (Any _ codefn) format = Any format codefn
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg _ (CmmLocal (LocalReg u pk))
= RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
getRegisterReg platform (CmmGlobal mid)
= case globalRegMaybe platform mid of
Just reg -> RegReal reg
Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
where blockLabel = mkAsmTempLabel (getUnique blockid)
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)
mangleIndexTree _ _
= panic "PPC.CodeGen.mangleIndexTree: no match"
data ChildCode64
= ChildCode64
InstrBlock
Reg
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)
getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
getI64Amodes addrTree = do
Amode hi_addr addr_code <- getAmode D addrTree
case addrOffset hi_addr 4 of
Just lo_addr -> return (hi_addr, lo_addr, addr_code)
Nothing -> do (hi_ptr, code) <- getSomeReg addrTree
return (AddrRegImm hi_ptr (ImmInt 0),
AddrRegImm hi_ptr (ImmInt 4),
code)
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code addrTree valueTree = do
(hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
ChildCode64 vcode rlo <- iselExpr64 valueTree
let
rhi = getHiVRegFromLo rlo
mov_hi = ST II32 rhi hi_addr
mov_lo = ST II32 rlo lo_addr
return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
let
r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
r_dst_hi = getHiVRegFromLo r_dst_lo
r_src_hi = getHiVRegFromLo r_src_lo
mov_lo = MR r_dst_lo r_src_lo
mov_hi = MR r_dst_hi r_src_hi
return (
vcode `snocOL` mov_lo `snocOL` mov_hi
)
assignReg_I64Code _ _
= panic "assignReg_I64Code(powerpc): invalid lvalue"
iselExpr64 :: CmmExpr -> NatM ChildCode64
iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
(hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
(rlo, rhi) <- getNewRegPairNat II32
let mov_hi = LD II32 rhi hi_addr
mov_lo = LD II32 rlo lo_addr
return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
= return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
iselExpr64 (CmmLit (CmmInt i _)) = do
(rlo,rhi) <- getNewRegPairNat II32
let
half0 = fromIntegral (fromIntegral i :: Word16)
half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)
half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)
code = toOL [
LIS rlo (ImmInt half1),
OR rlo rlo (RIImm $ ImmInt half0),
LIS rhi (ImmInt half3),
OR rhi rhi (RIImm $ ImmInt half2)
]
return (ChildCode64 code rlo)
iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
ChildCode64 code1 r1lo <- iselExpr64 e1
ChildCode64 code2 r2lo <- iselExpr64 e2
(rlo,rhi) <- getNewRegPairNat II32
let
r1hi = getHiVRegFromLo r1lo
r2hi = getHiVRegFromLo r2lo
code = code1 `appOL`
code2 `appOL`
toOL [ ADDC rlo r1lo r2lo,
ADDE rhi r1hi r2hi ]
return (ChildCode64 code rlo)
iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
ChildCode64 code1 r1lo <- iselExpr64 e1
ChildCode64 code2 r2lo <- iselExpr64 e2
(rlo,rhi) <- getNewRegPairNat II32
let
r1hi = getHiVRegFromLo r1lo
r2hi = getHiVRegFromLo r2lo
code = code1 `appOL`
code2 `appOL`
toOL [ SUBFC rlo r2lo (RIReg r1lo),
SUBFE rhi r2hi r1hi ]
return (ChildCode64 code rlo)
iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
(expr_reg,expr_code) <- getSomeReg expr
(rlo, rhi) <- getNewRegPairNat II32
let mov_hi = LI rhi (ImmInt 0)
mov_lo = MR rlo expr_reg
return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
iselExpr64 expr
= pprPanic "iselExpr64(powerpc)" (pprExpr expr)
getRegister :: CmmExpr -> NatM Register
getRegister e = do dflags <- getDynFlags
getRegister' dflags e
getRegister' :: DynFlags -> CmmExpr -> NatM Register
getRegister' dflags (CmmReg (CmmGlobal PicBaseReg))
| OSAIX <- platformOS (targetPlatform dflags) = do
let code dst = toOL [ LD II32 dst tocAddr ]
tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))
return (Any II32 code)
| target32Bit (targetPlatform dflags) = do
reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags))
return (Fixed (archWordFormat (target32Bit (targetPlatform dflags)))
reg nilOL)
| otherwise = return (Fixed II64 toc nilOL)
getRegister' dflags (CmmReg reg)
= return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
(getRegisterReg (targetPlatform dflags) reg) nilOL)
getRegister' dflags tree@(CmmRegOff _ _)
= getRegister' dflags (mangleIndexTree dflags tree)
getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
| target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
| target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])
| target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])
| target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
getRegister' dflags (CmmLoad mem pk)
| not (isWord64 pk) = do
let platform = targetPlatform dflags
Amode addr addr_code <- getAmode D mem
let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)
addr_code `snocOL` LD format dst addr
return (Any format code)
| not (target32Bit (targetPlatform dflags)) = do
Amode addr addr_code <- getAmode DS mem
let code dst = addr_code `snocOL` LD II64 dst addr
return (Any II64 code)
where format = cmmTypeFormat pk
getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))
getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))
getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))
getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode DS mem
return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
getRegister' dflags (CmmMachOp mop [x])
= case mop of
MO_Not rep -> triv_ucode_int rep NOT
MO_F_Neg w -> triv_ucode_float w FNEG
MO_S_Neg w -> triv_ucode_int w NEG
MO_FF_Conv W64 W32 -> trivialUCode FF32 FRSP x
MO_FF_Conv W32 W64 -> conversionNop FF64 x
MO_FS_Conv from to -> coerceFP2Int from to x
MO_SF_Conv from to -> coerceInt2FP from to x
MO_SS_Conv from to
| from == to -> conversionNop (intFormat to) x
MO_SS_Conv W64 to
| arch32 -> panic "PPC.CodeGen.getRegister no 64 bit int register"
| otherwise -> conversionNop (intFormat to) x
MO_SS_Conv W32 to
| arch32 -> conversionNop (intFormat to) x
| otherwise -> case to of
W64 -> triv_ucode_int to (EXTS II32)
W16 -> conversionNop II16 x
W8 -> conversionNop II8 x
_ -> panic "PPC.CodeGen.getRegister: no match"
MO_SS_Conv W16 W8 -> conversionNop II8 x
MO_SS_Conv W8 to -> triv_ucode_int to (EXTS II8)
MO_SS_Conv W16 to -> triv_ucode_int to (EXTS II16)
MO_UU_Conv from to
| from == to -> conversionNop (intFormat to) x
MO_UU_Conv W64 to
| arch32 -> panic "PPC.CodeGen.getRegister no 64 bit target"
| otherwise -> conversionNop (intFormat to) x
MO_UU_Conv W32 to
| arch32 -> conversionNop (intFormat to) x
| otherwise ->
case to of
W64 -> trivialCode to False AND x (CmmLit (CmmInt 4294967295 W64))
W16 -> conversionNop II16 x
W8 -> conversionNop II8 x
_ -> panic "PPC.CodeGen.getRegister: no match"
MO_UU_Conv W16 W8 -> conversionNop II8 x
MO_UU_Conv W8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 W32))
MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32))
_ -> panic "PPC.CodeGen.getRegister: no match"
where
triv_ucode_int width instr = trivialUCode (intFormat width) instr x
triv_ucode_float width instr = trivialUCode (floatFormat width) instr x
conversionNop new_format expr
= do e_code <- getRegister' dflags expr
return (swizzleRegisterRep e_code new_format)
arch32 = target32Bit $ targetPlatform dflags
getRegister' dflags (CmmMachOp mop [x, y])
= case mop of
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_Eq rep -> condIntReg EQQ (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_Ne rep -> condIntReg NE (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_S_Gt rep -> condIntReg GTT (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Ge rep -> condIntReg GE (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Lt rep -> condIntReg LTT (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Le rep -> condIntReg LE (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Gt rep -> condIntReg GU (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_U_Ge rep -> condIntReg GEU (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_U_Lt rep -> condIntReg LU (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_U_Le rep -> condIntReg LEU (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_F_Add w -> triv_float w FADD
MO_F_Sub w -> triv_float w FSUB
MO_F_Mul w -> triv_float w FMUL
MO_F_Quot w -> triv_float w FDIV
MO_Add W32 ->
case y of
CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm
-> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)
CmmLit lit
-> do
(src, srcCode) <- getSomeReg x
let imm = litToImm lit
code dst = srcCode `appOL` toOL [
ADDIS dst src (HA imm),
ADD dst dst (RIImm (LO imm))
]
return (Any II32 code)
_ -> trivialCode W32 True ADD x y
MO_Add rep -> trivialCode rep True ADD x y
MO_Sub rep ->
case y of
CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (imm)
-> trivialCode rep True ADD x (CmmLit $ CmmInt (imm) immrep)
_ -> case x of
CmmLit (CmmInt imm _)
| Just _ <- makeImmediate rep True imm
-> trivialCode rep True SUBFC y x
_ -> trivialCodeNoImm' (intFormat rep) SUBF y x
MO_Mul rep -> shiftMulCode rep True MULL x y
MO_S_MulMayOflo rep -> do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let
format = intFormat rep
code dst = code1 `appOL` code2
`appOL` toOL [ MULLO format dst src1 src2
, MFOV format dst
]
return (Any format code)
MO_S_Quot rep -> trivialCodeNoImmSign (intFormat rep) True DIV
(extendSExpr dflags rep x) (extendSExpr dflags rep y)
MO_U_Quot rep -> trivialCodeNoImmSign (intFormat rep) False DIV
(extendUExpr dflags rep x) (extendUExpr dflags rep y)
MO_S_Rem rep -> remainderCode rep True (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Rem rep -> remainderCode rep False (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_And rep -> case y of
(CmmLit (CmmInt imm _)) | imm == 8 || imm == 4
-> do
(src, srcCode) <- getSomeReg x
let clear_mask = if imm == 4 then 2 else 3
fmt = intFormat rep
code dst = srcCode
`appOL` unitOL (CLRRI fmt dst src clear_mask)
return (Any fmt code)
_ -> trivialCode rep False AND x y
MO_Or rep -> trivialCode rep False OR x y
MO_Xor rep -> trivialCode rep False XOR x y
MO_Shl rep -> shiftMulCode rep False SL x y
MO_S_Shr rep -> shiftMulCode rep False SRA (extendSExpr dflags rep x) y
MO_U_Shr rep -> shiftMulCode rep False SR (extendUExpr dflags rep x) y
_ -> panic "PPC.CodeGen.getRegister: no match"
where
triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y
getRegister' _ (CmmLit (CmmInt i rep))
| Just imm <- makeImmediate rep True i
= let
code dst = unitOL (LI dst imm)
in
return (Any (intFormat rep) code)
getRegister' _ (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
dflags <- getDynFlags
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let format = floatFormat frep
code dst =
LDATA (Section ReadOnlyData lbl)
(Statics lbl [CmmStaticLit (CmmFloat f frep)])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
getRegister' dflags (CmmLit lit)
| target32Bit (targetPlatform dflags)
= let rep = cmmLitType dflags lit
imm = litToImm lit
code dst = toOL [
LIS dst (HA imm),
ADD dst dst (RIImm (LO imm))
]
in return (Any (cmmTypeFormat rep) code)
| otherwise
= do lbl <- getNewLabelNat
dflags <- getDynFlags
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let rep = cmmLitType dflags lit
format = cmmTypeFormat rep
code dst =
LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)
extendSExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr
extendSExpr dflags W32 x
| target32Bit (targetPlatform dflags) = x
extendSExpr dflags W64 x
| not (target32Bit (targetPlatform dflags)) = x
extendSExpr dflags rep x =
let size = if target32Bit $ targetPlatform dflags
then W32
else W64
in CmmMachOp (MO_SS_Conv rep size) [x]
extendUExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr
extendUExpr dflags W32 x
| target32Bit (targetPlatform dflags) = x
extendUExpr dflags W64 x
| not (target32Bit (targetPlatform dflags)) = x
extendUExpr dflags rep x =
let size = if target32Bit $ targetPlatform dflags
then W32
else W64
in CmmMachOp (MO_UU_Conv rep size) [x]
data Amode
= Amode AddrMode InstrBlock
data InstrForm = D | DS
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode inf tree@(CmmRegOff _ _)
= do dflags <- getDynFlags
getAmode inf (mangleIndexTree dflags tree)
getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W32 True (i)
= do
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W32 True i
= do
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W64 True (i)
= do
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W64 True i
= do
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W64 True (i)
= do
(reg, code) <- getSomeReg x
(reg', off', code') <-
if i `mod` 4 == 0
then do return (reg, off, code)
else do
tmp <- getNewRegNat II64
return (tmp, ImmInt 0,
code `snocOL` ADD tmp reg (RIImm off))
return (Amode (AddrRegImm reg' off') code')
getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W64 True i
= do
(reg, code) <- getSomeReg x
(reg', off', code') <-
if i `mod` 4 == 0
then do return (reg, off, code)
else do
tmp <- getNewRegNat II64
return (tmp, ImmInt 0,
code `snocOL` ADD tmp reg (RIImm off))
return (Amode (AddrRegImm reg' off') code')
getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])
= do
dflags <- getDynFlags
(src, srcCode) <- getSomeReg x
let imm = litToImm lit
case () of
_ | OSAIX <- platformOS (targetPlatform dflags)
, isCmmLabelType lit ->
return (Amode (AddrRegImm src imm) srcCode)
| otherwise -> do
tmp <- getNewRegNat II32
let code = srcCode `snocOL` ADDIS tmp src (HA imm)
return (Amode (AddrRegImm tmp (LO imm)) code)
where
isCmmLabelType (CmmLabel {}) = True
isCmmLabelType (CmmLabelOff {}) = True
isCmmLabelType (CmmLabelDiffOff {}) = True
isCmmLabelType _ = False
getAmode _ (CmmLit lit)
= do
dflags <- getDynFlags
case platformArch $ targetPlatform dflags of
ArchPPC -> do
tmp <- getNewRegNat II32
let imm = litToImm lit
code = unitOL (LIS tmp (HA imm))
return (Amode (AddrRegImm tmp (LO imm)) code)
_ -> do
tmp <- getNewRegNat II64
let imm = litToImm lit
code = toOL [
LIS tmp (HIGHESTA imm),
OR tmp tmp (RIImm (HIGHERA imm)),
SL II64 tmp tmp (RIImm (ImmInt 32)),
ORIS tmp tmp (HA imm)
]
return (Amode (AddrRegImm tmp (LO imm)) code)
getAmode _ (CmmMachOp (MO_Add W32) [x, y])
= do
(regX, codeX) <- getSomeReg x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
getAmode _ (CmmMachOp (MO_Add W64) [x, y])
= do
(regX, codeX) <- getSomeReg x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
getAmode _ other
= do
(reg, code) <- getSomeReg other
let
off = ImmInt 0
return (Amode (AddrRegImm reg off) code)
data CondCode
= CondCode Bool Cond InstrBlock
getCondCode :: CmmExpr -> NatM CondCode
getCondCode (CmmMachOp mop [x, y])
= do
dflags <- getDynFlags
case mop of
MO_F_Eq W32 -> condFltCode EQQ x y
MO_F_Ne W32 -> condFltCode NE x y
MO_F_Gt W32 -> condFltCode GTT x y
MO_F_Ge W32 -> condFltCode GE x y
MO_F_Lt W32 -> condFltCode LTT x y
MO_F_Le W32 -> condFltCode LE x y
MO_F_Eq W64 -> condFltCode EQQ x y
MO_F_Ne W64 -> condFltCode NE x y
MO_F_Gt W64 -> condFltCode GTT x y
MO_F_Ge W64 -> condFltCode GE x y
MO_F_Lt W64 -> condFltCode LTT x y
MO_F_Le W64 -> condFltCode LE x y
MO_Eq rep -> condIntCode EQQ (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_Ne rep -> condIntCode NE (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_S_Gt rep -> condIntCode GTT (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Ge rep -> condIntCode GE (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Lt rep -> condIntCode LTT (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Le rep -> condIntCode LE (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Gt rep -> condIntCode GU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Ge rep -> condIntCode GEU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Lt rep -> condIntCode LU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Le rep -> condIntCode LEU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
_ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
getCondCode _ = panic "getCondCode(2)(powerpc)"
condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode cond (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)])
(CmmLit (CmmInt 0 _))
| not $ condUnsigned cond,
Just src2 <- makeImmediate rep False imm
= do
(src1, code) <- getSomeReg x
let code' = code `snocOL` AND r0 src1 (RIImm src2)
return (CondCode False cond code')
condIntCode cond x (CmmLit (CmmInt y rep))
| Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
= do
(src1, code) <- getSomeReg x
dflags <- getDynFlags
let format = archWordFormat $ target32Bit $ targetPlatform dflags
code' = code `snocOL`
(if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2)
return (CondCode False cond code')
condIntCode cond x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
dflags <- getDynFlags
let format = archWordFormat $ target32Bit $ targetPlatform dflags
code' = code1 `appOL` code2 `snocOL`
(if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2)
return (CondCode False cond code')
condFltCode cond x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let
code' = code1 `appOL` code2 `snocOL` FCMP src1 src2
code'' = case cond of
GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
_ -> code'
where
ltbit = 0 ; eqbit = 2 ; gtbit = 1
return (CondCode True cond code'')
assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignMem_IntCode pk addr src = do
(srcReg, code) <- getSomeReg src
Amode dstAddr addr_code <- case pk of
II64 -> getAmode DS addr
_ -> getAmode D addr
return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
assignReg_IntCode _ reg src
= do
dflags <- getDynFlags
let dst = getRegisterReg (targetPlatform dflags) reg
r <- getRegister src
return $ case r of
Any _ code -> code dst
Fixed _ freg fcode -> fcode `snocOL` MR dst freg
assignMem_FltCode = assignMem_IntCode
assignReg_FltCode = assignReg_IntCode
genJump :: CmmExpr -> NatM InstrBlock
genJump (CmmLit (CmmLabel lbl))
= return (unitOL $ JMP lbl)
genJump tree
= do
dflags <- getDynFlags
genJump' tree (platformToGCP (targetPlatform dflags))
genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock
genJump' tree (GCPLinux64ELF 1)
= do
(target,code) <- getSomeReg tree
return (code
`snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0))
`snocOL` LD II64 toc (AddrRegImm target (ImmInt 8))
`snocOL` MTCTR r11
`snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16))
`snocOL` BCTR [] Nothing)
genJump' tree (GCPLinux64ELF 2)
= do
(target,code) <- getSomeReg tree
return (code
`snocOL` MR r12 target
`snocOL` MTCTR r12
`snocOL` BCTR [] Nothing)
genJump' tree _
= do
(target,code) <- getSomeReg tree
return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
genBranch :: BlockId -> NatM InstrBlock
genBranch = return . toOL . mkJumpInstr
genCondJump
:: BlockId
-> CmmExpr
-> NatM InstrBlock
genCondJump id bool = do
CondCode _ cond code <- getCondCode bool
return (code `snocOL` BCC cond id)
genCCall :: ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall (PrimTarget MO_WriteBarrier) _ _
= return $ unitOL LWSYNC
genCCall (PrimTarget MO_Touch) _ _
= return $ nilOL
genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
= return $ nilOL
genCCall (PrimTarget (MO_Clz width)) [dst] [src]
= do dflags <- getDynFlags
let platform = targetPlatform dflags
reg_dst = getRegisterReg platform (CmmLocal dst)
if target32Bit platform && width == W64
then do
ChildCode64 code vr_lo <- iselExpr64 src
lbl1 <- getBlockIdNat
lbl2 <- getBlockIdNat
lbl3 <- getBlockIdNat
let vr_hi = getHiVRegFromLo vr_lo
cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))
, BCC NE lbl2
, BCC ALWAYS lbl1
, NEWBLOCK lbl1
, CNTLZ II32 reg_dst vr_lo
, ADD reg_dst reg_dst (RIImm (ImmInt 32))
, BCC ALWAYS lbl3
, NEWBLOCK lbl2
, CNTLZ II32 reg_dst vr_hi
, BCC ALWAYS lbl3
, NEWBLOCK lbl3
]
return $ code `appOL` cntlz
else do
let format = if width == W64 then II64 else II32
(s_reg, s_code) <- getSomeReg src
(pre, reg , post) <-
case width of
W64 -> return (nilOL, s_reg, nilOL)
W32 -> return (nilOL, s_reg, nilOL)
W16 -> do
reg_tmp <- getNewRegNat format
return
( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535))
, reg_tmp
, unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (16)))
)
W8 -> do
reg_tmp <- getNewRegNat format
return
( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255))
, reg_tmp
, unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (24)))
)
_ -> panic "genCall: Clz wrong format"
let cntlz = unitOL (CNTLZ format reg_dst reg)
return $ s_code `appOL` pre `appOL` cntlz `appOL` post
genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
= do dflags <- getDynFlags
let platform = targetPlatform dflags
reg_dst = getRegisterReg platform (CmmLocal dst)
if target32Bit platform && width == W64
then do
let format = II32
ChildCode64 code vr_lo <- iselExpr64 src
lbl1 <- getBlockIdNat
lbl2 <- getBlockIdNat
lbl3 <- getBlockIdNat
x' <- getNewRegNat format
x'' <- getNewRegNat format
r' <- getNewRegNat format
cnttzlo <- cnttz format reg_dst vr_lo
let vr_hi = getHiVRegFromLo vr_lo
cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))
, BCC NE lbl2
, BCC ALWAYS lbl1
, NEWBLOCK lbl1
, ADD x' vr_hi (RIImm (ImmInt (1)))
, ANDC x'' x' vr_hi
, CNTLZ format r' x''
, SUBFC reg_dst r' (RIImm (ImmInt 64))
, BCC ALWAYS lbl3
, NEWBLOCK lbl2
]
`appOL` cnttzlo `appOL`
toOL [ BCC ALWAYS lbl3
, NEWBLOCK lbl3
]
return $ code `appOL` cnttz64
else do
let format = if width == W64 then II64 else II32
(s_reg, s_code) <- getSomeReg src
(reg_ctz, pre_code) <-
case width of
W64 -> return (s_reg, nilOL)
W32 -> return (s_reg, nilOL)
W16 -> do
reg_tmp <- getNewRegNat format
return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1))
W8 -> do
reg_tmp <- getNewRegNat format
return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256)))
_ -> panic "genCall: Ctz wrong format"
ctz_code <- cnttz format reg_dst reg_ctz
return $ s_code `appOL` pre_code `appOL` ctz_code
where
cnttz format dst src = do
let format_bits = 8 * formatInBytes format
x' <- getNewRegNat format
x'' <- getNewRegNat format
r' <- getNewRegNat format
return $ toOL [ ADD x' src (RIImm (ImmInt (1)))
, ANDC x'' x' src
, CNTLZ format r' x''
, SUBFC dst r' (RIImm (ImmInt (format_bits)))
]
genCCall target dest_regs argsAndHints
= do dflags <- getDynFlags
let platform = targetPlatform dflags
case target of
PrimTarget (MO_S_QuotRem width) -> divOp1 platform True width
dest_regs argsAndHints
PrimTarget (MO_U_QuotRem width) -> divOp1 platform False width
dest_regs argsAndHints
PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs
argsAndHints
PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs
argsAndHints
PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints
PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints
PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width
dest_regs argsAndHints
PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width
dest_regs argsAndHints
PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints
PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints
_ -> genCCall' dflags (platformToGCP platform)
target dest_regs argsAndHints
where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y]
= do let reg_q = getRegisterReg platform (CmmLocal res_q)
reg_r = getRegisterReg platform (CmmLocal res_r)
fmt = intFormat width
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ DIV fmt signed reg_q x_reg y_reg
, MULL fmt reg_r reg_q (RIReg y_reg)
, SUBF reg_r reg_r x_reg
]
divOp1 _ _ _ _ _
= panic "genCCall: Wrong number of arguments for divOp1"
divOp2 platform width [res_q, res_r]
[arg_x_high, arg_x_low, arg_y]
= do let reg_q = getRegisterReg platform (CmmLocal res_q)
reg_r = getRegisterReg platform (CmmLocal res_r)
fmt = intFormat width
half = 4 * (formatInBytes fmt)
(xh_reg, xh_code) <- getSomeReg arg_x_high
(xl_reg, xl_code) <- getSomeReg arg_x_low
(y_reg, y_code) <- getSomeReg arg_y
s <- getNewRegNat fmt
b <- getNewRegNat fmt
v <- getNewRegNat fmt
vn1 <- getNewRegNat fmt
vn0 <- getNewRegNat fmt
un32 <- getNewRegNat fmt
tmp <- getNewRegNat fmt
un10 <- getNewRegNat fmt
un1 <- getNewRegNat fmt
un0 <- getNewRegNat fmt
q1 <- getNewRegNat fmt
rhat <- getNewRegNat fmt
tmp1 <- getNewRegNat fmt
q0 <- getNewRegNat fmt
un21 <- getNewRegNat fmt
again1 <- getBlockIdNat
no1 <- getBlockIdNat
then1 <- getBlockIdNat
endif1 <- getBlockIdNat
again2 <- getBlockIdNat
no2 <- getBlockIdNat
then2 <- getBlockIdNat
endif2 <- getBlockIdNat
return $ y_code `appOL` xl_code `appOL` xh_code `appOL`
toOL [
LI b (ImmInt 1)
, SL fmt b b (RIImm (ImmInt half))
, CNTLZ fmt s y_reg
, SL fmt v y_reg (RIReg s)
, SR fmt vn1 v (RIImm (ImmInt half))
, CLRLI fmt vn0 v half
, SL fmt un32 xh_reg (RIReg s)
, SUBFC tmp s
(RIImm (ImmInt (8 * formatInBytes fmt)))
, SR fmt tmp xl_reg (RIReg tmp)
, OR un32 un32 (RIReg tmp)
, SL fmt un10 xl_reg (RIReg s)
, SR fmt un1 un10 (RIImm (ImmInt half))
, CLRLI fmt un0 un10 half
, DIV fmt False q1 un32 vn1
, MULL fmt tmp q1 (RIReg vn1)
, SUBF rhat tmp un32
, BCC ALWAYS again1
, NEWBLOCK again1
, CMPL fmt q1 (RIReg b)
, BCC GEU then1
, BCC ALWAYS no1
, NEWBLOCK no1
, MULL fmt tmp q1 (RIReg vn0)
, SL fmt tmp1 rhat (RIImm (ImmInt half))
, ADD tmp1 tmp1 (RIReg un1)
, CMPL fmt tmp (RIReg tmp1)
, BCC LEU endif1
, BCC ALWAYS then1
, NEWBLOCK then1
, ADD q1 q1 (RIImm (ImmInt (1)))
, ADD rhat rhat (RIReg vn1)
, CMPL fmt rhat (RIReg b)
, BCC LTT again1
, BCC ALWAYS endif1
, NEWBLOCK endif1
, SL fmt un21 un32 (RIImm (ImmInt half))
, ADD un21 un21 (RIReg un1)
, MULL fmt tmp q1 (RIReg v)
, SUBF un21 tmp un21
, DIV fmt False q0 un21 vn1
, MULL fmt tmp q0 (RIReg vn1)
, SUBF rhat tmp un21
, BCC ALWAYS again2
, NEWBLOCK again2
, CMPL fmt q0 (RIReg b)
, BCC GEU then2
, BCC ALWAYS no2
, NEWBLOCK no2
, MULL fmt tmp q0 (RIReg vn0)
, SL fmt tmp1 rhat (RIImm (ImmInt half))
, ADD tmp1 tmp1 (RIReg un0)
, CMPL fmt tmp (RIReg tmp1)
, BCC LEU endif2
, BCC ALWAYS then2
, NEWBLOCK then2
, ADD q0 q0 (RIImm (ImmInt (1)))
, ADD rhat rhat (RIReg vn1)
, CMPL fmt rhat (RIReg b)
, BCC LTT again2
, BCC ALWAYS endif2
, NEWBLOCK endif2
, SL fmt reg_r un21 (RIImm (ImmInt half))
, ADD reg_r reg_r (RIReg un0)
, MULL fmt tmp q0 (RIReg v)
, SUBF reg_r tmp reg_r
, SR fmt reg_r reg_r (RIReg s)
, SL fmt reg_q q1 (RIImm (ImmInt half))
, ADD reg_q reg_q (RIReg q0)
]
divOp2 _ _ _ _
= panic "genCCall: Wrong number of arguments for divOp2"
multOp2 platform width [res_h, res_l] [arg_x, arg_y]
= do let reg_h = getRegisterReg platform (CmmLocal res_h)
reg_l = getRegisterReg platform (CmmLocal res_l)
fmt = intFormat width
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)
, MULHU fmt reg_h x_reg y_reg
]
multOp2 _ _ _ _
= panic "genCall: Wrong number of arguments for multOp2"
add2Op platform [res_h, res_l] [arg_x, arg_y]
= do let reg_h = getRegisterReg platform (CmmLocal res_h)
reg_l = getRegisterReg platform (CmmLocal res_l)
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ LI reg_h (ImmInt 0)
, ADDC reg_l x_reg y_reg
, ADDZE reg_h reg_h
]
add2Op _ _ _
= panic "genCCall: Wrong number of arguments/results for add2"
subcOp platform [res_r, res_c] [arg_x, arg_y]
= do let reg_r = getRegisterReg platform (CmmLocal res_r)
reg_c = getRegisterReg platform (CmmLocal res_c)
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ LI reg_c (ImmInt 0)
, SUBFC reg_r y_reg (RIReg x_reg)
, ADDZE reg_c reg_c
, XOR reg_c reg_c (RIImm (ImmInt 1))
]
subcOp _ _ _
= panic "genCCall: Wrong number of arguments/results for subc"
addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y]
= do let reg_r = getRegisterReg platform (CmmLocal res_r)
reg_c = getRegisterReg platform (CmmLocal res_c)
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ instr reg_r y_reg x_reg,
MFOV (intFormat width) reg_c
]
addSubCOp _ _ _ _ _
= panic "genCall: Wrong number of arguments/results for addC"
fabs platform [res] [arg]
= do let res_r = getRegisterReg platform (CmmLocal res)
(arg_reg, arg_code) <- getSomeReg arg
return $ arg_code `snocOL` FABS res_r arg_reg
fabs _ _ _
= panic "genCall: Wrong number of arguments/results for fabs"
data GenCCallPlatform = GCPLinux | GCPDarwin | GCPLinux64ELF !Int | GCPAIX
platformToGCP :: Platform -> GenCCallPlatform
platformToGCP platform = case platformOS platform of
OSLinux -> case platformArch platform of
ArchPPC -> GCPLinux
ArchPPC_64 ELF_V1 -> GCPLinux64ELF 1
ArchPPC_64 ELF_V2 -> GCPLinux64ELF 2
_ -> panic "PPC.CodeGen.platformToGCP: Unknown Linux"
OSAIX -> GCPAIX
OSDarwin -> GCPDarwin
_ -> panic "PPC.CodeGen.platformToGCP: not defined for this OS"
genCCall'
:: DynFlags
-> GenCCallPlatform
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall' dflags gcp target dest_regs args
= ASSERT(not $ any (`elem` [II16]) $ map cmmTypeFormat argReps)
do
(finalStack,passArgumentsCode,usedRegs) <- passArguments
(zip args argReps)
allArgRegs
(allFPArgRegs platform)
initialStackOffset
(toOL []) []
(labelOrExpr, reduceToFF32) <- case target of
ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
uses_pic_base_implicitly
return (Left lbl, False)
ForeignTarget expr _ -> do
uses_pic_base_implicitly
return (Right expr, False)
PrimTarget mop -> outOfLineMachOp mop
let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
case labelOrExpr of
Left lbl -> do
return ( codeBefore
`snocOL` BL lbl usedRegs
`appOL` maybeNOP
`appOL` codeAfter)
Right dyn -> do
(dynReg, dynCode) <- getSomeReg dyn
case gcp of
GCPLinux64ELF 1 -> return ( dynCode
`appOL` codeBefore
`snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40))
`snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0))
`snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8))
`snocOL` MTCTR r11
`snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16))
`snocOL` BCTRL usedRegs
`snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40))
`appOL` codeAfter)
GCPLinux64ELF 2 -> return ( dynCode
`appOL` codeBefore
`snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24))
`snocOL` MR r12 dynReg
`snocOL` MTCTR r12
`snocOL` BCTRL usedRegs
`snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24))
`appOL` codeAfter)
GCPAIX -> return ( dynCode
`appOL` codeBefore
`snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20))
`snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0))
`snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4))
`snocOL` MTCTR r11
`snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8))
`snocOL` BCTRL usedRegs
`snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20))
`appOL` codeAfter)
_ -> return ( dynCode
`snocOL` MTCTR dynReg
`appOL` codeBefore
`snocOL` BCTRL usedRegs
`appOL` codeAfter)
where
platform = targetPlatform dflags
uses_pic_base_implicitly = do
when (positionIndependent dflags && target32Bit platform) $ do
_ <- getPicBaseNat $ archWordFormat True
return ()
initialStackOffset = case gcp of
GCPAIX -> 24
GCPDarwin -> 24
GCPLinux -> 8
GCPLinux64ELF 1 -> 48
GCPLinux64ELF 2 -> 32
_ -> panic "genCall': unknown calling convention"
stackDelta finalStack = case gcp of
GCPAIX ->
roundTo 16 $ (24 +) $ max 32 $ sum $
map (widthInBytes . typeWidth) argReps
GCPDarwin ->
roundTo 16 $ (24 +) $ max 32 $ sum $
map (widthInBytes . typeWidth) argReps
GCPLinux -> roundTo 16 finalStack
GCPLinux64ELF 1 ->
roundTo 16 $ (48 +) $ max 64 $ sum $
map (roundTo 8 . widthInBytes . typeWidth)
argReps
GCPLinux64ELF 2 ->
roundTo 16 $ (32 +) $ max 64 $ sum $
map (roundTo 8 . widthInBytes . typeWidth)
argReps
_ -> panic "genCall': unknown calling conv."
argReps = map (cmmExprType dflags) args
roundTo a x | x `mod` a == 0 = x
| otherwise = x + a (x `mod` a)
spFormat = if target32Bit platform then II32 else II64
move_sp_down finalStack
| delta > stackFrameHeaderSize dflags =
toOL [STU spFormat sp (AddrRegImm sp (ImmInt (delta))),
DELTA (delta)]
| otherwise = nilOL
where delta = stackDelta finalStack
move_sp_up finalStack
| delta > stackFrameHeaderSize dflags =
toOL [ADD sp sp (RIImm (ImmInt delta)),
DELTA 0]
| otherwise = nilOL
where delta = stackDelta finalStack
maybeNOP = case gcp of
GCPAIX -> unitOL NOP
GCPLinux64ELF 1 -> unitOL NOP
GCPLinux64ELF 2 -> unitOL NOP
_ -> nilOL
passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
passArguments ((arg,arg_ty):args) gprs fprs stackOffset
accumCode accumUsed | isWord64 arg_ty
&& target32Bit (targetPlatform dflags) =
do
ChildCode64 code vr_lo <- iselExpr64 arg
let vr_hi = getHiVRegFromLo vr_lo
case gcp of
GCPAIX ->
do let storeWord vr (gpr:_) _ = MR gpr vr
storeWord vr [] offset
= ST II32 vr (AddrRegImm sp (ImmInt offset))
passArguments args
(drop 2 gprs)
fprs
(stackOffset+8)
(accumCode `appOL` code
`snocOL` storeWord vr_hi gprs stackOffset
`snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
((take 2 gprs) ++ accumUsed)
GCPDarwin ->
do let storeWord vr (gpr:_) _ = MR gpr vr
storeWord vr [] offset
= ST II32 vr (AddrRegImm sp (ImmInt offset))
passArguments args
(drop 2 gprs)
fprs
(stackOffset+8)
(accumCode `appOL` code
`snocOL` storeWord vr_hi gprs stackOffset
`snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
((take 2 gprs) ++ accumUsed)
GCPLinux ->
do let stackOffset' = roundTo 8 stackOffset
stackCode = accumCode `appOL` code
`snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
`snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
regCode hireg loreg =
accumCode `appOL` code
`snocOL` MR hireg vr_hi
`snocOL` MR loreg vr_lo
case gprs of
hireg : loreg : regs | even (length gprs) ->
passArguments args regs fprs stackOffset
(regCode hireg loreg) (hireg : loreg : accumUsed)
_skipped : hireg : loreg : regs ->
passArguments args regs fprs stackOffset
(regCode hireg loreg) (hireg : loreg : accumUsed)
_ ->
passArguments args [] fprs (stackOffset'+8)
stackCode accumUsed
GCPLinux64ELF _ -> panic "passArguments: 32 bit code"
passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed
| reg : _ <- regs = do
register <- getRegister arg
let code = case register of
Fixed _ freg fcode -> fcode `snocOL` MR reg freg
Any _ acode -> acode reg
stackOffsetRes = case gcp of
GCPDarwin -> stackOffset + stackBytes
GCPAIX -> stackOffset + stackBytes
GCPLinux -> stackOffset
GCPLinux64ELF _ -> stackOffset + stackBytes
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
stackOffsetRes
(accumCode `appOL` code)
(reg : accumUsed)
| otherwise = do
(vr, code) <- getSomeReg arg
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
(stackOffset' + stackBytes)
(accumCode `appOL` code `snocOL` ST (cmmTypeFormat rep) vr stackSlot)
accumUsed
where
stackOffset' = case gcp of
GCPDarwin ->
stackOffset
GCPAIX ->
stackOffset
GCPLinux
| isFloatType rep && typeWidth rep == W64 ->
roundTo 8 stackOffset
| otherwise ->
stackOffset
GCPLinux64ELF _ ->
stackOffset
stackOffset''
| isFloatType rep && typeWidth rep == W32 =
case gcp of
GCPLinux64ELF 1 -> stackOffset' + 4
_ -> stackOffset'
| otherwise = stackOffset'
stackSlot = AddrRegImm sp (ImmInt stackOffset'')
(nGprs, nFprs, stackBytes, regs)
= case gcp of
GCPAIX ->
case cmmTypeFormat rep of
II8 -> (1, 0, 4, gprs)
II16 -> (1, 0, 4, gprs)
II32 -> (1, 0, 4, gprs)
FF32 -> (1, 1, 4, fprs)
FF64 -> (2, 1, 8, fprs)
II64 -> panic "genCCall' passArguments II64"
FF80 -> panic "genCCall' passArguments FF80"
GCPDarwin ->
case cmmTypeFormat rep of
II8 -> (1, 0, 4, gprs)
II16 -> (1, 0, 4, gprs)
II32 -> (1, 0, 4, gprs)
FF32 -> (1, 1, 4, fprs)
FF64 -> (2, 1, 8, fprs)
II64 -> panic "genCCall' passArguments II64"
FF80 -> panic "genCCall' passArguments FF80"
GCPLinux ->
case cmmTypeFormat rep of
II8 -> (1, 0, 4, gprs)
II16 -> (1, 0, 4, gprs)
II32 -> (1, 0, 4, gprs)
FF32 -> (0, 1, 4, fprs)
FF64 -> (0, 1, 8, fprs)
II64 -> panic "genCCall' passArguments II64"
FF80 -> panic "genCCall' passArguments FF80"
GCPLinux64ELF _ ->
case cmmTypeFormat rep of
II8 -> (1, 0, 8, gprs)
II16 -> (1, 0, 8, gprs)
II32 -> (1, 0, 8, gprs)
II64 -> (1, 0, 8, gprs)
FF32 -> (1, 1, 8, fprs)
FF64 -> (1, 1, 8, fprs)
FF80 -> panic "genCCall' passArguments FF80"
moveResult reduceToFF32 =
case dest_regs of
[] -> nilOL
[dest]
| reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1)
| isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
| isWord64 rep && target32Bit (targetPlatform dflags)
-> toOL [MR (getHiVRegFromLo r_dest) r3,
MR r_dest r4]
| otherwise -> unitOL (MR r_dest r3)
where rep = cmmRegType dflags (CmmLocal dest)
r_dest = getRegisterReg platform (CmmLocal dest)
_ -> panic "genCCall' moveResult: Bad dest_regs"
outOfLineMachOp mop =
do
dflags <- getDynFlags
mopExpr <- cmmMakeDynamicReference dflags CallReference $
mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
_ -> Right mopExpr
return (mopLabelOrExpr, reduce)
where
(functionName, reduce) = case mop of
MO_F32_Exp -> (fsLit "exp", True)
MO_F32_Log -> (fsLit "log", True)
MO_F32_Sqrt -> (fsLit "sqrt", True)
MO_F32_Fabs -> unsupported
MO_F32_Sin -> (fsLit "sin", True)
MO_F32_Cos -> (fsLit "cos", True)
MO_F32_Tan -> (fsLit "tan", True)
MO_F32_Asin -> (fsLit "asin", True)
MO_F32_Acos -> (fsLit "acos", True)
MO_F32_Atan -> (fsLit "atan", True)
MO_F32_Sinh -> (fsLit "sinh", True)
MO_F32_Cosh -> (fsLit "cosh", True)
MO_F32_Tanh -> (fsLit "tanh", True)
MO_F32_Pwr -> (fsLit "pow", True)
MO_F64_Exp -> (fsLit "exp", False)
MO_F64_Log -> (fsLit "log", False)
MO_F64_Sqrt -> (fsLit "sqrt", False)
MO_F64_Fabs -> unsupported
MO_F64_Sin -> (fsLit "sin", False)
MO_F64_Cos -> (fsLit "cos", False)
MO_F64_Tan -> (fsLit "tan", False)
MO_F64_Asin -> (fsLit "asin", False)
MO_F64_Acos -> (fsLit "acos", False)
MO_F64_Atan -> (fsLit "atan", False)
MO_F64_Sinh -> (fsLit "sinh", False)
MO_F64_Cosh -> (fsLit "cosh", False)
MO_F64_Tanh -> (fsLit "tanh", False)
MO_F64_Pwr -> (fsLit "pow", False)
MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)
MO_Memcpy _ -> (fsLit "memcpy", False)
MO_Memset _ -> (fsLit "memset", False)
MO_Memmove _ -> (fsLit "memmove", False)
MO_BSwap w -> (fsLit $ bSwapLabel w, False)
MO_PopCnt w -> (fsLit $ popCntLabel w, False)
MO_Clz w -> (fsLit $ clzLabel w, False)
MO_Ctz w -> (fsLit $ ctzLabel w, False)
MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False)
MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)
MO_AtomicRead w -> (fsLit $ atomicReadLabel w, False)
MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False)
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_SubWordC {} -> unsupported
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
(MO_Prefetch_Data _ ) -> unsupported
unsupported = panic ("outOfLineCmmOp: " ++ show mop
++ " not supported")
genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch dflags expr targets
| OSAIX <- platformOS (targetPlatform dflags)
= do
(reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
sha = if target32Bit $ targetPlatform dflags then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = e_code `appOL` t_code `appOL` toOL [
SL fmt tmp reg (RIImm (ImmInt sha)),
LD fmt tmp (AddrRegReg tableReg tmp),
MTCTR tmp,
BCTR ids (Just lbl)
]
return code
| (positionIndependent dflags) || (not $ target32Bit $ targetPlatform dflags)
= do
(reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
sha = if target32Bit $ targetPlatform dflags then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = e_code `appOL` t_code `appOL` toOL [
SL fmt tmp reg (RIImm (ImmInt sha)),
LD fmt tmp (AddrRegReg tableReg tmp),
ADD tmp tmp (RIReg tableReg),
MTCTR tmp,
BCTR ids (Just lbl)
]
return code
| otherwise
= do
(reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
sha = if target32Bit $ targetPlatform dflags then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
let code = e_code `appOL` toOL [
SL fmt tmp reg (RIImm (ImmInt sha)),
ADDIS tmp tmp (HA (ImmCLbl lbl)),
LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
MTCTR tmp,
BCTR ids (Just lbl)
]
return code
where (offset, ids) = switchTargetsToTable targets
generateJumpTableForInstr :: DynFlags -> Instr
-> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr dflags (BCTR ids (Just lbl)) =
let jumpTable
| (positionIndependent dflags)
|| (not $ target32Bit $ targetPlatform dflags)
= map jumpTableEntryRel ids
| otherwise = map (jumpTableEntry dflags) ids
where jumpTableEntryRel Nothing
= CmmStaticLit (CmmInt 0 (wordWidth dflags))
jumpTableEntryRel (Just blockid)
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
where blockLabel = mkAsmTempLabel (getUnique blockid)
in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable))
generateJumpTableForInstr _ _ = Nothing
condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condReg :: NatM CondCode -> NatM Register
condReg getCond = do
CondCode _ cond cond_code <- getCond
dflags <- getDynFlags
let
code dst = cond_code
`appOL` negate_code
`appOL` toOL [
MFCR dst,
RLWINM dst dst (bit + 1) 31 31
]
negate_code | do_negate = unitOL (CRNOR bit bit bit)
| otherwise = nilOL
(bit, do_negate) = case cond of
LTT -> (0, False)
LE -> (1, True)
EQQ -> (2, False)
GE -> (0, True)
GTT -> (1, False)
NE -> (2, True)
LU -> (0, False)
LEU -> (1, True)
GEU -> (0, True)
GU -> (1, False)
_ -> panic "PPC.CodeGen.codeReg: no match"
format = archWordFormat $ target32Bit $ targetPlatform dflags
return (Any format code)
condIntReg cond x y = condReg (condIntCode cond x y)
condFltReg cond x y = condReg (condFltCode cond x y)
trivialCode
:: Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode rep signed instr x (CmmLit (CmmInt y _))
| Just imm <- makeImmediate rep signed y
= do
(src1, code1) <- getSomeReg x
let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
return (Any (intFormat rep) code)
trivialCode rep _ instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)
return (Any (intFormat rep) code)
shiftMulCode
:: Width
-> Bool
-> (Format-> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode width sign instr x (CmmLit (CmmInt y _))
| Just imm <- makeImmediate width sign y
= do
(src1, code1) <- getSomeReg x
let format = intFormat width
let code dst = code1 `snocOL` instr format dst src1 (RIImm imm)
return (Any format code)
shiftMulCode width _ instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let format = intFormat width
let code dst = code1 `appOL` code2 `snocOL` instr format dst src1 (RIReg src2)
return (Any format code)
trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm' format instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
return (Any format code)
trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm format instr x y = trivialCodeNoImm' format (instr format) x y
trivialCodeNoImmSign :: Format -> Bool
-> (Format -> Bool -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImmSign format sgn instr x y
= trivialCodeNoImm' format (instr format sgn) x y
trivialUCode
:: Format
-> (Reg -> Reg -> Instr)
-> CmmExpr
-> NatM Register
trivialUCode rep instr x = do
(src, code) <- getSomeReg x
let code' dst = code `snocOL` instr dst src
return (Any rep code')
remainderCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainderCode rep sgn x y = do
let fmt = intFormat rep
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let code dst = code1 `appOL` code2 `appOL` toOL [
DIV fmt sgn dst src1 src2,
MULL fmt dst dst (RIReg src2),
SUBF dst dst src1
]
return (Any (intFormat rep) code)
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP fromRep toRep x = do
dflags <- getDynFlags
let arch = platformArch $ targetPlatform dflags
coerceInt2FP' arch fromRep toRep x
coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' ArchPPC fromRep toRep x = do
(src, code) <- getSomeReg x
lbl <- getNewLabelNat
itmp <- getNewRegNat II32
ftmp <- getNewRegNat FF64
dflags <- getDynFlags
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
LDATA (Section ReadOnlyData lbl) $ Statics lbl
[CmmStaticLit (CmmInt 0x43300000 W32),
CmmStaticLit (CmmInt 0x80000000 W32)],
XORIS itmp src (ImmInt 0x8000),
ST II32 itmp (spRel dflags 3),
LIS itmp (ImmInt 0x4330),
ST II32 itmp (spRel dflags 2),
LD FF64 ftmp (spRel dflags 2)
] `appOL` addr_code `appOL` toOL [
LD FF64 dst addr,
FSUB FF64 dst ftmp dst
] `appOL` maybe_frsp dst
maybe_exts = case fromRep of
W8 -> unitOL $ EXTS II8 src src
W16 -> unitOL $ EXTS II16 src src
W32 -> nilOL
_ -> panic "PPC.CodeGen.coerceInt2FP: no match"
maybe_frsp dst
= case toRep of
W32 -> unitOL $ FRSP dst dst
W64 -> nilOL
_ -> panic "PPC.CodeGen.coerceInt2FP: no match"
return (Any (floatFormat toRep) code')
coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do
(src, code) <- getSomeReg x
dflags <- getDynFlags
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
ST II64 src (spRel dflags 3),
LD FF64 dst (spRel dflags 3),
FCFID dst dst
] `appOL` maybe_frsp dst
maybe_exts = case fromRep of
W8 -> unitOL $ EXTS II8 src src
W16 -> unitOL $ EXTS II16 src src
W32 -> unitOL $ EXTS II32 src src
W64 -> nilOL
_ -> panic "PPC.CodeGen.coerceInt2FP: no match"
maybe_frsp dst
= case toRep of
W32 -> unitOL $ FRSP dst dst
W64 -> nilOL
_ -> panic "PPC.CodeGen.coerceInt2FP: no match"
return (Any (floatFormat toRep) code')
coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch"
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int fromRep toRep x = do
dflags <- getDynFlags
let arch = platformArch $ targetPlatform dflags
coerceFP2Int' arch fromRep toRep x
coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' ArchPPC _ toRep x = do
dflags <- getDynFlags
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
code' dst = code `appOL` toOL [
FCTIWZ tmp src,
ST FF64 tmp (spRel dflags 2),
LD II32 dst (spRel dflags 3)]
return (Any (intFormat toRep) code')
coerceFP2Int' (ArchPPC_64 _) _ toRep x = do
dflags <- getDynFlags
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
code' dst = code `appOL` toOL [
FCTIDZ tmp src,
ST FF64 tmp (spRel dflags 3),
LD II64 dst (spRel dflags 3)]
return (Any (intFormat toRep) code')
coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"