blob: 632696d6fde7cfbd814a3ee2f44ad9f3da73484d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
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'))
-
|