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
(* SPDX-License-Identifier: AGPL-3.0-or-later *)
(* Copyright © 2021-2024 OCamlPro *)
(* Written by the Owi programmers *)
open Text
open Syntax
type env =
{ start : bool
; declared_memory : bool
; funcs : bool
; tables : bool
; globals : bool
}
let empty_env () =
{ start = false
; declared_memory = false
; funcs = false
; tables = false
; globals = false
}
let check_mem_limits { is_i64; min; max } =
if is_i64 then
let* min =
match int_of_string_opt min with
| Some min -> Ok min
| None -> Error `Constant_out_of_range
in
match max with
| None ->
if min > 0x1_0000_0000_0000 then Error `Memory_size_too_large else Ok ()
| Some max -> (
match int_of_string_opt max with
| Some max ->
if min > max then Error `Size_minimum_greater_than_maximum
else if min > 0x1_0000_0000_0000 || max > 0x1_0000_0000_0000 then
Error `Memory_size_too_large
else Ok ()
| None -> Error `Constant_out_of_range )
else
let* min =
try Ok (Int32.of_string_exn min)
with Failure _ -> Error `Constant_out_of_range
in
match max with
| None ->
if Int32.lt_u 0x1_0000l min then Error `Memory_size_too_large else Ok ()
| Some max ->
let* max =
try Ok (Int32.of_string_exn max)
with Failure _ -> Error `Constant_out_of_range
in
if Int32.lt_u max min then Error `Size_minimum_greater_than_maximum
else if Int32.lt_u 0x1_0000l min || Int32.lt_u 0x1_0000l max then
Error `Memory_size_too_large
else Ok ()
let modul m =
Log.info (fun m -> m "checking ...");
let add_global, global_exists =
let seen = Hashtbl.create 512 in
let add_global = function
| None -> Ok ()
| Some id ->
if Hashtbl.mem seen id then Error (`Duplicate_global id)
else Ok (Hashtbl.replace seen id ())
in
let global_exists id = Hashtbl.mem seen id in
(add_global, global_exists)
in
let add_table, get_table =
let cnt = ref 0 in
let names2ids = Hashtbl.create 512 in
let seen = Hashtbl.create 512 in
let add_table name ty =
match name with
| None ->
Hashtbl.replace seen !cnt ty;
incr cnt;
Ok ()
| Some name ->
if Hashtbl.mem names2ids name then Error (`Duplicate_table name)
else (
Hashtbl.replace names2ids name !cnt;
Hashtbl.replace seen !cnt ty;
incr cnt;
Ok () )
in
let get_table name =
match name with
| None -> begin
match Hashtbl.find_opt seen 0 with
| None -> assert false
| Some ty -> Ok ty
end
| Some (Text name) -> begin
match Hashtbl.find_opt names2ids name with
| None -> Error (`Unknown_table (Text name))
| Some id -> begin
match Hashtbl.find_opt seen id with
| None -> assert false
| Some ty -> Ok ty
end
end
| Some (Raw id) -> begin
match Hashtbl.find_opt seen id with
| None -> Error (`Unknown_table (Raw id))
| Some ty -> Ok ty
end
in
(add_table, get_table)
in
let elem_check_type env (elemnull, elemty) mode explicit_typ =
match mode with
| Text.Elem.Mode.(Passive | Declarative) -> Ok env
| Text.Elem.Mode.Active (id, _) ->
let* _, (tabnull, tabty) = get_table id in
(* Only if elem_ty is explicit, otherwise it can be inferred *)
if
(not explicit_typ)
|| Text.heap_type_eq elemty tabty
&& Text.compare_nullable elemnull tabnull >= 0
then Ok env
else
Error
(`Type_mismatch
(Fmt.str "Declared elem of type %a for table of type %a"
Text.pp_ref_type (elemnull, elemty) Text.pp_ref_type
(tabnull, tabty) ) )
in
let rec check_expr = function
| [] -> Ok ()
| { Annotated.raw = Global_get (Text id); _ } :: _
when not (global_exists id) ->
Error (`Unknown_global (Text id))
| { Annotated.raw = Global_get (Text _id); _ } :: _ -> Ok ()
| { raw = _; _ } :: t -> check_expr t
(* TODO: complete for other operations *)
in
let rec elem_check_init = function
| [] -> Ok ()
| { Annotated.raw = l; _ } :: t ->
let* () = check_expr l in
elem_check_init t
in
let add_memory =
let seen = Hashtbl.create 512 in
function
| None -> Ok ()
| Some id ->
if Hashtbl.mem seen id then Error (`Duplicate_memory id)
else Ok (Hashtbl.add seen id ())
in
let+ (_env : env) =
let open Module in
list_fold_left
(fun env ->
let open Field in
function
| Export _e -> Ok env
| Func _f -> Ok { env with funcs = true }
| Start _start ->
if env.start then Error `Multiple_start_sections
else Ok { env with start = true }
| Import i ->
if env.funcs then Error `Import_after_function
else if env.declared_memory then Error `Import_after_memory
else if env.tables then Error `Import_after_table
else if env.globals then Error `Import_after_global
else begin
match i.typ with
| Mem (id, _) ->
let* () = add_memory id in
Ok env
| Func _ -> Ok env
| Global (id, _) ->
let+ () = add_global id in
env
| Table (id, ty) ->
let+ () = add_table id ty in
env
| Tag _ -> Ok env
end
| Data _d -> Ok env
| Tag _t -> Ok env
| Elem { typ; mode; explicit_typ; init; _ } ->
let* env = elem_check_type env typ mode explicit_typ in
let* () = elem_check_init init in
Ok env
| Mem (id, limits) ->
let* () = check_mem_limits limits in
let* () = add_memory id in
Ok { env with declared_memory = true }
| Typedef _t -> Ok env
| Global { id; _ } ->
let+ () = add_global id in
{ env with globals = true }
| Table { id; typ; init } ->
let* () = add_table id typ in
let* () =
match init with None -> Ok () | Some e -> check_expr e.raw
in
Ok { env with tables = true } )
(empty_env ()) m.fields
in
m