Don't eagerly blackhole single-entry thunks (#10414)

In a parallel program they can actually be entered more than once,
leading to deadlock.

Reviewers: austin, simonmar

Subscribers: michaelt, thomie, bgamari

Differential Revision: https://phabricator.haskell.org/D1040

GHC Trac Issues: #10414

compiler/codeGen/StgCmmClosure.hs

@@ -754,6 +754,16 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
 -- was on. But it didn't work, and it wasn't strictly necessary
 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
 -- is unconditionally disabled. -- krc 1/2007
+--
+--
+-- A single-entry (non-updatable) thunk can actually be entered
+-- more than once in a parallel program, if work is duplicated
+-- by two threads both entering the same updatable thunk before
+-- the other has blackholed it. So, we must not eagerly
+-- blackhole non-updatable thunks, or the second thread to
+-- enter one will become blocked indefinitely. (They are not
+-- blackholed by lazy blackholing either, since they have no
+-- associated update frame.) See Trac #10414.
 
 -- Static closures are never themselves black-holed.
 
@@ -766,7 +776,7 @@ blackHoleOnEntry cl_info
   = case closureLFInfo cl_info of
         LFReEntrant _ _ _ _          -> False
         LFLetNoEscape                   -> False
-        LFThunk _ _no_fvs _updatable _ _ -> True
+        LFThunk _ _no_fvs updatable _ _ -> updatable
         _other -> panic "blackHoleOnEntry"      -- Should never happen
 
 isStaticClosure :: ClosureInfo -> Bool

testsuite/.gitignore

@@ -164,6 +164,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/codeGen/should_run/SizeOfSmallArray
 /tests/codeGen/should_run/StaticArraySize
 /tests/codeGen/should_run/StaticByteArraySize
+/tests/codeGen/should_run/T10414
 /tests/codeGen/should_run/T10521
 /tests/codeGen/should_run/T10521b
 /tests/codeGen/should_run/T1852

testsuite/tests/codeGen/should_run/T10414.hs

+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+import GHC.Exts
+newtype Eval a = Eval {runEval :: State# RealWorld -> (# State# RealWorld, a #)}
+
+-- inline sequence ::  [Eval a] -> Eval [a]
+well_sequenced ::  [Eval a] -> Eval [a]
+well_sequenced = foldr cons nil where
+  cons e es = Eval $ \s -> case runEval e s of
+                       (# s', a #) -> case runEval es s' of
+                         (# s'', as #) -> (# s'', a : as #)
+  nil = Eval $ \s -> (# s, [] #)
+
+-- seemingly demonic use of spark#
+ill_sequenced ::  [Eval a] -> Eval [a]
+ill_sequenced  as = Eval $ spark# (case well_sequenced as of
+             Eval f -> case f realWorld# of  (# _, a' #) -> a')
+
+-- 'parallelized' version of (show >=> show >=> show >=> show >=> show)
+main :: IO ()
+main = putStrLn ((layer . layer . layer . layer . layer) (:[]) 'y')
+  where
+  layer :: (Char -> String) -> (Char -> String)
+  layer f = (\(Eval x) -> case x realWorld# of (# _, as #) -> concat as)
+        . well_sequenced    -- [Eval String] -> Eval [String]
+        . map ill_sequenced -- [[Eval Char]] -> [Eval String];
+                            -- 'map well_sequenced' is fine
+        . map (map (\x -> Eval $ \s -> (# s, x #))) -- wrap each Char in Eval
+        . chunk'            -- String -> [String]
+        . concatMap f
+        . show              -- add single quotes
+
+  chunk' ::  String -> [String]
+  chunk' [] = []
+  chunk' xs =  as : chunk' bs where (as,bs) = splitAt 3 xs
+
+  -- this doesn't work:
+  -- chunk (a:b:c:xs) = [a,b,c]:chunk xs
+  -- chunk xs = [xs]

testsuite/tests/codeGen/should_run/T10414.stdout

+'\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''y''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\''

testsuite/tests/codeGen/should_run/all.T

@@ -133,5 +133,7 @@ test('cgrun074', normal, compile_and_run, [''])
 test('CmmSwitchTest', when(fast(), skip), compile_and_run, [''])
 test('T10245', expect_broken(10246), compile_and_run, [''])
 test('T10246', expect_broken(10246), compile_and_run, [''])
+test('T10414', [only_ways(['threaded2']), extra_ways(['threaded2'])],
+     compile_and_run, ['-feager-blackholing'])
 test('T10521', normal, compile_and_run, [''])
 test('T10521b', normal, compile_and_run, [''])