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
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
(* SPDX-License-Identifier: AGPL-3.0-or-later *)
(* Copyright © 2021-2024 OCamlPro *)
(* Written by the Owi programmers *)
open Types
module type Value_types = sig
type int32
type int64
type float32
type float64
type v128
type bool
end
module type Monad_type = sig
type 'a t
end
module type Memory_type = sig
type t
end
module type T_Extern_func = sig
type int32
type int64
type float32
type float64
type v128
type 'a m
type memory
type _ telt =
| I32 : int32 telt
| I64 : int64 telt
| F32 : float32 telt
| F64 : float64 telt
| V128 : 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
(* val extern_type : _ func_type -> Simplified.func_type *)
val extern_type : extern_func -> binary Types.func_type
module Syntax : sig
type l
type lr
type elt
type mem
type (_, _, _) t = private
| 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
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
type t =
| WASM of int * binary func * Env_id.t
| Extern of Func_id.t
module type T = sig
include T_Extern_func
type nonrec t = t
(* val typ : ('env, extern_func) t -> Simplified.func_type *)
val wasm : binary func -> Env_id.t -> t
end
module Make_extern_func
(V : Value_types)
(M : Monad_type)
(Memory : Memory_type) : sig
type nonrec t = t
val fresh : unit -> int
val wasm : Types.binary Types.func -> Env_id.t -> t
include
T_Extern_func
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 -> []
let extern_type (Extern_func (Func (arg, res), _)) : binary Types.func_type =
(arg_type arg, res_type res)
type nonrec t = t
let fresh =
let r = ref ~-1 in
fun () ->
incr r;
!r
let wasm func env : t = WASM (fresh (), func, env)
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