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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
module Func = struct
module type T = sig
type int32
type int64
type float32
type float64
type v128
type 'a m
type memory
type _ telt = private
| I32 : int32 telt
| I64 : int64 telt
| F32 : float32 telt
| F64 : float64 telt
| V128 : v128 telt
| Externref : 'a Type.Id.t -> 'a telt
type (_, _) atype = private
| Mem : ('b, 'r) atype -> (memory -> 'b, 'r) atype
| UArg : ('b, 'r) atype -> (unit -> 'b, 'r) atype
| Arg : 'a telt * ('b, 'r) atype -> ('a -> 'b, 'r) atype
| NArg : string * 'a telt * ('b, 'r) atype -> ('a -> 'b, 'r) atype
| Res : ('r, 'r) atype
type _ rtype = private
| R0 : unit rtype
| R1 : 'a telt -> 'a rtype
| R2 : 'a telt * 'b telt -> ('a * 'b) rtype
| R3 : 'a telt * 'b telt * 'c telt -> ('a * 'b * 'c) rtype
| R4 : 'a telt * 'b telt * 'c telt * 'd telt -> ('a * 'b * 'c * 'd) rtype
type _ func_type = private
| Func : ('f, 'r m) atype * 'r rtype -> 'f func_type
type extern_func = Extern_func : 'a func_type * 'a -> extern_func
val extern_type : extern_func -> Binary.func_type
module Syntax : sig
type l
type lr
type elt
type mem
type (_, _, _) t
val i32 : (lr, elt, int32) t
val i64 : (lr, elt, int64) t
val f32 : (lr, elt, float32) t
val f64 : (lr, elt, float64) t
val v128 : (lr, elt, v128) t
val externref : 'a Type.Id.t -> (lr, elt, 'a) t
val unit : (lr, unit, unit) t
val memory : (l, mem, memory) t
val label : string -> (lr, elt, 'a) t -> (l, string * elt, 'a) t
val ( ^-> ) : ('r, 'k, 'a) t -> 'b func_type -> ('a -> 'b) func_type
val ( ^->. ) : ('r, 'k, 'a) t -> (lr, 'kk, 'b) t -> ('a -> 'b m) func_type
val ( ^->.. ) :
('ll, 'k, 'a) t
-> (lr, elt, 'b1) t * (lr, elt, 'b2) t
-> ('a -> ('b1 * 'b2) m) func_type
val ( ^->... ) :
('ll, 'k, 'a) t
-> (lr, elt, 'b1) t * (lr, elt, 'b2) t * (lr, elt, 'b3) t
-> ('a -> ('b1 * 'b2 * 'b3) m) func_type
val ( ^->.... ) :
('ll, 'k, 'a) t
-> (lr, elt, 'b1) t
* (lr, elt, 'b2) t
* (lr, elt, 'b3) t
* (lr, elt, 'b4) t
-> ('a -> ('b1 * 'b2 * 'b3 * 'b4) m) func_type
end
end
module Make (V : sig
type int32
type int64
type float32
type float64
type v128
end) (M : sig
(** The monad type *)
type 'a t
end) (Memory : sig
(** The memory type *)
type t
end) : sig
val fresh : unit -> int
include
T
with type int32 := V.int32
and type int64 := V.int64
and type float32 := V.float32
and type float64 := V.float64
and type v128 := V.v128
and type 'a m := 'a M.t
and type memory := Memory.t
end = struct
type 'a m = 'a M.t
type memory = Memory.t
type _ telt =
| I32 : V.int32 telt
| I64 : V.int64 telt
| F32 : V.float32 telt
| F64 : V.float64 telt
| V128 : V.v128 telt
| Externref : 'a Type.Id.t -> 'a telt
type _ rtype =
| R0 : unit rtype
| R1 : 'a telt -> 'a rtype
| R2 : 'a telt * 'b telt -> ('a * 'b) rtype
| R3 : 'a telt * 'b telt * 'c telt -> ('a * 'b * 'c) rtype
| R4 : 'a telt * 'b telt * 'c telt * 'd telt -> ('a * 'b * 'c * 'd) rtype
type (_, _) atype =
| Mem : ('b, 'r) atype -> (memory -> 'b, 'r) atype
| UArg : ('b, 'r) atype -> (unit -> 'b, 'r) atype
| Arg : 'a telt * ('b, 'r) atype -> ('a -> 'b, 'r) atype
| NArg : string * 'a telt * ('b, 'r) atype -> ('a -> 'b, 'r) atype
| Res : ('r, 'r) atype
type _ func_type = Func : ('f, 'r m) atype * 'r rtype -> 'f func_type
type extern_func = Extern_func : 'a func_type * 'a -> extern_func
let elt_type (type t) (e : t telt) : Binary.val_type =
match e with
| I32 -> Num_type I32
| I64 -> Num_type I64
| F32 -> Num_type F32
| F64 -> Num_type F64
| V128 -> Num_type V128
| Externref _ -> Ref_type (Null, Extern_ht)
let res_type (type t) (r : t rtype) : Binary.result_type =
match r with
| R0 -> []
| R1 a -> [ elt_type a ]
| R2 (a, b) -> [ elt_type a; elt_type b ]
| R3 (a, b, c) -> [ elt_type a; elt_type b; elt_type c ]
| R4 (a, b, c, d) -> [ elt_type a; elt_type b; elt_type c; elt_type d ]
let rec arg_type : type t r. (t, r) atype -> Binary.param_type = function
| Mem tl -> arg_type tl
| UArg tl -> arg_type tl
| Arg (hd, tl) -> (None, elt_type hd) :: arg_type tl
| NArg (name, hd, tl) -> (Some name, elt_type hd) :: arg_type tl
| Res -> []
(* TODO: we could move this out, as it does not really depend on the functor's parameters *)
let extern_type (Extern_func (Func (arg, res), _)) : Binary.func_type =
(arg_type arg, res_type res)
let fresh =
let r = ref ~-1 in
fun () ->
incr r;
!r
module Syntax = struct
type l
type lr
type elt
type mem
type (_, _, _) t =
| Unit : (lr, unit, unit) t
| Memory : (l, mem, memory) t
| Elt : 'a telt -> (lr, elt, 'a) t
| Elt_labeled : string * 'a telt -> (l, string * elt, 'a) t
let return r = Func (Res, r)
let r0 = R0 |> return
let r1 (Elt a) = R1 a |> return
let r2 (Elt a) (Elt b) = R2 (a, b) |> return
let r3 (Elt a) (Elt b) (Elt c) = R3 (a, b, c) |> return
let r4 (Elt a) (Elt b) (Elt c) (Elt d) = R4 (a, b, c, d) |> return
let i32 = Elt I32
let i64 = Elt I64
let f32 = Elt F32
let f64 = Elt F64
let v128 = Elt V128
let externref id = Elt (Externref id)
let unit = Unit
let memory = Memory
let label s (Elt v) = Elt_labeled (s, v)
let ( ^-> ) : type lr k a b.
(lr, k, a) t -> b func_type -> (a -> b) func_type =
fun a (Func (b, r)) ->
match a with
| Elt a -> Func (Arg (a, b), r)
| Elt_labeled (label, a) -> Func (NArg (label, a, b), r)
| Unit -> Func (UArg b, r)
| Memory -> Func (Mem b, r)
let ( ^->. ) : type ll k kk a b.
(ll, k, a) t -> (lr, kk, b) t -> (a -> b m) func_type =
fun a b -> match b with Elt _ -> a ^-> r1 b | Unit -> a ^-> r0
let ( ^->.. ) : type ll k a b1 b2.
(ll, k, a) t
-> (lr, elt, b1) t * (lr, elt, b2) t
-> (a -> (b1 * b2) m) func_type =
fun a (b1, b2) -> a ^-> r2 b1 b2
let ( ^->... ) : type ll k a b1 b2 b3.
(ll, k, a) t
-> (lr, elt, b1) t * (lr, elt, b2) t * (lr, elt, b3) t
-> (a -> (b1 * b2 * b3) m) func_type =
fun a (b1, b2, b3) -> a ^-> r3 b1 b2 b3
let ( ^->.... ) : type ll k a b1 b2 b3 b4.
(ll, k, a) t
-> (lr, elt, b1) t * (lr, elt, b2) t * (lr, elt, b3) t * (lr, elt, b4) t
-> (a -> (b1 * b2 * b3 * b4) m) func_type =
fun a (b1, b2, b3, b4) -> a ^-> r4 b1 b2 b3 b4
end
end
end
module Module = struct
(** extern modules *)
type 'extern_func t =
{ functions : (string * 'extern_func) list
; func_type : 'extern_func -> Binary.func_type
}
end