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