import MachInstrs
import MachRegs
import NCGMonad
+import PositionIndependentCode ( cmmMakeDynamicReference, initializePicBase )
-- Our intermediate code:
import PprCmm ( pprExpr )
import CLabel
-- The rest:
-import CmdLineOpts ( opt_Static )
+import CmdLineOpts ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
import Pretty
cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop]
cmmTopCodeGen (CmmProc info lab params blocks) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
- return (CmmProc info lab params (concat nat_blocks) : concat statics)
+ picBaseMb <- getPicBaseMaybeNat
+ let proc = CmmProc info lab params (concat nat_blocks)
+ tops = proc : concat statics
+ case picBaseMb of
+ Just picBase -> initializePicBase picBase tops
+ Nothing -> return tops
+
cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec dat] -- no translation, we just use CmmStatic
getRegister tree@(CmmRegOff _ _)
= getRegister (mangleIndexTree tree)
+getRegister CmmPicBaseReg
+ = do
+ reg <- getPicBaseNat wordRep
+ return (Fixed wordRep reg nilOL)
+
-- end of machine-"independent" bit; here we go on the rest...
#if alpha_TARGET_ARCH
MO_Mul F64 -> trivialCodeNoImm F64 (FMUL F64) x y
MO_S_Quot F64 -> trivialCodeNoImm F64 (FDIV F64) x y
+ -- optimize addition with 32-bit immediate
+ -- (needed for PIC)
+ MO_Add I32 ->
+ case y of
+ CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate I32 True (-imm)
+ -> trivialCode I32 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 I32 code)
+ _ -> trivialCode I32 True ADD x y
+
MO_Add rep -> trivialCode rep True ADD x y
MO_Sub rep ->
case y of -- subfi ('substract from' with immediate) doesn't exist
in
return (Any rep code)
-getRegister (CmmLit (CmmFloat f F32)) = do
+getRegister (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
- tmp <- getNewRegNat I32
- let code dst = toOL [
+ dynRef <- cmmMakeDynamicReference addImportNat False lbl
+ Amode addr addr_code <- getAmode dynRef
+ let code dst =
LDATA ReadOnlyData [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat f F32)],
- LIS tmp (HA (ImmCLbl lbl)),
- LD F32 dst (AddrRegImm tmp (LO (ImmCLbl lbl)))
- ]
- -- in
- return (Any F32 code)
-
-getRegister (CmmLit (CmmFloat d F64)) = do
- lbl <- getNewLabelNat
- tmp <- getNewRegNat I32
- let code dst = toOL [
- LDATA ReadOnlyData [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat d F64)],
- LIS tmp (HA (ImmCLbl lbl)),
- LD F64 dst (AddrRegImm tmp (LO (ImmCLbl lbl)))
- ]
- -- in
- return (Any F32 code)
-
-#if darwin_TARGET_OS
-getRegister (CmmLit (CmmLabel lbl))
- | labelCouldBeDynamic lbl
- = do
- addImportNat False lbl
- let imm = ImmDyldNonLazyPtr lbl
- code dst = toOL [
- LIS dst (HA imm),
- LD I32 dst (AddrRegImm dst (LO imm))
- ]
- return (Any I32 code)
-#endif
+ CmmStaticLit (CmmFloat f frep)]
+ `consOL` (addr_code `snocOL` LD frep dst addr)
+ return (Any frep code)
getRegister (CmmLit lit)
- = let
- rep = cmmLitRep lit
- imm = litToImm lit
- code dst = toOL [
- LIS dst (HI imm),
- OR dst dst (RIImm (LO imm))
- ]
- in
- return (Any rep code)
+ = let rep = cmmLitRep lit
+ imm = litToImm lit
+ code dst = toOL [
+ LIS dst (HI imm),
+ OR dst dst (RIImm (LO imm))
+ ]
+ in return (Any rep code)
+
getRegister other = pprPanic "getRegister(ppc)" (pprExpr other)
-- extend?Rep: wrap integer expression of type rep
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
+ -- optimize addition with 32-bit immediate
+ -- (needed for PIC)
+getAmode (CmmMachOp (MO_Add I32) [x, CmmLit lit])
+ = do
+ tmp <- getNewRegNat I32
+ (src, srcCode) <- getSomeReg x
+ let imm = litToImm lit
+ code = srcCode `snocOL` ADDIS tmp src (HA imm)
+ return (Amode (AddrRegImm tmp (LO imm)) code)
+
getAmode (CmmLit lit)
= do
tmp <- getNewRegNat I32
- let
+ let imm = litToImm lit
code = unitOL (LIS tmp (HA imm))
return (Amode (AddrRegImm tmp (LO imm)) code)
- where
- imm = litToImm lit
getAmode (CmmMachOp (MO_Add I32) [x, y])
= do
* SysV insists on either passing I64 arguments on the stack, or in two GPRs,
starting with an odd-numbered GPR. It may skip a GPR to achieve this.
Darwin just treats an I64 like two separate I32s (high word first).
+ * I64 and F64 arguments are 8-byte aligned on the stack for SysV, but only
+ 4-byte aligned like everything else on Darwin.
+ * The SysV spec claims that F32 is represented as F64 on the stack. GCC on
+ PowerPC Linux does not agree, so neither do we.
According to both conventions, The parameter area should be part of the
caller's stack frame, allocated in the caller's prologue code (large enough
initialStackOffset
(toOL []) []
+ (labelOrExpr, reduceToF32) <- case target of
+ CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False)
+ CmmForeignCall expr conv -> return (Right expr, False)
+ CmmPrim mop -> outOfLineFloatOp mop
+
let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
- codeAfter = move_sp_up finalStack `appOL` moveResult
+ codeAfter = move_sp_up finalStack `appOL` moveResult reduceToF32
case labelOrExpr of
Left lbl -> do
- addImportNat True lbl
return ( codeBefore
`snocOL` BL lbl usedRegs
`appOL` codeAfter)
#if darwin_TARGET_OS
initialStackOffset = 24
-- size of linkage area + size of arguments, in bytes
- stackDelta _finalStack = roundTo16 $ (24 +) $ max 32 $ sum $
+ stackDelta _finalStack = roundTo 16 $ (24 +) $ max 32 $ sum $
map machRepByteWidth argReps
#elif linux_TARGET_OS
initialStackOffset = 8
- stackDelta finalStack = roundTo16 finalStack
+ stackDelta finalStack = roundTo 16 finalStack
#endif
args = map fst argsAndHints
argReps = map cmmExprRep args
- roundTo16 x | x `mod` 16 == 0 = x
- | otherwise = x + 16 - (x `mod` 16)
+ roundTo a x | x `mod` a == 0 = x
+ | otherwise = x + a - (x `mod` a)
move_sp_down finalStack
| delta > 64 =
storeWord vr [] offset = ST I32 vr (AddrRegImm sp (ImmInt offset))
#elif linux_TARGET_OS
- let stackCode = accumCode `appOL` code
- `snocOL` ST I32 vr_hi (AddrRegImm sp (ImmInt stackOffset))
- `snocOL` ST I32 vr_lo (AddrRegImm sp (ImmInt (stackOffset+4)))
+ let stackOffset' = roundTo 8 stackOffset
+ stackCode = accumCode `appOL` code
+ `snocOL` ST I32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
+ `snocOL` ST I32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
regCode hireg loreg =
accumCode `appOL` code
`snocOL` MR hireg vr_hi
passArguments args regs fprs stackOffset
(regCode hireg loreg) (hireg : loreg : accumUsed)
_ -> -- only one or no regs left
- passArguments args [] fprs (stackOffset+8)
+ passArguments args [] fprs (stackOffset'+8)
stackCode accumUsed
#endif
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
- (stackOffset + stackBytes)
+ (stackOffset' + stackBytes)
(accumCode `appOL` code `snocOL` ST rep vr stackSlot)
accumUsed
where
- stackSlot = AddrRegImm sp (ImmInt stackOffset)
+#if darwin_TARGET_OS
+ -- stackOffset is at least 4-byte aligned
+ -- The Darwin ABI is happy with that.
+ stackOffset' = stackOffset
+#else
+ -- ... the SysV ABI requires 8-byte alignment for doubles.
+ stackOffset' | rep == F64 = roundTo 8 stackOffset
+ | otherwise = stackOffset
+#endif
+ stackSlot = AddrRegImm sp (ImmInt stackOffset')
(nGprs, nFprs, stackBytes, regs) = case rep of
I32 -> (1, 0, 4, gprs)
#if darwin_TARGET_OS
F64 -> (0, 1, 8, fprs)
#endif
- moveResult =
+ moveResult reduceToF32 =
case dest_regs of
[] -> nilOL
[(dest, _hint)]
where rep = cmmRegRep dest
r_dest = getRegisterReg dest
- (labelOrExpr, reduceToF32) = case target of
- CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> (Left lbl, False)
- CmmForeignCall expr conv -> (Right expr, False)
- CmmPrim mop -> (Left $ mkForeignLabel label Nothing False, reduce)
- where
- (label, reduce) = case mop of
- MO_F32_Exp -> (FSLIT("exp"), True)
- MO_F32_Log -> (FSLIT("log"), True)
- MO_F32_Sqrt -> (FSLIT("sqrt"), True)
-
- 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)
+ outOfLineFloatOp mop =
+ do
+ mopExpr <- cmmMakeDynamicReference addImportNat True $
+ mkForeignLabel functionName Nothing True
+ 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_F64_Sin -> (FSLIT("sin"), False)
- MO_F64_Cos -> (FSLIT("cos"), False)
- MO_F64_Tan -> (FSLIT("tan"), False)
+ 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_Asin -> (FSLIT("asin"), False)
- MO_F64_Acos -> (FSLIT("acos"), False)
- MO_F64_Atan -> (FSLIT("atan"), False)
+ MO_F64_Exp -> (FSLIT("exp"), False)
+ MO_F64_Log -> (FSLIT("log"), False)
+ MO_F64_Sqrt -> (FSLIT("sqrt"), 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)
- other -> pprPanic "genCCall(ppc): unknown callish op"
- (pprCallishMachOp other)
+ 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)
+ other -> pprPanic "genCCall(ppc): unknown callish op"
+ (pprCallishMachOp other)
#endif /* darwin_TARGET_OS || linux_TARGET_OS */
-- in
return code
#elif powerpc_TARGET_ARCH
-genSwitch expr ids = do
- (reg,e_code) <- getSomeReg expr
- tmp <- getNewRegNat I32
- lbl <- getNewLabelNat
- let
- jumpTable = map jumpTableEntry ids
-
- code = e_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
- SLW tmp reg (RIImm (ImmInt 2)),
- ADDIS tmp tmp (HA (ImmCLbl lbl)),
- LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
- MTCTR tmp,
- BCTR [ id | Just id <- ids ]
- ]
- -- in
- return code
+genSwitch expr ids
+ | opt_PIC
+ = do
+ (reg,e_code) <- getSomeReg expr
+ tmp <- getNewRegNat I32
+ lbl <- getNewLabelNat
+ dynRef <- cmmMakeDynamicReference addImportNat False lbl
+ (tableReg,t_code) <- getSomeReg $ dynRef
+ let
+ jumpTable = map jumpTableEntryRel ids
+
+ jumpTableEntryRel Nothing
+ = CmmStaticLit (CmmInt 0 wordRep)
+ jumpTableEntryRel (Just (BlockId id))
+ = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+ where blockLabel = mkAsmTempLabel id
+
+ code = e_code `appOL` t_code `appOL` toOL [
+ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ SLW tmp reg (RIImm (ImmInt 2)),
+ LD I32 tmp (AddrRegReg tableReg tmp),
+ ADD tmp tmp (RIReg tableReg),
+ MTCTR tmp,
+ BCTR [ id | Just id <- ids ]
+ ]
+ return code
+ | otherwise
+ = do
+ (reg,e_code) <- getSomeReg expr
+ tmp <- getNewRegNat I32
+ lbl <- getNewLabelNat
+ let
+ jumpTable = map jumpTableEntry ids
+
+ code = e_code `appOL` toOL [
+ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ SLW tmp reg (RIImm (ImmInt 2)),
+ ADDIS tmp tmp (HA (ImmCLbl lbl)),
+ LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
+ MTCTR tmp,
+ BCTR [ id | Just id <- ids ]
+ ]
+ return code
#else
genSwitch expr ids = panic "ToDo: genSwitch"
#endif
lbl <- getNewLabelNat
itmp <- getNewRegNat I32
ftmp <- getNewRegNat F64
+ dynRef <- cmmMakeDynamicReference addImportNat False lbl
+ Amode addr addr_code <- getAmode dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
LDATA ReadOnlyData
ST I32 itmp (spRel 3),
LIS itmp (ImmInt 0x4330),
ST I32 itmp (spRel 2),
- LD F64 ftmp (spRel 2),
- LIS itmp (HA (ImmCLbl lbl)),
- LD F64 dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
+ LD F64 ftmp (spRel 2)
+ ] `appOL` addr_code `appOL` toOL [
+ LD F64 dst addr,
FSUB F64 dst ftmp dst
] `appOL` maybe_frsp dst
eXTRA_STK_ARGS_HERE
= IF_ARCH_alpha(0, IF_ARCH_sparc(23, ???))
#endif
+
projects / ghc-hetmet.git / blobdiff