diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index b65d56bae2a9ee854c71d5fbf13825f3d054c24d..984e704e3a43725f71655141736a6784eddbeabc 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 1c3630842e0f465774696763d165281c79f8d78e..3583a062af342a0fcb22b8e6781e68965895edda 100644 --- a/testsuite/.gitignore +++ b/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 diff --git a/testsuite/tests/codeGen/should_run/T10414.hs b/testsuite/tests/codeGen/should_run/T10414.hs new file mode 100644 index 0000000000000000000000000000000000000000..197206a6ab87868bcd99135ccfb586de058e5f39 --- /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 0000000000000000000000000000000000000000..8e22b0cb67a83a7b4c5bae3523585d0f852ba1a0 --- /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 db2d04ed952811a523c3912131f792180fe5137e..bae6d10fde009d9f502169d41d3852aeefd2c6f6 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/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, [''])