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
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
(* SPDX-License-Identifier: AGPL-3.0-or-later *)
(* Copyright © 2021-2024 OCamlPro *)
(* Written by the Owi programmers *)
module type S = sig
type boolean
type i32
type i64
type f32
type f64
type v128
type ref_value
type value
type t = value list
val empty : t
val pp : t Fmt.t
(** pop operations *)
val drop : t -> t
val drop_n : 'a list -> int -> 'a list
val pop : t -> value * t
val pop_n : t -> int -> t * t
val keep : t -> int -> t
val pop_bool : t -> boolean * t
val pop_i32 : t -> i32 * t
val pop2_i32 : t -> (i32 * i32) * t
val pop_i64 : t -> i64 * t
val pop2_i64 : t -> (i64 * i64) * t
val pop_f32 : t -> f32 * t
val pop2_f32 : t -> (f32 * f32) * t
val pop_f64 : t -> f64 * t
val pop2_f64 : t -> (f64 * f64) * t
val pop_v128 : t -> v128 * t
val pop2_v128 : t -> (v128 * v128) * t
val pop_ref : t -> value * t
val pop_as_ref : t -> ref_value * t
(** push operations *)
val push : t -> value -> t
val push_bool : t -> boolean -> t
val push_i32 : t -> i32 -> t
val push_concrete_i32 : t -> Int32.t -> t
val push_i32_of_int : t -> int -> t
val push_i64 : t -> i64 -> t
val push_concrete_i64 : t -> Int64.t -> t
val push_f32 : t -> f32 -> t
val push_concrete_f32 : t -> Float32.t -> t
val push_f64 : t -> f64 -> t
val push_concrete_f64 : t -> Float64.t -> t
val push_v128 : t -> v128 -> t
val push_concrete_v128 : t -> Concrete_v128.t -> t
val push_ref : t -> ref_value -> t
val push_array : t -> unit Array.t -> t
(** apply operations *)
val apply_i32_i32 : t -> (i32 -> i32) -> t
val apply_i32_i64 : t -> (i32 -> i64) -> t
val apply_i32_f32 : t -> (i32 -> f32) -> t
val apply_i32_f64 : t -> (i32 -> f64) -> t
val apply_i32_boolean : t -> (i32 -> boolean) -> t
val apply_i32_i32_i32 : t -> (i32 -> i32 -> i32) -> t
val apply_i32_i32_boolean : t -> (i32 -> i32 -> boolean) -> t
val apply_i64_i64 : t -> (i64 -> i64) -> t
val apply_i64_i32 : t -> (i64 -> i32) -> t
val apply_i64_f32 : t -> (i64 -> f32) -> t
val apply_i64_f64 : t -> (i64 -> f64) -> t
val apply_i64_boolean : t -> (i64 -> boolean) -> t
val apply_i64_i64_i64 : t -> (i64 -> i64 -> i64) -> t
val apply_i64_i64_boolean : t -> (i64 -> i64 -> boolean) -> t
val apply_f32_f32 : t -> (f32 -> f32) -> t
val apply_f32_f64 : t -> (f32 -> f64) -> t
val apply_f32_i32 : t -> (f32 -> i32) -> t
val apply_f32_i64 : t -> (f32 -> i64) -> t
val apply_f32_f32_f32 : t -> (f32 -> f32 -> f32) -> t
val apply_f32_f32_boolean : t -> (f32 -> f32 -> boolean) -> t
val apply_f64_f64 : t -> (f64 -> f64) -> t
val apply_f64_f32 : t -> (f64 -> f32) -> t
val apply_f64_i32 : t -> (f64 -> i32) -> t
val apply_f64_i64 : t -> (f64 -> i64) -> t
val apply_f64_f64_f64 : t -> (f64 -> f64 -> f64) -> t
val apply_f64_f64_boolean : t -> (f64 -> f64 -> boolean) -> t
end
module Make (Value : Value_intf.T) :
S
with type value := Value.t
and type boolean := Value.boolean
and type i32 := Value.i32
and type i64 := Value.i64
and type f32 := Value.f32
and type f64 := Value.f64
and type v128 := Value.v128
and type ref_value := Value.Ref.t = struct
open Value
type t = Value.t list
exception Empty
let empty = []
let push s v = v :: s
let push_bool s b = push s (I32 (Value.I32.of_boolean b))
let push_concrete_i32 s i = push s (I32 (Value.I32.of_int32 i))
let push_i32 s i = push s (I32 i)
let push_i32_of_int s i = push_concrete_i32 s (Int32.of_int i)
let push_concrete_i64 s i = push s (I64 (Value.I64.of_int64 i))
let push_i64 s i = push s (I64 i)
let push_concrete_f32 s f = push s (F32 (Value.F32.of_float32 f))
let push_f32 s f = push s (F32 f)
let push_concrete_f64 s f =
push s (F64 (Value.F64.of_float (Float64.to_float f)))
let push_f64 s f = push s (F64 f)
let push_concrete_v128 s f = push s (V128 (Value.V128.of_concrete f))
let push_v128 s f = push s (V128 f)
let push_ref s r = push s (Ref r)
let push_array _ _ = assert false
let pp fmt (s : t) =
Fmt.list ~sep:(fun fmt () -> Fmt.string fmt " ; ") Value.pp fmt s
let pop = function [] -> raise Empty | hd :: tl -> (hd, tl)
let drop = function [] -> raise Empty | _hd :: tl -> tl
let pop_i32 s =
let hd, tl = pop s in
match hd with I32 n -> (n, tl) | _ -> assert false
let pop2_i32 s =
let n2, s = pop s in
let n1, tl = pop s in
match (n1, n2) with I32 n1, I32 n2 -> ((n1, n2), tl) | _ -> assert false
let pop_i64 s =
let hd, tl = pop s in
match hd with I64 n -> (n, tl) | _ -> assert false
let pop2_i64 s =
let n2, s = pop s in
let n1, tl = pop s in
match (n1, n2) with I64 n1, I64 n2 -> ((n1, n2), tl) | _ -> assert false
let pop_f32 s =
let hd, tl = pop s in
match hd with F32 f -> (f, tl) | _ -> assert false
let pop2_f32 s =
let n2, s = pop s in
let n1, tl = pop s in
match (n1, n2) with F32 n1, F32 n2 -> ((n1, n2), tl) | _ -> assert false
let pop_f64 s =
let hd, tl = pop s in
match hd with F64 f -> (f, tl) | _ -> assert false
let pop2_f64 s =
let n2, s = pop s in
let n1, tl = pop s in
match (n1, n2) with F64 n1, F64 n2 -> ((n1, n2), tl) | _ -> assert false
let pop_v128 s =
let hd, tl = pop s in
match hd with V128 f -> (f, tl) | _ -> assert false
let pop2_v128 s =
let n2, s = pop s in
let n1, tl = pop s in
match (n1, n2) with V128 n1, V128 n2 -> ((n1, n2), tl) | _ -> assert false
let pop_ref s =
let hd, tl = pop s in
match hd with Ref _ -> (hd, tl) | _ -> assert false
let pop_as_ref s =
let hd, tl = pop s in
match hd with Ref hd -> (hd, tl) | _ -> assert false
let pop_bool s =
let hd, tl = pop s in
match hd with I32 n -> (Value.I32.to_boolean n, tl) | _ -> assert false
let pop_n s n =
(List.filteri (fun i _hd -> i < n) s, List.filteri (fun i _hd -> i >= n) s)
let keep s n = List.filteri (fun i _hd -> i < n) s
let rec drop_n s n =
if n = 0 then s
else match s with [] -> assert false | _ :: tl -> drop_n tl (n - 1)
let apply_i32_boolean s f =
let hd, tl = pop_i32 s in
push_bool tl (f hd)
let apply_i32_i32 s f =
let hd, tl = pop_i32 s in
push_i32 tl (f hd)
let apply_i32_f32 s f =
let hd, tl = pop_i32 s in
push_f32 tl (f hd)
let apply_i32_f64 s f =
let hd, tl = pop_i32 s in
push_f64 tl (f hd)
let apply_i32_i64 s f =
let hd, tl = pop_i32 s in
push_i64 tl (f hd)
let apply_i32_i32_i32 s f =
let (hd1, hd2), tl = pop2_i32 s in
push_i32 tl (f hd1 hd2)
let apply_i32_i32_boolean s f =
let (hd1, hd2), tl = pop2_i32 s in
push_bool tl (f hd1 hd2)
let apply_i64_boolean s f =
let hd, tl = pop_i64 s in
push_bool tl (f hd)
let apply_i64_i64 s f =
let hd, tl = pop_i64 s in
push_i64 tl (f hd)
let apply_i64_i32 s f =
let hd, tl = pop_i64 s in
push_i32 tl (f hd)
let apply_i64_f32 s f =
let hd, tl = pop_i64 s in
push_f32 tl (f hd)
let apply_i64_f64 s f =
let hd, tl = pop_i64 s in
push_f64 tl (f hd)
let apply_i64_i64_i64 s f =
let (hd1, hd2), tl = pop2_i64 s in
push_i64 tl (f hd1 hd2)
let apply_i64_i64_boolean s f =
let (hd1, hd2), tl = pop2_i64 s in
push_bool tl (f hd1 hd2)
let apply_f32_f32 s f =
let hd, tl = pop_f32 s in
push_f32 tl (f hd)
let apply_f32_f64 s f =
let hd, tl = pop_f32 s in
push_f64 tl (f hd)
let apply_f32_i32 s f =
let hd, tl = pop_f32 s in
push_i32 tl (f hd)
let apply_f32_i64 s f =
let hd, tl = pop_f32 s in
push_i64 tl (f hd)
let apply_f32_f32_f32 s f =
let (hd1, hd2), tl = pop2_f32 s in
push_f32 tl (f hd1 hd2)
let apply_f32_f32_boolean s f =
let (hd1, hd2), tl = pop2_f32 s in
push_bool tl (f hd1 hd2)
let apply_f64_f64 s f =
let hd, tl = pop_f64 s in
push_f64 tl (f hd)
let apply_f64_f32 s f =
let hd, tl = pop_f64 s in
push_f32 tl (f hd)
let apply_f64_i32 s f =
let hd, tl = pop_f64 s in
push_i32 tl (f hd)
let apply_f64_i64 s f =
let hd, tl = pop_f64 s in
push_i64 tl (f hd)
let apply_f64_f64_f64 s f =
let (hd1, hd2), tl = pop2_f64 s in
push_f64 tl (f hd1 hd2)
let apply_f64_f64_boolean s f =
let (hd1, hd2), tl = pop2_f64 s in
push_bool tl (f hd1 hd2)
end