primitives.sml 8.76 KB
Newer Older
mb0's avatar
mb0 committed
1

Axel Simon's avatar
Axel Simon committed
2
structure Primitives = struct
mb0's avatar
STYLE!    
mb0 committed
3
   structure ST = SymbolTables
Axel Simon's avatar
Axel Simon committed
4
   structure SC = SizeConstraint
5
   open Types
Axel Simon's avatar
Axel Simon committed
6
   
7
   (* result type of the decoder function *)
8
   val size = freshVar ()
Axel Simon's avatar
Axel Simon committed
9
   val stateA = freshVar ()
10
   val stateA' = newFlow stateA
Axel Simon's avatar
Axel Simon committed
11
   val stateB = freshVar ()
12
   val stateB' = newFlow stateB
Axel Simon's avatar
Axel Simon committed
13
   val stateC = freshVar ()
14
   val stateC' = newFlow stateC
Axel Simon's avatar
Axel Simon committed
15
   val stateD = freshVar ()
16
   val stateD' = newFlow stateD
Axel Simon's avatar
Axel Simon committed
17
   val stateE = freshVar ()
Axel Simon's avatar
Axel Simon committed
18
19
20
   val stateE' = freshVar ()
   val stateE'' = newFlow stateE'
   val stateE''' = freshVar ()
21
   val stateE'''' = newFlow stateE
Axel Simon's avatar
Axel Simon committed
22
   val stateE''''' = newFlow stateE'''
Axel Simon's avatar
Axel Simon committed
23
   val stateF = freshVar ()
Axel Simon's avatar
Axel Simon committed
24
25
26
   val stateF' = freshVar ()
   val stateF'' = newFlow stateF'
   val stateF''' = freshVar ()
27
   val stateF'''' = newFlow stateF
Axel Simon's avatar
Axel Simon committed
28
   val stateF''''' = newFlow stateF'''
Axel Simon's avatar
Axel Simon committed
29
30
31
   val stateG = freshVar ()
   val stateG' = newFlow stateG
   val stateH = freshVar ()
Axel Simon's avatar
Axel Simon committed
32
   val stateH' = freshVar ()
33
   val stateH'' = newFlow stateH
Axel Simon's avatar
Axel Simon committed
34
   val stateH''' = newFlow stateH'
35
36
37
   val stateI = freshVar ()
   val stateI' = newFlow stateI
   val stateI'' = newFlow stateI
Axel Simon's avatar
merge    
Axel Simon committed
38
39
40
41
42
43
   val stateJ = freshVar ()
   val stateJ' = newFlow stateJ
   val stateK = freshVar ()
   val stateK' = newFlow stateK
   val stateL = freshVar ()
   val stateL' = newFlow stateL
44
45
46
47
48
49
50
51
52
53
54
55
   val a = freshVar ()
   val a' = newFlow a
   val b = freshVar ()
   val b' = newFlow b
   val c = freshVar ()
   val d = freshVar ()
   val d' = newFlow d
   val e = freshVar ()
   val e' = newFlow e
   val f = freshVar ()
   val g = freshVar ()
   val g' = newFlow g
Axel Simon's avatar
Axel Simon committed
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
   val s1 = freshVar ()
   val s2 = freshVar ()
   val s3 = freshVar ()
   val s4 = freshVar ()
   val s5 = freshVar ()
   val s6 = freshVar ()
   val s7 = freshVar ()
   val s8 = freshVar ()
   val s9 = freshVar ()
   val s10 = freshVar ()
   val s11 = freshVar ()
   val s12 = freshVar ()
   val s13 = freshVar ()
   val s14 = freshVar ()
   val s15 = freshVar ()
   val s16 = freshVar ()
   val s17 = freshVar ()
   val s18 = freshVar ()
   val s19 = freshVar ()
Axel Simon's avatar
Axel Simon committed
75

76
   (*create a type from two vectors to one vector, all of size s*)
77
78
79
80
   fun func (a,b) = FUN ([a],b)
   fun vvv s = FUN ([VEC s, VEC s], VEC s)
   fun vv  s = FUN ([VEC s], VEC s)
   fun vvb s = FUN ([VEC s, VEC s], VEC (CONST 1))
81

Axel Simon's avatar
Axel Simon committed
82
   val granularity : string = "stream granularity"
Axel Simon's avatar
Axel Simon committed
83
   val globalState : string = "global state"
84
   val caseExpression : string = "case expression"
85
86
   fun noFlow bFun = bFun

mb0's avatar
STYLE!    
mb0 committed
87
   val primitiveValues =
88
89
90
91
      [{name="true", ty=VEC (CONST 1),
        flow = noFlow},
       {name="false", ty=VEC (CONST 1),
        flow = noFlow},
Axel Simon's avatar
merge    
Axel Simon committed
92
       {name="consume", ty=MONAD (VEC size,stateA, stateA'),
93
        flow = BD.meetVarZero (bvar size) o
Axel Simon's avatar
Axel Simon committed
94
               BD.meetVarImpliesVar (bvar stateA', bvar stateA)},
Axel Simon's avatar
merge    
Axel Simon committed
95
       {name="unconsume", ty=MONAD (UNIT,stateB, stateB'),
Axel Simon's avatar
Axel Simon committed
96
        flow = BD.meetVarImpliesVar (bvar stateB', bvar stateB)}, 
Axel Simon's avatar
merge    
Axel Simon committed
97
       {name="slice", ty=MONAD (freshVar (),stateC, stateC'),
Axel Simon's avatar
Axel Simon committed
98
        flow = BD.meetVarImpliesVar (bvar stateC', bvar stateC)},
99
100
       {name="raise", ty=MONAD (freshVar (),stateD, stateD'),
        flow = noFlow},
mb0's avatar
mb0 committed
101
       {name="%raise", ty=UNIT, flow = noFlow},
mb0's avatar
mb0 committed
102
       {name="%and", ty=UNIT, flow = noFlow},
mb0's avatar
Foo.    
mb0 committed
103
104
105
106
       {name="%sx", ty=UNIT, flow = noFlow},
       {name="%zx", ty=UNIT, flow = noFlow},
       {name="%add", ty=UNIT, flow = noFlow},
       {name="%sub", ty=UNIT, flow = noFlow},
mb0's avatar
mb0 committed
107
108
       {name="%not", ty=UNIT, flow = noFlow},
       {name="%equal", ty=UNIT, flow = noFlow},
mb0's avatar
mb0 committed
109
       {name="%concat", ty=UNIT, flow = noFlow},
110
111
112
113
114
115
       {name=caseExpression, ty=UNIT,
        flow = noFlow},
       (*{name=globalState, ty=state,
        flow = noFlow},*)
       {name=granularity, ty=UNIT,
        flow = noFlow},
Axel Simon's avatar
Axel Simon committed
116
       (* 'a M -> ('a -> 'b M) -> 'b M *)
117
118
       {name=">>=", ty=func (MONAD (a, stateE, stateE'),
            func (func (a', MONAD (b,stateE'', stateE''')),
119
               MONAD (b', stateE'''', stateE'''''))),
Axel Simon's avatar
Axel Simon committed
120
121
122
123
124
        flow = BD.meetVarImpliesVar (bvar a', bvar a) o
               BD.meetVarImpliesVar (bvar b', bvar b) o
               BD.meetVarImpliesVar (bvar stateE, bvar stateE'''') o
               BD.meetVarImpliesVar (bvar stateE'', bvar stateE') o
               BD.meetVarImpliesVar (bvar stateE''''', bvar stateE''') },
Axel Simon's avatar
merge    
Axel Simon committed
125
       (* 'f M -> 'g M -> 'g M *)
126
127
       {name=">>", ty=func (MONAD (c, stateF, stateF'),
            func (MONAD (d,stateF'', stateF'''),
128
               MONAD (d', stateF'''', stateF'''''))),
Axel Simon's avatar
Axel Simon committed
129
130
131
132
        flow = BD.meetVarImpliesVar (bvar d', bvar d) o
               BD.meetVarImpliesVar (bvar stateF, bvar stateF'''') o
               BD.meetVarImpliesVar (bvar stateF'', bvar stateF') o
               BD.meetVarImpliesVar (bvar stateF''''', bvar stateF''') },
133
       {name="return", ty=func (e, MONAD (e',stateG,stateG')),
Axel Simon's avatar
Axel Simon committed
134
135
        flow = BD.meetVarImpliesVar (bvar e', bvar e) o
               BD.meetVarImpliesVar (bvar stateG', bvar stateG) },
136
       {name="update", ty=func (func (stateH, stateH'),
Axel Simon's avatar
Axel Simon committed
137
138
139
                               MONAD (UNIT,stateH'',stateH''')),
        flow = BD.meetVarImpliesVar (bvar stateH, bvar stateH'') o
               BD.meetVarImpliesVar (bvar stateH''', bvar stateH') },
140
       {name="query", ty=func (func (stateI', g), MONAD (g',stateI,stateI'')),
Axel Simon's avatar
Axel Simon committed
141
142
143
        flow = BD.meetVarImpliesVar (bvar g', bvar g) o
               BD.meetVarImpliesVar (bvar stateI', bvar stateI) o
               BD.meetVarImpliesVar (bvar stateI'', bvar stateI) },
mb0's avatar
Foo.    
mb0 committed
144
145
146
       {name="+", ty=FUN([ZENO,ZENO],ZENO),flow=noFlow},
       {name="-", ty=FUN([ZENO,ZENO],ZENO),flow=noFlow},
       {name="++", ty=vvv s1,
147
        flow = BD.meetVarZero (bvar s1)},
mb0's avatar
Foo.    
mb0 committed
148
       {name="--", ty=vvv s2,
149
        flow = BD.meetVarZero (bvar s2)},
mb0's avatar
Foo.    
mb0 committed
150
       {name="**", ty=vvv s3,
151
        flow = BD.meetVarZero (bvar s3)},
152
       {name="^", ty=FUN ([VEC s4, VEC s5], VEC s6),
153
154
155
        flow = BD.meetVarZero (bvar s4) o
               BD.meetVarZero (bvar s5) o
               BD.meetVarZero (bvar s6)},
156
       {name="bits8", ty=func (ZENO, VEC (CONST 8)),
157
158
159
160
161
162
163
164
165
166
167
        flow = noFlow},
       {name=Atom.toString Op.orElse, ty = vvv s7,
        flow = BD.meetVarZero (bvar s7)},
       {name=Atom.toString Op.andAlso, ty = vvv s8,
        flow = BD.meetVarZero (bvar s8)},
       {name="==", ty = vvb s9,
        flow = BD.meetVarZero (bvar s9)},
       {name="!=", ty = vvb s10,
        flow = BD.meetVarZero (bvar s10)},
       {name="not", ty = vv s11,
        flow = BD.meetVarZero (bvar s11)},
mb0's avatar
Foo.    
mb0 committed
168
       {name="sx", ty=func (VEC s12, ZENO),
169
        flow = BD.meetVarZero (bvar s12)},
mb0's avatar
Foo.    
mb0 committed
170
       {name="zx", ty=func (VEC s13, ZENO),
171
        flow = BD.meetVarZero (bvar s13)},
172
       {name="prefix", ty=func (VEC s14, VEC s15),
173
174
175
        flow = BD.meetVarZero (bvar s14) o
               BD.meetVarZero (bvar s15) o
               BD.meetVarZero (bvar s16)},
176
       {name="suffix", ty=func (VEC s17, VEC s18),
177
178
        flow = BD.meetVarZero (bvar s17) o
               BD.meetVarZero (bvar s18) o
Axel Simon's avatar
merge    
Axel Simon committed
179
180
181
182
183
184
185
186
               BD.meetVarZero (bvar s19)},
       {name="%consume", ty=MONAD (VEC size,stateJ, stateJ'),
        flow = BD.meetVarZero (bvar size) o
               BD.meetVarImpliesVar (bvar stateJ', bvar stateJ)},
       {name="%unconsume", ty=MONAD (UNIT,stateK, stateK'),
        flow = BD.meetVarImpliesVar (bvar stateK', bvar stateK)}, 
       {name="%slice", ty=MONAD (freshVar (),stateL, stateL'),
        flow = BD.meetVarImpliesVar (bvar stateL', bvar stateL)}
Axel Simon's avatar
Axel Simon committed
187
       ]
188

mb0's avatar
mb0 committed
189
   val primitiveSizeConstraints =
Axel Simon's avatar
Axel Simon committed
190
191
192
193
194
      [SC.equality (tvar s6, [tvar s4,tvar s5], 0),
       SC.equality (tvar s14, [tvar s15,tvar s16], 0),
       SC.equality (tvar s17, [tvar s18,tvar s19], 0)
      ]

195
   val primitiveDecoders =
Axel Simon's avatar
Axel Simon committed
196
197
198
199
      [{name=granularity, ty=size},
       {name="consume", ty=size},
       {name="prefix", ty=s16}, (* hack to get s16 expanded with s14,s15 *)
       {name="suffix", ty=s19}]
200

mb0's avatar
STYLE!    
mb0 committed
201
   val primitiveTypes =
202
203
      [{name="int", ty=ZENO, flow=noFlow},
       {name="string", ty=FLOAT, flow=noFlow}]
204

205
   fun addPrim table {name, ty, flow} = let
mb0's avatar
STYLE!    
mb0 committed
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
      val (newTable, _) =
         SymbolTable.create
            (!table,
             Atom.atom name,
             SymbolTable.noSpan)
   in
      table := newTable
   end

   fun registerPrimitives () =
      (ST.varTable := VarInfo.empty
      ;ST.conTable := ConInfo.empty
      ;ST.typeTable := TypeInfo.empty
      ;ST.fieldTable := FieldInfo.empty
      ;List.map (addPrim ST.varTable) primitiveValues
      ;List.map (addPrim ST.typeTable) primitiveTypes)
222
223
224
   
   fun getSymbolTypes () =
      let
mb0's avatar
mb0 committed
225
226
227
228
229
230
231
232
         fun find n nts =
            case nts of
               [] => NONE
             | {name, ty} :: nts =>
                  case String.compare (n, name) of
                     EQUAL => SOME ty
                   | _ => find n nts

233
         fun genInfo {name=n, ty=t, flow=f} =
mb0's avatar
mb0 committed
234
235
            (SymbolTable.lookup(!ST.varTable, Atom.atom n),
             t,
236
             f,
mb0's avatar
mb0 committed
237
             find n primitiveDecoders)
238
      in
239
         List.map genInfo primitiveValues
240
      end
mb0's avatar
STYLE!    
mb0 committed
241
end