[commit: ghc] master: Fix a bug in SRT generation (#15892) (eb46345)

git at git.haskell.org git at git.haskell.org
Thu Nov 15 03:35:48 UTC 2018


Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/eb46345d37ee61575e6fed04da718c1b7ee0bb99/ghc

>---------------------------------------------------------------

commit eb46345d37ee61575e6fed04da718c1b7ee0bb99
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


>---------------------------------------------------------------

eb46345d37ee61575e6fed04da718c1b7ee0bb99
 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