Source file make.ml
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
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
module Typ = Runtime.Type.Typ
module Value = Runtime.Value
open Runtime.Sim.Io
open Runtime.Sim.Signature
open Error
open Util.Source
module Make
(Interface : INTERFACE)
(MakeArch : functor (Spec : Spec.S) -> ARCH)
(MakeInterp_AL : functor
(Interface : INTERFACE)
(Extern : EXTERN)
()
-> INTERP_AL)
(MakeInterp_SL : functor
(Interface : INTERFACE)
(Extern : EXTERN)
()
-> INTERP_SL)
(MakeInterp_PL : functor
(Interface : INTERFACE)
(Extern : EXTERN)
()
-> INTERP_PL) : SIM = struct
module Spec_ = Spec.Make ()
module Arch = MakeArch (Spec_)
module Table = Table.Make (Spec_.Func)
module MakeExtern
(Interp_AL : INTERP_AL)
(Interp_SL : INTERP_SL)
(Interp_PL : INTERP_PL) : EXTERN = struct
let init_mode mode_ =
let call_func name typs values =
(match mode_ with
| AL_mode -> Interp_AL.eval_func name typs values
| SL_mode -> Interp_SL.eval_func name typs values
| PL_mode -> Interp_PL.eval_func name typs values
| Empty_mode -> assert false)
|> function
| Pass value -> value
| Fail (at, msg) -> error at msg
in
let call_rel name values =
(match mode_ with
| AL_mode -> Interp_AL.eval_rel name values
| SL_mode -> Interp_SL.eval_rel name values
| PL_mode -> Interp_PL.eval_rel name values
| Empty_mode -> assert false)
|> function
| Pass values -> values
| Fail (at, msg) -> error at msg
in
let call_pgm relname includes path =
(match mode_ with
| AL_mode -> Interp_AL.eval_program relname includes path
| SL_mode -> Interp_SL.eval_program relname includes path
| PL_mode -> Interp_PL.eval_program relname includes path
| Empty_mode -> assert false)
|> function
| Pass [ value_ctx; value_arch ] -> (value_ctx, value_arch)
| Pass _ -> error no_region "unexpected number of return values"
| Fail (`Syntax (at, msg) | `Runtime (at, msg)) -> error at msg
in
Spec_.Func.register call_func;
Spec_.Rel.register call_rel;
Spec_.Pgm.register call_pgm
let checkpoint () : int = 0
let seff (before : int) (after : int) : bool = before <> after
let clear () = ()
module Cache = struct
let cache_on () = ()
let cache_off () = ()
end
let eval_extern_rel = Arch.eval_extern_rel
let eval_extern_func = Arch.eval_extern_func
end
include (
Runner.Make.Make_rec (Interface) (MakeExtern) (MakeInterp_AL)
(MakeInterp_SL)
(MakeInterp_PL) :
RUNNER)
let verbose = ref true
let log (msg : string) : unit = if !verbose then print_endline msg
let (tx : IO.tx) (expect_queue : IO.expect list) :
(IO.expect * IO.expect list) option =
let tx_port, _ = tx in
let rec expects = function
| [] -> None
| expect_h :: expect_t ->
let (expect_port, expect_packet), exact = expect_h in
if expect_port = tx_port then
if compare_tx ~exact tx (expect_port, expect_packet) then
Some (expect_h, List.rev_append expects expect_t)
else
error_stf
(Format.asprintf "expected %s but got %s"
(string_of_tx (expect_port, expect_packet))
(string_of_tx tx))
else extract_matching_expect (expect_h :: expects) expect_t
in
extract_matching_expect [] expect_queue
let on_tx_output (txs : IO.tx list) (tx_output_queue : IO.tx list)
(expect_queue : IO.expect list) : IO.tx list * IO.expect list =
match txs with
| [] -> (tx_output_queue, expect_queue)
| tx_h :: tx_t -> (
match extract_matching_expect tx_h expect_queue with
| None ->
let tx_output_queue = tx_output_queue @ txs in
(tx_output_queue, expect_queue)
| Some (expect, expect_queue) ->
let tx, _ = expect in
Format.asprintf "[PASS] Transmitted %s" (string_of_tx tx) |> log;
(tx_output_queue @ tx_t, expect_queue))
let (expect : IO.expect)
(tx_output_queue : IO.tx list) : (IO.tx * IO.tx list) option =
let (expect_port, expect_packet), exact = expect in
let rec txs = function
| [] -> None
| tx_h :: tx_t ->
let tx_port, _ = tx_h in
if expect_port = tx_port then
if compare_tx ~exact tx_h (expect_port, expect_packet) then
Some (tx_h, List.rev_append txs tx_t)
else
error_stf
(Format.asprintf "expected %s but got %s"
(string_of_tx (expect_port, expect_packet))
(string_of_tx tx_h))
else extract_matching_output (tx_h :: txs) tx_t
in
extract_matching_output [] tx_output_queue
let on_tx_expect (expect : IO.expect) (tx_output_queue : IO.tx list)
(expect_queue : IO.expect list) : IO.tx list * expect list =
match extract_matching_output expect tx_output_queue with
| None ->
let expect_queue = expect_queue @ [ expect ] in
(tx_output_queue, expect_queue)
| Some (tx_output, tx_output_queue) ->
Format.asprintf "[PASS] Transmitted %s" (string_of_tx tx_output) |> log;
(tx_output_queue, expect_queue)
let run_stf_stmt (value_ctx : Value.t) (value_arch : Value.t)
(tx_output_queue : IO.tx list) (expect_queue : IO.expect list)
(stmt_stf : Stf.Ast.stmt) :
Value.t * Value.t * IO.tx list * IO.expect list =
let stmt_stf = Arch.transform_stf_stmt stmt_stf in
match stmt_stf with
| Stf.Ast.Packet (port_in, packet_in) ->
let port_in = int_of_string port_in in
let packet_in = String.uppercase_ascii packet_in in
let rx = (port_in, packet_in) in
let value_ctx, value_arch, tx_outputs =
Arch.drive_pipe value_ctx value_arch rx
in
let tx_output_queue, expect_queue =
on_tx_output tx_outputs tx_output_queue expect_queue
in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.Expect (port_expect, packet_expect_opt, exact) ->
let port_expect = int_of_string port_expect in
let packet_expect = Option.value packet_expect_opt ~default:"" in
let packet_expect = String.uppercase_ascii packet_expect in
let expect = ((port_expect, packet_expect), exact) in
let tx_output_queue, expect_queue =
on_tx_expect expect tx_output_queue expect_queue
in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.Add
( table_name,
table_entry_priority_opt,
table_entry_keys,
table_entry_action,
_ ) ->
let value_tableName = table_name |> String.escaped |> Value.Make.text in
let value_tableEntryPriorityInterface =
table_entry_priority_opt
|> Option.map (fun table_entry_priority ->
table_entry_priority |> Bigint.of_int |> Value.Make.int)
|> Value.Make.opt (Typ.Make.opt Typ.Make.int)
in
let typ_tableKeyInterface =
Typ.Make.var ("tableKeyInterface" $ no_region) []
in
let typ_tableKeysetInterface = Typ.Make.list typ_tableKeyInterface in
let value_tableKeysetInterface =
table_entry_keys
|> List.map (fun (table_entry_key : Stf.Ast.mtch) ->
let table_key_name, table_key_value = table_entry_key in
let table_key_name =
Stf.Print.convert_dollar_to_brackets table_key_name
in
let value_table_key_name = Value.Make.text table_key_name in
let value_table_key_value =
match table_key_value with
| Num number ->
if String.starts_with ~prefix:"0x" number then
let number_base_len = String.length number - 2 in
let number_base =
String.sub number 2 number_base_len
in
Value.Make.(
"_HEX text"
<| [ text number_base ]
<<| "tableKeyValueInterface")
else if String.starts_with ~prefix:"0b" number then
let number_base_len = String.length number - 2 in
let number_base =
String.sub number 2 number_base_len
in
Value.Make.(
"_BIN text"
<| [ text number_base ]
<<| "tableKeyValueInterface")
else
Value.Make.(
"_DEC text"
<| [ text number ]
<<| "tableKeyValueInterface")
| Slash (prefix, mask) ->
let value_prefix = Value.Make.text prefix in
let mask = Bigint.of_int (int_of_string mask) in
let value_mask = Value.Make.nat mask in
Value.Make.(
"text _SLASH nat"
<| [ value_prefix; value_mask ]
<<| "tableKeyValueInterface")
in
Value.Make.tuple typ_tableKeyInterface
[ value_table_key_name; value_table_key_value ])
|> Value.Make.list typ_tableKeysetInterface
in
let value_tableActionInterface =
let table_action_name, table_action_args = table_entry_action in
let typ_tableActionInterface =
Typ.Make.var ("tableActionInterface" $ no_region) []
in
let typ_tableActionArgumentInterface =
Typ.Make.var ("tableActionArgumentInterface" $ no_region) []
in
let typ_tableActionArgumentInterfaceList =
Typ.Make.list typ_tableActionArgumentInterface
in
let value_table_action_name = Value.Make.text table_action_name in
let value_tableActionArgumentInterfaces =
table_action_args
|> List.map (fun (name, number) ->
let value_name = Value.Make.text name in
let value_number =
number |> int_of_string |> Bigint.of_int |> Value.Make.int
in
Value.Make.tuple typ_tableActionArgumentInterface
[ value_name; value_number ])
|> Value.Make.list typ_tableActionArgumentInterfaceList
in
Value.Make.tuple typ_tableActionInterface
[ value_table_action_name; value_tableActionArgumentInterfaces ]
in
let value_arch =
Table.add_entry value_ctx value_arch value_tableName
value_tableEntryPriorityInterface value_tableKeysetInterface
value_tableActionInterface
in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.SetDefault (table_name, table_entry_action) ->
let value_tableName = Value.Make.text table_name in
let value_tableActionInterface =
let table_action_name, table_action_args = table_entry_action in
let typ_tableActionInterface =
Typ.Make.var ("tableActionInterface" $ no_region) []
in
let typ_tableActionArgumentInterface =
Typ.Make.var ("tableActionArgumentInterface" $ no_region) []
in
let typ_tableActionArgumentInterfaceList =
Typ.Make.list typ_tableActionArgumentInterface
in
let value_table_action_name = Value.Make.text table_action_name in
let value_tableActionArgumentInterfaces =
table_action_args
|> List.map (fun (name, number) ->
let value_name = Value.Make.text name in
let value_number =
number |> int_of_string |> Bigint.of_int |> Value.Make.int
in
Value.Make.tuple typ_tableActionArgumentInterface
[ value_name; value_number ])
|> Value.Make.list typ_tableActionArgumentInterfaceList
in
Value.Make.tuple typ_tableActionInterface
[ value_table_action_name; value_tableActionArgumentInterfaces ]
in
let value_arch =
Table.add_default_action value_ctx value_arch value_tableName
value_tableActionInterface
in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.MirroringAdd (session, port) ->
let session = int_of_string session in
let port = int_of_string port in
let value_arch = Arch.add_mirror_session value_arch session port in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.MirroringAddMc (session, id) ->
let session = int_of_string session in
let id = int_of_string id in
let value_arch = Arch.add_mirror_session_mc value_arch session id in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.MirroringGet _session ->
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.McGroupCreate mgid ->
let mgid = int_of_string mgid in
let value_arch = Arch.mc_mgrp_create value_arch mgid in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.McNodeCreate (rid, ports) ->
let rid = int_of_string rid in
let ports = List.map int_of_string ports in
let value_arch = Arch.mc_node_create value_arch rid ports in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.McNodeAssociate (mgid, handle) ->
let mgid = int_of_string mgid in
let handle = int_of_string handle in
let value_arch = Arch.mc_node_associate value_arch mgid handle in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.RegisterRead (reg_name, index) ->
let index = int_of_string index in
let value_arch = Arch.register_read value_arch reg_name index in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.RegisterWrite (reg_name, index, value) ->
let index = int_of_string index in
let value = int_of_string value in
let value_arch = Arch.register_write value_arch reg_name index value in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.RegisterReset reg_name ->
let value_arch = Arch.register_reset value_arch reg_name in
(value_ctx, value_arch, tx_output_queue, expect_queue)
| Stf.Ast.Wait -> (value_ctx, value_arch, tx_output_queue, expect_queue)
| _ ->
error_stf
(Format.asprintf "not yet supported: %a" Stf.Print.print_stmt stmt_stf)
let run_stf_stmts (value_ctx : Value.t) (value_arch : Value.t)
(stmts_stf : Stf.Ast.stmt list) : unit =
let _, _, tx_output_queue, expect_queue =
List.fold_left
(fun (value_ctx, value_arch, tx_output_queue, expect_queue) stmt_stf ->
run_stf_stmt value_ctx value_arch tx_output_queue expect_queue
stmt_stf)
(value_ctx, value_arch, [], [])
stmts_stf
in
match (tx_output_queue, expect_queue) with
| [], [] -> ()
| tx_output_queue, expect_queue ->
let msg_output =
if tx_output_queue <> [] then
Format.asprintf "[FAIL] Remaining packets to be matched:\n%s"
(tx_output_queue |> List.map string_of_tx |> String.concat "\n")
else ""
in
let msg_expect =
if expect_queue <> [] then
Format.asprintf "[FAIL] Expected packets to be output:\n%s"
(expect_queue
|> List.map (fun (tx, _) -> string_of_tx tx)
|> String.concat "\n")
else ""
in
error_stf (msg_output ^ msg_expect)
let run_stf_test (includes_p4 : string list) (path_p4 : string)
(path_stf : string) : stf_result =
try
let value_ctx, value_arch = Arch.init_pipe includes_p4 path_p4 in
let stf_stmts = Stf.Parse.parse_file path_stf in
run_stf_stmts value_ctx value_arch stf_stmts;
Pass
with
| Util.Error.ParseError (at, msg) -> Fail (`Syntax (at, msg))
| Util.Error.InterpError (at, msg) | Util.Error.ExternError (at, msg) ->
Fail (`Runtime (at, msg))
| Util.Error.StfError msg -> Fail (`Runtime (no_region, msg))
end