X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=d1536bff9c63aeac6d25d6126f93e28b81a892a3;hb=b88025eabcd83f65d1d81f09272f5172f06a60e7;hp=6d63e876472ac6719fb95fa6dd816c2f3b157082;hpb=45b5e0b79b4276e761cab5e4a51a7eff9220c3ba;p=ghc-hetmet.git

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 6d63e87..d1536bf 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -60,6 +60,10 @@ import Control.Monad.ST
 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
 
@@ -325,7 +329,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
@@ -609,18 +613,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)
@@ -629,8 +630,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
@@ -643,20 +644,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.
@@ -668,7 +675,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_ *"))
@@ -876,6 +883,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.