[Git][ghc/ghc][master] rts/CNF: Fix fixup comparison function

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
cf4f1e2f by Ben Gamari at 2020-05-13T02:02:33-04:00
rts/CNF: Fix fixup comparison function

Previously we would implicitly convert the difference between two words
to an int, resulting in an integer overflow on 64-bit machines.

Fixes #16992

- - - - -


4 changed files:

- + libraries/ghc-compact/tests/T16992.hs
- + libraries/ghc-compact/tests/T16992.stdout
- libraries/ghc-compact/tests/all.T
- rts/sm/CNF.c


Changes:

=====================================
libraries/ghc-compact/tests/T16992.hs
=====================================
@@ -0,0 +1,22 @@
+import Data.Bifunctor
+import Foreign.Ptr
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Unsafe as BS
+import qualified GHC.Compact as Compact
+import qualified GHC.Compact.Serialized as CompactSerialize
+
+-- | Minimal test case for reproducing compactFixupPointers# bug for large compact regions.
+-- See Issue #16992.
+main :: IO ()
+main = do
+  let
+    large = 1024 * 1024 * 128
+    largeString = replicate large 'A'
+
+  region <- Compact.compact largeString
+
+  Just deserialized <- CompactSerialize.withSerializedCompact region $ \s -> do
+    blks <- mapM (BS.unsafePackCStringLen . bimap castPtr fromIntegral) (CompactSerialize.serializedCompactBlockList s)
+    CompactSerialize.importCompactByteStrings s blks
+
+  print (Compact.getCompact deserialized == largeString)


=====================================
libraries/ghc-compact/tests/T16992.stdout
=====================================
@@ -0,0 +1 @@
+True


=====================================
libraries/ghc-compact/tests/all.T
=====================================
@@ -22,3 +22,8 @@ test('compact_share', omit_ways(['ghci', 'profasm', 'profthreaded']),
 test('compact_bench', [ ignore_stdout, extra_run_opts('100') ],
                        compile_and_run, [''])
 test('T17044', normal, compile_and_run, [''])
+# N.B. Sanity check times out due to large list.
+test('T16992', [when(wordsize(32), skip), # Resource limit exceeded on 32-bit
+                high_memory_usage,
+                run_timeout_multiplier(5),
+                omit_ways(['sanity'])], compile_and_run, [''])


=====================================
rts/sm/CNF.c
=====================================
@@ -1020,8 +1020,9 @@ cmp_fixup_table_item (const void *e1, const void *e2)
 {
     const StgWord *w1 = e1;
     const StgWord *w2 = e2;
-
-    return *w1 - *w2;
+    if (*w1 > *w2) return +1;
+    else if (*w1 < *w2) return -1;
+    else return 0;
 }
 
 static StgWord *



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf4f1e2f78840d25b132de55bce1e02256334ace

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf4f1e2f78840d25b132de55bce1e02256334ace
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200513/f98d070d/attachment-0001.html>