Skip to content

Commit 1e943af

Browse files
Merge pull request #48 from kth-step/dev_bool_cast
Cast to bool
2 parents 5b6c041 + 98def5f commit 1e943af

13 files changed

+373
-82
lines changed

hol/p4Script.sml

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -94,6 +94,7 @@ binop =
9494
val _ = Hol_datatype `
9595
cast =
9696
cast_unsigned of m (* unsigned cast *)
97+
| cast_bool (* bool cast *)
9798
`;
9899
val _ = Hol_datatype `
99100
unop =
@@ -343,6 +344,14 @@ val bool_cast_def = Define `
343344
bool_cast n' b = (fixwidth n' [b], n')
344345
`;
345346

347+
val to_bool_cast_def = Define `
348+
to_bool_cast (bl, n) = HD $ REVERSE bl
349+
`;
350+
351+
val id_bool_cast_def = Define `
352+
id_bool_cast b = b
353+
`;
354+
346355
val bitv_bl_binop_def = Define `
347356
bitv_bl_binop binop (bl, n) (bl', n') = (fixwidth n (binop bl bl'), n)
348357
`;
@@ -2325,6 +2334,18 @@ Inductive e_sem:
23252334
==>
23262335
( ( e_red ctx g_scope_list scope_list (e_cast (cast_unsigned n) (e_v (v_bool b ))) (e_v (v_bit bitv)) ([]:frame list) )))
23272336

2337+
[e_cast_to_bool:] (! (ctx:'a ctx) (g_scope_list:g_scope_list) (scope_list:scope_list) (bitv:bitv) (b:b) .
2338+
(clause_name "e_cast_to_bool") /\
2339+
(( (to_bool_cast bitv = b ) ))
2340+
==>
2341+
( ( e_red ctx g_scope_list scope_list (e_cast cast_bool (e_v (v_bit bitv))) (e_v (v_bool b )) ([]:frame list) )))
2342+
2343+
[e_cast_id_bool:] (! (ctx:'a ctx) (g_scope_list:g_scope_list) (scope_list:scope_list) (b:b) (b':b) .
2344+
(clause_name "e_cast_id_bool") /\
2345+
(( (id_bool_cast b = b' ) ))
2346+
==>
2347+
( ( e_red ctx g_scope_list scope_list (e_cast cast_bool (e_v (v_bool b ))) (e_v (v_bool b' )) ([]:frame list) )))
2348+
23282349
[e_mul:] (! (ctx:'a ctx) (g_scope_list:g_scope_list) (scope_list:scope_list) (bitv:bitv) (bitv':bitv) (bitv'':bitv) .
23292350
(clause_name "e_mul") /\
23302351
(( (bitv_binop binop_mul bitv bitv' = SOME bitv'' ) ))
@@ -3324,6 +3345,12 @@ Inductive e_typ:
33243345
( ? b tp. ( e_typ t_scopes_tup T_e e tp b /\ ? n . ( tp = t_tau (tau_bit n) \/ tp = t_tau (tau_bool ) ) ) ))
33253346
==>
33263347
( ( e_typ t_scopes_tup T_e (e_cast (cast_unsigned n) e) (t_tau (tau_bit n )) F )))
3348+
3349+
[e_typ_cast_to_bool:] (! (t_scopes_tup:t_scopes_tup) (T_e:T_e) (e:e) (tau:tau) (b:b) .
3350+
(clause_name "e_typ_cast_to_bool") /\
3351+
(( ? b tp. ( e_typ t_scopes_tup T_e e tp b /\ ? n . ( tp = t_tau (tau_bit n) \/ tp = t_tau (tau_bool ) ) ) ))
3352+
==>
3353+
( ( e_typ t_scopes_tup T_e (e_cast cast_bool e) (t_tau tau_bool) F )))
33273354
End
33283355
(** definitions *)
33293356

hol/p4_e_progressScript.sml

Lines changed: 13 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1637,14 +1637,19 @@ Cases_on `is_const e` >| [
16371637

16381638
(*from the typing rules we know *)
16391639
Cases_on ‘c’ >>
1640-
gvs[] >>
1641-
1642-
OPEN_EXP_TYP_TAC ``(e_cast (cast_unsigned n) (e_v v))`` >> fs[] >>
1643-
OPEN_EXP_TYP_TAC ``e_v v`` >> fs[] >>
1644-
1645-
gvs[Once e_sem_cases] >>
1646-
OPEN_V_TYP_TAC ``v`` >> gvs[clause_name_def]
1647-
,
1640+
gvs[] >| [
1641+
OPEN_EXP_TYP_TAC ``(e_cast (cast_unsigned n) (e_v v))`` >> fs[] >>
1642+
OPEN_EXP_TYP_TAC ``e_v v`` >> fs[] >> (
1643+
gvs[Once e_sem_cases] >>
1644+
OPEN_V_TYP_TAC ``v`` >> gvs[clause_name_def]
1645+
),
1646+
1647+
OPEN_EXP_TYP_TAC ``(e_cast cast_bool (e_v v))`` >> fs[] >>
1648+
OPEN_EXP_TYP_TAC ``e_v v`` >> fs[] >> (
1649+
gvs[Once e_sem_cases] >>
1650+
OPEN_V_TYP_TAC ``v`` >> gvs[clause_name_def]
1651+
)
1652+
],
16481653

16491654

16501655
OPEN_EXP_TYP_TAC ``(e_cast c e)`` >>

hol/p4_e_subject_reductionScript.sml

Lines changed: 17 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -5557,14 +5557,28 @@ REPEAT STRIP_TAC >| [
55575557
gvs[Once e_typ_cases] >>
55585558
gvs[Once v_typ_cases] >>
55595559
gvs[Once v_typ_cases] >>
5560-
METIS_TAC[bv_casting_length2]
5561-
,
5560+
METIS_TAC[bv_casting_length2],
5561+
55625562
OPEN_EXP_TYP_TAC ``e_cast (cast_unsigned n) (e_v (v_bool b'))`` >>
55635563
gvs[Once e_typ_cases] >>
55645564
gvs[Once e_typ_cases] >>
55655565
gvs[Once v_typ_cases] >>
55665566
gvs[Once v_typ_cases] >>
5567-
METIS_TAC[bool_casting_length, clause_name_def]
5567+
METIS_TAC[bool_casting_length, clause_name_def],
5568+
5569+
OPEN_EXP_TYP_TAC ``e_cast cast_bool (e_v (v_bit bitv))`` >>
5570+
gvs[Once e_typ_cases] >>
5571+
gvs[Once e_typ_cases] >>
5572+
gvs[Once v_typ_cases] >>
5573+
gvs[Once v_typ_cases] >>
5574+
METIS_TAC[bool_casting_length, clause_name_def],
5575+
5576+
OPEN_EXP_TYP_TAC ``e_cast cast_bool (e_v (v_bool b'))`` >>
5577+
gvs[Once e_typ_cases] >>
5578+
gvs[Once e_typ_cases] >>
5579+
gvs[Once v_typ_cases] >>
5580+
gvs[Once v_typ_cases] >>
5581+
METIS_TAC[bool_casting_length, clause_name_def]
55685582
]
55695583
,
55705584

hol/p4_exec_semScript.sml

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -64,15 +64,19 @@ Definition e_exec_unop_def:
6464
End
6565

6666
Definition cast_exec_def:
67-
(cast_exec cast (v_bit bitv) = SOME (v_bit $ bitv_cast cast bitv))
67+
(cast_exec (cast_unsigned n) (v_bit bitv) = SOME (v_bit $ bitv_cast n bitv))
6868
/\
69-
(cast_exec cast (v_bool b) = SOME (v_bit $ bool_cast cast b))
69+
(cast_exec (cast_unsigned n) (v_bool b) = SOME (v_bit $ bool_cast n b))
7070
/\
71-
(cast_exec cast v = NONE)
71+
(cast_exec (cast_bool) (v_bit bitv) = SOME (v_bool $ to_bool_cast bitv))
72+
/\
73+
(cast_exec _ _ = NONE)
7274
End
7375

7476
Definition e_exec_cast_def:
75-
(e_exec_cast (cast_unsigned n) (e_v v) = cast_exec n v)
77+
(e_exec_cast (cast_unsigned n) (e_v v) = cast_exec (cast_unsigned n) v)
78+
/\
79+
(e_exec_cast (cast_bool) (e_v v) = cast_exec (cast_bool) v)
7680
/\
7781
(e_exec_cast _ _ = NONE)
7882
End

hol/p4_exec_sem_e_soundnessScript.sml

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -578,6 +578,9 @@ Cases_on `is_v e` >| [
578578
fs [clause_name_def],
579579

580580
irule ((valOf o find_clause_e_red) "e_cast_bitv") >>
581+
fs [clause_name_def],
582+
583+
irule ((valOf o find_clause_e_red) "e_cast_to_bool") >>
581584
fs [clause_name_def]
582585
],
583586

hol/p4_from_json/excluded.sml

Lines changed: 7 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -74,10 +74,11 @@ val exclude_descs =
7474
["decl-soundness",
7575
"enum-bmv2"]),
7676
(*
77-
To-bool cast (manually spotted)
77+
More expressive STF specifications
7878
*)
79-
("supporting to-bool cast in HOL4P4",
80-
["issue1814-1-bmv2"]),
79+
("more expressive STF specifications",
80+
["issue1814-1-bmv2",
81+
"switch_ebpf"]),
8182
(*
8283
To-struct cast (manually spotted)
8384
*)
@@ -94,20 +95,10 @@ val exclude_descs =
9495
("adding counter extern to V1Model model",
9596
["issue1566-bmv2"]),
9697
(*
97-
Return struct of table application
98-
*)
99-
("adding support for desugaring more table application expressions to import tool",
100-
["hit_ebpf",
101-
"key-issue-1020_ebpf",
102-
"switch_ebpf"]),
103-
(*
104-
Set expressions in select expression
105-
FAIL: Could not parse .*\/(.*?)\. .*?: \["range".*
98+
If-expressions
10699
*)
107-
("adding set expressions in select expressions to HOL4P4",
108-
["issue995-bmv2",
109-
"issue1000-bmv2",
110-
"issue-2123-2-bmv2",
100+
("adding if-expressions to HOL4P4",
101+
["issue-2123-2-bmv2",
111102
"issue-2123-3-bmv2"]),
112103
(*
113104
Exit statement

hol/p4_from_json/petr4_get_arch.sh

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,8 @@ elif grep -q "#include \"very_simple_model.p4\"" "$1"; then
77
echo "vss"
88
elif grep -q "#include <v1model.p4>" "$1"; then
99
echo "v1model"
10+
elif grep -q "#include \"v1model.p4\"" "$1"; then
11+
echo "v1model"
1012
else
1113
echo "none"
1214
fi

hol/p4_from_json/petr4_to_hol4p4.sh

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@ fi
2222
arch=$(./petr4_get_arch.sh "${JSON_PATH%.json}.p4")
2323

2424
if [ "$arch" = "none" ]; then
25-
echo "No architecture found in the associated .p4 file. Check that your P4 program uses a proper architecture, or adapt petr4_get_arch.sh to recognize the right architecture."
25+
echo "No architecture found in ${JSON_PATH%.json}.p4. Check that your P4 program uses a proper architecture, or adapt petr4_get_arch.sh to recognize the right architecture."
2626
exit 1
2727
fi
2828

0 commit comments

Comments
 (0)