X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=b8ba5b7cc455a938c53d3771bbe792b7aec7b676;hb=317fc69d18eda68fd65f5ba634feafbe4a3923da;hp=5c60b8a8974a3e0f9d83fdbb0e823148a451bd4d;hpb=f9c1512a1da2e52f88dc6fde57920fefa37fc0eb;p=ghc-hetmet.git

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 5c60b8a..b8ba5b7 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -2,7 +2,7 @@
 --
 -- Pretty-printing of Cmm as C, suitable for feeding gcc
 --
--- (c) The University of Glasgow 2004
+-- (c) The University of Glasgow 2004-2006
 --
 -----------------------------------------------------------------------------
 
@@ -30,33 +30,37 @@ import MachOp
 import ForeignCall
 
 -- Utils
-import DynFlags		( DynFlags, DynFlag(..), dopt )
-import Unique           ( getUnique )
+import DynFlags
+import Unique
 import UniqSet
 import FiniteMap
-import UniqFM		( eltsUFM )
+import UniqFM
 import FastString
 import Outputable
 import Constants
-import StaticFlags 	( opt_Unregisterised )
 
 -- The rest
-import Data.List        ( intersperse, groupBy )
-import Data.Bits        ( shiftR )
-import Char             ( ord, chr )
-import IO               ( Handle )
-import DATA_BITS
-import Data.Word	( Word8 )
+import Data.List
+import Data.Bits
+import Data.Char
+import System.IO
+import Data.Word
 
 #ifdef DEBUG
 import PprCmm		() -- instances only
 -- import Debug.Trace
 #endif
 
-#if __GLASGOW_HASKELL__ >= 504
 import Data.Array.ST
+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
-import MONAD_ST
 
 -- --------------------------------------------------------------------------
 -- Top level
@@ -323,7 +327,7 @@ pprExpr e = case e of
 
     CmmLoad expr rep ->
 	-- the general case:
-	char '*' <> parens (cCast (machRepPtrCType rep) expr)
+	cLoad expr rep
 
     CmmReg reg      -> pprCastReg reg
     CmmRegOff reg 0 -> pprCastReg reg
@@ -354,6 +358,20 @@ pprMachOpApp op args
 	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
@@ -413,6 +431,9 @@ pprStatics (CmmStaticLit (CmmInt i I64) : rest)
 #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)
@@ -593,18 +614,15 @@ pprAssign :: CmmReg -> CmmExpr -> SDoc
 
 -- 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)
@@ -613,8 +631,8 @@ pprAssign r1 (CmmRegOff r2 off)
 -- 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
@@ -627,20 +645,26 @@ pprCastReg reg
    | 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.
@@ -652,7 +676,7 @@ isStrangeTypeGlobal :: GlobalReg -> Bool
 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_ *"))
@@ -860,6 +884,18 @@ te_Reg _            = return ()
 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.
@@ -927,46 +963,20 @@ big_doubles
   | 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)
     )
 
@@ -974,21 +984,21 @@ doubleToWords :: Rational -> [CmmLit]
 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 ]
     )