Commit cd307058 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Test for strictness loss in FloatOut

A bug in 6.12 meant loss of strictness on a floated binding.
The HEAD is ok, but this test checks for regressions.
parent df5a4866
-- There was a bug in 6.12 that meant that the binding
-- for 'rght' was initially determined (correctly) to be
-- strictly demanded, but the FloatOut pass made it lazy
-- The test compiles the program and greps for the
-- binding of 'rght' to check that it is marked strict
-- somethign like this:
-- rght [Dmd=Just S] :: EvalTest.AList a
module EvalTest where
import GHC.Conc
data Eval a = Done a
instance Monad Eval where
return x = Done x
Done x >>= k = k x -- Note: pattern 'Done x' makes '>>=' strict
rpar :: a -> Eval a
rpar x = x `par` return x
rseq :: a -> Eval a
rseq x = x `pseq` return x
runEval :: Eval a -> a
runEval (Done x) = x
data AList a = ANil | ASing a | Append (AList a) (AList a) | AList [a]
append ANil r = r
append l ANil = l -- **
append l r = Append l r
parListTreeLike :: Integer -> Integer -> (Integer -> a) -> AList a
parListTreeLike min max fn
| max - min <= threshold = ASing (fn max)
| otherwise =
runEval $ do
rpar rght
rseq left
return (left `append` rght)
mid = min + ((max - min) `quot` 2)
left = parListTreeLike min mid fn
rght = parListTreeLike (mid+1) max fn
threshold = 1
......@@ -34,3 +34,5 @@ T4918:
'$(TEST_HC)' -c -O T4918.hs
'$(TEST_HC)' --show-iface T4918.hi | grep 'C#'
'$(TEST_HC)' -c -O EvalTest.hs -ddump-simpl -dsuppress-uniques | grep 'rght.*Dmd'
......@@ -87,6 +87,11 @@ test('T3772',
extra_clean(['T3772_A.hi', 'T3772_A.o']),
run_command, ['$MAKE -s --no-print-directory T3772'])
['$MAKE -s --no-print-directory EvalTest'])
test('T3831', normal, compile, [''])
test('T4345', normal, compile, [''])
test('T4398', normal, compile, [''])
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