From caacd1d60dbea9e7c129c6036071d6fe7c0e2fbb Mon Sep 17 00:00:00 2001
From: Reid Barton <rwbarton@gmail.com>
Date: Mon, 6 Jul 2015 19:24:31 +0200
Subject: [PATCH] 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
Conflicts:
testsuite/tests/codeGen/should_run/all.T
---
compiler/codeGen/StgCmmClosure.hs | 12 +++++-
testsuite/.gitignore | 1 +
testsuite/tests/codeGen/should_run/T10414.hs | 38 +++++++++++++++++++
.../tests/codeGen/should_run/T10414.stdout | 1 +
testsuite/tests/codeGen/should_run/all.T | 2 +
5 files changed, 53 insertions(+), 1 deletion(-)
create mode 100644 testsuite/tests/codeGen/should_run/T10414.hs
create mode 100644 testsuite/tests/codeGen/should_run/T10414.stdout
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index b65d56bae2a9..984e704e3a43 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/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
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index b1ed88791cd6..75105270a87c 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -165,6 +165,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
diff --git a/testsuite/tests/codeGen/should_run/T10414.hs b/testsuite/tests/codeGen/should_run/T10414.hs
new file mode 100644
index 000000000000..197206a6ab87
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T10414.hs
@@ -0,0 +1,38 @@
+{-# 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]
diff --git a/testsuite/tests/codeGen/should_run/T10414.stdout b/testsuite/tests/codeGen/should_run/T10414.stdout
new file mode 100644
index 000000000000..8e22b0cb67a8
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T10414.stdout
@@ -0,0 +1 @@
+'\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''y''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\'''\'''\'''\\''\\''\'''\'''\\''\'''\'''\'''\\''\'''\''
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index b2970a2eba74..9a04bcf68054 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -129,5 +129,7 @@ test('T9013', omit_ways(['ghci']), # ghci doesn't support unboxed tuples
compile_and_run, [''])
test('T9340', normal, compile_and_run, [''])
test('cgrun074', normal, 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, [''])
--
GitLab