commit a6ea05e21e175407dc9e45f18c56c1d727fd0f26
Author: Sergei Trofimovich <slyfox@gentoo.org>
Date:   Fri Aug 22 23:24:32 2014 +0300

    UNREG: fix emission of large Integer literals in C codegen
    
    Summary:
    On amd64/UNREG build there is many failing tests trying
    to deal with 'Integer' types.
    
    Looking at 'overflow1' test I've observed invalid C code generated by
    GHC.
    
    Cmm code
        CInt a = -1; (a == -1)
    yields 'False' with optimisations enabled via the following C code:
        StgWord64 a = (StgWord32)0xFFFFffffFFFFffffu; (a == 0xFFFFffffFFFFffffu)
    
    The patch fixes it by shrinking emitted literals to required sizes:
        StgWord64 a = (StgWord32)0xFFFFffffu; (a == 0xFFFFffffu)
    
    Thanks to Reid Barton for tracking down and fixing the issue.
    
    Signed-off-by: Sergei Trofimovich <slyfox@gentoo.org>
    
    Test Plan: validate on UNREG build (amd64)
    
    Reviewers: simonmar, rwbarton, austin
    
    Subscribers: simonmar, ezyang, carter
    
    Differential Revision: https://phabricator.haskell.org/D173

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 93a5d06..8605988 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -1221,8 +1221,9 @@ commafy xs = hsep $ punctuate comma xs
 pprHexVal :: Integer -> Width -> SDoc
 pprHexVal 0 _ = ptext (sLit "0x0")
 pprHexVal w rep
-  | w < 0     = parens (char '-' <> ptext (sLit "0x") <> go (-w) <> repsuffix rep)
-  | otherwise = ptext (sLit "0x") <> go w <> repsuffix rep
+  | w < 0     = parens (char '-' <>
+                    ptext (sLit "0x") <> intToDoc (-w) <> repsuffix rep)
+  | otherwise =     ptext (sLit "0x") <> intToDoc   w  <> repsuffix rep
   where
         -- type suffix for literals:
         -- Integer literals are unsigned in Cmm/C.  We explicitly cast to
@@ -1237,10 +1238,33 @@ pprHexVal w rep
           else panic "pprHexVal: Can't find a 64-bit type"
       repsuffix _ = char 'U'
 
+      intToDoc :: Integer -> SDoc
+      intToDoc i = go (truncInt i)
+
+      -- We need to truncate value as Cmm backend does not drop
+      -- redundant bits to ease handling of negative values.
+      -- Thus the following Cmm code on 64-bit arch, like amd64:
+      --     CInt v;
+      --     v = {something};
+      --     if (v == %lobits32(-1)) { ...
+      -- leads to the following C code:
+      --     StgWord64 v = (StgWord32)({something});
+      --     if (v == 0xFFFFffffFFFFffffU) { ...
+      -- Such code is incorrect as it promotes both operands to StgWord64
+      -- and the whole condition is always false.
+      truncInt :: Integer -> Integer
+      truncInt i =
+          case rep of
+              W8  -> i `rem` (2^(8 :: Int))
+              W16 -> i `rem` (2^(16 :: Int))
+              W32 -> i `rem` (2^(32 :: Int))
+              W64 -> i `rem` (2^(64 :: Int))
+              _   -> panic ("pprHexVal/truncInt: C backend can't encode "
+                            ++ show rep ++ " literals")
+
       go 0 = empty
       go w' = go q <> dig
            where
              (q,r) = w' `quotRem` 16
              dig | r < 10    = char (chr (fromInteger r + ord '0'))
                  | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
-