Merge branch 'master' into atomics
[ghc.git] / testsuite / tests / simplCore / should_compile / EvalTest.hs
1 -- There was a bug in 6.12 that meant that the binding
2 -- for 'rght' was initially determined (correctly) to be
3 -- strictly demanded, but the FloatOut pass made it lazy
4 --
5 -- The test compiles the program and greps for the
6 -- binding of 'rght' to check that it is marked strict
7 -- somethign like this:
8 -- rght [Dmd=Just S] :: EvalTest.AList a
9
10 module EvalTest where
11
12 import GHC.Conc
13
14 data Eval a = Done a
15
16 instance Monad Eval where
17 return x = Done x
18 Done x >>= k = k x -- Note: pattern 'Done x' makes '>>=' strict
19
20 rpar :: a -> Eval a
21 rpar x = x `par` return x
22
23 rseq :: a -> Eval a
24 rseq x = x `pseq` return x
25
26 runEval :: Eval a -> a
27 runEval (Done x) = x
28
29 data AList a = ANil | ASing a | Append (AList a) (AList a) | AList [a]
30
31 append ANil r = r
32 append l ANil = l -- **
33 append l r = Append l r
34
35 parListTreeLike :: Integer -> Integer -> (Integer -> a) -> AList a
36 parListTreeLike min max fn
37 | max - min <= threshold = ASing (fn max)
38 | otherwise =
39 runEval $ do
40 rpar rght
41 rseq left
42 return (left `append` rght)
43 where
44 mid = min + ((max - min) `quot` 2)
45 left = parListTreeLike min mid fn
46 rght = parListTreeLike (mid+1) max fn
47
48 threshold = 1