-- import Debug.Trace
#endif
-#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
-#endif
import Control.Monad.ST
+#if x86_64_TARGET_ARCH
+import StaticFlags ( opt_Unregisterised )
+#endif
+
+#if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH)
+#define BEWARE_LOAD_STORE_ALIGNMENT
+#endif
+
-- --------------------------------------------------------------------------
-- Top level
where
rep = cmmExprRep src
- CmmCall (CmmForeignCall fn cconv) results args volatile ->
+ CmmCall (CmmForeignCall fn cconv) results args ->
-- Controversial: leave this out for now.
-- pprUndef fn $$
- pprCall ppr_fn cconv results args volatile
+ pprCall ppr_fn cconv results args
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
- CmmCall (CmmPrim op) results args volatile ->
- pprCall ppr_fn CCallConv results args volatile
+ CmmCall (CmmPrim op) results args ->
+ pprCall ppr_fn CCallConv results args
where
ppr_fn = pprCallishMachOp_for_C op
CmmLoad expr rep ->
-- the general case:
- char '*' <> parens (cCast (machRepPtrCType rep) expr)
+ cLoad expr rep
CmmReg reg -> pprCastReg reg
CmmRegOff reg 0 -> pprCastReg reg
isMulMayOfloOp _ = False
pprMachOpApp mop args
+ | Just ty <- machOpNeedsCast mop
+ = ty <> parens (pprMachOpApp' mop args)
+ | otherwise
+ = pprMachOpApp' mop args
+
+-- Comparisons in C have type 'int', but we want type W_ (this is what
+-- resultRepOfMachOp says). The other C operations inherit their type
+-- from their operands, so no casting is required.
+machOpNeedsCast :: MachOp -> Maybe SDoc
+machOpNeedsCast mop
+ | isComparisonMachOp mop = Just mkW_
+ | otherwise = Nothing
+
+pprMachOpApp' mop args
= case args of
-- dyadic
[x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
#endif
where r = i .&. 0xffffffff
q = i `shiftR` 32
+pprStatics (CmmStaticLit (CmmInt i rep) : rest)
+ | machRepByteWidth rep /= wORD_SIZE
+ = panic "pprStatics: cannot emit a non-word-sized static literal"
pprStatics (CmmStaticLit lit : rest)
= pprLit1 lit : pprStatics rest
pprStatics (other : rest)
-- dest is a reg, rhs is a reg
pprAssign r1 (CmmReg r2)
- | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2)
- || isPtrReg r1 && isPtrReg r2
+ | isPtrReg r1 && isPtrReg r2
= hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
-- dest is a reg, rhs is a CmmRegOff
pprAssign r1 (CmmRegOff r2 off)
- | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2)
- || isPtrReg r1 && isPtrReg r2
+ | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
= hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
where
- off1 | isPtrReg r2 = off `shiftR` wordShift
- | otherwise = off
+ off1 = off `shiftR` wordShift
(op,off') | off >= 0 = (char '+', off1)
| otherwise = (char '-', -off1)
-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting
-- the lvalue elicits a warning from new GCC versions (3.4+).
pprAssign r1 r2
- | isPtrReg r1
- = pprAsPtrReg r1 <> ptext SLIT(" = ") <> mkP_ <> pprExpr1 r2 <> semi
+ | isFixedPtrReg r1
+ = pprReg r1 <> ptext SLIT(" = ") <> mkP_ <> pprExpr1 r2 <> semi
| Just ty <- strangeRegType r1
= pprReg r1 <> ptext SLIT(" = ") <> parens ty <> pprExpr1 r2 <> semi
| otherwise
| isStrangeTypeReg reg = mkW_ <> pprReg reg
| otherwise = pprReg reg
--- True if the register has type StgPtr in C, otherwise it has an
--- integer type. We need to take care with pointer arithmetic on registers
--- with type StgPtr.
-isPtrReg :: CmmReg -> Bool
-isPtrReg (CmmLocal _) = False
-isPtrReg (CmmGlobal r) = isPtrGlobalReg r
+-- True if (pprReg reg) will give an expression with type StgPtr. We
+-- need to take care with pointer arithmetic on registers with type
+-- StgPtr.
+isFixedPtrReg :: CmmReg -> Bool
+isFixedPtrReg (CmmLocal _) = False
+isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
-isPtrGlobalReg :: GlobalReg -> Bool
-isPtrGlobalReg (VanillaReg n) = True
-isPtrGlobalReg Sp = True
-isPtrGlobalReg Hp = True
-isPtrGlobalReg HpLim = True
-isPtrGlobalReg SpLim = True
-isPtrGlobalReg _ = False
+-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
+isPtrReg :: CmmReg -> Bool
+isPtrReg (CmmLocal _) = False
+isPtrReg (CmmGlobal (VanillaReg n)) = True -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg
+
+-- True if this global reg has type StgPtr
+isFixedPtrGlobalReg :: GlobalReg -> Bool
+isFixedPtrGlobalReg Sp = True
+isFixedPtrGlobalReg Hp = True
+isFixedPtrGlobalReg HpLim = True
+isFixedPtrGlobalReg SpLim = True
+isFixedPtrGlobalReg _ = False
-- True if in C this register doesn't have the type given by
-- (machRepCType (cmmRegRep reg)), so it has to be cast.
isStrangeTypeGlobal CurrentTSO = True
isStrangeTypeGlobal CurrentNursery = True
isStrangeTypeGlobal BaseReg = True
-isStrangeTypeGlobal r = isPtrGlobalReg r
+isStrangeTypeGlobal r = isFixedPtrGlobalReg r
strangeRegType :: CmmReg -> Maybe SDoc
strangeRegType (CmmGlobal CurrentTSO) = Just (ptext SLIT("struct StgTSO_ *"))
-- Foreign Calls
pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
- -> Maybe [GlobalReg] -> SDoc
+ -> SDoc
-pprCall ppr_fn cconv results args vols
+pprCall ppr_fn cconv results args
| not (is_cish cconv)
= panic "pprCall: unknown calling convention"
| otherwise
- = save vols $$
- ptext SLIT("CALLER_SAVE_SYSTEM") $$
+ =
#if x86_64_TARGET_ARCH
-- HACK around gcc optimisations.
-- x86_64 needs a __DISCARD__() here, to create a barrier between
then ptext SLIT("__DISCARD__();")
else empty) $$
#endif
- ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi $$
- ptext SLIT("CALLER_RESTORE_SYSTEM") $$
- restore vols
+ ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
pprUnHint SignedHint rep = parens (machRepCType rep)
pprUnHint _ _ = empty
- save = save_restore SLIT("CALLER_SAVE")
- restore = save_restore SLIT("CALLER_RESTORE")
-
- -- Nothing says "I don't know what's live; save everything"
- -- CALLER_SAVE_USER is defined in ghc/includes/Regs.h
- save_restore txt Nothing = ptext txt <> ptext SLIT("_USER")
- save_restore txt (Just these) = vcat (map saveRestoreGlobal these)
- where saveRestoreGlobal r = ptext txt <> char '_' <> pprGlobalRegName r
-
pprGlobalRegName :: GlobalReg -> SDoc
pprGlobalRegName gr = case gr of
VanillaReg n -> char 'R' <> int n -- without the .w suffix
te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
-te_Stmt (CmmCall _ rs es _) = mapM_ (te_Reg.fst) rs >>
+te_Stmt (CmmCall _ rs es) = mapM_ (te_Reg.fst) rs >>
mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
cCast :: SDoc -> CmmExpr -> SDoc
cCast ty expr = parens ty <> pprExpr1 expr
+cLoad :: CmmExpr -> MachRep -> SDoc
+#ifdef BEWARE_LOAD_STORE_ALIGNMENT
+cLoad expr rep =
+ let decl = machRepCType rep <+> ptext SLIT("x") <> semi
+ struct = ptext SLIT("struct") <+> braces (decl)
+ packed_attr = ptext SLIT("__attribute__((packed))")
+ cast = parens (struct <+> packed_attr <> char '*')
+ in parens (cast <+> pprExpr1 expr) <> ptext SLIT("->x")
+#else
+cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr)
+#endif
+
-- This is for finding the types of foreign call arguments. For a pointer
-- argument, we always cast the argument to (void *), to avoid warnings from
-- the C compiler.
| machRepByteWidth F64 == wORD_SIZE = False
| otherwise = panic "big_doubles"
-#if __GLASGOW_HASKELL__ >= 504
-newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
-newFloatArray = newArray_
-
-newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
-newDoubleArray = newArray_
-
castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
castFloatToIntArray = castSTUArray
castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
castDoubleToIntArray = castSTUArray
-writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
-writeFloatArray = writeArray
-
-writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
-writeDoubleArray = writeArray
-
-readIntArray :: STUArray s Int Int -> Int -> ST s Int
-readIntArray = readArray
-
-#else
-
-castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
-castFloatToIntArray = return
-
-castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
-castDoubleToIntArray = return
-
-#endif
-
-- floats are always 1 word
floatToWord :: Rational -> CmmLit
floatToWord r
= runST (do
- arr <- newFloatArray ((0::Int),0)
- writeFloatArray arr 0 (fromRational r)
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 (fromRational r)
arr' <- castFloatToIntArray arr
- i <- readIntArray arr' 0
+ i <- readArray arr' 0
return (CmmInt (toInteger i) wordRep)
)
doubleToWords r
| big_doubles -- doubles are 2 words
= runST (do
- arr <- newDoubleArray ((0::Int),1)
- writeDoubleArray arr 0 (fromRational r)
+ arr <- newArray_ ((0::Int),1)
+ writeArray arr 0 (fromRational r)
arr' <- castDoubleToIntArray arr
- i1 <- readIntArray arr' 0
- i2 <- readIntArray arr' 1
+ i1 <- readArray arr' 0
+ i2 <- readArray arr' 1
return [ CmmInt (toInteger i1) wordRep
, CmmInt (toInteger i2) wordRep
]
)
| otherwise -- doubles are 1 word
= runST (do
- arr <- newDoubleArray ((0::Int),0)
- writeDoubleArray arr 0 (fromRational r)
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 (fromRational r)
arr' <- castDoubleToIntArray arr
- i <- readIntArray arr' 0
+ i <- readArray arr' 0
return [ CmmInt (toInteger i) wordRep ]
)
projects / ghc-hetmet.git / blobdiff