X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fcmm%2FPprC.hs;h=9fece36a427c634d7d33e1ad1c89a5fb1eb051a1;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=f2c607b668cdf9b93802469f03b3ef88c91fbe75;hpb=4315fc9f54d2af3aad9300d285f4fd8b387e9bca;p=ghc-hetmet.git

diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs
index f2c607b..9fece36 100644
--- a/ghc/compiler/cmm/PprC.hs
+++ b/ghc/compiler/cmm/PprC.hs
@@ -45,6 +45,7 @@ import Data.Bits        ( shiftR )
 import Char             ( ord, chr )
 import IO               ( Handle )
 import DATA_BITS
+import Data.Word	( Word8 )
 
 #ifdef DEBUG
 import PprCmm		() -- instances only
@@ -69,8 +70,7 @@ pprCs dflags cmms
 
 writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
 writeCs dflags handle cmms 
-  = printForUser handle alwaysQualify (pprCs dflags cmms)
- 	-- ToDo: should be printForC
+  = printForC handle (pprCs dflags cmms)
 
 -- --------------------------------------------------------------------------
 -- Now do some real work
@@ -655,6 +655,7 @@ 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 (CmmGlobal BaseReg) = Just (ptext SLIT("struct StgRegTable_ *"))
 strangeRegType _ = Nothing
 
 -- pprReg just prints the register name.
@@ -708,6 +709,9 @@ pprCall ppr_fn cconv results args vols
   where 
      ppr_results []     = empty
      ppr_results [(one,hint)] 
+	 | Just ty <- strangeRegType one
+	 = pprReg one <> ptext SLIT(" = ") <> parens ty
+	 | otherwise
 	 = pprReg one <> ptext SLIT(" = ")
 		 <> pprUnHint hint (cmmRegRep one)
      ppr_results _other = panic "pprCall: multiple results"
@@ -738,9 +742,10 @@ pprGlobalRegName gr = case gr of
     VanillaReg n   -> char 'R' <> int n  -- without the .w suffix
     _              -> pprGlobalReg gr
 
+-- Currently we only have these two calling conventions, but this might
+-- change in the future...
 is_cish CCallConv   = True
 is_cish StdCallConv = True
-is_cish _	    = False
 
 -- ---------------------------------------------------------------------
 -- Find and print local and external declarations for a list of
@@ -822,11 +827,10 @@ te_Stmt _			= return ()
 
 te_Expr :: CmmExpr -> TE ()
 te_Expr (CmmLit lit)		= te_Lit lit
-te_Expr (CmmReg r)		= te_Reg r
 te_Expr (CmmLoad e _)		= te_Expr e
+te_Expr (CmmReg r)		= te_Reg r
 te_Expr (CmmMachOp _ es) 	= mapM_ te_Expr es
 te_Expr (CmmRegOff r _) 	= te_Reg r
-te_Expr _ 			= return ()
 
 te_Reg :: CmmReg -> TE ()
 te_Reg (CmmLocal l) = te_temp l
@@ -878,25 +882,21 @@ machRepSignedCType r | r == wordRep = ptext SLIT("I_")
 -- ---------------------------------------------------------------------
 -- print strings as valid C strings
 
--- Assumes it contains only characters '\0'..'\xFF'!
-pprFSInCStyle :: FastString -> SDoc
-pprFSInCStyle fs = pprStringInCStyle (unpackFS fs)
-
-pprStringInCStyle :: String -> SDoc
+pprStringInCStyle :: [Word8] -> SDoc
 pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
 
-charToC :: Char -> String
-charToC '\"' = "\\\""
-charToC '\'' = "\\\'"
-charToC '\\' = "\\\\"
-charToC c | c >= ' ' && c <= '~' = [c]
-          | c > '\xFF' = panic ("charToC "++show c)
-          | otherwise = ['\\',
+charToC :: Word8 -> String
+charToC w = 
+  case chr (fromIntegral w) of
+	'\"' -> "\\\""
+	'\'' -> "\\\'"
+	'\\' -> "\\\\"
+	c | c >= ' ' && c <= '~' -> [c]
+          | otherwise -> ['\\',
                          chr (ord '0' + ord c `div` 64),
                          chr (ord '0' + ord c `div` 8 `mod` 8),
                          chr (ord '0' + ord c         `mod` 8)]
 
-
 -- ---------------------------------------------------------------------------
 -- Initialising static objects with floating-point numbers.  We can't
 -- just emit the floating point number, because C will cast it to an int
@@ -992,11 +992,16 @@ pprHexVal w rep
   | otherwise = ptext SLIT("0x") <> go w <> repsuffix rep
   where
   	-- type suffix for literals:
-	-- on 32-bit platforms, add "LL" to 64-bit literals
-      repsuffix I64 | wORD_SIZE == 4 = ptext SLIT("LL")
+	-- Integer literals are unsigned in Cmm/C.  We explicitly cast to
+	-- signed values for doing signed operations, but at all other
+	-- times values are unsigned.  This also helps eliminate occasional
+	-- warnings about integer overflow from gcc.
+
+	-- on 32-bit platforms, add "ULL" to 64-bit literals
+      repsuffix I64 | wORD_SIZE == 4 = ptext SLIT("ULL")
       	-- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
-      repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("L")
-      repsuffix _ = empty
+      repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("UL")
+      repsuffix _ = char 'U'
       
       go 0 = empty
       go w' = go q <> dig