X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fcmm%2FPprC.hs;h=51e429b0aeb9cf0b7662faa56f1f4979c3ecdab0;hb=69cb15e2f6853435602f00ecbccd2598a9e7eea9;hp=e7e72abfaa0edfcb55543041f92204b8df09da19;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git

diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs
index e7e72ab..51e429b 100644
--- a/ghc/compiler/cmm/PprC.hs
+++ b/ghc/compiler/cmm/PprC.hs
@@ -40,7 +40,7 @@ import Constants
 import CmdLineOpts	( opt_EnsureSplittableC )
 
 -- The rest
-import Data.List        ( intersperse, group )
+import Data.List        ( intersperse, groupBy )
 import Data.Bits        ( shiftR )
 import Char             ( ord, chr )
 import IO               ( Handle )
@@ -251,29 +251,26 @@ pprCondBranch expr ident
 --
 pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
 pprSwitch e maybe_ids 
-  = let ids  = [ i | Just i <- maybe_ids ]
-        pairs = zip [ 0 .. ] (concatMap markfalls (group ids))
+  = let pairs  = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
+	pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
     in 
         (hang (ptext SLIT("switch") <+> parens ( pprExpr e ) <+> lbrace)
-                4 (vcat ( map caseify pairs )))
+                4 (vcat ( map caseify pairs2 )))
         $$ rbrace
 
   where
-    -- fall through case
-    caseify (i,Left ident) = 
-        hsep [ ptext SLIT("case") , pprHexVal i <> colon ,
-                        ptext SLIT("/* fall through for"), 
-                        pprBlockId ident, 
-                        ptext SLIT("*/") ]
-
-    caseify (i,Right ident) = 
-        hsep [ ptext SLIT("case") , pprHexVal i <> colon ,
-                        ptext SLIT("goto") , (pprBlockId ident) <> semi ]
+    sndEq (_,x) (_,y) = x == y
 
-    -- mark the bottom of a fallthough sequence of cases as `Right'
-    markfalls [a] = [Right a]
-    markfalls as  = map (\a -> Left a) (init as) ++ [Right (last as)]
+    -- fall through case
+    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
+	where 
+	do_fallthrough ix =
+                 hsep [ ptext SLIT("case") , pprHexVal ix <> colon ,
+                        ptext SLIT("/* fall through */") ]
 
+	final_branch ix = 
+	        hsep [ ptext SLIT("case") , pprHexVal ix <> colon ,
+                       ptext SLIT("goto") , (pprBlockId ident) <> semi ]
 
 -- ---------------------------------------------------------------------
 -- Expressions.
@@ -336,7 +333,7 @@ pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
 
 pprMachOpApp op args
   | isMulMayOfloOp op
-  = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args)) <> semi
+  = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args))
   where isMulMayOfloOp (MO_U_MulMayOflo _) = True
 	isMulMayOfloOp (MO_S_MulMayOflo _) = True
 	isMulMayOfloOp _ = False
@@ -585,9 +582,16 @@ pprAssign r1 (CmmRegOff r2 off)
 	(op,off') | off >= 0  = (char '+', off1)
 		  | otherwise = (char '-', -off1)
 
--- dest is a reg, rhs is anything
+-- dest is a reg, rhs is anything.
+-- 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
-    = pprCastReg r1 <+> equals <+> pprExpr r2 <> semi
+  | isPtrReg r1
+  = pprAsPtrReg r1 <> ptext SLIT(" = ") <> mkP_ <> pprExpr1 r2 <> semi
+  | Just ty <- strangeRegType r1
+  = pprReg r1 <> ptext SLIT(" = ") <> parens ty <> pprExpr1 r2 <> semi
+  | otherwise
+  = pprReg r1 <> ptext SLIT(" = ") <> pprExpr r2 <> semi
 
 -- ---------------------------------------------------------------------
 -- Registers
@@ -622,6 +626,10 @@ isStrangeTypeGlobal CurrentTSO		= True
 isStrangeTypeGlobal CurrentNursery 	= True
 isStrangeTypeGlobal r 			= isPtrGlobalReg r
 
+strangeRegType :: CmmReg -> Maybe SDoc
+strangeRegType (CmmGlobal CurrentTSO) = Just (ptext SLIT("struct StgTSO_ *"))
+strangeRegType (CmmGlobal CurrentNursery) = Just (ptext SLIT("struct bdescr_ *"))
+strangeRegType _ = Nothing
 
 -- pprReg just prints the register name.
 --
@@ -673,7 +681,9 @@ pprCall ppr_fn cconv results args vols
     restore vols
   where 
      ppr_results []     = empty
-     ppr_results [(one,hint)]  = pprArg (CmmReg one,hint) <> ptext SLIT(" = ")
+     ppr_results [(one,hint)] 
+	 = pprExpr (CmmReg one) <> ptext SLIT(" = ")
+		 <> pprUnHint hint (cmmRegRep one)
      ppr_results _other = panic "pprCall: multiple results"
 
      pprArg (expr, PtrHint)
@@ -684,6 +694,10 @@ pprCall ppr_fn cconv results args vols
      pprArg (expr, _other)
 	= pprExpr expr
 
+     pprUnHint PtrHint    rep = parens (machRepCType rep)
+     pprUnHint SignedHint rep = parens (machRepCType rep)
+     pprUnHint _          _   = empty
+
      save    = save_restore SLIT("CALLER_SAVE")
      restore = save_restore SLIT("CALLER_RESTORE")