{-# LANGUAGE CPP, GADTs #-}
module PPC.CodeGen (
cmmTopCodeGen,
generateJumpTableForInstr,
InstrBlock
)
where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
#include "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 (gopt Opt_PIC 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
| (gopt Opt_PIC 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
| (gopt Opt_PIC 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"