[commit: ghc] ghc-8.6: Fix a bug in SRT generation (#15892) (4519d98)
git at git.haskell.org
git at git.haskell.org
Thu Nov 22 21:55:21 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.6
Link : http://ghc.haskell.org/trac/ghc/changeset/4519d98d5399c2a958b2592b0ab50d89980d48b5/ghc
>---------------------------------------------------------------
commit 4519d98d5399c2a958b2592b0ab50d89980d48b5
Author: Simon Marlow <marlowsd at gmail.com>
Date: Thu Nov 15 06:31:35 2018 +0300
Fix a bug in SRT generation (#15892)
Summary:
The logic in `Note [recursive SRTs]` was correct. However, my
implementation of it wasn't: I got the associativity of
`Set.difference` wrong, which led to an extremely subtle and difficult
to find bug.
Fortunately now we have a test case. I was able to cut down the code
to something manageable, and I've added it to the test suite.
Test Plan:
Before (using my stage 1 compiler without the fix):
```
====> T15892(normal) 1 of 1 [0, 0, 0]
cd "T15892.run" && "/home/smarlow/ghc/inplace/bin/ghc-stage1" -o T15892
T15892.hs -dcore-lint -dcmm-lint -no-user-package-db -rtsopts
-fno-warn-missed-specialisations -fshow-warning-groups
-fdiagnostics-color=never -fno-diagnostics-show-caret -Werror=compat
-dno-debug-output -O
cd "T15892.run" && ./T15892 +RTS -G1 -A32k -RTS
Wrong exit code for T15892(normal)(expected 0 , actual 134 )
Stderr ( T15892 ):
T15892: internal error: evacuate: strange closure type 0
(GHC version 8.7.20181113 for x86_64_unknown_linux)
Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug
Aborted (core dumped)
*** unexpected failure for T15892(normal)
=====> T15892(g1) 1 of 1 [0, 1, 0]
cd "T15892.run" && "/home/smarlow/ghc/inplace/bin/ghc-stage1" -o T15892
T15892.hs -dcore-lint -dcmm-lint -no-user-package-db -rtsopts
-fno-warn-missed-specialisations -fshow-warning-groups
-fdiagnostics-color=never -fno-diagnostics-show-caret -Werror=compat
-dno-debug-output -O
cd "T15892.run" && ./T15892 +RTS -G1 -RTS +RTS -G1 -A32k -RTS
Wrong exit code for T15892(g1)(expected 0 , actual 134 )
Stderr ( T15892 ):
T15892: internal error: evacuate: strange closure type 0
(GHC version 8.7.20181113 for x86_64_unknown_linux)
Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug
Aborted (core dumped)
```
After (using my stage 2 compiler with the fix):
```
=====> T15892(normal) 1 of 1 [0, 0, 0]
cd "T15892.run" && "/home/smarlow/ghc/inplace/test spaces/ghc-stage2"
-o T15892 T15892.hs -dcore-lint -dcmm-lint -no-user-package-db -rtsopts
-fno-warn-missed-specialisations -fshow-warning-groups
-fdiagnostics-color=never -fno-diagnostics-show-caret -Werror=compat
-dno-debug-output
cd "T15892.run" && ./T15892 +RTS -G1 -A32k -RTS
=====> T15892(g1) 1 of 1 [0, 0, 0]
cd "T15892.run" && "/home/smarlow/ghc/inplace/test spaces/ghc-stage2"
-o T15892 T15892.hs -dcore-lint -dcmm-lint -no-user-package-db -rtsopts
-fno-warn-missed-specialisations -fshow-warning-groups
-fdiagnostics-color=never -fno-diagnostics-show-caret -Werror=compat
-dno-debug-output
cd "T15892.run" && ./T15892 +RTS -G1 -RTS +RTS -G1 -A32k -RTS
```
Reviewers: bgamari, osa1, erikd
Reviewed By: osa1
Subscribers: rwbarton, carter
GHC Trac Issues: #15892
Differential Revision: https://phabricator.haskell.org/D5334
>---------------------------------------------------------------
4519d98d5399c2a958b2592b0ab50d89980d48b5
compiler/cmm/CmmBuildInfoTables.hs | 2 +-
testsuite/tests/codeGen/should_run/T15892.hs | 67 ++++++++++++++++++++++++++++
testsuite/tests/codeGen/should_run/all.T | 7 +++
3 files changed, 75 insertions(+), 1 deletion(-)
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index a8f89a1..be96fba 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -703,7 +703,7 @@ oneSRT dflags staticFuns blockids lbls isCAF cafs = do
-- Remove recursive references from the SRT, except for (all but
-- one of the) static functions. See Note [recursive SRTs].
nonRec = cafs `Set.difference`
- Set.fromList lbls `Set.difference` Set.fromList otherFunLabels
+ (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels)
-- First resolve all the CAFLabels to SRTEntries
-- Implements the [Inline] optimisation.
diff --git a/testsuite/tests/codeGen/should_run/T15892.hs b/testsuite/tests/codeGen/should_run/T15892.hs
new file mode 100644
index 0000000..d132943
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T15892.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module Main (enumFromCallbackCatch, consume, next, main) where
+
+import Control.Monad
+import Foreign
+import GHC.ForeignPtr
+import GHC.Base (realWorld#)
+import Data.Word (Word8)
+import Foreign.Storable (peek)
+import GHC.IO
+
+data ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8) {-# UNPACK #-} !Int
+
+instance Show ByteString where
+ showsPrec p ps r = showsPrec p (unpackAppendCharsStrict ps []) r
+
+unpackAppendCharsStrict :: ByteString -> [Char] -> [Char]
+unpackAppendCharsStrict (PS fp len) xs =
+ unsafeDupablePerformIO $ withForeignPtr fp $ \base ->
+ loop (base `plusPtr` (-1)) (base `plusPtr` 960) xs
+ where
+ loop !sentinal !p acc
+ | p == sentinal = return acc
+ | otherwise = do x <- peek p
+ loop sentinal (p `plusPtr` (-1)) (w2c x:acc)
+
+w2c :: Word8 -> Char
+w2c = toEnum . fromEnum
+
+packCStringLen :: Int -> IO ByteString
+packCStringLen l = do
+ p <- callocBytes bufsize
+ fp <- newForeignPtr finalizerFree p
+ return $! PS fp l
+{-# NOINLINE packCStringLen #-}
+
+bufsize :: Int
+bufsize = 8192
+
+{-# NOINLINE readFromPtr #-}
+readFromPtr :: IO ByteString
+readFromPtr = do
+ bs <- packCStringLen bufsize
+ length (show bs) `seq` return bs
+
+newtype Iteratee s = Iteratee { runIter :: forall r.
+ ((s -> Iteratee s) -> IO r) ->
+ IO r}
+
+enumFromCallbackCatch :: IO ()
+enumFromCallbackCatch = produce 500 consume
+ where
+ produce 0 (Iteratee f) = return ()
+ produce n (Iteratee f) = f onCont
+ where onCont k = do bs <- readFromPtr; produce (n-1) (k bs)
+
+consume = Iteratee $ \onCont -> onCont next
+next x = Iteratee $ \onCont -> print x >> onCont (\_ -> consume)
+
+main :: IO ()
+main = do
+ _ <- enumFromCallbackCatch
+ pure ()
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 3935574..1dec2a6 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -181,3 +181,10 @@ test('T15696_1', normal, compile_and_run, ['-O'])
test('T15696_2', normal, compile_and_run, ['-O'])
# This requires -O
test('T15696_3', normal, compile_and_run, ['-O'])
+
+test('T15892',
+ [ ignore_stdout,
+ # we want to do lots of major GC to make the bug more likely to
+ # happen, so -G1 -A32k:
+ extra_run_opts('+RTS -G1 -A32k -RTS') ],
+ compile_and_run, ['-O'])
More information about the ghc-commits
mailing list