testsuite: Bump a performance tests
[ghc.git] / testsuite / tests / perf / compiler / T5030.hs
1 {-# LANGUAGE TypeFamilies, GADTs, EmptyDataDecls, FlexibleContexts #-}
2 {-# LANGUAGE UndecidableInstances #-}
3
4 module SlowComp where
5
6 import Control.Monad
7
8 -------------------------------------------------------------------------------
9 -- Usual Peano integers.
10
11
12 class NatInt a where
13 natInt :: a -> Int
14
15 data D0 n = D0 {d0Arg :: n}
16 data D1 n = D1 {d1Arg :: n}
17
18 data C0
19 data C1
20
21 class DPosInt n where posInt :: n -> (Int,Int)
22 instance DPosInt () where posInt _ = (0,1)
23 instance DPosInt n => DPosInt (D0 n) where
24 posInt a = (dsum,w*2)
25 where
26 (dsum,w) = posInt $ d0Arg a
27 instance DPosInt n => DPosInt (D1 n) where
28 posInt a = (dsum+w,w*2)
29 where
30 (dsum,w) = posInt $ d1Arg a
31
32 instance NatInt () where natInt _ = 0
33 instance DPosInt n => NatInt (D0 n) where natInt a = fst $ posInt a
34 instance DPosInt n => NatInt (D1 n) where natInt a = fst $ posInt a
35
36 type family DRev a
37 type instance DRev a = DRev' a ()
38
39 type family DRev' x acc
40 type instance DRev' () acc = acc
41 type instance DRev' (D0 a) acc = DRev' a (D0 acc)
42 type instance DRev' (D1 a) acc = DRev' a (D1 acc)
43
44 type family DAddC c a b
45 type instance DAddC C0 (D0 a) (D0 b) = D0 (DAddC C0 a b)
46 type instance DAddC C0 (D1 a) (D0 b) = D1 (DAddC C0 a b)
47 type instance DAddC C0 (D0 a) (D1 b) = D1 (DAddC C0 a b)
48 type instance DAddC C0 (D1 a) (D1 b) = D0 (DAddC C1 a b)
49 type instance DAddC C1 (D0 a) (D0 b) = D1 (DAddC C0 a b)
50 type instance DAddC C1 (D1 a) (D0 b) = D0 (DAddC C1 a b)
51 type instance DAddC C1 (D0 a) (D1 b) = D0 (DAddC C1 a b)
52 type instance DAddC C1 (D1 a) (D1 b) = D1 (DAddC C1 a b)
53 type instance DAddC C0 () () = ()
54 type instance DAddC C1 () () = D1 ()
55 type instance DAddC c (D0 a) () = DAddC c (D0 a) (D0 ())
56 type instance DAddC c (D1 a) () = DAddC c (D1 a) (D0 ())
57 type instance DAddC c () (D0 b) = DAddC c (D0 b) (D0 ())
58 type instance DAddC c () (D1 b) = DAddC c (D1 b) (D0 ())
59
60 type family DNorm a
61 type instance DNorm () = D0 ()
62 type instance DNorm (D0 ()) = D0 ()
63 type instance DNorm (D0 (D1 a)) = D1 a
64 type instance DNorm (D0 (D0 a)) = DNorm a
65 type instance DNorm (D1 a) = D1 a
66
67 type family DPlus a b
68 type instance DPlus a b = DNorm (DRev (DAddC C0 (DRev a) (DRev b)))
69
70 type family DDepth a
71 type instance DDepth () = D0 ()
72 type instance DDepth (D0 ()) = D0 ()
73 type instance DDepth (D1 ()) = D1 ()
74 type instance DDepth (D1 (D0 n)) = DPlus ONE (DDepth (D1 n))
75 type instance DDepth (D1 (D1 n)) = DPlus ONE (DDepth (D1 n))
76
77 type family DLog2 a
78 type instance DLog2 a = DDepth a
79
80 type ZERO = D0 ()
81
82 type ONE = D1 ()
83 type TWO = DPlus ONE ONE
84 type THREE = DPlus ONE TWO
85 type FOUR = DPlus TWO TWO
86 type FIVE = DPlus ONE FOUR
87 type SIX = DPlus TWO FOUR
88 type SEVEN = DPlus ONE SIX
89 type EIGHT = DPlus FOUR FOUR
90 type NINE = DPlus FOUR FIVE
91 type TEN = DPlus EIGHT TWO
92 type SIZE8 = EIGHT
93 type SIZE9 = NINE
94 type SIZE10 = TEN
95 type SIZE12 = DPlus SIX SIX
96 type SIZE15 = DPlus EIGHT SEVEN
97 type SIZE16 = DPlus EIGHT EIGHT
98 type SIZE17 = DPlus ONE SIZE16
99 type SIZE24 = DPlus SIZE8 SIZE16
100 type SIZE32 = DPlus SIZE8 SIZE24
101 type SIZE30 = DPlus SIZE24 SIX
102
103 -------------------------------------------------------------------------------
104 -- Description of CPU.
105
106 class CPU cpu where
107 -- register address.
108 type RegAddrSize cpu
109 -- register width
110 type RegDataSize cpu
111 -- immediate width.
112 type ImmSize cpu
113 -- variables in CPU - register indices, command format variables, etc.
114 type CPUVars cpu :: * -> *
115
116 data Const size = Const Integer
117
118 data Var cpu size where
119 Temp :: Int -> Var cpu size
120 Var :: CPUVars cpu size -> Var cpu size
121
122 -------------------------------------------------------------------------------
123 -- Command description monad.
124
125 data Command cpu where
126 Command :: (Var cpu size) -> (Operation cpu size) -> Command cpu
127
128 type RegVar cpu = Var cpu (RegDataSize cpu)
129 type Immediate cpu = Const (ImmSize cpu)
130
131 data Operation cpu resultSize where
132 Add :: RegVar cpu -> Either (Immediate cpu) (RegVar cpu) -> Operation cpu (RegDataSize cpu)
133 Sub :: RegVar cpu -> Either (Immediate cpu) (RegVar cpu) -> Operation cpu (RegDataSize cpu)
134
135 type CDM cpu a = IO a
136
137 ($=) :: Var cpu size -> Operation cpu size -> CDM cpu ()
138 var $= op = undefined
139
140 tempVar :: CDM cpu (Var cpu size)
141 tempVar = do
142 cnt <- liftM fst undefined
143 return $ Temp cnt
144
145 op :: Operation cpu size -> CDM cpu (Var cpu size)
146 op operation = do
147 v <- tempVar
148 v $= operation
149 return v
150
151 -------------------------------------------------------------------------------
152 -- Dummy CPU.
153
154 data DummyCPU = DummyCPU
155
156 data DummyVar size where
157 DummyFlag :: Flag -> DummyVar ONE
158 DummyReg :: Int -> DummyVar SIZE16
159 DummyZero :: DummyVar SIZE16
160
161 data Flag = C | Z | N | V
162
163 instance CPU DummyCPU where
164 type RegAddrSize DummyCPU = FIVE
165 type RegDataSize DummyCPU = SIZE16
166 type ImmSize DummyCPU = SIZE12
167 type CPUVars DummyCPU = DummyVar
168
169 -------------------------------------------------------------------------------
170 -- Long compiling program.
171
172 {- cnst has very simple code, and should be fast to typecheck
173 But if you insist on normalising (Immediate DummyCPU) you get
174
175 Immediate DummyCPU = Const (ImmSize DummyCPU)
176 -> Const SIZE12
177 = Const (DPlus SIX SIX)
178 ...etc...
179
180 similarly for (RegVar DummyCPU).
181
182 So you get a lot of work and big coercions, for no gain.
183 -}
184
185 cnst :: Integer -> Either (Immediate DummyCPU) (RegVar DummyCPU)
186 cnst x = Left (Const x)
187
188 longCompilingProgram :: CDM DummyCPU ()
189 longCompilingProgram = do
190 -- the number of lines below greatly affects compilation time.
191 x10 <- op $ Add (Var DummyZero) (cnst 10)
192 x10 <- op $ Add (Var DummyZero) (cnst 10)
193 x10 <- op $ Add (Var DummyZero) (cnst 10)
194 x10 <- op $ Add (Var DummyZero) (cnst 10)
195 x10 <- op $ Add (Var DummyZero) (cnst 10)
196 x10 <- op $ Add (Var DummyZero) (cnst 10)
197 x10 <- op $ Add (Var DummyZero) (cnst 10)
198 x10 <- op $ Add (Var DummyZero) (cnst 10)
199 x10 <- op $ Add (Var DummyZero) (cnst 10)
200 x10 <- op $ Add (Var DummyZero) (cnst 10)
201 x10 <- op $ Add (Var DummyZero) (cnst 10)
202 x10 <- op $ Add (Var DummyZero) (cnst 10)
203 x10 <- op $ Add (Var DummyZero) (cnst 10)
204 x10 <- op $ Add (Var DummyZero) (cnst 10)
205 x10 <- op $ Add (Var DummyZero) (cnst 10)
206 x10 <- op $ Add (Var DummyZero) (cnst 10)
207 return ()