blob: 8fce496ab3ba4f0434bd718803b9b64bd09cd998 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
-- 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)
where
mid = min + ((max - min) `quot` 2)
left = parListTreeLike min mid fn
rght = parListTreeLike (mid+1) max fn
threshold = 1
|
