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
(* SPDX-License-Identifier: AGPL-3.0-or-later *)
(* Copyright © 2021-2026 OCamlPro *)
(* Written by the Owi programmers *)
module Func = struct
module Make (Value : sig
type i32
type i64
type f32
type f64
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
Extern_intf.T
with 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 '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 : Value.i32 telt
| I64 : Value.i64 telt
| F32 : Value.f32 telt
| F64 : Value.f64 telt
| V128 : Value.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 : int * ('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
| Res : ('r, 'r) atype
type _ func_type = Func : ('f, 'r m) atype * 'r rtype -> 'f func_type
type t = Extern_func : 'a func_type * 'a -> t
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 arg_type =
let rec aux : type t r. (t, r) atype -> Binary.param_type = function
| Mem (_, tl) -> aux tl
| UArg tl -> aux tl
| Arg (hd, tl) -> (None, elt_type hd) :: aux tl
| Res -> []
in
aux
(* TODO: we could move this out, as it does not really depend on the functor's parameters *)
let to_func_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 = private [ `L ]
type lr = private [ `Lr ]
type elt = private [ `Elt ]
type (_, _, _) t =
| Unit : (lr, unit, unit) t
| Memory : int -> (l, memory, memory) t
| Elt : 'a telt -> (lr, 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 id = Memory id
let ( ^-> ) =
let aux : 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)
| Unit -> Func (UArg b, r)
| Memory id -> Func (Mem (id, b), r)
in
aux
let ( ^->. ) =
let aux : 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
in
aux
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