Ticket #5030: SlowComp.hs

File SlowComp.hs, 6.0 KB (added by thesz, 4 years ago)

The program I created to reproduce the behavior

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