Commit eb46345d authored by Simon Marlow's avatar Simon Marlow Committed by Ömer Sinan Ağacan

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
parent 89fa34ec
......@@ -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.
......
{-# 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 ()
......@@ -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'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment